diff --git a/code/obs_operators/DIM.INC b/code/obs_operators/DIM.INC new file mode 100644 index 0000000..2847216 --- /dev/null +++ b/code/obs_operators/DIM.INC @@ -0,0 +1,68 @@ + INTEGER NTRAC ! Number of tracers + INTEGER NX ! State space + INTEGER NY ! Measurment space + INTEGER NYY + INTEGER IIGR ! Gridsize of data + INTEGER JJGR ! Gridsize of data + INTEGER LLGR ! Gridsize of data + INTEGER II1 ! start index for i-grid + INTEGER II2 ! end index for i-grid + INTEGER JJ1 ! start index for j-grid + INTEGER JJ2 ! end index for j-grid + INTEGER NAS ! number of pts in nmc asia grid + + REAL LON_lim1 ! min longitude box + REAL LON_lim2 ! max longitude box + REAL LAT_lim1 ! min latitude box + REAL LAT_lim2 ! max latitude box + + + PARAMETER ( NTRAC = 1 ) ! Tagged tracers (+1 for total CO) +! PARAMETER ( NX = 8 ) + PARAMETER ( NX = 14 ) + PARAMETER ( NY = 2500 ) ! MAX due to svdcmp.f + PARAMETER ( NYY = 5000 ) ! MAX due to svdcmp.f + +! Window #1 : +! lon [180W ; 15W] +! lat [ 0N ; 76N] +! PARAMETER ( IIGR = 67 ) ! 67 = [180W - 15W] +! PARAMETER ( JJGR = 39 ) ! 34 = [0N - 76N] +! PARAMETER ( LLGR = 1 ) +! PARAMETER ( II1 = 1 ) ! 0 = 180W +! PARAMETER ( II2 = 67 ) ! 66 = 15W +! PARAMETER ( JJ1 = 47 ) ! 50 = 0N +! PARAMETER ( JJ2 = 85 ) ! 83 = 76N +! PARAMETER ( NAS = 2613 ) ! IIGR*JJGR + +! Window #2 : [reduced window] +! lon [167.5W ; 45W] +! lat [ 16N ; 70N] +! PARAMETER ( IIGR = 50 ) +! PARAMETER ( JJGR = 28 ) +! PARAMETER ( LLGR = 1 ) +! PARAMETER ( II1 = 6 ) +! PARAMETER ( II2 = 55 ) +! PARAMETER ( JJ1 = 54 ) +! PARAMETER ( JJ2 = 81 ) +! PARAMETER ( NAS = 1400 ) ! IIGR*JJGR + +! Window #3 : [reduced window for Alaska and Canada] +! lon [167.5W ; 45W] +! lat [ 30N ; 70N] + PARAMETER ( IIGR = 50 ) + PARAMETER ( JJGR = 21 ) + PARAMETER ( LLGR = 1 ) + PARAMETER ( II1 = 6 ) + PARAMETER ( II2 = 55 ) + PARAMETER ( JJ1 = 61 ) + PARAMETER ( JJ2 = 81 ) + PARAMETER ( NAS = 1050 ) ! IIGR*JJGR + + +! Read MOPITT data and model outputs directly: (timedep inversion) + PARAMETER (LAT_Lim1 = 30.) + PARAMETER (LAT_Lim2 = 75.) + PARAMETER (LON_Lim1 = -167.5) + PARAMETER (LON_Lim2 = -30.) + diff --git a/code/obs_operators/ErrorModule.f90 b/code/obs_operators/ErrorModule.f90 new file mode 100644 index 0000000..425de3e --- /dev/null +++ b/code/obs_operators/ErrorModule.f90 @@ -0,0 +1,480 @@ +! $Id: ErrorModule.f90,v 1.2 2009/06/23 06:47:07 daven Exp $ +MODULE ErrorModule + + !======================================================================== + ! Module ErrorModule contains error check routines for the Fortran code + ! that reads netCDF data from disk. (bmy, 2/15/07) + ! + ! Module Methods: + ! ----------------------------------------------------------------------- + ! (1 ) AllocErr : Prints an error message for allocating arrays + ! (2 ) ErrMsg : Prints an error message and halts execution + ! (3 ) Msg : Prints a message and flushes buffer + ! (4 ) CheckValue : Checks a value for NaN or Infinity condition + ! (5 ) ReplaceNanAndInfR4 : Replaces a REAL*4 Nan/Inf value w/ other data + ! (6 ) ReplaceNanAndInfR8 : Checks for NaN + ! (7 ) ItIsFiniteR4 : Checks a REAL*4 value for Infinity + ! (8 ) ItIsFiniteR8 : Checks a REAL*8 value for Infinity + ! (9 ) ItIsNanR4 : Checks a REAL*4 value for NaN + ! (10) ItIsNanR8 : Checks a REAL*8 value for NaN + ! + ! Module Interfaces: + ! ----------------------------------------------------------------------- + ! (1 ) ReplaceNanAndInf : Overloads ReplaceNanAndInfR4, ReplaceNanAndInfR8 + ! (2 ) ItIsFinite : Overloads ItIsFiniteR4, ItIsFiniteR8 + ! (3 ) ItIsNan : Overloads ItIsNanR4, ItIsNanR8 + ! + ! NOTES: + ! (1 ) Adapted from He4ErrorModule.f90 (bmy, 2/15/07) + !======================================================================== + + IMPLICIT NONE + + !------------------------------- + ! PRIVATE / PUBLIC DECLARATIONS + !------------------------------- + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: AllocErr + PUBLIC :: ErrMsg + PUBLIC :: Msg + PUBLIC :: CheckValue + PUBLIC :: ItIsNan + PUBLIC :: ItIsFinite + PUBLIC :: ReplaceNanAndInf + + !------------------------------- + ! MODULE INTERFACES + !------------------------------- + + INTERFACE ReplaceNanAndInf + MODULE PROCEDURE ReplaceNanAndInfR4 + MODULE PROCEDURE ReplaceNanAndInfR8 + END INTERFACE + + INTERFACE ItIsNan + MODULE PROCEDURE ItIsNanR4 + MODULE PROCEDURE ItIsNanR8 + END INTERFACE + + INTERFACE ItIsFinite + MODULE PROCEDURE ItIsFiniteR4 + MODULE PROCEDURE ItIsFiniteR8 + END INTERFACE + + !------------------------------- + ! MODULE ROUTINES + !------------------------------- + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE AllocErr( arrayName ) + + !====================================================================== + ! Subroutine He4AllocErr stops program execution upon an error + ! allocating arrays. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) arrayName (CHARACTER) : Name of array + ! + ! NOETS: + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: arrayName + + !---------------------------- + ! He4AllocErr begins here! + !---------------------------- + + ! Write info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) TRIM( arrayName ) + WRITE( 6, 110 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL FLUSH( 6 ) + + ! Exit + CALL EXIT( 1 ) + + ! FORMAT strings +100 FORMAT( 'Allocation error for array ', a ) +110 FORMAT( 'STOP in allocErr ("Hdf4ErrorModule.f90")' ) + + END SUBROUTINE AllocErr + +!------------------------------------------------------------------------------ + + SUBROUTINE ErrMsg( msg, loc ) + + !====================================================================== + ! Subroutine ErrMsg halts displays an error message and halts + ! program execution. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) msg (CHARACTER) : Error message to display + ! (2 ) loc (CHARACTER) : Location where the error occurred + ! + ! NOTES: + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: msg + CHARACTER(LEN=*), INTENT(IN) :: loc + + !-------------------------- + ! ErrMsg begins here! + !-------------------------- + + ! Print error message + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) TRIM( msg ) + WRITE( 6, 100 ) TRIM( loc ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL FLUSH( 6 ) + + ! Exit simulation + CALL EXIT( 1 ) + + ! FORMAT string +100 FORMAT( 'STOP in ', a ) + + END SUBROUTINE ErrMsg + +!------------------------------------------------------------------------------ + + SUBROUTINE Msg( str ) + + !====================================================================== + ! Subroutine Msg prints a string and flushes the output buffer. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) str (CHARACTER) : Message to display + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: str + + !--------------------- + ! Msg begins here! + !--------------------- + + ! Print message + WRITE( 6, '(a)' ) TRIM( str ) + CALL flush( 6 ) + + END SUBROUTINE Msg + +!----------------------------------------------------------------------------- + + SUBROUTINE CheckValue( value, name, loc ) + + !====================================================================== + ! Subroutine CheckValue tests a value for IEEE NaN or Infinity. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*4 ) : value to be tested + ! (2 ) name (CHARACTER) : name of the variable + ! (3 ) loc (INTEGER ) : Grid box location (/i,j,l,t/) + !====================================================================== + + ! Arguments + REAL*4, INTENT(IN) :: value + CHARACTER(LEN=*), INTENT(IN) :: name + INTEGER, INTENT(IN) :: loc(4) + + ! If VALUE is NaN, stop w/ error message + IF ( itIsNaN( value ) ) THEN +!!$OMP CRITICAL + WRITE( 6, 100 ) TRIM( name ), loc + 100 FORMAT( a, ' is NaN at grid box: ', 4i4, '!' ) + STOP +!!$OMP END CRITICAL + ENDIF + + ! If VALUE is +/- Infinity, stop w/ error message + IF ( .not. itIsFinite( value ) ) THEN +!!$OMP CRITICAL + WRITE( 6, 110 ) TRIM( name ), loc + 110 FORMAT( a, ' is +/- Infinity at grid box: ', 4i4, '!' ) + STOP +!!$OMP END CRITICAL + ENDIF + + END SUBROUTINE CheckValue + +!----------------------------------------------------------------------------- + + SUBROUTINE ReplaceNanAndInfR4( value, replacement ) + + !====================================================================== + ! Subroutine ReplaceNaNandInfR4 replaces a NaN or infinity REAL*4 + ! value with a replacement value. You can use this to assign missing + ! data flags such as -9999 to NaN or infinity values. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*4) : Value to be tested + ! (2 ) replacement (REAL*4) : Replacement value + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*4) : Value is overwritten and returned + !====================================================================== + + ! Arguments + REAL*4, INTENT(INOUT) :: value + REAL*4, INTENT(IN) :: replacement + + !---------------------------------- + ! ReplaceNanAndInfR4 begins here! + !---------------------------------- + + IF ( ItIsNan( value ) ) THEN + value = replacement + ELSE IF ( .not. ItIsFinite( value ) ) THEN + value = replacement + ENDIF + + END SUBROUTINE ReplaceNanAndInfR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE ReplaceNanAndInfR8( value, replacement ) + + !====================================================================== + ! Subroutine ReplaceNaNandInfR8 replaces a NaN or infinity REAL*8 + ! value with a replacement value. You can use this to assign missing + ! data flags such as -9999 to NaN or infinity values. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*8) : Value to be tested + ! (2 ) replacement (REAL*8) : Replacement value + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*4) : Value is overwritten and returned + !====================================================================== + + ! Arguments + REAL*8, INTENT(INOUT) :: value + REAL*8, INTENT(IN) :: replacement + + !---------------------------------- + ! ReplaceNanAndInfR8 begins here! + !---------------------------------- + + IF ( ItIsNan( value ) ) THEN + value = replacement + ELSE IF ( .not. ItIsFinite( value ) ) THEN + value = replacement + ENDIF + + END SUBROUTINE ReplaceNanAndInfR8 + +!----------------------------------------------------------------------------- + + FUNCTION ItIsNanR4( value ) RESULT( itIsANaN ) + + !=================================================================== + ! Subroutine ItIsNanR4 tests a REAL*4 value for IEEE NaN on SGI, + ! Altix, Linux, or Sun platforms. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*4) : value to be tested + !=================================================================== + +# include "define.h" + + ! Argument + REAL*4, INTENT(IN) :: value + LOGICAL :: itIsANaN + + !------------------------- + ! ItIsNanR4 begins here! + !------------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + ItIsANan = IEEE_IS_NAN( value ) + +#elif defined( ALTIX ) || defined( PC ) + + ! Declare IS_NAN as an external function + INTEGER, EXTERNAL :: IS_NAN + + ! For LINUX or IFORT compilers, use C routine "is_nan" to test for NaN + ! VALUE must be cast to DBLE since "is_nan" only takes doubles. + ItIsANan = ( IS_NAN( DBLE( value ) ) /= 0 ) + +#elif defined( SPARC ) + + ! Declare Sun intrinsic IR_ISNAN as an external function + INTEGER, EXTERNAL :: IR_ISNAN + + ! Test if VALUE is a NaN + ItIsANan = ( IR_ISNAN( value ) /= 0 ) + +#endif + + END FUNCTION ItIsNanR4 + +!----------------------------------------------------------------------------- + + FUNCTION ItIsNanR8( value ) RESULT( ItIsANan ) + + !=================================================================== + ! Subroutine ItIsNanR8 tests a REAL*8 value for IEEE NaN on SGI, + ! Altix, Linux, or Sun platforms. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*8) : value to be tested + !=================================================================== + + ! Argument + REAL*8, INTENT(IN) :: value + LOGICAL :: ItIsANan + + !------------------------- + ! ItisNanR8 begins here! + !------------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + ItIsANan = IEEE_IS_NAN( value ) + +#elif defined( ALTIX ) || defined( PC ) + + ! Declare IS_NAN as an external function + INTEGER, EXTERNAL :: IS_NAN + + ! For LINUX or IFORT compilers, use C routine "is_nan" to test for NaN + ! VALUE must be cast to DBLE since "is_nan" only takes doubles. + ItIsANan = ( is_nan( value ) /= 0 ) + +#elif defined( SPARC ) + + ! Declare ID_ISNAN as an external function + INTEGER, EXTERNAL :: ID_ISNAN + + ! Test if VALUE is a NaN + ItIsANan = ( ID_ISNAN( value ) /= 0 ) + +#endif + + END FUNCTION ItIsNanR8 + +!----------------------------------------------------------------------------- + + FUNCTION ItIsFiniteR4( value ) RESULT( itIsAFinite ) + + !=================================================================== + ! Subroutine ItIsFiniteR4 tests a REAL*4 value for IEEE Finite on + ! SGI, Altix, Linux, or Sun platforms. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*4) : value to be tested + !=================================================================== + + ! Arguments + REAL*4, INTENT(IN) :: value + LOGICAL :: ItIsAFinite + + !---------------------------- + ! ItIsFiniteR4 begins here! + !---------------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + ItIsAFinite = IEEE_FINITE( value ) + +#elif defined( ALTIX ) || defined( PC ) + + ! Declare IS_FINITE as an external function + INTEGER, EXTERNAL :: IS_FINITE + + ! For LINUX or INTEL_FC compilers, use C routine "is_finite" to test if + ! VALUE is finite. VALUE must be cast to DBLE since "is_finite" only + ! takes doubles. + ItIsAFinite = ( IS_FINITE( DBLE( value ) ) /= 0 ) + +#elif defined( SPARC ) + + ! Declare Sun intrinsic IR_FINITE as an external function + INTEGER, EXTERNAL :: IR_FINITE + + ! Test if VALUE is a finite number + ItIsAFinite = ( IR_FINITE( VALUE ) /= 0 ) + +#endif + + END FUNCTION ItIsFiniteR4 + +!----------------------------------------------------------------------------- + + FUNCTION ItIsFiniteR8( value ) RESULT( itIsAFinite ) + + !=================================================================== + ! Subroutine ItIsFiniteR8 tests a REAL*8 value for IEEE Finite on + ! SGI, Altix, Linux, or Sun platforms. (bmy, 2/15/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*8) : value to be tested + !=================================================================== + + ! Arguments + REAL*8, INTENT(IN) :: value + LOGICAL :: ItIsAFinite + + !---------------------------- + ! ItIsFiniteR4 begins here! + !---------------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + ItIsAFinite = IEEE_FINITE( value ) + +#elif defined( ALTIX ) || defined( PC ) + + ! Declare IS_FINITE as an external function + INTEGER, EXTERNAL :: IS_FINITE + + ! For Altix or Linux compilers, use C routine + ! "is_finite" to test if VALUE is finite. + ItIsAFinite = ( IS_FINITE( value ) /= 0 ) + +#elif defined( SPARC ) + + ! Declare Sun intrinsic ID_FINITE as an external function + INTEGER, EXTERNAL :: ID_FINITE + + ! Test if VALUE is a finite number + ItIsAFinite = ( ID_FINITE( VALUE ) /= 0 ) + +#endif + + END FUNCTION ItIsFiniteR8 + +!----------------------------------------------------------------------------- + +END MODULE ErrorModule diff --git a/code/obs_operators/HdfIncludeModule.f90 b/code/obs_operators/HdfIncludeModule.f90 new file mode 100644 index 0000000..f35e3b0 --- /dev/null +++ b/code/obs_operators/HdfIncludeModule.f90 @@ -0,0 +1,449 @@ +! $Id: HdfIncludeModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +! +!**************************************************************************** +!* NCSA HDF * +!* Software Development Group * +!* National Center for Supercomputing Applications * +!* University of Illinois at Urbana-Champaign * +!* 605 E. Springfield, Champaign IL 61820 * +!* * +!* For conditions of distribution and use, see the accompanying * +!* hdf/COPYING file. * +!* * +!**************************************************************************** +! +! hdf.inc,v 1.22 1997/02/11 17:32:54 sxu Exp +! +! *-------------------------------------------------------------------------- +! * File: hdf.inc +! * Purpose: Fortran header file for HDF routines +! * Contents: +! * Tag definitions +! * Error return codes +! * Logical constants +! * Remarks: This file can be included with Fortran user programs. As a +! * general rule, don't use DFNT constants that don't include a +! * number in their name. E.g., don't use DFNT_FLOAT, use +! * DFNT_FLOAT32 or DFNT_FLOAT64. The DFNT constants that don't +! * include numbers are for backward compatibility only. Also, +! * there are no current plans to support 128-bit number types. +! * For more information about constants in this file, see the +! * equivalent constant declarations in the C include file 'hdf.h' +! * +! * placed into F90 module "HdfIncludeModule" by bmy (1/24/2000) +! *-------------------------------------------------------------------------- + + MODULE HdfIncludeModule + + ! Error Return Codes + + integer DFE_NOERROR, DFE_NONE, DFE_FNF + integer DFE_DENIED, DFE_ALROPEN, DFE_TOOMANY + integer DFE_BADNAME, DFE_BADACC, DFE_BADOPEN + integer DFE_NOTOPEN, DFE_CANTCLOSE, DFE_DFNULL + integer DFE_ILLTYPE, DFE_UNSUPPORTED, DFE_BADDDLIST + integer DFE_NOTDFFILE, DFE_SEEDTWICE, DFE_NOSPACE + integer DFE_NOSUCHTAG, DFE_READERROR + + parameter(DFE_NOERROR = 0) + parameter(DFE_NONE = 0) + parameter(DFE_FNF = -1) + parameter(DFE_DENIED = -2) + parameter(DFE_ALROPEN = -3) + parameter(DFE_TOOMANY = -4) + parameter(DFE_BADNAME = -5) + parameter(DFE_BADACC = -6) + parameter(DFE_BADOPEN = -7) + parameter(DFE_NOTOPEN = -8) + parameter(DFE_CANTCLOSE = -9) + parameter(DFE_DFNULL = -10) + parameter(DFE_ILLTYPE = -11) + parameter(DFE_UNSUPPORTED = -12) + parameter(DFE_BADDDLIST = -13) + parameter(DFE_NOTDFFILE = -14) + parameter(DFE_SEEDTWICE = -15) + parameter(DFE_NOSPACE = -16) + parameter(DFE_NOSUCHTAG = -17) + parameter(DFE_READERROR = -18) + + integer DFE_WRITEERROR, DFE_SEEKERROR, DFE_NOFREEDD + integer DFE_BADTAG, DFE_BADREF, DFE_RDONLY + integer DFE_BADCALL, DFE_BADPTR, DFE_BADLEN + integer DFE_BADSEEK, DFE_NOMATCH, DFE_NOTINSET + integer DFE_BADDIM, DFE_BADOFFSET, DFE_BADSCHEME + integer DFE_NODIM, DFE_NOTENOUGH, DFE_NOVALS + integer DFE_CORRUPT, DFE_BADFP + + parameter(DFE_WRITEERROR = -19) + parameter(DFE_SEEKERROR = -20) + parameter(DFE_NOFREEDD = -21) + parameter(DFE_BADTAG = -22) + parameter(DFE_BADREF = -23) + parameter(DFE_RDONLY = -24) + parameter(DFE_BADCALL = -25) + parameter(DFE_BADPTR = -26) + parameter(DFE_BADLEN = -27) + parameter(DFE_BADSEEK = -28) + parameter(DFE_NOMATCH = -29) + parameter(DFE_NOTINSET = -30) + parameter(DFE_BADDIM = -31) + parameter(DFE_BADOFFSET = -32) + parameter(DFE_BADSCHEME = -33) + parameter(DFE_NODIM = -34) + parameter(DFE_NOTENOUGH = -35) + parameter(DFE_NOVALS = -36) + parameter(DFE_CORRUPT = -37) + parameter(DFE_BADFP = -38) + + integer DFE_NOREF, DFE_BADDATATYPE, DFE_BADMCTYPE + integer DFE_BADNUMTYPE, DFE_BADORDER, DFE_ARGS + integer DFE_INTERNAL, DFE_DUPDD, DFE_CANTMOD + integer DFE_RANGE, DFE_BADTABLE, DFE_BADSDG + integer DFE_BADNDG, DFE_BADFIELDS, DFE_NORESET + integer DFE_NOVS, DFE_VGSIZE, DFE_DIFFFILES + integer DFE_VTAB, DFE_BADAID + + parameter(DFE_NOREF = -39) + parameter(DFE_BADDATATYPE = -40) + parameter(DFE_BADMCTYPE = -41) + parameter(DFE_BADNUMTYPE = -42) + parameter(DFE_BADORDER = -43) + parameter(DFE_ARGS = -44) + parameter(DFE_INTERNAL = -45) + parameter(DFE_DUPDD = -46) + parameter(DFE_CANTMOD = -47) + parameter(DFE_RANGE = -48) + parameter(DFE_BADTABLE = -49) + parameter(DFE_BADSDG = -50) + parameter(DFE_BADNDG = -51) + parameter(DFE_BADFIELDS = -52) + parameter(DFE_NORESET = -53) + parameter(DFE_NOVS = -54) + parameter(DFE_VGSIZE = -55) + parameter(DFE_DIFFFILES = -56) + parameter(DFE_VTAB = -57) + parameter(DFE_BADAID = -58) + + integer DFE_OPENAID, DFE_BADCONV, DFE_GENAPP, DFE_CANTFLUSH + integer DFE_BADTYPE, DFE_SYMSIZE, DFE_BADATTACH + integer DFE_CANTDETACH + + parameter(DFE_OPENAID = -59) + parameter(DFE_BADCONV = -60) + parameter(DFE_GENAPP = -61) + parameter(DFE_CANTFLUSH = -62) + parameter(DFE_BADTYPE = -63) + parameter(DFE_SYMSIZE = -64) + parameter(DFE_BADATTACH = -65) + parameter(DFE_CANTDETACH = -66) + + ! internal file access codes + + integer DFACC_READ, DFACC_WRITE, DFACC_CREATE, DFACC_ALL + integer DFACC_RDONLY, DFACC_RDWR, DFACC_CLOBBER + + parameter(DFACC_READ = 1) + parameter(DFACC_WRITE = 2) + parameter(DFACC_CREATE = 4) + parameter(DFACC_ALL = 7) + parameter(DFACC_RDONLY = 1) + parameter(DFACC_RDWR = 3) + parameter(DFACC_CLOBBER = 4) + + ! Access types for SDsetaccesstype + + integer DFACC_DEFAULT, DFACC_SERIAL, DFACC_PARALLEL + parameter(DFACC_DEFAULT = 0) + parameter(DFACC_SERIAL = 1) + parameter(DFACC_PARALLEL = 9) + + ! Constants for DFSDsetorder + + integer DFO_FORTRAN, DFO_C + + parameter(DFO_FORTRAN = 1) + parameter(DFO_C = 2) + + ! Definitions of storage convention + + integer DFNTF_IEEE, DFNTF_VAX, DFNTF_CRAY, DFNTF_PC + integer DFNTF_CONVEX, DFNTF_VP + + parameter(DFNTF_IEEE = 1) + parameter(DFNTF_VAX = 2) + parameter(DFNTF_CRAY = 3) + parameter(DFNTF_PC = 4) + parameter(DFNTF_CONVEX = 5) + parameter(DFNTF_VP = 6) + + ! Masks for types + + integer DFNT_HDF, DFNT_NATIVE, DFNT_CUSTOM, DFNT_LITEND + + parameter(DFNT_HDF = 0) + parameter(DFNT_NATIVE = 4096) + parameter(DFNT_CUSTOM = 8192) + parameter(DFNT_LITEND = 16384) + + ! Number type info codes + + integer DFNT_NONE, DFNT_QUERY, DFNT_VERSION + + parameter(DFNT_NONE = 0) + parameter(DFNT_QUERY = 0) + parameter(DFNT_VERSION = 1) + + integer DFNT_FLOAT32, DFNT_FLOAT, DFNT_FLOAT64 + integer DFNT_DOUBLE, DFNT_FLOAT128 + + parameter(DFNT_FLOAT32 = 5) + parameter(DFNT_FLOAT = 5) + parameter(DFNT_FLOAT64 = 6) + parameter(DFNT_DOUBLE = 6) + parameter(DFNT_FLOAT128 = 7) + + integer DFNT_INT8, DFNT_UINT8 + integer DFNT_INT16, DFNT_UINT16 + integer DFNT_INT32, DFNT_UINT32 + integer DFNT_INT64, DFNT_UINT64 + integer DFNT_INT128,DFNT_UINT128 + + parameter(DFNT_INT8 = 20) + parameter(DFNT_UINT8 = 21) + parameter(DFNT_INT16 = 22) + parameter(DFNT_UINT16 = 23) + parameter(DFNT_INT32 = 24) + parameter(DFNT_UINT32 = 25) + parameter(DFNT_INT64 = 26) + parameter(DFNT_UINT64 = 27) + parameter(DFNT_INT128 = 28) + parameter(DFNT_UINT128 = 29) + + integer DFNT_UCHAR8, DFNT_UCHAR, DFNT_CHAR8 + integer DFNT_CHAR, DFNT_CHAR16, DFNT_UCHAR16 + + parameter(DFNT_UCHAR8 = 3) + parameter(DFNT_UCHAR = 3) + parameter(DFNT_CHAR8 = 4) + parameter(DFNT_CHAR = 4) + parameter(DFNT_CHAR16 = 42) + parameter(DFNT_UCHAR16 = 43) + + integer DFNT_NFLOAT32, DFNT_NFLOAT, DFNT_NFLOAT64 + integer DFNT_NDOUBLE, DFNT_NFLOAT128 + + parameter(DFNT_NFLOAT32 = 4101) + parameter(DFNT_NFLOAT = 4101) + parameter(DFNT_NFLOAT64 = 4102) + parameter(DFNT_NDOUBLE = 4102) + parameter(DFNT_NFLOAT128 = 4103) + + integer DFNT_NINT8, DFNT_NUINT8 + integer DFNT_NINT16, DFNT_NUINT16 + integer DFNT_NINT32, DFNT_NUINT32 + integer DFNT_NINT64, DFNT_NUINT64 + integer DFNT_NINT128,DFNT_NUINT128 + + parameter(DFNT_NINT8 = 4116) + parameter(DFNT_NUINT8 = 4117) + parameter(DFNT_NINT16 = 4118) + parameter(DFNT_NUINT16 = 4119) + parameter(DFNT_NINT32 = 4120) + parameter(DFNT_NUINT32 = 4121) + parameter(DFNT_NINT64 = 4122) + parameter(DFNT_NUINT64 = 4123) + parameter(DFNT_NINT128 = 4124) + parameter(DFNT_NUINT128 = 4125) + + integer DFNT_NUCHAR8, DFNT_NUCHAR, DFNT_NCHAR8 + integer DFNT_NCHAR, DFNT_NCHAR16, DFNT_NUCHAR16 + + parameter(DFNT_NUCHAR8 = 4099) + parameter(DFNT_NUCHAR = 4099) + parameter(DFNT_NCHAR8 = 4100) + parameter(DFNT_NCHAR = 4100) + parameter(DFNT_NCHAR16 = 4138) + parameter(DFNT_NUCHAR16 = 4139) + + integer DFNT_LFLOAT32, DFNT_LFLOAT, DFNT_LFLOAT64 + integer DFNT_LDOUBLE, DFNT_LFLOAT128 + + parameter(DFNT_LFLOAT32 = 16389) + parameter(DFNT_LFLOAT = 16389) + parameter(DFNT_LFLOAT64 = 16390) + parameter(DFNT_LDOUBLE = 16390) + parameter(DFNT_LFLOAT128 = 16391) + + integer DFNT_LINT8,DFNT_LUINT8,DFNT_LINT16,DFNT_LUINT16 + integer DFNT_LINT32,DFNT_LUINT32,DFNT_LINT64,DFNT_LUINT64 + integer DFNT_LINT128,DFNT_LUINT128 + + parameter(DFNT_LINT8 = 16404) + parameter(DFNT_LUINT8 = 16405) + parameter(DFNT_LINT16 = 16406) + parameter(DFNT_LUINT16 = 16407) + parameter(DFNT_LINT32 = 16408) + parameter(DFNT_LUINT32 = 16409) + parameter(DFNT_LINT64 = 16410) + parameter(DFNT_LUINT64 = 16411) + parameter(DFNT_LINT128 = 16412) + parameter(DFNT_LUINT128 = 16413) + + integer DFNT_LUCHAR8, DFNT_LUCHAR, DFNT_LCHAR8 + integer DFNT_LCHAR, DFNT_LCHAR16, DFNT_LUCHAR16 + + parameter(DFNT_LUCHAR8 = 16387) + parameter(DFNT_LUCHAR = 16387) + parameter(DFNT_LCHAR8 = 16388) + parameter(DFNT_LCHAR = 16388) + parameter(DFNT_LCHAR16 = 16426) + parameter(DFNT_LUCHAR16 = 16427) + + ! tags and refs + + integer DFREF_WILDCARD, DFTAG_WILDCARD, DFTAG_NULL + integer DFTAG_LINKED, DFTAG_VERSION, DFTAG_COMPRESSED + + parameter(DFREF_WILDCARD = 0, DFTAG_WILDCARD = 0) + parameter(DFTAG_NULL = 1, DFTAG_LINKED = 20) + parameter(DFTAG_VERSION = 30,DFTAG_COMPRESSED = 40) + + + ! utility set + + integer DFTAG_FID, DFTAG_FD, DFTAG_TID, DFTAG_TD + integer DFTAG_DIL, DFTAG_DIA, DFTAG_NT, DFTAG_MT + + parameter(DFTAG_FID = 100, DFTAG_FD = 101) + parameter(DFTAG_TID = 102, DFTAG_TD = 103) + parameter(DFTAG_DIL = 104, DFTAG_DIA = 105) + parameter(DFTAG_NT = 106, DFTAG_MT = 107) + + ! raster-8 set + + integer DFTAG_ID8, DFTAG_IP8, DFTAG_RI8 + integer DFTAG_CI8, DFTAG_II8 + + parameter(DFTAG_ID8 = 200, DFTAG_IP8 = 201) + parameter(DFTAG_RI8 = 202, DFTAG_CI8 = 203) + parameter(DFTAG_II8 = 204) + + ! Raster Image set + + integer DFTAG_ID, DFTAG_LUT, DFTAG_RI, DFTAG_CI + + parameter(DFTAG_ID = 300, DFTAG_LUT = 301) + parameter(DFTAG_RI = 302, DFTAG_CI = 303) + + integer DFTAG_RIG, DFTAG_LD, DFTAG_MD, DFTAG_MA + integer DFTAG_CCN, DFTAG_CFM, DFTAG_AR + + parameter(DFTAG_RIG = 306, DFTAG_LD = 307) + parameter(DFTAG_MD = 308, DFTAG_MA = 309) + parameter(DFTAG_CCN = 310, DFTAG_CFM = 311) + parameter(DFTAG_AR = 312) + + integer DFTAG_DRAW, DFTAG_RUN, DFTAG_XYP, DFTAG_MTO + + parameter(DFTAG_DRAW = 400, DFTAG_RUN = 401) + parameter(DFTAG_XYP = 500, DFTAG_MTO = 501) + + ! Tektronix + + integer DFTAG_T14, DFTAG_T105 + + parameter(DFTAG_T14 = 602, DFTAG_T105 = 603) + + ! Scientific Data set + + integer DFTAG_SDG, DFTAG_SDD, DFTAG_SD, DFTAG_SDS, DFTAG_SDL + integer DFTAG_SDU, DFTAG_SDF, DFTAG_SDM, DFTAG_SDC + integer DFTAG_SDT,DFTAG_SDLNK,DFTAG_NDG + integer DFTAG_BREQ,DFTAG_EREQ,DFTAG_CAL, DFTAG_FV + + parameter(DFTAG_SDG = 700, DFTAG_SDD = 701) + parameter(DFTAG_SD = 702, DFTAG_SDS = 703) + parameter(DFTAG_SDL = 704, DFTAG_SDU = 705) + parameter(DFTAG_SDF = 706, DFTAG_SDM = 707) + parameter(DFTAG_SDC = 708, DFTAG_SDT = 709) + parameter(DFTAG_SDLNK = 710, DFTAG_NDG = 720) + parameter(DFTAG_CAL = 731, DFTAG_FV = 732) + parameter(DFTAG_BREQ = 799, DFTAG_EREQ = 780) + + ! VSets + + integer DFTAG_VG, DFTAG_VH, DFTAG_VS + + parameter(DFTAG_VG = 1965, DFTAG_VH = 1962) + parameter(DFTAG_VS = 1963) + + ! compression schemes + + integer DFTAG_RLE, DFTAG_IMC, DFTAG_IMCOMP, DFTAG_JPEG + integer DFTAG_GREYJPEG + + parameter(DFTAG_RLE =11, DFTAG_IMC =12) + parameter(DFTAG_IMCOMP =12, DFTAG_JPEG =13) + parameter(DFTAG_GREYJPEG =14) + + ! SPECIAL CODES + + integer SPECIAL_LINKED, SPECIAL_EXT + + parameter(SPECIAL_LINKED = 1, SPECIAL_EXT = 2) + + ! PARAMETERS + + integer DF_MAXFNLEN + integer SD_UNLIMITED + integer SD_DIMVAL_BW_COMP + integer SD_DIMVAL_BW_INCOMP + integer SD_FILL + integer SD_NOFILL + + parameter(DF_MAXFNLEN = 256, SD_UNLIMITED = 0) + parameter(SD_DIMVAL_BW_COMP = 1, SD_DIMVAL_BW_INCOMP = 0) + parameter(SD_FILL = 0, SD_NOFILL = 256) + + integer HDF_VDATA + + parameter(HDF_VDATA = -1) + + ! Standard return codes + integer SUCCEED, FAIL + + parameter(SUCCEED = 0, FAIL = -1) + + + ! Compression Types + + integer COMP_NONE, COMP_RLE, COMP_IMCOMP, COMP_JPEG + + parameter(COMP_NONE = 0, COMP_RLE = 11) + parameter(COMP_IMCOMP = 12, COMP_JPEG = 2) + + ! Interlace Types + + integer MFGR_INTERLACE_PIXEL, MFGR_INTERLACE_LINE + integer MFGR_INTERLACE_COMPONENT + + parameter(MFGR_INTERLACE_PIXEL = 0) + parameter(MFGR_INTERLACE_LINE = 1) + parameter(MFGR_INTERLACE_COMPONENT= 2) + + integer FULL_INTERLACE, NO_INTERLACE + + parameter(FULL_INTERLACE = 0, NO_INTERLACE = 1) + + ! Vdata fields packing types + integer HDF_VSPACK, HDF_VSUNPACK + parameter (HDF_VSPACK = 0, HDF_VSUNPACK = 1) + + ! Multi-file Annotation types + integer AN_DATA_LABEL, AN_DATA_DESC, AN_FILE_LABEL, AN_FILE_DESC + + parameter(AN_DATA_LABEL = 0, AN_DATA_DESC = 1) + parameter(AN_FILE_LABEL = 2, AN_FILE_DESC = 3) + + END MODULE HdfIncludeModule +!******************End of hdf.inc*************************** diff --git a/code/obs_operators/HdfSdModule.f90 b/code/obs_operators/HdfSdModule.f90 new file mode 100644 index 0000000..2b0a4ba --- /dev/null +++ b/code/obs_operators/HdfSdModule.f90 @@ -0,0 +1,1277 @@ +! $Id: HdfSdModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +MODULE HdfSdModule + + !=========================================================================== + ! Module "HdfSdModule" contains variables and methods that are used to + ! read data fields stored in HDF-SD format. (bmy, 4/26/02, 4/27/05) + ! + ! In order to use HdfSdModule, you must first install the HDF-4 library + ! on your system. You may download the library source code from: + ! + ! http://hdf.ncsa.uiuc.edu/hdf4.html + ! + ! There is also a good online tutorial about the HDF-SD interface at: + ! + ! http://hdf.ncsa.uiuc.edu/training/HDFtraining/tutorial/sd/sds.html + ! + ! Module Variables: + ! -------------------------------------------------------------------------- + ! (1 ) fileId : ID number for the HDF file + ! (2 ) nDataSets : # of data fields contained w/in a HDF file + ! (3 ) nAttributes : # of global atttributes contained w/in a HDF file + ! (4 ) saveFileName : Shadow variable used to store HDF file name + ! + ! Module Methods: + ! -------------------------------------------------------------------------- + ! (1 ) sdOpen : Opens the HDF file + ! (2 ) sdClose : Closes the HDF file + ! (3 ) sdName2Index : Locates position of field w/in a HDF file by name + ! (4 ) sdOpenField : Opens a data field w/in a HDF file by index + ! (5 ) sdOpenFieldByName : Opens a data field w/in a HDF file by name + ! (6 ) sdCloseField : Closes access to a data field w/in a HDF file + ! (7 ) sdPrintInfo : Prints information about fields w/in a HDF file + ! (8 ) sdGetFieldDims : Gets dimensions of a given field w/in a HDF file + ! (9 ) sdGetData1dI4 : Reads a 1-D INTEGER data field from the HDF file + ! (10) sdGetData1d : Reads a 1-D REAL*4 data field from the HDF file + ! (11) sdGetData2d : Reads a 2-D REAL*4 data field from the HDF file + ! (12) sdGetData3d : Reads a 3-D REAL*4 data field from the HDF file + ! (13) sdGetData4d : Reads a 4-D REAL*4 data field from the HDF file + ! (14) sdGetData1d1Time : Reads one time value of a 2-D REAL*4 data field + ! (15) sdGetData2d1Time : Reads one time value of a 2-D REAL*4 data field + ! (16) sdGetData2d1TimeR8: Reads one time value of a 2-D REAL*8 data fiedl + ! (17) sdGetData3d1Time : Reads one time value of a 3-D REAL*4 data field + ! (18) sdGetData3d1TimeR8: Reads one time value of a 3-D REAL*8 data fiedl + ! (19) sdShift1d : Shifts a 1-D REAL*4 data field by 180 degrees + ! (20) sdShift2d : Shifts a 2-D REAL*4 data field by 180 degrees + ! (21) sdShift3d : Shifts a 3-D REAL*4 data field by 180 degrees + ! (22) sdShift4d : Shifts a 4-D REAL*4 data field by 180 degrees + ! (23) sdGetMaxDims : Returns the value of MAX_DIMS to outside routines + ! + ! Module Interfaces: + ! -------------------------------------------------------------------------- + ! (1 ) sdGetData : sdGetData1d, sdGetData1d_i4, sdGetData2d, + ! sdGetData3d, sdGetData4d + ! (2 ) sdGetData1 : sdGetData1d1Time, sdGetData2d1Time, + ! sdGetData2d1TimeR8, sdGetData3d1Time, + ! sdGetData3d1TimeR8 + ! (3 ) sdShift : sdShift1d, sdShift2d, sdShift3d, sdShift4d + ! + ! NOTES: + ! (1 ) HdfSdModule is designed to only have one HDF file open at a time. + ! Once you have opened a file, you may attach/detach from as many + ! individual data fields as you want. (bmy, 4/9/02) + ! (2 ) Added routines sdGetData1d1Time, sdGetData2d1Time, and + ! sdGetData3d1Time to read an array for only one time value + ! from the HDF file, instead of reading the whole array (bmy, 4/25/02) + ! (3 ) Declared internal routines and variables PRIVATE (bmy, 7/19/02) + ! (4 ) Added routines sdGetData2d1TimeR8 and sdGetData3d1TimeR8 in order + ! to read REAL*8 data from the HDF file. Also changed the name of + ! sdGetData1d_i4 to sdGetData1dI4. (bmy, 7/19/02) + ! (5 ) Minor updates. Improved documentation and error/warning messages. + ! (bmy, 7/3/03) + ! (6 ) Modified for inclusion into GEOS-CHEM (bmy, 4/27/05) + !=========================================================================== + USE HdfIncludeModule + + IMPLICIT NONE + + !===================================================================== + ! MODULE PRIVATE DECLARATIONS + !===================================================================== + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: sdClose + PUBLIC :: sdCloseField + PUBLIC :: sdGetMaxDims + PUBLIC :: sdGetData + PUBLIC :: sdGetData1 + PUBLIC :: sdGetFieldDims + PUBLIC :: sdName2Index + PUBLIC :: sdOpen + PUBLIC :: sdOpenField + PUBLIC :: sdOpenFieldByName + PUBLIC :: sdPrintInfo + PUBLIC :: sdShift + + !===================================================================== + ! MODULE VARIABLES + !===================================================================== + INTEGER :: fileId, nDataSets, nAttributes + INTEGER, PARAMETER :: MAX_DIMS = 4 + + ! Shadow variable for file name + CHARACTER(LEN=255), PRIVATE :: saveFileName + + !======================================================================= + ! Module interfaces: allow you to associate a name w/ several routines + ! with different numbers of arguments or different argument types + !======================================================================= + INTERFACE sdGetData + MODULE PROCEDURE sdGetData1dI4 + MODULE PROCEDURE sdGetData1d + MODULE PROCEDURE sdGetData2d + MODULE PROCEDURE sdGetData3d + MODULE PROCEDURE sdGetData4d + END INTERFACE + + INTERFACE sdGetData1 + MODULE PROCEDURE sdGetData1d1Time + MODULE PROCEDURE sdGetData2d1Time + MODULE PROCEDURE sdGetData3d1Time + MODULE PROCEDURE sdGetData2d1TimeR8 + MODULE PROCEDURE sdGetData3d1TimeR8 + END INTERFACE + + INTERFACE sdShift + MODULE PROCEDURE sdShift1d + MODULE PROCEDURE sdShift2d + MODULE PROCEDURE sdShift3d + MODULE PROCEDURE sdShift4d + END INTERFACE + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE sdOpen( fileName ) + + !===================================================================== + ! Subroutine "sdOpenFile" opens an HDF file and initializes the + ! scientific datasaet (HDF-SD) interface. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fileName : CHARACTER name of the HDF-EOS file to be opened + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) sfStart : returns INTEGER value ( fileId ) + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*) :: fileName + + ! Local Variables + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfStart + + !===================================================================== + ! sdOpen begins here! + !===================================================================== + + ! Save file name to a private shadow variable + saveFileName = TRIM( fileName ) + + ! Open the HDF file + fileId = sfStart( TRIM( fileName ), DFACC_RDONLY ) + + ! Error check fileId + IF ( fileId == FAIL ) THEN + message = 'ERROR: Could not open the HDF file ' // TRIM( fileName ) + CALL ERROR_STOP( message, 'sdOpen' ) + ENDIF + + END SUBROUTINE sdOpen + +!------------------------------------------------------------------------------ + + SUBROUTINE sdClose( fileName ) + + !===================================================================== + ! Subroutine "sdClose" terminates the HDF Scientific Dataset + ! (HDF-SD) interface and closes the HDF file. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fileName : CHARACTER name of the HDF-EOS file to be opened + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) sfEnd : takes INTEGER value ( fileId ) + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fileName + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfEnd + + !===================================================================== + ! sdClose begins here! + !===================================================================== + + ! Close the HDF file + status = sfEnd( fileId ) + + ! Error check status + IF ( status == FAIL ) THEN + message = 'ERROR: could not close the HDF file: ' // TRIM( fileName ) + CALL ERROR_STOP( message, 'sdClose' ) + ENDIF + + END SUBROUTINE sdClose + +!----------------------------------------------------------------------------- + + SUBROUTINE sdName2Index( name, n ) + + !=================================================================== + ! Subroutine sdName2Index finds out the number of a given data set + ! within an HDF file given its name. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) name (CHARACTER) : Name of the field to search for + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (2 ) n (INTEGER) : Number of the field in the HDF file + ! + ! External Functions: + ! ------------------------------------------------------------------ + ! (1 ) sfN2Index (INTEGER) : Returns index based on the name + !=================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: name + INTEGER, INTENT(OUT) :: n + + ! Local variables + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfN2Index + + !===================================================================== + ! sdName2Index begins here! + !===================================================================== + + ! Translate NAME to the HDF-EOS index number + n = sfN2Index( fileId, TRIM( name ) ) + + ! Make sure INDEX is valid + IF ( n == FAIL ) THEN + message = 'ERROR: ' // TRIM( name ) // & + ' is not found in ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdName2Index' ) + ENDIF + + END SUBROUTINE sdName2Index + +!----------------------------------------------------------------------------- + + SUBROUTINE sdOpenField( n, sdId ) + + !=================================================================== + ! Function sdOpenField initializes the HDF-SD interface for the Nth + ! field in the HDF file. The SD ID # is returned to the calling + ! program. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) n (INTEGER) : # of the scientific dataset in the HDF file + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (2 ) sdId (INTEGER) : ID # for the corresponding SD + ! + ! External Functions: + ! ------------------------------------------------------------------ + ! (1 ) sfSelect (INTEGER) : Returns ID # for scientific dataset + !=================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: n + INTEGER, INTENT(OUT) :: sdId + + ! Local variables + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER :: sfSelect + + !=================================================================== + ! sdOpenField begins here! + !=================================================================== + + ! Get the SD Index for the Nth dataset in the file + sdId = sfSelect( fileId, n ) + + ! Make sure data set ID is valid + IF ( sdId == FAIL ) then + message = 'ERROR: Invalid ID # for HDF-SDATA field!' + CALL ERROR_STOP( message, 'sdGetFieldId' ) + ENDIF + + END SUBROUTINE sdOpenField + +!----------------------------------------------------------------------------- + + SUBROUTINE sdOpenFieldByName( name, sdId ) + + !=================================================================== + ! Function sdOpenFieldbyName initializes the HDF-SD interface for + ! given the field name. The SD ID # is returned to the calling + ! program. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) name (CHARACTER) : name of the SD field in the HDF file + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (2 ) sdId (INTEGER) : ID # for the corresponding SD + ! + ! External Functions: + ! ------------------------------------------------------------------ + ! (1 ) sfSelect (INTEGER) : Returns ID # for scientific dataset + !=================================================================== + + ! Arguments + !CHARACTER(LEN=255) :: name + CHARACTER(LEN=*) :: name + INTEGER, INTENT(OUT) :: sdId + + ! Local variables + INTEGER :: n + CHARACTER(LEN=255) :: message + + !=================================================================== + ! sdOpenFieldByName begins here! + !=================================================================== + + ! Convert name to index + CALL sdName2Index( name, n ) + + ! Open field w/ via the index + CALL sdOpenField( n, sdId ) + + END SUBROUTINE sdOpenFieldByName + +!----------------------------------------------------------------------------- + + SUBROUTINE sdCloseField( sdId ) + + !===================================================================== + ! Subroutine sdCloseField terminates the HDF-SD interface for a + ! given field. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) N (INTEGER) : Number of the scientific dataset in the HDF file + ! + ! External Functions: + ! -------------------------------------------------------------------- + ! (1 ) sfSelect (INTEGER) : Returns ID # if successful or FAIL if not + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER :: sfEndAcc + + !===================================================================== + ! sdCloseField begins here! + !===================================================================== + + ! Terminate the ID # for this field + status = sfEndAcc( sdId ) + + ! Make sure data set ID is valid + IF ( status == FAIL ) then + message = 'ERROR: Could not terminate HDF-SDATA interface!' + CALL ERROR_STOP( message, 'sdCloseField' ) + ENDIF + + END SUBROUTINE sdCloseField + +!----------------------------------------------------------------------------- + + SUBROUTINE sdPrintInfo + + !===================================================================== + ! Subroutine sdPrintInfo obtains and prints information about each + ! data field stored in the HDF file. (bmy, 4/3/02, 7/3/03) + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) sdFInfo : returns nAttributes, nDataSets + ! (2) sdGInfo : returns name, rank, dims, numType, nAttrs for fields + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Local variables + INTEGER :: sdId, rank, dims(MAX_DIMS), numType + INTEGER :: n, i, nAttrs, status + CHARACTER(LEN=9) :: numStr + CHARACTER(LEN=255) :: message, name + + ! External functions + INTEGER, EXTERNAL :: sfFInfo, sfGInfo + + !===================================================================== + ! sdPrintInfo begins here! + ! + ! Get global file information: # of data sets and attributes + !===================================================================== + status = sfFInfo( fileId, nDataSets, nAttributes ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'Could not get info for ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetInfo' ) + ENDIF + + !===================================================================== + ! Get information about each field in the file + !===================================================================== + DO n = 0, nDataSets-1 + + ! Initialize the HDF-SD interface for field # N + CALL sdOpenField( n, sdId ) + + ! Get information about field #N from the HDF File + status = sfGInfo( sdId, name, rank, dims, numType, nAttrs ) + + ! Print info if successful + IF ( status == SUCCEED ) THEN + + ! Define string for number type + SELECT CASE ( numType ) + CASE( 5 ) + numStr = 'REAL*4 ' + CASE( 6 ) + numStr = 'REAL*8 ' + CASE( 24 ) + numStr = 'INTEGER*4' + CASE DEFAULT + numStr = 'N/A ' + END SELECT + + ! Print information + PRINT*, '--------------------------------------' + PRINT*, 'HDF-SDATA # : ', n + PRINT*, 'Name : ', TRIM( name ) + PRINT*, 'Rank : ', rank + PRINT*, 'Dimensions : ', (dims(i), i=1,rank) + PRINT*, 'Number Type : ', numStr + PRINT*, 'Attributes : ', nAttrs + ENDIF + + ! Terminate the HDF-SD interface for field # N + CALL sdCloseField( sdId ) + + ENDDO + + END SUBROUTINE sdPrintInfo + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetFieldDims( sdId, nDims, dims ) + + !=================================================================== + ! Subroutine sdGetFieldDims returns dimension information for + ! the given field stored in the HDF file. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1) sdId (INTEGER) : HDF-SD ID # for the given field + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (2) nDims (INTEGER) : Number of dimensions + ! (3) dims (INTEGER) : Array containing dimension information + ! + ! HDF-EOS library routines referenced: + ! ------------------------------------------------------------------ + ! (1) sdGInfo : returns name, rank, dims, numType, nAttrs for fields + !=================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId + INTEGER, INTENT(OUT) :: nDims, dims(MAX_DIMS) + + ! Local variables + INTEGER :: numType, nAttrs, status + CHARACTER(LEN=255) :: message, name + + ! External functions + INTEGER, EXTERNAL :: sfFInfo, sfGInfo + + !=================================================================== + ! sdGetFieldDims begins here! + !=================================================================== + + ! Zero out dimension array + dims(:) = 0 + + ! Get information about field #N from the HDF File + status = sfGInfo( sdId, name, nDims, dims, numType, nAttrs ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not locate HDF-SDATA field ' // & + TRIM( name ) // ' in ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdPrintInfo' ) + ENDIF + + END SUBROUTINE sdGetFieldDims + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData1dI4( sdId, nX, tData ) + + !===================================================================== + ! Subroutine sdGetData1dI4 reads a 1-D data array (INTEGER) + ! from the HDF file. The entire array will be returned. + ! (bmy, 7/19/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3 ) tData (INTEGER) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, tData(nX) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData1d_i4 begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0/), (/1/), (/nX/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData1d' ) + ENDIF + + END SUBROUTINE sdGetData1dI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData1d( sdId, nX, tData ) + + !===================================================================== + ! Subroutine sdGetData1d reads a 1-D data array from the HDF file. + ! The entire array will be returned. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX + REAL*4, INTENT(OUT) :: tData(nX) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData1d begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0/), (/1/), (/nX/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData1d' ) + ENDIF + + END SUBROUTINE sdGetData1d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData2d( sdId, nX, nY, tData ) + + !===================================================================== + ! Subroutine sdGetData2d reads a 2-D data array from the HDF file. + ! The entire array will be returned. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! (3 ) nY (INTEGER) : Number of elements in the Y-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (4 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nY + REAL*4, INTENT(OUT) :: tData(nX,nY) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData2d begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0/), (/1,1/), (/nX,nY/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData2d' ) + ENDIF + + END SUBROUTINE sdGetData2d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData3d( sdId, nX, nY, nZ, tData ) + + !===================================================================== + ! Subroutine sdGetData3d reads a 3-D data array from the HDF file. + ! The entire array will be returned. (bmy, 4/3/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! (3 ) nY (INTEGER) : Number of elements in the Y-dimension + ! (4 ) nZ (INTEGER) : Number of elements in the Z-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (5 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nY, nZ + REAL*4, INTENT(OUT) :: tData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData3d begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,0/), (/1,1,1/), (/nX,nY,nZ/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData3d' ) + ENDIF + + END SUBROUTINE sdGetData3d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData4d( sdId, nX, nY, nZ, nW, tData ) + + !===================================================================== + ! Subroutine sdGetData4d reads a 3-D data array from the HDF file. + ! The entire array will be returned. (bmy, 4/9/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! (3 ) nY (INTEGER) : Number of elements in the Y-dimension + ! (4 ) nZ (INTEGER) : Number of elements in the Z-dimension + ! (5 ) nW (INTEGER) : Number of elements in the W-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (6 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nY, nZ, nW + REAL*4, INTENT(OUT) :: tData(nX,nY,nZ,nW) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData4d begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,0,0/), (/1,1,1,1/), (/nX,nY,nZ,nW/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData4d' ) + ENDIF + + END SUBROUTINE sdGetData4d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData1d1Time( sdId, nTime, nX, tData ) + + !===================================================================== + ! Subroutine sdGetData2d1Time reads a 1-D data array for a single + ! time. We assume that the first dimension of the array in the + ! HDF file is a spatial dimension, and the 2nd dimension is a time + ! dimension. (bmy, 4/26/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nTime (INTEGER) : Time index (starting from 0) + ! (3 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (4 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nTime + REAL*4, INTENT(OUT) :: tData(nX) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData1d1Time begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,nTime/), (/1,1/), (/nX,1/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData2d1Time' ) + ENDIF + + END SUBROUTINE sdGetData1d1Time + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData2d1Time( sdId, nTime, nX, nY, tData ) + + !===================================================================== + ! Subroutine sdGetData2d1Time reads a 2-D data array for a single + ! time. We assume that the first 2 dimensions of the array in the + ! HDF file are spatial dimensions, and the 3rd dimension is a time + ! dimension. (bmy, 4/26/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nTime (INTEGER) : Time index (starting from 0) + ! (3 ) nX (INTEGER) : Number of elements in the X-dimension + ! (4 ) nY (INTEGER) : Number of elements in the Y-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (5 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nY, nTime + REAL*4, INTENT(OUT) :: tData(nX,nY) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData2d1Time begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,nTime/), (/1,1,1/), (/nX,nY,1/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData2d1Time' ) + ENDIF + + END SUBROUTINE sdGetData2d1Time + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData2d1TimeR8( sdId, nTime, nX, nY, tData ) + + !===================================================================== + ! Subroutine sdGetData2d1TimeR8 reads a 2-D data array (REAL*8) for + ! a single time. We assume that the first 2 dimensions of the array + ! in the HDF file are spatial dimensions, and the 3rd dimension is + ! a time dimension. (bmy, 7/19/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2 ) nTime (INTEGER) : Time index (starting from 0) + ! (3 ) nX (INTEGER) : Number of elements in the X-dimension + ! (4 ) nY (INTEGER) : Number of elements in the Y-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (5 ) tData (REAL*8 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nX, nY, nTime + REAL*8, INTENT(OUT) :: tData(nX,nY) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData2d1Time begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,nTime/), (/1,1,1/), (/nX,nY,1/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData2d1Time' ) + ENDIF + + END SUBROUTINE sdGetData2d1TimeR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData3d1Time( sdId, nTime, nX, nY, nZ, tData ) + + !===================================================================== + ! Subroutine sdGetData3d1Time reads a 3-D data array for a single + ! time. We assume that the first 3 dimensions of the array in the + ! HDF file are spatial dimensions, and the 4th dimension is a time + ! dimension. (bmy, 4/26/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2) nX (INTEGER) : Number of elements in the X-dimension + ! (3) nY (INTEGER) : Number of elements in the Y-dimension + ! (4) nZ (INTEGER) : Number of elements in the Z-dimension + ! (5) nW (INTEGER) : Number of elements in the W-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (6) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nTime, nX, nY, nZ + REAL*4, INTENT(OUT) :: tData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData3d1Time begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,0,nTime/), (/1,1,1,1/), & + (/nX,nY,nZ,1/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDAT field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData3d1Time' ) + ENDIF + + END SUBROUTINE sdGetData3d1Time + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetData3d1TimeR8( sdId, nTime, nX, nY, nZ, tData ) + + !===================================================================== + ! Subroutine sdGetData3d1TimeR8 reads a 3-D data array (REAL*8) for + ! a single time. We assume that the first 3 dimensions of the array + ! in the HDF file are spatial dimensions, and the 4th dimension is + ! a time dimension. (bmy, 7/19/02, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) sdId (INTEGER) : HDF-SD # of the data field in the HDF file + ! (2) nX (INTEGER) : Number of elements in the X-dimension + ! (3) nY (INTEGER) : Number of elements in the Y-dimension + ! (4) nZ (INTEGER) : Number of elements in the Z-dimension + ! (5) nW (INTEGER) : Number of elements in the W-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (6) tData (REAL*8 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1) sfRData : Reads numeric data from the HDF file + ! + ! NOTES: + !===================================================================== + + ! References to F90 Modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: sdId, nTime, nX, nY, nZ + REAL*8, INTENT(OUT) :: tData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: sfRData + + !=================================================================== + ! sdGetData3d1Time begins here! + !=================================================================== + + ! Read the data for the given field + status = sfRData( sdId, (/0,0,0,nTime/), (/1,1,1,1/), & + (/nX,nY,nZ,1/), tData ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not read HDF-SDATA field from ' // & + TRIM( saveFileName ) + CALL ERROR_STOP( message, 'sdGetData3d1Time' ) + ENDIF + + END SUBROUTINE sdGetData3d1TimeR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE sdShift1d( nX, tData ) + + !===================================================================== + ! Subroutine sdShift1d shifts a 1-D data array by 180 degrees. + ! This is necessary since fvDAS data starts at 0 longitude, but + ! GEOS-CHEM needs the first box to be at -180 longitude. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) nX (INTEGER) : Number of elements in the X-dimension + ! (2) tData (REAL*4 ) : Data array + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (2) tData (REAL*4 ) : Data array (shifted by 180 degrees) + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nX + REAL*4, INTENT(INOUT) :: tData(nX) + + !=================================================================== + ! sdShift1d begins here! + !=================================================================== + + ! Shift the longitude dimension by nX/2 elements + tData = CSHIFT( tdata, nX/2, 1 ) + + END SUBROUTINE sdShift1d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdShift2d( nX, nY, tData ) + + !===================================================================== + ! Subroutine sdShift2d shifts a 2-D data array by 180 degrees. + ! This is necessary since fvDAS data starts at 0 longitude, but + ! GEOS-CHEM needs the first box to be at -180 longitude. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) nX (INTEGER) : Number of elements in the X-dimension + ! (2) nY (INTEGER) : Number of elements in the Y-dimension + ! (3) tData (REAL*4 ) : Data array + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3) tData (REAL*4 ) : Data array (shifted by 180 degrees) + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nX, nY + REAL*4, INTENT(INOUT) :: tData(nX,nY) + + !=================================================================== + ! sdShift2d begins here! + !=================================================================== + + ! Shift the longitude dimension by nX/2 elements + tData = CSHIFT( tdata, nX/2, 1 ) + + END SUBROUTINE sdShift2d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdShift3d( nX, nY, nZ, tData ) + + !===================================================================== + ! Subroutine sdShift3d shifts a 3-D data array by 180 degrees. + ! This is necessary since fvDAS data starts at 0 longitude, but + ! GEOS-CHEM needs the first box to be at -180 longitude. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) nX (INTEGER) : Number of elements in the X-dimension + ! (2 ) nY (INTEGER) : Number of elements in the Y-dimension + ! (3 ) nZ (INTEGER) : Number of elements in the Z-dimension + ! (4 ) tData (REAL*4 ) : Data array + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (5 ) tData (REAL*4 ) : Data array (shifted by 180 degrees) + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nX, nY, nZ + REAL*4, INTENT(INOUT) :: tData(nX,nY,nZ) + + !=================================================================== + ! sdShift3d begins here! + !=================================================================== + + ! Shift the longitude dimension by nX/2 elements + tData = CSHIFT( tdata, nX/2, 1 ) + + END SUBROUTINE sdShift3d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdShift4d( nX, nY, nZ, nW, tData ) + + !===================================================================== + ! Subroutine sdShift4d shifts a 4-D data array by 180 degrees. + ! This is necessary since fvDAS data starts at 0 longitude, but + ! GEOS-CHEM needs the first box to be at -180 longitude. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) nX (INTEGER) : Number of elements in the X-dimension + ! (2 ) nY (INTEGER) : Number of elements in the Y-dimension + ! (3 ) nZ (INTEGER) : Number of elements in the Z-dimension + ! (4 ) nW (INTEGER) : Number of elements in the W-dimension + ! (5 ) tData (REAL*4 ) : Data array + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (5 ) tData (REAL*4 ) : Data array (shifted by 180 degrees) + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nX, nY, nZ, nW + REAL*4, INTENT(INOUT) :: tData(nX,nY,nZ,nW) + + !=================================================================== + ! sdShift4d begins here! + !=================================================================== + + ! Shift the longitude dimension by nX/2 elements + tData = CSHIFT( tData, nX/2, 1 ) + + END SUBROUTINE sdShift4d + +!----------------------------------------------------------------------------- + + SUBROUTINE sdGetMaxDims( maxDims ) + + !=================================================================== + ! Subroutine sdGetMaxDims returns the value of MAX_DIMS to the + ! calling program. This allows us to keep MAX_DIMS private. + ! (bmy, 4/3/02) + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (1 ) maxDims : Maximum # of dimensions for arrays in the HDF file + !=================================================================== + + ! Arguments + INTEGER, INTENT(OUT) :: maxDims + + !=================================================================== + ! sdGetMaxDims begins here! + !=================================================================== + maxDims = MAX_DIMS + + END SUBROUTINE sdGetMaxDims + +!------------------------------------------------------------------------------ + +END MODULE HdfSdModule diff --git a/code/obs_operators/HdfVdModule.f90 b/code/obs_operators/HdfVdModule.f90 new file mode 100644 index 0000000..cc8a929 --- /dev/null +++ b/code/obs_operators/HdfVdModule.f90 @@ -0,0 +1,966 @@ +! $Id: HdfVdModule.f90,v 1.2 2012/03/01 22:00:27 daven Exp $ +MODULE HdfVdModule + + !=========================================================================== + ! Module "HdfVdModule" contains variables and methods that are used to + ! read data fields stored in HDF-VDATA format. (bmy, 7/3/03, 12/12/05) + ! + ! In order to use HdfVdModule, you must first install the HDF-4 library + ! on your system. You may download the library source code from: + ! + ! http://hdf.ncsa.uiuc.edu/hdf4.html + ! + ! There is also a good online tutorial about the HDF-VD interface at: + ! + ! http://hdf.ncsa.uiuc.edu/training/HDFtraining/tutorial/vd/vds.html + ! + ! Module Variables: + ! -------------------------------------------------------------------------- + ! (1 ) fileId : ID number for the HDF file + ! (2 ) saveFileName : Shadow variable for filename + ! + ! Module Methods: + ! -------------------------------------------------------------------------- + ! (1 ) vdOpen : Opens the HDF file + ! (2 ) vdClose : Closes the HDF file + ! (3 ) vdOpenField : Opens access to a HDF-VDATA field w/in the file + ! (4 ) vdCloseField : Closes acess to a HDF-VDATA field w/in the file + ! (5 ) vdPrintInfo : Prints information about all HDF-VDATA fields + ! (6 ) vdGetFieldDim : Gets dimensions of a given HDF-VDATA field + ! (7 ) vdGetDataR4 : Reads a 1-D REAL*4 HDF-VDATA field from the file + ! (8 ) vdGetDataR8 : Reads a 1-D REAL*8 HDF-VDATA field from the file + ! (9 ) vdShift : Shifts a 1-D REAL*4 data field by 180 degrees + ! (10) getTauFromDate : Converts a date to a TAU value + ! (11) calDate : Converts Julian day to NYMD, NHMS + ! (12) julDay : Converts Year/month/day to Julian day + ! (13) mint : Function required by routine julDay + ! + ! Module Interfaces: + ! -------------------------------------------------------------------------- + ! (1 ) vdGetData : vdGetDataR4, vdGetDataR8 + ! + ! NOTES: + ! (1 ) Based on HdfSdModule.f90 (bmy, 7/3/03) + ! (2 ) Added function getTauFromDate (bmy, 12/12/05) + !=========================================================================== + USE HdfIncludeModule + + IMPLICIT NONE + + !===================================================================== + ! MODULE PRIVATE DECLARATIONS + !===================================================================== + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these variables ... + PUBLIC :: fileId + PUBLIC :: saveFileName + + ! ... and these routines + PUBLIC :: vdOpen + PUBLIC :: vdClose + PUBLIC :: vdCloseField + PUBLIC :: vdGetData + PUBLIC :: vdGetFieldDim + PUBLIC :: vdOpenField + PUBLIC :: vdPrintInfo + PUBLIC :: vdShift + PUBLIC :: getTauFromDate + + !===================================================================== + ! Private module variables -- visible only within HdfModule + !===================================================================== + INTEGER :: fileId + CHARACTER(LEN=255) :: saveFileName + + !======================================================================= + ! Module interfaces: allow you to associate a name w/ several routines + ! with different numbers of arguments or different argument types + !======================================================================= + INTERFACE vdGetData + MODULE PROCEDURE vdGetDataInt + MODULE PROCEDURE vdGetDataR4 + MODULE PROCEDURE vdGetDataR8 + END INTERFACE + + INTERFACE vdShift + MODULE PROCEDURE vdShift1d + END INTERFACE + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE vdOpen( fileName ) + + !===================================================================== + ! Subroutine "vdOpen" opens an HDF file and initializes the + ! HDF-VDATA interface. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fileName : CHARACTER name of the HDF-EOS file to be opened + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) hOpen : returns INTEGER value ( fileId ) + ! (2) vfStart : returns INTEGER value ( vdId ) + ! + ! NOTES: + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*) :: fileName + + ! Local Variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: hOpen, vfStart + + !===================================================================== + ! vdOpen begins here! + !===================================================================== + + ! Save file name to a private shadow variable for error msgs + saveFileName = TRIM( fileName ) + + ! Open the HDF file + fileId = hopen( TRIM( fileName ), DFACC_READ, 16 ) + + ! Error check fileId + IF ( fileId == FAIL ) THEN + message = 'ERROR: Could not open HDF file ' // TRIM( fileName ) + CALL ERROR_STOP( message, 'vdOpen' ) + ENDIF + + ! Start the VDATA interface for this file + status = vfstart( fileId ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not start HDF-VDATA interface for file ' // & + TRIM( fileName ) + CALL ERROR_STOP( message, 'vdOpen' ) + ENDIF + + END SUBROUTINE vdOpen + +!------------------------------------------------------------------------------ + + SUBROUTINE vdClose( fileName ) + + !===================================================================== + ! Subroutine "vdClose" terminates the HDF Scientific Dataset + ! (HDF-VD) interface and closes the HDF file. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fileName : CHARACTER name of the HDF-EOS file to be opened + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) hClose : takes INTEGER value ( fileId ) + ! (2) vfEnd : takes INTEGER value ( fileId ) + ! + ! NOTES: + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fileName + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: hClose, vfEnd + + !===================================================================== + ! vdClose begins here! + !===================================================================== + + ! Close VDATA interface to the file + status = vfEnd( fileId ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not close HDF-VDATA interface for ' // & + TRIM( fileName ) + CALL ERROR_STOP( message, 'vdClose' ) + ENDIF + + ! Close the HDF file + status = hClose( fileId ) + + ! Error check status + IF ( status == FAIL ) THEN + message = 'ERROR: Could not close the HDF file ' // TRIM( fileName ) + CALL ERROR_STOP( message, 'vdClose' ) + ENDIF + + END SUBROUTINE vdClose + +!----------------------------------------------------------------------------- + + SUBROUTINE vdOpenField( name, vdId ) + + !===================================================================== + ! Subroutine "vdOpenField" initializes the HDF-VDATA interface + ! for a given VDATA field w/in the HDF file. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) name : CHARACTER name of the VDATA field to be initialized + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (2) vdId : INTEGER VDATA ID# of the field + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) vsfAtch : returns INTEGER value ( vdId ) + ! (2) vsfDtch : returns INTEGER value ( status ) + ! (3) vsfGid : returns INTEGER value ( status ) + ! (4) vsfInq : returns INTEGER value ( status ) + ! + ! NOTES: + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: name + INTEGER, INTENT(OUT) :: vdId + + ! Local Variables + LOGICAL :: found + INTEGER :: intMode, nRec + INTEGER :: numType, status, vDataRef + CHARACTER(LEN=255) :: list, message, vdName + + ! External functions + INTEGER, EXTERNAL :: vsfAtch, vsfDtch, vsfGid, vsfInq + + !===================================================================== + ! vdOpenField begins here! + !===================================================================== + + ! Initialize + found = .FALSE. + vDataRef = -1 + + ! Loop thru file + DO + + ! Look for HDF-VDATA field + vDataRef = vsfGid( fileId, vDataRef ) + + ! Exit if we are have come to EOF + if ( vDataRef == FAIL ) EXIT + + ! Attach to this HDF-VDATA field + vdId = vsfAtch( fileId, vDataRef, 'r' ) + + ! Get the name of this HDF-VDATA field + status = vsfInq( vdId, nRec, intMode, list, numType, vdName ) + + ! If the name of the field matches the name that we are + ! looking for, exit and return vdID to the calling routine + IF ( TRIM( vdName ) == TRIM( name ) ) THEN + found = .TRUE. + EXIT + ENDIF + + ! Otherwise, detach from this HDF-VDATA and loop again + status = vsfDtch( vdId ) + ENDDO + + ! Error check if no files were found + IF ( .not. found ) THEN + message = 'ERROR: Could not HDF-VDATA field ' // TRIM( name ) // & + ' in file ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'vdOpenField' ) + ENDIF + + END SUBROUTINE vdOpenField + +!----------------------------------------------------------------------------- + + SUBROUTINE vdCloseField( vdId ) + + !===================================================================== + ! Subroutine "vdCloseField" terminates the HDF-VDATA interface + ! for a given VDATA field w/in the HDF file. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) name : CHARACTER name of the VDATA field to be closed + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) vsfDtch : returns INTEGER value + ! + ! NOTES: + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + INTEGER, INTENT(IN) :: vdId + + ! Local Variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: vsfDtch + + !===================================================================== + ! vdCloseField begins here! + !===================================================================== + + ! Terminate VDATA interface + status = vsfDtch( vdId ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not terminate HDF-VDATA interface!' + CALL ERROR_STOP( message, 'vdCloseField' ) + ENDIF + END SUBROUTINE vdCloseField + +!----------------------------------------------------------------------------- + + SUBROUTINE vdPrintInfo + + !===================================================================== + ! Subroutine "vdPrintInfo: obtains and prints information about + ! each HDF-VDATA field stored in the HDF file. (bmy, 7/3/03) + ! + ! HDF-EOS library routines referenced: + ! -------------------------------------------------------------------- + ! (1) vsfAtch : returns INTEGER value ( vdId ) + ! (2) vsfDtch : returns INTEGER value ( status ) + ! (3) vsfEx : returns INTEGER value ( status ) + ! (4) vsfGid : returns INTEGER value ( status ) + ! (5) vsfInq : returns INTEGER value ( status ) + !===================================================================== + + ! Local variables + INTEGER :: vdId, vDataRef, numType + INTEGER :: nRec, intMode, status + CHARACTER(LEN=6) :: numStr + CHARACTER(LEN=255) :: message, name, list + + ! External functions + INTEGER, EXTERNAL :: vsfAtch, vsfDtch, vsfEx, vsfGid, vsfInq + + !===================================================================== + ! vdPrintInfo begins here! + !===================================================================== + + ! Start at beginning of file + vDataRef = -1 + + ! Loop thru file + DO + + ! Look for VDATA Reference + vDataRef = vsfGid( fileId, vDataRef ) + if ( VDataRef == FAIL ) EXIT + + ! Attach to this VDATA + vdId = vsfAtch( fileId, vDataRef, 'r' ) + + ! If attach was successful, continue... + IF ( status == SUCCEED ) THEN + + ! Get information about field #N from the HDF File + status = vsfInq( vdId, nRec, intMode, list, numType, name ) + + ! If status is successful, then print info + IF ( status == SUCCEED ) THEN + + ! Pick number string + SELECT CASE ( numType ) + CASE( 4 ) + numStr = 'REAL*4' + CASE( 8 ) + numStr = 'REAL*8' + CASE DEFAULT + numStr = 'N/A ' + END SELECT + + ! Print info + PRINT*, '--------------------------------------' + PRINT*, 'HDF-VDATA # : ', vdId + PRINT*, 'Name : ', TRIM( name ) + PRINT*, '# records : ', nRec + PRINT*, 'Number Type : ', numStr + PRINT*, 'Interlace : ', intMode + + ENDIF + ENDIF + + ! Detach from this VDATA and try again + status = vsfDtch( vdId ) + ENDDO + + END SUBROUTINE vdPrintInfo + +!----------------------------------------------------------------------------- + + SUBROUTINE vdGetFieldDim( vdId, vdDim ) + + !=================================================================== + ! Subroutine vdGetFieldDim returns dimension information for + ! a given HDF-VDATA field stored in the HDF file. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1) vdId (INTEGER) : HDF-VD ID # for the given field + ! + ! Arguments as Output: + ! ------------------------------------------------------------------ + ! (2) vdDim (INTEGER) : Dimension (# of elements) of the VDATA + ! + ! HDF-EOS library routines referenced: + ! ------------------------------------------------------------------ + ! (1) vsQfNelt : returns INTEGER ( status ) + !=================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: vdId + INTEGER, INTENT(OUT) :: vdDim + + ! Local variables + INTEGER :: status + CHARACTER(LEN=255) :: message + + ! External functions + INTEGER, EXTERNAL :: vsQfNelt + + !=================================================================== + ! vdGetFieldSize begins here! + !=================================================================== + + ! Get information about field #N from the HDF File + status = vsQfNelt( vdId, vdDim ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not get the dimensions of HDF-VDATA field!' + CALL ERROR_STOP( message, 'vdGetFieldDim' ) + ENDIF + + END SUBROUTINE vdGetFieldDim + +!----------------------------------------------------------------------------- + SUBROUTINE vdGetDataInt( vdId, nX, tData ) + + !===================================================================== + ! Subroutine vdGetDataInt reads a 1-D data array (INTEGER) from the + ! HDF file. The entire array will be returned. (zhe, 14/6/11) + ! Added to standard code (zhej, dkh, 01/17/12, adj32_016) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) vdId (INTEGER) : HDF-VD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3 ) tData (INTEGER ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) vsfInq : Returns INTEGER ( status ) + ! (2 ) vsfRd : Returns INTEGER ( # of records read ) + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: vdId, nX + INTEGER, INTENT(OUT) :: tdata(nX) + + ! Local variables + INTEGER :: intMode, nRec, numType, status + CHARACTER(LEN=255) :: message, name, list + + ! External functions + INTEGER, EXTERNAL :: vsfInq, vsfRd + + !=================================================================== + ! vdGetDataR8 begins here! + !=================================================================== + + ! Get information about the HDF-VDATA field + status = vsfInq( vdId, nRec, intMode, list, numType, name ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not find HDF-VDATA field ' // & + TRIM( name ) // ' in file ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + ! Also make sure the dimensions are compatible + IF ( nX /= nRec ) THEN + message = 'ERROR: nX does not match number of records in file!' + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + ! Read the HDF-VDATA field from the file + ! (status returns the # of records read) + status = vsfRd( vdId, tData, nRec, intMode ) + + ! Error check + IF ( status <= 0 ) THEN + message = 'ERROR: Did not read any records for HDF-VDATA field ' // & + TRIM( name ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + END SUBROUTINE vdGetDataInt + +!----------------------------------------------------------------------------- + + SUBROUTINE vdGetDataR4( vdId, nX, tData ) + + !===================================================================== + ! Subroutine vdGetDataR4 reads a 1-D data array (REAL*4) from the + ! HDF file. The entire array will be returned. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) vdId (INTEGER) : HDF-VD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3 ) tData (REAL*4 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) vsfInq : Returns INTEGER ( status ) + ! (2 ) vsfRd : Returns INTEGER ( # of records read ) + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: vdId, nX + REAL*4, INTENT(OUT) :: tdata(nX) + + ! Local variables + INTEGER :: intMode, nRec, numType, status + CHARACTER(LEN=255) :: message, name, list + + ! External functions + INTEGER, EXTERNAL :: vsfInq, vsfRd + + !=================================================================== + ! vdGetDataR8 begins here! + !=================================================================== + + ! Get information about the HDF-VDATA field + status = vsfInq( vdId, nRec, intMode, list, numType, name ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not find HDF-VDATA field ' // & + TRIM( name ) // ' in file ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + ! Also make sure the dimensions are compatible + IF ( nX /= nRec ) THEN + message = 'ERROR: nX does not match number of records in file!' + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + ! Read the HDF-VDATA field from the file + ! (status returns the # of records read) + status = vsfRd( vdId, tData, nRec, intMode ) + + ! Error check + IF ( status <= 0 ) THEN + message = 'ERROR: Did not read any records for HDF-VDATA field ' // & + TRIM( name ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + END SUBROUTINE vdGetDataR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE vdGetDataR8( vdId, nX, tData ) + + !===================================================================== + ! Subroutine vdGetData reads a 1-D data array (REAL*8) from the + ! HDF file. The entire array will be returned. (bmy, 7/3/03) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) vdId (INTEGER) : HDF-VD # of the data field in the HDF file + ! (2 ) nX (INTEGER) : Number of elements in the X-dimension + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (3 ) tData (REAL*8 ) : Data array + ! + ! HDF library routines referenced: + ! -------------------------------------------------------------------- + ! (1 ) vsfInq : Returns INTEGER ( status ) + ! (2 ) vsfRd : Returns INTEGER ( # of records read ) + !===================================================================== + + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: vdId, nX + REAL*8, INTENT(OUT) :: tdata(nX) + + ! Local variables + INTEGER :: intMode, nRec, numType, status + CHARACTER(LEN=255) :: message, name, list + + ! External functions + INTEGER, EXTERNAL :: vsfInq, vsfRd + + !=================================================================== + ! vdGetDataR8 begins here! + !=================================================================== + + ! Get information about this field + status = vsfInq( vdId, nRec, intMode, list, numType, name ) + + ! Error check + IF ( status == FAIL ) THEN + message = 'ERROR: Could not find HDF-VDATA field ' // & + TRIM( name ) // ' in file ' // TRIM( saveFileName ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + ! Also make sure the dimensions are compatible + IF ( nX /= nRec ) THEN + message = 'ERROR: nX does not match number of records in file!' + CALL ERROR_STOP( message, 'vdGetDataR4' ) + ENDIF + + ! Read the HDF-VDATA field from the file + ! (status returns the # of records read) + status = vsfRd( vdId, tData, nRec, intMode ) + + ! Error check + IF ( status <= 0 ) THEN + message = 'ERROR: Did not read any records for HDF-VDATA field ' // & + TRIM( name ) + CALL ERROR_STOP( message, 'vdGetDataR8' ) + ENDIF + + END SUBROUTINE vdGetDataR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE vdShift1d( nX, tData ) + + !===================================================================== + ! Subroutine vdShift1d shifts a 1-D data array by 180 degrees. + ! This is necessary since fvDAS data starts at 0 longitude, but + ! GEOS-CHEM needs the first box to be at -180 longitude. (bmy, 4/3/02) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) nX (INTEGER) : Number of elements in the X-dimension + ! (2) tData (REAL*4 ) : Data array + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (2) tData (REAL*4 ) : Data array (shifted by 180 degrees) + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nX + REAL*4, INTENT(INOUT) :: tData(nX) + + !=================================================================== + ! vdShift1d begins here! + !=================================================================== + + ! Shift the longitude dimension by nX/2 elements + tData = CSHIFT( tdata, nX/2, 1 ) + + END SUBROUTINE vdShift1d + +!----------------------------------------------------------------------------- + + FUNCTION getTauFromDate( year, month, day ) RESULT( tau ) + + !===================================================================== + ! Function getTauFromDate returns the TAU value (hours since 0 GMT + ! on Jan 1, 1985) at the beginning of the given date. (bmy, 12/12/05) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1 ) year (INTEGER) : Current YYYY year value + ! (2 ) year (INTEGER) : Current MM month value + ! (3 ) year (INTEGER) : Current DD day value + ! + ! NOTES: + !===================================================================== + + ! Arguments + INTEGER :: year, month, day + + ! Local variables + REAL*8 :: tau, jdToday + + ! Astronomical Julian Date at 0 GMT, 1 Jan 1985 + REAL*8, PARAMETER :: JD85 = 2446066.5d0 + + !===================================================================== + ! getTauFromDate begins here! + !===================================================================== + + ! Get today's astronomical Julian date + jdToday = julDay( year, month, DBLE( day ) ) + + ! Get Tau0 value + tau = ( jdToday - jd85 ) * 24d0 + + END FUNCTION getTauFromDate + +!----------------------------------------------------------------------------- + + SUBROUTINE calDate( julDay, nymd, nhms ) + + !===================================================================== + ! Subroutine "calDate" converts an astronomical Julian day to + ! the NYMD (e.g. YYYYMMDD) and NHMS (i.e. HHMMSS) format. + ! + ! Algorithm taken from "Practical Astronomy With Your Calculator", + ! Third Edition, by Peter Duffett-Smith, Cambridge UP, 1992. + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) julDay : REAL*8 : Astronomical julian day + ! + ! Arguments as output: + ! -------------------------------------------------------------------- + ! (1) nymd : INTEGER : YYYYMMDD corresponding to JDAY + ! (2) nhms : INTEGER : HHMMSS corresponding to JDAY + !===================================================================== + + ! Arguments + REAL*8, INTENT(IN) :: julDay + INTEGER, INTENT(OUT) :: nymd, nhms + + ! Local variables + REAL*8 :: a, b, c, d, day, e, f + REAL*8 :: fDay, g, i, j, jd, m, y + + !===================================================================== + ! "calDate begins here! + ! See "Practical astronomy with your calculator", Peter Duffett-Smith + ! 1992, for an explanation of the following algorithm. + !===================================================================== + jd = julDay + 0.5d0 + i = INT( jd ) + f = jd - INT( I ) + + IF ( i > 2299160d0 ) THEN + a = INT( ( I - 1867216.25d0 ) / 36524.25 ) + b = i + 1 + a - INT( a / 4 ) + ELSE + b = i + ENDIF + + c = b + 1524d0 + + d = INT( ( c - 122.1d0 ) / 365.25d0 ) + + e = INT( 365.25d0 * d ) + + g = INT( ( c - e ) / 30.6001d0 ) + + ! Day is the day number + day = c - e + f - INT( 30.6001d0 * g ) + + ! fDay is the fractional day number + fDay = day - int( day ) + + ! M is the month number + IF ( g < 13.5d0 ) THEN + m = g - 1d0 + ELSE + m = g - 13d0 + ENDIF + + ! Y is the year number + IF ( m > 2.5d0 ) THEN + y = d - 4716d0 + ELSE + y = d - 4715d0 + ENDIF + + ! NYMD is YYYYMMDD + nymd = ( INT( y ) * 10000 ) + ( INT( m ) * 100 ) + INT( day ) + + ! NHMS is HHMMSS + nhms = INT( fday * 24 ) * 10000 + + END SUBROUTINE calDate + +!----------------------------------------------------------------------------- + + FUNCTION julDay( year, month, day ) RESULT( julianDay ) + + !=================================================================== + ! Function JULDAY returns the astronomical Julian day. + ! + ! Algorithm taken from "Practical Astronomy With Your Calculator", + ! Third Edition, by Peter Duffett-Smith, Cambridge UP, 1992. + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1) YEAR : (INTEGER) Current year + ! (2) MONTH : (INTEGER) Current month + ! (3) DAY : (REAL*8 ) Current day (can be fractional, e.g. 17.25) + ! + ! NOTES: + ! (2) JULDAY requires the external function MINT.F. + ! + ! (3) JULDAY will compute the correct Julian day for any + ! BC or AD date. + ! + ! (4) For BC dates, subtract 1 from the year and append a minus + ! sign. For example, 1 BC is 0, 2 BC is -1, etc. This is + ! necessary for the algorithm. + !=================================================================== + + ! Arguments + INTEGER :: year, month + REAL*8 :: day, julianDay + + ! Local variables + INTEGER :: year1, month1 + REAL*8 :: x1, a, b, c, d + LOGICAL :: isGregorian + + !=================================================================== + ! JULDAY begins here! + ! + ! Follow algorithm from Peter Duffett-Smith (1992) + !=================================================================== + + ! Compute YEAR and MONTH1 + IF ( ( month == 1 ) .OR. ( month == 2 ) ) THEN + year1 = year - 1 + month1 = month + 12 + ELSE + year1 = year + month1 = month + ENDIF + + ! Compute the "A" term. + x1 = DBLE( year ) / 100.0d0 + a = mint( x1 ) + + ! The Gregorian calendar begins on 10 October 1582 + ! Any dates prior to this will be in the Julian calendar + IF ( year > 1582 ) THEN + isGregorian = .TRUE. + ELSE + IF ( ( year == 1582 ) .AND. & + ( month1 >= 10 ) .AND. & + ( day >= 15.0 ) ) THEN + isGregorian = .TRUE. + ELSE + isGregorian = .FALSE. + ENDIF + ENDIF + + ! Compute the "B" term according to Gregorian or Julian calendar + IF ( isGregorian ) THEN + b = 2.0d0 - a + mint( a / 4.0d0 ) + ELSE + b = 0.0d0 + ENDIF + + ! Compute the "C" term for BC dates (YEAR1 <= 0 ) + ! or AD dates (YEAR1 > 0) + IF ( year1 < 0 ) THEN + x1 = ( 365.25d0 * year1 ) - 0.75d0 + c = mint( x1 ) + ELSE + x1 = 365.25d0 * year1 + c = mint( x1 ) + ENDIF + + ! Compute the "D" term + x1 = 30.6001d0 * DBLE( month1 + 1 ) + d = mint( x1 ) + + + ! Add the terms to get the Julian Day number + julianDay = b + c + d + day + 1720994.5d0 + + END FUNCTION julDay + +!----------------------------------------------------------------------------- + + FUNCTION mint( x ) RESULT ( value ) + + !=================================================================== + ! Function MINT is defined as follows: + ! + ! MINT = -INT( ABS( X ) ), X < 0 + ! MINT = INT( ABS( X ) ), X >= 0 + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1) X : (REAL*8) Argument for the function MINT + ! + ! NOTES: + ! (1) MINT is primarily intended for use with routine JULDAY. + !=================================================================== + + ! Arguments + REAL*8, INTENT(IN) :: x + + ! Return value + REAL*8 :: value + + !=================================================================== + ! MINT begins here! + !=================================================================== + IF ( x < 0d0 ) THEN + value = -INT( ABS( x ) ) + ELSE + value = INT( ABS( x ) ) + ENDIF + + END FUNCTION MINT + +!------------------------------------------------------------------------------ + +END MODULE HdfVdModule diff --git a/code/obs_operators/He4Define.h b/code/obs_operators/He4Define.h new file mode 100644 index 0000000..d6eced2 --- /dev/null +++ b/code/obs_operators/He4Define.h @@ -0,0 +1,40 @@ +! $Id: He4Define.h,v 1.1 2009/07/03 01:55:32 daven Exp $ +! +! "He4Define.h" -- sets Cpp flags for HD4 and HDF-EOS4 code (bmy, 3/21/08) + +!----------------------------------------------------- +! Pick the compiler/architecture that you are using +!----------------------------------------------------- +!#define INTEL32 'INTEL32' +#define INTEL64 'INTEL64' +!#define SGI32 'SGI32' +!#define SGI64 'SGI64' +!#define SUN32 'SUN32' +!#define SUN64 'SUN64' + +!----------------------------------------------------- +! For HDF5-EOS you may have to pass 64-bit integer +! (INTEGER*8) dimensions to some routines. If so, +! then you can #define NEED_INT_64. +! +! However, for HDF4-EOS, it seems like 32-bit +! integers (INTEGER*4) are used for dimensioning +! variables. +!----------------------------------------------------- + +#if defined( INTEL32 ) || defined( INTEL64 ) + +! IFORT compiler +#define NEED_INT_32 'NEED_INT_32' + +#elif defined( SGI32 ) || defined( SGI64 ) + +! 32-bit SGI +#define NEED_INT_32 'NEED_INT_32' + +#elif defined( SUN32 ) || defined( SUN64 ) + +! SPARC or SunStudio compiolers +#define NEED_INT_32 'NEED_INT_32' + +#endif diff --git a/code/obs_operators/He4ErrorModule.f90 b/code/obs_operators/He4ErrorModule.f90 new file mode 100644 index 0000000..aa334d5 --- /dev/null +++ b/code/obs_operators/He4ErrorModule.f90 @@ -0,0 +1,303 @@ +! $Id: He4ErrorModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +MODULE He4ErrorModule + + !======================================================================== + ! Module He4ErrorModule contains error check routines for the + ! Fortran code that reads HDF4 and HDF-EOS4 data from disk. + ! (bmy, 7/26/00, 3/21/08) + ! + ! Module Methods: + ! ----------------------------------------------------------------------- + ! (1 ) He4AllocErr : Prints an error message for allocating arrays + ! (2 ) He4ErrMsg : Prints an error message and halts execution + ! (3 ) He4Msg : Prints a message and flushes buffer + ! (4 ) He4CheckValue : Checks a value for NaN or Infinity condition + ! (5 ) ItIsNan : Checks for NaN + ! (6 ) ItIsFinite : Checks for Infinity + ! + ! NOTES: + ! (1 ) Now use intrinsic functions ISNAN and FP_CLASS to test for + ! NaN and Infinity on IFORT compiler. These functions were not + ! available in the older EFC compiler. (bmy, 8/14/07) + ! (2 ) Now uses updated flags from He4Define.h (bmy, 3/21/08) + !======================================================================== + + IMPLICIT NONE + + !------------------------------- + ! PRIVATE / PUBLIC DECLARATIONS + !------------------------------- + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: He4AllocErr + PUBLIC :: He4ErrMsg + PUBLIC :: He4Msg + PUBLIC :: He4CheckValue + PUBLIC :: ItIsNan + PUBLIC :: ItIsFinite + + !------------------------------- + ! MODULE ROUTINES + !------------------------------- + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE He4AllocErr( arrayName ) + + !====================================================================== + ! Subroutine He4AllocErr stops program execution upon an error + ! allocating arrays. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) arrayName (CHARACTER) : Name of array + ! + ! NOETS: + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: arrayName + + !---------------------------- + ! He4AllocErr begins here! + !---------------------------- + + ! Write info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) TRIM( arrayName ) + WRITE( 6, 110 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL FLUSH( 6 ) + + ! Exit + CALL EXIT( 1 ) + + ! FORMAT strings +100 FORMAT( 'Allocation error for array ', a ) +110 FORMAT( 'STOP in allocErr ("Hdf4ErrorModule.f90")' ) + + END SUBROUTINE He4AllocErr + +!------------------------------------------------------------------------------ + + SUBROUTINE He4ErrMsg( msg, loc ) + + !====================================================================== + ! Subroutine He4ErrMsg halts displays an error message and halts + ! program execution. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) msg (CHARACTER) : Error message to display + ! (2 ) loc (CHARACTER) : Location where the error occurred + ! + ! NOTES: + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: msg + CHARACTER(LEN=*), INTENT(IN) :: loc + + !-------------------------- + ! He4ErrMsg begins here! + !-------------------------- + + ! Print error message + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) TRIM( msg ) + WRITE( 6, 100 ) TRIM( loc ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL FLUSH( 6 ) + + ! Exit simulation + CALL EXIT( 1 ) + + ! FORMAT string +100 FORMAT( 'STOP in ', a ) + + END SUBROUTINE He4ErrMsg + +!------------------------------------------------------------------------------ + + SUBROUTINE He4Msg( str ) + + !====================================================================== + ! Subroutine He4Msg prints a string and flushes the output buffer. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) str (CHARACTER) : Message to display + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: str + + !--------------------- + ! He4Msg begins here! + !--------------------- + + ! Print message + WRITE( 6, '(a)' ) TRIM( str ) + CALL flush( 6 ) + + END SUBROUTINE He4Msg + +!----------------------------------------------------------------------------- + + SUBROUTINE He4CheckValue( value, name, loc ) + + !====================================================================== + ! Subroutine He4CheckValue tests a value for IEEE NaN or Infinity. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) value (REAL*4 ) : value to be tested + ! (2 ) name (CHARACTER) : name of the variable + ! (3 ) loc (INTEGER ) : Grid box location (/i,j,l,t/) + !====================================================================== + + ! Arguments + REAL*4, INTENT(IN) :: value + CHARACTER(LEN=*), INTENT(IN) :: name + INTEGER, INTENT(IN) :: loc(4) + + ! If VALUE is NaN, stop w/ error message + IF ( itIsNaN( value ) ) THEN +!!$OMP CRITICAL + WRITE( 6, 100 ) TRIM( name ), loc + 100 FORMAT( a, ' is NaN at grid box: ', 4i4, '!' ) + STOP +!!$OMP END CRITICAL + ENDIF + + ! If VALUE is +/- Infinity, stop w/ error message + IF ( .not. itIsFinite( value ) ) THEN +!!$OMP CRITICAL + WRITE( 6, 110 ) TRIM( name ), loc + 110 FORMAT( a, ' is +/- Infinity at grid box: ', 4i4, '!' ) + STOP +!!$OMP END CRITICAL + ENDIF + + END SUBROUTINE He4CheckValue + +!----------------------------------------------------------------------------- + + FUNCTION ItIsNan( value ) RESULT( itIsANaN ) + + !=================================================================== + ! Subroutine itIsNaN tests a value for IEEE NaN on SGI, Altix, + ! Linux, or Sun platforms. (bmy, 1/17/06, 8/14/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*4) : value to be tested + ! + ! NOTES: + ! (1 ) Add error checking for Sun/SPARC compiler (bmy, 2/15/07) + ! (2 ) Now use FP_CLASS function for IFORT compiler (bmy, 8/14/07) + !=================================================================== + +#include "He4Define.h" + + ! Argument + REAL*4, INTENT(IN) :: value + LOGICAL :: itIsANaN + + !---------------------- + ! ItIsNan begins here! + !---------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + itIsANaN = IEEE_IS_NAN( value ) + +#elif defined( INTEL32 ) || defined( INTEL64 ) + + ! Use Intel/IFORT intrinsic function ISNAN + itIsANan = ISNAN( value ) + +#elif defined( SUN32 ) || defined( SUN64 ) + + ! Declare Sun intrinsic IR_ISNAN as an external function + INTEGER, EXTERNAL :: IR_ISNAN + + ! Test if VALUE is a NaN + ItIsANan = ( IR_ISNAN( value ) /= 0 ) + +#endif + + END FUNCTION ItIsNan + +!----------------------------------------------------------------------------- + + FUNCTION ItIsFinite( value ) RESULT( itIsAFinite ) + + !=================================================================== + ! Subroutine itIsFinite tests a value for IEEE Finite on SGI, + ! Altix, Linux, or Sun platforms. (bmy, 1/17/06, 8/14/07) + ! + ! Arguments as Input: + ! ------------------------------------------------------------------ + ! (1 ) value (REAL*4) : value to be tested + ! + ! NOTES: + ! (1 ) Add error checking for Sun/SPARC compiler (bmy, 2/15/07) + ! (2 ) Now use FP_CLASS function for IFORT compiler (bmy, 8/14/07) + !=================================================================== + +# include "He4Define.h" + +#if defined( INTEL32 ) || defined( INTEL64 ) +# include "fordef.for" + INTEGER :: fpc +#endif + + ! Arguments + REAL*4, INTENT(IN) :: value + LOGICAL :: itIsAFinite + + !------------------------- + ! itisFinite begins here! + !------------------------- + +#if defined( SGI32 ) || defined( SGI64 ) + + ! Use SGI intrinsic function + itIsAFinite = IEEE_FINITE( value ) + +#elif defined( INTEL32 ) || defined( INTEL64 ) + + ! Get the floating point type class for VALUE + fpc = FP_CLASS( value ) + + ! VALUE is infinite if it is either +Inf or -Inf + ! Also flag an error if VALUE is a signaling or quiet NaN + itIsAFinite = ( fpc /= FOR_K_FP_POS_INF .and. & + fpc /= FOR_K_FP_NEG_INF .and. & + fpc /= FOR_K_FP_SNAN .and. & + fpc /= FOR_K_FP_QNAN ) + +#elif defined( SUN32 ) || defined( SUN64 ) + + ! Declare Sun intrinsic IR_FINITE as an external function + INTEGER, EXTERNAL :: IR_FINITE + + ! Test if VALUE is a finite number + ItIsAFinite = ( IR_FINITE( value ) /= 0 ) + +#endif + + END FUNCTION ItIsFinite + +!----------------------------------------------------------------------------- + +END MODULE He4ErrorModule diff --git a/code/obs_operators/He4GridModule.f90 b/code/obs_operators/He4GridModule.f90 new file mode 100644 index 0000000..7ed90f4 --- /dev/null +++ b/code/obs_operators/He4GridModule.f90 @@ -0,0 +1,1566 @@ +! $Id: He4GridModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +MODULE He4GridModule + + !======================================================================== + ! Module "He4GridModule" contains variable declarations and routines + ! that are used for reading data from HDF-EOS4 "Grid" structures. + ! (bmy, 1/17/06, 4/10/08) + ! + ! Module Variables: + ! -------------------------------------------------------------------------- + ! fId (INTEGER ) : ID number for the HDF_EOS file + ! gId (INTEGER ) : ID number for the HDF_EOS grid + ! start3D (INTEGER ) : Starting index for 3-D arrays + ! stride3D (INTEGER ) : Stride for 3-D arrays + ! edge3D (INTEGER ) : Ending index for 3-D arrays + ! start4D (INTEGER ) : Starting index for 4-D arrays + ! stride4D (INTEGER ) : Stride for 4-D arrays + ! edge4D (INTEGER ) : Ending index for 4-D arrays + ! xStart (INTEGER ) : Starting index for the XDIM array + ! xStride (INTEGER ) : Stride for the XDIM array + ! xEdge (INTEGER ) : Ending index for the XDIM array + ! yStart (INTEGER ) : Starting index for the YDIM array + ! yStride (INTEGER ) : Stride for the YDIM array + ! yEdge (INTEGER ) : Ending index for the YDIM array + ! zStart (INTEGER ) : Starting index for the ZDIM array + ! zStride (INTEGER ) : Stride for the ZDIM array + ! zEdge (INTEGER ) : Ending index for the ZDIM array + ! tStart (INTEGER ) : Starting index for the TIME, TAU arrays + ! tStride (INTEGER ) : Stride for the TIME, TAU arrays + ! tEdge (INTEGER ) : Ending index for the TIME, TAU arrays + ! nFields (INTEGER ) : Number of fields in the current file + ! fieldRank (INTEGER ) : Array of Argument for "gdinqfld" routine + ! fieldType (INTEGER ) : Array of data types for each field in the file + ! fieldName (CHARACTER) : Array of names for each field in the file + ! nAttrs (INTEGER ) : Number of attributes defined in the file + ! attrName (CHARACTER) : Array of attribute names + ! attrValue (REAL*4 ) : Array of attribute values + ! time (REAL*8 ) : Array of times (# of seconds since 1/1/1993) + ! saveFileName (CHARACTER) : Shadow variable for the file name + ! timefrom1993 (LOGICAL ) : = T if TIME starts from 1/1/1993 + ! VERBOSE (LOGICAL ) : = T if we are printing info to the std output + ! xDimSize (INTEGER ) : # of grid boxes in the X (longitude) dimension + ! yDimSize (INTEGER ) : # of grid boxes in the Y (latitude ) dimension + ! zDimSize (INTEGER ) : # of grid boxes in the Z (altitude ) dimension + ! tDimSize (INTEGER ) : # of time intervals contained within this file + ! xDim (REAL*8 ) : Array of longitude centers + ! yDim (REAL*8 ) : Array of latitude centers + ! zdim (REAL*8 ) : Array of alitude centers + ! nymd (INTEGER ) : Array of YYYYMMDD values -- date indices + ! nhms (INTEGER ) : Array of HHMMSS values -- hour indices + ! + ! Module Methods: + ! -------------------------------------------------------------------------- + ! (1 ) He4SetVerbose : toggles information display on/off + ! (2 ) He4GridOpen : opens file & attaches to HDF-EOS4 grid + ! (3 ) He4GridClose : detaches from HDF-EOS4 grid & closes file + ! (4 ) He4GridGetDimInfo : gets dimensions of data fields in file + ! (5 ) He4GridGetFldInfo : gets info about each field + ! (6 ) He4GridGetAttrInfo : gets global attributes for HDF-EOS4 grid + ! (7 ) He4GridReadAttrChar : Reads CHARACTER attribute from grid + ! (8 ) He4GridReadAttrI2 : Reads INTEGER*2 attribute from grid + ! (9 ) He4GridReadAttrI4 : Reads INTEGER*4 attribute from grid + ! (10) He4GridReadAttrR4 : Reads REAL*4 attribute from grid + ! (11) He4GridReadAttrR8 : Reads REAL*8 attribute from grid + ! (12) He4GridGetFillValue : gets missing data "fill" value for fields + ! (13) He4GridReadData3D : reads a 3-D data block from the file + ! (14) He4GridReadData4D : reads a 4-D data block from the file + ! (15) He4GridReadX : gets the longitudes (X) for the grid + ! (16) He4GridReadY : gets the latitudes (Y) for the grid + ! (17) He4GridReadZ : gets the altitudes (Z) for the grid + ! (18) He4GridReadT : gets the time values (T) for the grid + ! (19) He4GetNymdNhms : converts T to NYMD, NHMS + ! (20) He4CleanUpIndexFields : deallocates index arrays + ! (21) makeCharArrayFromCharList : separates a string into a string array + ! (22) calDate : converts Julian day to NYMD, NHMS + ! (24) julDay : converts Year/month/day to Julian day + ! (25) mint : function required by routine julDay + ! + ! Module Interfaces: + ! -------------------------------------------------------------------------- + ! (1 ) He4ReadGridAttr -- overloads these routines + ! (a) He4GridReadAttrChar + ! (b) He4GridReadAttrI2 + ! (c) He4GridReadAttrI4 + ! (d) He4GridReadAttrR4 + ! (e) He4GridReadAttrR8 + ! + ! (2 ) He4GridReadData overloads the following routines + ! (a) He4GridReadData3D + ! (b) He4GridReadData4D + ! + ! NOTES: + ! (1 ) Updated for more consistency + ! (2 ) Now declare "makeCharArrayFromCharList" public. (bmy, 11/8/06) + ! (3 ) Updated comments. TYPEARRAY is now a global variable. (bmy, 8/14/07) + ! (4 ) Added interface to read attribute data (bmy, 4/10/08) + !=========================================================================== + + ! References to F90 modules + USE He4ErrorModule + USE He4IncludeModule + + ! Force explicit data types + IMPLICIT NONE + + !--------------------------------------------------------------------- + ! PUBLIC / PRIVATE declarations + !--------------------------------------------------------------------- + + ! Make everything PRIVATE ... + PRIVATE + + ! ... and these routines + PUBLIC :: xDimSize + PUBLIC :: yDimSize + PUBLIC :: zDimSize + PUBLIC :: tDimSize + PUBLIC :: nymd + PUBLIC :: nhms + PUBLIC :: xDim + PUBLIC :: yDim + PUBLIC :: zDim + + ! ... and these routines + PUBLIC :: He4SetVerbose + PUBLIC :: He4GridOpen + PUBLIC :: He4GridClose + PUBLIC :: He4GridGetDimInfo + PUBLIC :: He4GridGetFldInfo + PUBLIC :: He4GridGetAttrInfo + PUBLIC :: He4GridReadAttr + PUBLIC :: He4GridGetFillValue + PUBLIC :: He4GridReadData + PUBLIC :: He4GridReadX + PUBLIC :: He4GridReadY + PUBLIC :: He4GridReadZ + PUBLIC :: He4GridReadT + PUBLIC :: He4GetNymdNhms + PUBLIC :: He4CleanUpIndexFields + PUBLIC :: makeCharArrayFromCharList + + !------------------------------------------------------------------------ + ! MODULE VARIABLES + !------------------------------------------------------------------------ + + ! Switch for printing output to the screen + LOGICAL :: VERBOSE + + ! ID's + INTEGER :: fId, gId + + ! Data extent + INTEGER :: start3D(3), stride3D(3), edge3D(3) + INTEGER :: start4D(4), stride4D(4), edge4D(4) + INTEGER :: xStart(1), xStride(1), xEdge(1) + INTEGER :: yStart(1), yStride(1), yEdge(1) + INTEGER :: zStart(1), zStride(1), zEdge(1) + INTEGER :: tStart(1), tStride(1), tEdge(1) + + ! Fields + INTEGER :: nFields + INTEGER :: fieldRank(HE4_MAX_FLDS) + INTEGER :: fieldType(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: fieldName(HE4_MAX_FLDS) + + ! Attributes + INTEGER :: nAttrs + REAL*4 :: attrValue(HE4_MAX_ATRS) + CHARACTER(LEN=HE4_MAX_CHAR) :: attrName(HE4_MAX_ATRS) + + ! Variables for timing + LOGICAL :: timeFrom1993 = .TRUE. + REAL*8, ALLOCATABLE :: time(:) + + ! Shadow variable for file name + CHARACTER(LEN=HE4_MAX_CHAR) :: saveFileName + + ! Index arrays for grid + INTEGER :: xDimSize, yDimSize, zDimSize, tDimSize + INTEGER, ALLOCATABLE :: nymd(:), nhms(:) + REAL*8, ALLOCATABLE :: xDim(:), yDim(:), zDim(:) + + ! Array for number types + CHARACTER(LEN=10) :: typeArray(10) = & + (/ ' ', ' ', ' ', ' ', 'REAL*4 ', & + 'REAL*8 ', ' ', ' ', ' ', ' ' /) + + !------------------------------------------------------------------------ + ! MODULE INTERFACES + !------------------------------------------------------------------------ + INTERFACE He4GridReadData + MODULE PROCEDURE He4GridReadData3D + MODULE PROCEDURE He4GridReadData4D + END INTERFACE + + INTERFACE He4GridReadAttr + MODULE PROCEDURE He4GridReadAttrChar + MODULE PROCEDURE He4GridReadAttrI2 + MODULE PROCEDURE He4GridReadAttrI4 + MODULE PROCEDURE He4GridReadAttrR4 + MODULE PROCEDURE He4GridReadAttrR8 + END INTERFACE + + !------------------------------------------------------------------------ + ! MODULE ROUTINES + !------------------------------------------------------------------------ + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SetVerbose( v ) + + !====================================================================== + ! Subroutine setVerbose sets the value of module variable "verbose" + ! which determines if information is echoed to the standard output + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) v (LOGICAL) : TRUE or FALSE value + ! + ! NOTES: + !====================================================================== + + ! Arguments + LOGICAL, INTENT(IN) :: v + + ! Set the value of verbose + VERBOSE = v + + END SUBROUTINE He4SetVerbose + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridOpen( fileName ) + + !====================================================================== + ! Subroutine "gridOpen" opens the HDF_EOS file and attaches to the + ! grid structure contained in the file. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) fileName (CHARACTER) : Name of the HDF-EOS file to be opened + ! + ! NOTES: + ! (1) The DAO uses the generic name "EOSGRID" for the grid + ! structure in all products. + !====================================================================== + + ! Arguments + CHARACTER(LEN=*) :: fileName + + ! Local Variables + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdAttach, gdOpen + + !-------------------------- + ! He4GridOpen begins here! + !-------------------------- + + ! Save file name to a private shadow variable + saveFileName = TRIM( fileName ) + + ! Call HDF library routine "gdopen" to open the HDF file + fId = gdOpen( TRIM( fileName ), DFACC_RDONLY ) + + ! Error check fId + IF ( fId == FAIL ) THEN + msg = 'ERROR: Could not open file ' // TRIM( fileName ) + loc = 'He4GridOpen ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Call HDF library routine "gdAttach" to attach to the + ! grid structure contained in the HDF-EOS file. + gId = gdAttach( fId, 'EOSGRID' ) + + ! Error check gId + IF ( gId == FAIL ) THEN + msg = 'ERROR: Could not attach to grid structure!' + loc = 'He4GridOpen ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + END SUBROUTINE He4GridOpen + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridClose( fileName ) + + !===================================================================== + ! Subroutine He4GridClose detaches from the currently opened grid + ! and closes the HDF-EOS file that contains the grid. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fileName (CHARACTER) : Name of the HDF-EOS4 file to be closed + ! + ! NOTES: + !===================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fileName + + ! Local variables + INTEGER :: status + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdDetach, gdClose + + !--------------------------- + ! He4GridClose begins here! + !--------------------------- + + ! Call HDF library routine "gdDetach" to detach from the + ! grid structure in the HDF-EOS file. + status = gdDetach( gId ) + + ! Error check status + IF ( status == FAIL ) THEN + msg = 'ERROR detaching from grid structure!' + loc = 'He4GridClose ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Call HDF library routine "gdClose" to close the HDF-EOS file. + status = gdClose( fId ) + + ! Error check status + IF ( status == FAIL ) THEN + msg = 'ERROR closing the file: ' // TRIM( fileName ) + loc = 'He4GridClose ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + END SUBROUTINE He4GridClose + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridGetDimInfo + + !===================================================================== + ! Subroutine He4GridGetDimInfo obtains information about each + ! dimension of the grid contained in the HDF-EOS4 file. (bmy, 1/17/06) + ! + ! He4GridGetDimInfo also creates the various START, STRIDE, and EDGE + ! arrays needed to read data from the grid structure. + ! + ! NOTES: + !===================================================================== + + ! Local variables + INTEGER :: dims(4), status + INTEGER :: xNumType, yNumType, zNumType, tNumType + CHARACTER(LEN=HE4_MAX_CHAR) :: dimList + + ! HDF-EOS4 library routines + INTEGER :: gdFldInfo + + !--------------------------------------------------------------------- + ! He4GridGetDimInfo begins here + ! + ! Call HDF library routine "gdFldInfo" to get the grid dimensions. + ! + ! xDimSize < 0 denotes missing X-dimension + ! yDimSize < 0 denotes missing Y-dimension + ! zDimSize < 0 denotes missing Z-dimension + ! tDimSize < 0 denotes missing Time-dimension + !--------------------------------------------------------------------- + status = gdFldInfo( gId, 'XDim', dims, xDimSize, xNumType, dimList ) + status = gdFldInfo( gId, 'YDim', dims, yDimSize, yNumType, dimList ) + status = gdFldInfo( gId, 'Height', dims, zDimSize, zNumType, dimList ) + status = gdFldInfo( gId, 'Time', dims, tDimSize, tNumType, dimList ) + + ! Create START, STRIDE, EDGE arrays for 3-D data fields (X,Y,Time) + IF ( xDimSize > 0 .and. yDimSize > 0 .and. tDimSize > 0 ) THEN + start3D = 0 + stride3D = 1 + edge3D = (/ xDimSize, yDimSize, tDimSize /) + ENDIF + + ! Create START, STRIDE, EDGE arrays for 4-D data fields (X,Y,Z,Time) + IF ( xDimSize > 0 .and. yDimSize > 0 .and. & + zDimSize > 0 .and. tDimSize > 0 ) THEN + start4D = 0 + stride4D = 1 + edge4D = (/ xDimSize, yDimSize, zDimSize, tDimSize /) + endif + + ! Create START, STRIDE, EDGE arrays for index field xDim + IF ( xDimSize > 0 ) THEN + xStart = 0 + xStride = 1 + xEdge = xDimSize + ENDIF + + ! Create START, STRIDE, EDGE arrays for index field yDim + IF ( yDimSize > 0 ) THEN + yStart = 0 + yStride = 1 + yEdge = yDimSize + ENDIF + + ! Create START, STRIDE, EDGE arrays for index field zDim + IF ( zDimSize > 0 ) THEN + zStart = 0 + zStride = 1 + zEdge = zDimSize + ENDIF + + ! Create START, STRIDE, EDGE arrays for index field Time + IF ( tDimSize > 0 ) THEN + tStart = 0 + tStride = 1 + tEdge = tDimSize + ENDIF + + ! Echo dimension information to the screen + IF ( VERBOSE ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' Index Quantity (Units) Number of Number' + WRITE( 6, '(a)' ) ' Field Elements Type' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + IF ( xDimSize > 0 ) THEN + WRITE( 6, '(6x, ''XDim Longitude (degrees) '', i8,7x,a10 )' ) & + xDimSize, typeArray(xNumType) + ENDIF + + IF ( yDimSize > 0 ) THEN + WRITE( 6, '(6x, ''YDim Latitude (degrees) '', i8,7x,a10 )' ) & + yDimSize, typeArray(yNumType) + ENDIF + + IF ( zDimSize > 0 ) THEN + WRITE( 6, '(6x, ''Height Altitude (mb ) '', i8,7x,a10 )' ) & + zDimSize, typeArray(zNumType) + ENDIF + + IF ( tDimSize > 0 ) THEN + WRITE( 6, '(6x, ''Time Time Index (seconds) '', i8,7x,a10 )' ) & + tDimSize, typeArray(tNumType) + ENDIF + ENDIF + + END SUBROUTINE He4GridGetDimInfo + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridGetFldInfo + + !====================================================================== + ! Subroutine He4GridGetFldInfo obtains information about each of + ! the fields stored in the HDF-EOS4 file. Some information + ! is echoed to the standard output. + ! + ! NOTES: + !====================================================================== + + ! Local variables + INTEGER :: i, dims(4), rank, numType, status + REAL*4 :: fillValue + CHARACTER(LEN=HE4_MAX_CHAR) :: fieldList, dimList, msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdInqFlds, gdFldInfo + + !-------------------------------- + ! He4GridGetFldInfo begins here! + !-------------------------------- + + ! Call HDF library routine gdInqFlds to get information about + ! each of the fields contained in the HDF-EOS file. + nFields = gdInqFlds( gId, fieldList, fieldRank, fieldType ) + + ! Call "makeCharArrayFromCharList" to create a character array + ! using the comma-separated list of field names, FIELDLIST. + CALL makeCharArrayFromCharList( fieldList, ',', fieldName ) + + ! Write some header lines to the standard output + IF ( VERBOSE ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' )' Field Number Fill Dimensions' + WRITE( 6, '(a)' )' Name Type Value of Field ' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + ENDIF + + ! Loop over each field + DO i = 1, nFields + + ! Call HDF-EOS library routine "gdFldInfo" to read + ! information about each field's dimensions and type + status = gdFldInfo( gId, TRIM( fieldName(i) ), & + dims, rank, numType, dimList ) + + ! Get the "missing data" fill value for each field + CALL He4GridGetFillValue( fieldName(i), fillValue ) + + ! Echo information to the standard output + IF ( VERBOSE ) THEN + WRITE( 6, '( i4,'') '', a10, 1x, a10, 1x, es9.2, 6x, a )' ) & + i, fieldName(i), typeArray( fieldType(i) ), & + fillValue, TRIM( dimList ) + ENDIF + + ENDDO + + END SUBROUTINE He4GridGetFldInfo + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridGetAttrInfo + + !====================================================================== + ! Subroutine He4GridGetAttrInfo obtains information about each of + ! the global attributes for the HDF-EOS4 grid. Some information + ! is echoed to the standard output. (bmy, 1/17/06) + ! + ! NOTES + !====================================================================== + + ! Local variables + INTEGER :: i, status, strBufSize + REAL :: attrValue + CHARACTER(LEN=HE4_MAX_CHAR) :: attrList, message + + ! HDF-EOS4 library routines + INTEGER :: gdInqAttrs, gdRdAttr + + !--------------------------------- + ! He4GridGetAttrInfo begins here! + !--------------------------------- + + ! Call HDF library routine gdInqAttrs to get information about + ! each of the global attributes for the HDF-EOS grid + nAttrs = gdInqAttrs( gId, attrList, strBufSize ) + + ! Call "makeCharArrayFromCharList" to create a character array + ! using the comma-separated list of attribute names, ATTRLIST. + CALL makeCharArrayFromCharList( attrList, ',', attrName ) + + ! Write some header lines to the standard output + IF ( VERBOSE ) then + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' Attribute Attribute' + WRITE( 6, '(a)' ) ' Name Value' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + ENDIF + + ! Loop over all field names + DO i = 1, nAttrs + + ! Read the value of each attribute + status = gdRdAttr( gId, TRIM( attrName(i) ), attrValue ) + + ! Echo information to the standard output + IF ( verbose ) then + WRITE( 6, '( i4,'') '', a20, 1x, es13.6 )' ) & + i, attrName(i), attrValue + ENDIF + ENDDO + + END SUBROUTINE He4GridGetAttrInfo + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridReadAttrChar( gId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4GridAttrChar returns a global attributes of type + ! CHARACTER associated with the grid data structure. (bmy, 4/10/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) gId (INTEGER ) : HDF-EOS4 Grid ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (CHARACTER) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: gId + CHARACTER(LEN=*), INTENT(IN) :: attrName + CHARACTER(LEN=*), INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: GdRdAttr + + !----------------------------------- + ! He4GridReadAttrChar begins here! + !----------------------------------- + + ! Read attribute + status = GdRdAttr( gId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4GridReadAttrChar + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridReadAttrI2( gId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4GridAttrI2 returns a global attributes of type + ! INTEGER*2 associated with the grid data structure. (bmy, 4/10/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) gId (INTEGER ) : HDF-EOS4 grid ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: gId + CHARACTER(LEN=*), INTENT(IN) :: attrName + INTEGER*2, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: GdRdAttr + + !----------------------------------- + ! He4GridReadAttrI2 begins here! + !----------------------------------- + + ! Read attribute + status = GdRdAttr( gId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4GridReadAttrI2 + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridReadAttrI4( gId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4GridAttrI4 returns a global attributes of type + ! INTEGER*4 associated with the grid data structure. (bmy, 4/10/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) gId (INTEGER ) : HDF-EOS4 grid ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: gId + CHARACTER(LEN=*), INTENT(IN) :: attrName + INTEGER, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: GdRdAttr + + !----------------------------------- + ! He4GridReadAttrI4 begins here! + !----------------------------------- + + ! Read attribute + status = GdRdAttr( gId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4GridReadAttrI4 + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridReadAttrR4( gId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4GridAttrR4 returns a global attributes of type + ! REAL*4 associated with the grid data structure. (bmy, 4/10/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) gId (INTEGER ) : HDF-EOS4 grid ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (REAL*4 ) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: gId + CHARACTER(LEN=*), INTENT(IN) :: attrName + REAL*4, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: GdRdAttr + + !----------------------------------- + ! He4SwathReadAttrR4 begins here! + !----------------------------------- + + ! Read attribute + status = GdRdAttr( gId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4GridReadAttrR4 + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridReadAttrR8( gId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4GridAttrR8 returns a global attributes of type + ! REAL*8 associated with the grid data structure. (bmy, 4/10/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (REAL*8 ) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: gId + CHARACTER(LEN=*), INTENT(IN) :: attrName + REAL*8, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: GdRdAttr + + !----------------------------------- + ! He4GridReadAttrR8 begins here! + !----------------------------------- + + ! Read attribute + status = GdRdAttr( gId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4GridReadAttrR8 + +!------------------------------------------------------------------------------ + + SUBROUTINE He4GridGetFillValue( fieldName, fillValue ) + + !===================================================================== + ! Subroutine He4GridGetFillValue reads the missing data "fill" value + ! for a field contained in the HDF-EOS file. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fieldName (CHARACTER) : Name of the field to read in + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (2) fillValue (REAL*4 ) : Fill value for missing data + ! + ! NOTES: + !===================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fieldName + REAL*4, INTENT(OUT) :: fillValue + + ! Local variables + INTEGER :: status + + ! HDF-EOS4 library routines + INTEGER :: gdGetFill + + !---------------------------------- + ! He4GridGetFillValue begins here! + !---------------------------------- + + ! Call HDF library routine "gdrdfld" to read the data field + status = gdGetFill( gId, TRIM( fieldName ), fillValue ) + + ! Assign a large negative number to FILLVALUE if + IF ( status == FAIL ) fillValue = 0.0 + + END SUBROUTINE He4GridGetFillValue + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadData3D( fldName, data3D ) + + !===================================================================== + ! Subroutine He4GridReadData3D" reads a 3-dimensional data field + ! (X,Y,Time) from the HDF-EOS4 file. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fldName (CHARACTER) : Name of the field to read in + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (2) data3D (REAL*4 ) : Data array (3 dimensions) + ! + ! NOTES: + !===================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: data3D(:,:,:) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !-------------------------------- + ! He4GridReadData3D begins here! + !-------------------------------- + + ! Call HDF library routine "gdrdfld" to read the data field + status = gdRdFld( gId, TRIM( fldName ), start3D, stride3D, edge3D, data3D ) + + ! Error check + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field ' // TRIM( fldName ) + loc = 'He4GridReadData3D ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + END SUBROUTINE He4GridReadData3D + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadData4D( fldName, data4D ) + + !===================================================================== + ! Subroutine He4GridReadData4D reads a 4-dimensional data field + ! (X,Y,Z,Time) from the HDF-EOS file. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) fldName (CHARACTER) : Name of the field to read in + ! + ! Arguments as Output: + ! -------------------------------------------------------------------- + ! (1) data4D (REAL*4 ) : Data array (4 dimensions) + ! + ! NOTES: + !===================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: data4D(:,:,:,:) + + ! Local variables + INTEGER :: status + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !-------------------------------- + ! He4GridReadData4D begins here! + !-------------------------------- + + ! Call HDF library routine "gdrdfld" to read the data field + status = gdRdFld( gId, TRIM( fldName ), start4D, stride4D, edge4D, data4D ) + + ! Error check + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field ' // TRIM( fldName ) + loc = 'He4GridReadData4D ("He4GridReadModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + END SUBROUTINE He4GridReadData4D + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadX + + !===================================================================== + ! Subroutine He4GridReadX reads XDIM, the index field for the + ! X-dimension of the HDF-EOS4 grid structure. (bmy, 1/17/06) + ! + ! NOTES: + !===================================================================== + + ! Local variables + INTEGER :: status, as + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !--------------------------- + ! He4GridReadX begins here! + !--------------------------- + + ! Allocate the XDIM array of longitude centers (if necessary) + IF ( xDimSize > 0 .and. .not. ALLOCATED( xDim ) ) THEN + ALLOCATE( xDim( xEdge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'xDim' ) + ELSE + RETURN + ENDIF + + ! Read XDIM, the vector of longitudes (in degrees), if present + status = gdRdFld( gId, 'XDim', xStart, xStride, xEdge, xDim ) + + ! Error check + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field xDim!' + loc = 'gridReadX ("He4GridReadModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Echo information to the standard output + IF ( VERBOSE ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' XDim: Longitude Centers (in degrees)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(9f8.2)' ) xDim + ENDIF + + END SUBROUTINE He4GridReadX + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadY + + !===================================================================== + ! Subroutine He4GridReadY reads YDIM, the index field for the + ! Y-dimension of the HDF-EOS grid structure. (bmy, 1/17/06) + ! + ! NOTES: + !===================================================================== + + ! Local variables + INTEGER :: status, as + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !--------------------------- + ! He4GridReadY begins here! + !--------------------------- + + ! Allocate the YDIM array of longitude centers (if necessary) + IF ( yDimSize > 0 .and. .not. ALLOCATED( yDim ) ) THEN + ALLOCATE( yDim( yedge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'yDim' ) + ELSE + RETURN + ENDIF + + ! Read YDIM, the vector of latitudes (in degrees), if present + status = gdRdFld( gId, 'YDim', yStart, yStride, yEdge, yDim ) + + ! Error check + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field yDim!' + loc = 'gridReadY ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Echo information to the standard output + IF ( verbose ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' YDim: Latitude Centers (in degrees)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(9f8.2)' ) yDim + ENDIF + + END SUBROUTINE He4GridReadY + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadZ + + !===================================================================== + ! Subroutine He4GridReadZ reads ZDIM, the index field for the + ! Z-dimension of the HDF-EOS grid structure. (bmy, 1/17/06) + ! + ! + ! NOTES: + !===================================================================== + + ! Local variables + INTEGER :: status, as + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !--------------------------- + ! He4GridReadZ begins here! + !--------------------------- + + ! Allocate the ZDIM array of altitude centers (if necessary) + IF ( zDimSize > 0 .and. .not. ALLOCATED( zDim ) ) THEN + ALLOCATE( zDim( zedge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'zDim' ) + ELSE + RETURN + ENDIF + + ! Read ZDIM, the vector of pressures, if present + status = gdRdFld( gId, 'Height', zStart, zStride, zEdge, zDim ) + + ! Error check + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field zDim!' + loc = 'gridReadZ ("He4GridReadModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Echo information to the standard output + IF ( verbose ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' ZDim: Altitude Indices' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(9f8.2)' ) zDim + ENDIF + + END SUBROUTINE He4GridReadZ + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GridReadT + + !===================================================================== + ! Subroutine He4GridReadT reads TIME, the index field for the + ! time-dimension of the HDF-EOS grid structure. (bmy, 1/17/06) + ! + ! NOTES: + !===================================================================== + + ! Local variables + INTEGER :: status, as, t + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: gdRdFld + + !--------------------------- + ! He4gridReadT begins here! + !--------------------------- + + ! Allocate the time array, if it has not been previously allocated + IF ( tDimSize > 0 .and. .not. ALLOCATED( time ) ) THEN + ALLOCATE( time( tEdge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'time' ) + ELSE + RETURN + ENDIF + + ! Read TIME, the vector of longitudes (in degrees), if present + status = gdRdFld( gId, 'Time', tStart, tStride, tEdge, time ) + + ! Error check TIME + IF ( status == FAIL ) THEN + msg = 'ERROR reading data for field Time!' + loc = 'He4GridReadT ("He4GridModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + END SUBROUTINE He4GridReadT + +!----------------------------------------------------------------------------- + + SUBROUTINE He4GetNymdNhms + + !===================================================================== + ! Subroutine He4getNymdNhms converts the "Time" array into YYYYMMDD + ! (NYMD) and HHMMSS (NHMS) values. + ! + ! NOTES: + ! (1) Some HDF-EOS files index time as seconds since 1993. If this + ! is the case, then set module variable TIMEFROM1993 = .TRUE. + ! + ! (2) The HDF-EOS files for the GEOS-3/Terra assimilation index time + ! from the starting date and time contained in the file name. + ! To read these files, first set TIMEFROM1993 = .FALSE. + ! + ! (3) Call routines JULDAY and CALDAT to compute the Year/Month/Day + ! and Hour/Minute/Second. These will account for time periods + ! that straddle a month change. + ! + ! (4) Now trim excess spaces from SAVEFILENAME before splitting + ! it up into segments. Also error check NYMD and NHMS for + ! negative values. (bmy, 9/21/00) + !===================================================================== + + ! Local variables + INTEGER :: t, as, year0, month0, day0, hour0 + REAL*8 :: julianDay, julianDay0 + CHARACTER(LEN=HE4_MAX_CHAR) :: tmpStr, suffix(10) + + !----------------------------- + ! He4GetNymdNhms begins here! + !----------------------------- + + ! Get the time index array + CALL He4GridReadT + + ! Allocate the nymd and nhms arrays + IF ( tDimSize > 0 ) THEN + + ! NYMD array + IF ( .not. ALLOCATED( nymd ) ) THEN + ALLOCATE( nymd( tEdge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'nymd' ) + ENDIF + + ! NHMS array + IF ( .not. ALLOCATED( nhms ) ) THEN + ALLOCATE( nhms( tEdge(1) ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'nhms' ) + ENDIF + ELSE + RETURN + ENDIF + + !===================================================================== + ! If TIME is measured from 1/1/1993, call "calDate" to + ! convert time to YYYYMMDD and HHMMSS values. + !===================================================================== + IF ( timeFrom1993 ) THEN + DO t = 1, tDimSize + julianDay = 2448988.5d0 + ( time(t) / 86400d0 ) + CALL calDate( julianDay, nymd(t), nhms(t) ) + ENDDO + + !===================================================================== + ! If TIME is NOT measured from 1/1/1993, then read YYYYMMDD from + ! from the file name. HDF-EOS containing GEOS-3/Terra data stick + ! to the following naming convention: + ! + ! (1) Assimilation files -- the suffix "tYYYYMMDD" indicates the + ! starting date. The starting time is always 0h GMT. + ! + ! (2) Forecast files -- the suffix "bYYYYMMDDHH" indicates the + ! starting date and GMT time. + ! + ! Therefore, extract the time/date info from the appropriate suffix. + !===================================================================== + ELSE + + ! Initialize + suffix = '' + + ! Separate file name into individual segments + ! Trim excess spaces from SAVEFILENAME (bmy, 9/21/00) + CALL makeCharArrayfromCharList( TRIM( saveFileName ), '.', suffix ) + + ! Initialize TMPSTR, for safety's sake + tmpStr = '' + + ! Loop thru the file name segments from right to left + DO t = 1, 10 + + ! Save each segment into a temp string + tmpStr = suffix(t) + + ! Skip null strings + IF ( LEN_TRIM( tmpStr ) == 0 ) CYCLE + + ! Assimilation files have the date listed as "tYYYYMMDD" + ! Extract starting year, month, day, and hour + IF ( tmpStr(1:1) == 't' ) THEN + IF ( LEN_TRIM( tmpStr ) == 9 ) THEN + READ( tmpStr, '(1x,i4,i2,i2)' ) year0, month0, day0 + hour0 = 0 + EXIT + ENDIF + ENDIF + + ! Forecast files have the starting date/time listed as + ! "bYYYYMMDDHH". Extract starting year, month, day, and hour + IF ( tmpStr(1:1) == 'b' ) THEN + IF ( LEN_TRIM( tmpStr ) == 11 ) THEN + READ( tmpStr, '(1x,i4,i2,i2,i2)' ) year0, month0, day0, hour0 + EXIT + ENDIF + ENDIF + ENDDO + + ! Compute starting Julian day + julianDay0 = julDay( year0, month0, DBLE( day0 ) ) + + ! Loop over all the elements of TIME + DO t = 1, tDimSize + + ! Compute the julian day corresponding to each element of TIME + julianDay = julianDay0 + ( time(t) / 1440.d0 ) + & + ( DBLE( hour0 ) / 24d0 ) + + ! Convert Julian day to NYMD, NHMS + ! This will work for days that straddle the 1st of the month + CALL calDate( julianDay, nymd(t), nhms(t) ) + ENDDO + ENDIF + + ! Error check NYMD + IF ( ANY( nymd < 0 ) ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR: NYMD is negative!' + WRITE( 6, '(8i9)' ) nymd + WRITE( 6, '(a)' ) 'STOP in getNymdNhms (HdfModule)' + STOP + ENDIF + + ! Error check NHMS + IF ( ANY( nhms < 0 ) ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR: NYMD is negative!' + WRITE( 6, '(8i9)' ) nymd + WRITE( 6, '(a)' ) 'STOP in getNymdNhms (HdfModule)' + STOP + ENDIF + + ! Echo information values to the standard output + IF ( VERBOSE ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) ' Time Time from Date Time' + IF ( timeFrom1993 ) THEN + WRITE( 6, '(a)' ) ' Index 1993 (s) (YYYYMMDD) (HHMMSS)' + ELSE + WRITE( 6, '(a)' ) ' Index start (s) (YYYYMMDD) (HHMMSS)' + ENDIF + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + DO t = 1, tDimSize + WRITE( 6, '(i5,1x,f13.1,8x,i8.8,8x,i6.6)' ) & + t, time(t), nymd(t), nhms(t) + ENDDO + ENDIF + + END SUBROUTINE He4GetNymdNhms + +!----------------------------------------------------------------------------- + + SUBROUTINE He4CleanUpIndexFields + + !===================================================================== + ! Subroutine He4CleanUpIndexFields deallocates the HDF-EOS index + ! fields xDim, YDim, ZDim, time, nymd, and nhms. (bmy, 1/17/06) + !===================================================================== + IF ( ALLOCATED( xDim ) ) DEALLOCATE( xDim ) + IF ( ALLOCATED( yDim ) ) DEALLOCATE( yDim ) + IF ( ALLOCATED( zDim ) ) DEALLOCATE( zDim ) + IF ( ALLOCATED( time ) ) DEALLOCATE( time ) + IF ( ALLOCATED( nymd ) ) DEALLOCATE( nymd ) + IF ( ALLOCATED( nhms ) ) DEALLOCATE( nhms ) + + END SUBROUTINE He4CleanUpIndexFields + +!----------------------------------------------------------------------------- + + SUBROUTINE calDate( julDay, nymd, nhms ) + + !===================================================================== + ! Subroutine "calDate" converts an astronomical Julian day to + ! the NYMD (e.g. YYYYMMDD) and NHMS (i.e. HHMMSS) format. + ! + ! Algorithm taken from "Practical Astronomy With Your Calculator", + ! Third Edition, by Peter Duffett-Smith, Cambridge UP, 1992. + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) julDay : REAL*8 : Astronomical julian day + ! + ! Arguments as output: + ! -------------------------------------------------------------------- + ! (1) nymd : INTEGER : YYYYMMDD corresponding to JDAY + ! (2) nhms : INTEGER : HHMMSS corresponding to JDAY + !===================================================================== + + ! Arguments + REAL*8, INTENT(IN) :: julDay + INTEGER, INTENT(OUT) :: nymd, nhms + + ! Local variables + REAL*8 :: a, b, c, d, day, e, f + REAL*8 :: fDay, g, i, j, jd, m, y + + !===================================================================== + ! "calDate begins here! + ! See "Practical astronomy with your calculator", Peter Duffett-Smith + ! 1992, for an explanation of the following algorithm. + !===================================================================== + jd = julDay + 0.5d0 + i = INT( jd ) + f = jd - INT( I ) + + IF ( i > 2299160d0 ) THEN + a = INT( ( I - 1867216.25d0 ) / 36524.25 ) + b = i + 1 + a - INT( a / 4 ) + ELSE + b = i + ENDIF + + c = b + 1524d0 + + d = INT( ( c - 122.1d0 ) / 365.25d0 ) + + e = INT( 365.25d0 * d ) + + g = INT( ( c - e ) / 30.6001d0 ) + + ! Day is the day number + day = c - e + f - INT( 30.6001d0 * g ) + + ! fDay is the fractional day number + fDay = day - int( day ) + + ! M is the month number + IF ( g < 13.5d0 ) THEN + m = g - 1d0 + ELSE + m = g - 13d0 + ENDIF + + ! Y is the year number + IF ( m > 2.5d0 ) THEN + y = d - 4716d0 + ELSE + y = d - 4715d0 + ENDIF + + ! NYMD is YYYYMMDD + nymd = ( INT( y ) * 10000 ) + ( INT( m ) * 100 ) + INT( day ) + + ! NHMS is HHMMSS + nhms = INT( fday * 24 ) * 10000 + + END SUBROUTINE calDate + +!----------------------------------------------------------------------------- + + FUNCTION julDay( year, month, day ) RESULT( julianDay ) + + !====================================================================== + ! Function JULDAY returns the astronomical Julian day. (bmy, 1/17/06) + ! + ! Algorithm taken from "Practical Astronomy With Your Calculator", + ! Third Edition, by Peter Duffett-Smith, Cambridge UP, 1992. + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) YEAR : (INTEGER) Current year + ! (2) MONTH : (INTEGER) Current month + ! (3) DAY : (REAL*8 ) Current day (can be fractional, e.g. 17.25) + ! + ! NOTES: + ! (2) JULDAY requires the external function MINT.F. + ! + ! (3) JULDAY will compute the correct Julian day for any + ! BC or AD date. + ! + ! (4) For BC dates, subtract 1 from the year and append a minus + ! sign. For example, 1 BC is 0, 2 BC is -1, etc. This is + ! necessary for the algorithm. + !=================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: year, month + REAL*8, INTENT(IN) :: day + + ! Local variables + LOGICAL :: isGregorian + INTEGER :: year1, month1 + REAL*8 :: x1, a, b, c, d, julianDay + + !====================================================================== + ! JULDAY begins here! + ! + ! Follow algorithm from Peter Duffett-Smith (1992) + !====================================================================== + + ! Compute YEAR and MONTH1 + IF ( ( month == 1 ) .OR. ( month == 2 ) ) THEN + year1 = year - 1 + month1 = month + 12 + ELSE + year1 = year + month1 = month + ENDIF + + ! Compute the "A" term. + x1 = DBLE( year ) / 100.0d0 + a = mint( x1 ) + + ! The Gregorian calendar begins on 10 October 1582 + ! Any dates prior to this will be in the Julian calendar + IF ( year > 1582 ) THEN + isGregorian = .TRUE. + ELSE + IF ( ( year == 1582 ) .AND. & + ( month1 >= 10 ) .AND. & + ( day >= 15.0 ) ) THEN + isGregorian = .TRUE. + ELSE + isGregorian = .FALSE. + ENDIF + ENDIF + + ! Compute the "B" term according to Gregorian or Julian calendar + IF ( isGregorian ) THEN + b = 2.0d0 - a + mint( a / 4.0d0 ) + ELSE + b = 0.0d0 + ENDIF + + ! Compute the "C" term for BC dates (YEAR1 <= 0 ) + ! or AD dates (YEAR1 > 0) + IF ( year1 < 0 ) THEN + x1 = ( 365.25d0 * year1 ) - 0.75d0 + c = mint( x1 ) + ELSE + x1 = 365.25d0 * year1 + c = mint( x1 ) + ENDIF + + ! Compute the "D" term + x1 = 30.6001d0 * DBLE( month1 + 1 ) + d = mint( x1 ) + + + ! Add the terms to get the Julian Day number + julianDay = b + c + d + day + 1720994.5d0 + + END FUNCTION julDay + +!----------------------------------------------------------------------------- + + FUNCTION mint( x ) RESULT ( value ) + + !====================================================================== + ! Function MINT is defined as follows: + ! + ! MINT = -INT( ABS( X ) ), X < 0 + ! MINT = INT( ABS( X ) ), X >= 0 + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) X : (REAL*8) Argument for the function MINT + ! + ! NOTES: + ! (1) MINT is primarily intended for use with routine JULDAY. + !====================================================================== + + ! Arguments + REAL*8, INTENT(IN) :: x + + ! Function value + REAL*8 :: value + + !-------------------- + ! MINT begins here! + !-------------------- + IF ( x < 0d0 ) THEN + value = -INT( ABS( x ) ) + ELSE + value = INT( ABS( x ) ) + ENDIF + + END FUNCTION MINT + +!----------------------------------------------------------------------------- + + SUBROUTINE makeCharArrayFromCharList( list, separator, array ) + + !====================================================================== + ! Subroutine makeCharArrayFromCharList takes a comma-separated word + ! list, and places each word into a separate element of a character + ! array. (bmy, 1/17/06, 11/8/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) list (CHARACTER) : String with comma-separated words + ! (2) separator (CHARACTER) : String for separator text + ! + ! Arguments as output: + ! --------------------------------------------------------------------- + ! (3) array (CHARACTER) : Array of substrings + ! + ! NOTES: + ! (1) Now set the output "array" argument to '' (bmy, 11/8/06) + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: list + CHARACTER(LEN=1 ), INTENT(IN) :: separator + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: array(:) + + ! local variables + INTEGER :: P, N, ind(HE4_MAX_CHAR) + CHARACTER(LEN=1) :: C + + !---------------------------------------- + ! makeCharArrayFromCharList begins here! + !---------------------------------------- + + ! Initialize + N = 1 + ind = 0 + array = '' + + ! Find the positions of all the commas in LIST + DO P = 1, LEN( list ) + + ! Look at each character individually + C = list(P:P) + + ! If a comma... + IF ( C == separator ) THEN + + ! Increment comma + N = N + 1 + ind(N) = P + ENDIF + ENDDO + + ! Add the position of the end of the string into IND + ind(N+1) = LEN( list ) + + ! Save text between the commas into ARRAY + DO P = 1, N + IF ( P == N ) THEN + array(P) = list( ind(P)+1:ind(P+1) ) + ELSE + array(P) = list( ind(P)+1:ind(P+1)-1 ) + ENDIF + ENDDO + + END SUBROUTINE makeCharArrayFromCharList + +!----------------------------------------------------------------------------- + +END MODULE He4GridModule diff --git a/code/obs_operators/He4IncludeModule.f90 b/code/obs_operators/He4IncludeModule.f90 new file mode 100644 index 0000000..2e437b5 --- /dev/null +++ b/code/obs_operators/He4IncludeModule.f90 @@ -0,0 +1,494 @@ +! $Id: He4IncludeModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +MODULE He4IncludeModule + + !======================================================================== + ! Module He4IncludeModule contains the various parameter settings for + ! the HDF-EOS4 library routines and F90 modules. (bmy, 1/17/06) + ! + ! Original Code From: + ! + ! NCSA HDF + ! Software Development Group + ! National Center for Supercomputing Applications + ! University of Illinois at Urbana-Champaign + ! 605 E. Springfield, Champaign IL 61820 + ! + ! hdf.inc,v 1.22 1997/02/11 17:32:54 sxu Exp + ! -------------------------------------------------------------------- + ! File: hdf.inc + ! Purpose: Fortran header file for HDF routines + ! Contents: Tag definitions + ! Error return codes + ! Logical constants + ! Remarks: This file can be included with Fortran user programs. + ! As a general rule, don't use DFNT constants that don't + ! include a number in their name. E.g., don't use + ! DFNT_FLOAT, use DFNT_FLOAT32 or DFNT_FLOAT64. The DFNT + ! constants that don't include numbers are for backward + ! compatibility only. Also, there are no current plans to + ! support 128-bit number types. For more information about + ! constants in this file, see the equivalent constant + ! declarations in the C include file 'hdf.h' + ! + ! With extra parameter settings by Bob Yantosca (1/13/06) + ! + ! NOTES: + !======================================================================== + + ! Force explicit data types + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !%%% %%% + !%%% Original HDF-EOS4 parameters begin here! %%% + !%%% %%% + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Error Return Codes + integer DFE_NOERROR, DFE_NONE, DFE_FNF + integer DFE_DENIED, DFE_ALROPEN, DFE_TOOMANY + integer DFE_BADNAME, DFE_BADACC, DFE_BADOPEN + integer DFE_NOTOPEN, DFE_CANTCLOSE, DFE_DFNULL + integer DFE_ILLTYPE, DFE_UNSUPPORTED, DFE_BADDDLIST + integer DFE_NOTDFFILE, DFE_SEEDTWICE, DFE_NOSPACE + integer DFE_NOSUCHTAG, DFE_READERROR + + parameter(DFE_NOERROR = 0) + parameter(DFE_NONE = 0) + parameter(DFE_FNF = -1) + parameter(DFE_DENIED = -2) + parameter(DFE_ALROPEN = -3) + parameter(DFE_TOOMANY = -4) + parameter(DFE_BADNAME = -5) + parameter(DFE_BADACC = -6) + parameter(DFE_BADOPEN = -7) + parameter(DFE_NOTOPEN = -8) + parameter(DFE_CANTCLOSE = -9) + parameter(DFE_DFNULL = -10) + parameter(DFE_ILLTYPE = -11) + parameter(DFE_UNSUPPORTED = -12) + parameter(DFE_BADDDLIST = -13) + parameter(DFE_NOTDFFILE = -14) + parameter(DFE_SEEDTWICE = -15) + parameter(DFE_NOSPACE = -16) + parameter(DFE_NOSUCHTAG = -17) + parameter(DFE_READERROR = -18) + + integer DFE_WRITEERROR, DFE_SEEKERROR, DFE_NOFREEDD + integer DFE_BADTAG, DFE_BADREF, DFE_RDONLY + integer DFE_BADCALL, DFE_BADPTR, DFE_BADLEN + integer DFE_BADSEEK, DFE_NOMATCH, DFE_NOTINSET + integer DFE_BADDIM, DFE_BADOFFSET, DFE_BADSCHEME + integer DFE_NODIM, DFE_NOTENOUGH, DFE_NOVALS + integer DFE_CORRUPT, DFE_BADFP + + parameter(DFE_WRITEERROR = -19) + parameter(DFE_SEEKERROR = -20) + parameter(DFE_NOFREEDD = -21) + parameter(DFE_BADTAG = -22) + parameter(DFE_BADREF = -23) + parameter(DFE_RDONLY = -24) + parameter(DFE_BADCALL = -25) + parameter(DFE_BADPTR = -26) + parameter(DFE_BADLEN = -27) + parameter(DFE_BADSEEK = -28) + parameter(DFE_NOMATCH = -29) + parameter(DFE_NOTINSET = -30) + parameter(DFE_BADDIM = -31) + parameter(DFE_BADOFFSET = -32) + parameter(DFE_BADSCHEME = -33) + parameter(DFE_NODIM = -34) + parameter(DFE_NOTENOUGH = -35) + parameter(DFE_NOVALS = -36) + parameter(DFE_CORRUPT = -37) + parameter(DFE_BADFP = -38) + + integer DFE_NOREF, DFE_BADDATATYPE, DFE_BADMCTYPE + integer DFE_BADNUMTYPE, DFE_BADORDER, DFE_ARGS + integer DFE_INTERNAL, DFE_DUPDD, DFE_CANTMOD + integer DFE_RANGE, DFE_BADTABLE, DFE_BADSDG + integer DFE_BADNDG, DFE_BADFIELDS, DFE_NORESET + integer DFE_NOVS, DFE_VGSIZE, DFE_DIFFFILES + integer DFE_VTAB, DFE_BADAID + + parameter(DFE_NOREF = -39) + parameter(DFE_BADDATATYPE = -40) + parameter(DFE_BADMCTYPE = -41) + parameter(DFE_BADNUMTYPE = -42) + parameter(DFE_BADORDER = -43) + parameter(DFE_ARGS = -44) + parameter(DFE_INTERNAL = -45) + parameter(DFE_DUPDD = -46) + parameter(DFE_CANTMOD = -47) + parameter(DFE_RANGE = -48) + parameter(DFE_BADTABLE = -49) + parameter(DFE_BADSDG = -50) + parameter(DFE_BADNDG = -51) + parameter(DFE_BADFIELDS = -52) + parameter(DFE_NORESET = -53) + parameter(DFE_NOVS = -54) + parameter(DFE_VGSIZE = -55) + parameter(DFE_DIFFFILES = -56) + parameter(DFE_VTAB = -57) + parameter(DFE_BADAID = -58) + + integer DFE_OPENAID, DFE_BADCONV, DFE_GENAPP, DFE_CANTFLUSH + integer DFE_BADTYPE, DFE_SYMSIZE, DFE_BADATTACH + integer DFE_CANTDETACH + + parameter(DFE_OPENAID = -59) + parameter(DFE_BADCONV = -60) + parameter(DFE_GENAPP = -61) + parameter(DFE_CANTFLUSH = -62) + parameter(DFE_BADTYPE = -63) + parameter(DFE_SYMSIZE = -64) + parameter(DFE_BADATTACH = -65) + parameter(DFE_CANTDETACH = -66) + + ! internal file access codes + + integer DFACC_READ, DFACC_WRITE, DFACC_CREATE, DFACC_ALL + integer DFACC_RDONLY, DFACC_RDWR, DFACC_CLOBBER + + parameter(DFACC_READ = 1) + parameter(DFACC_WRITE = 2) + parameter(DFACC_CREATE = 4) + parameter(DFACC_ALL = 7) + parameter(DFACC_RDONLY = 1) + parameter(DFACC_RDWR = 3) + parameter(DFACC_CLOBBER = 4) + + ! Access types for SDsetaccesstype + + integer DFACC_DEFAULT, DFACC_SERIAL, DFACC_PARALLEL + parameter(DFACC_DEFAULT = 0) + parameter(DFACC_SERIAL = 1) + parameter(DFACC_PARALLEL = 9) + + ! Constants for DFSDsetorder + + integer DFO_FORTRAN, DFO_C + + parameter(DFO_FORTRAN = 1) + parameter(DFO_C = 2) + + ! Definitions of storage convention + + integer DFNTF_IEEE, DFNTF_VAX, DFNTF_CRAY, DFNTF_PC + integer DFNTF_CONVEX, DFNTF_VP + + parameter(DFNTF_IEEE = 1) + parameter(DFNTF_VAX = 2) + parameter(DFNTF_CRAY = 3) + parameter(DFNTF_PC = 4) + parameter(DFNTF_CONVEX = 5) + parameter(DFNTF_VP = 6) + + ! Masks for types + + integer DFNT_HDF, DFNT_NATIVE, DFNT_CUSTOM, DFNT_LITEND + + parameter(DFNT_HDF = 0) + parameter(DFNT_NATIVE = 4096) + parameter(DFNT_CUSTOM = 8192) + parameter(DFNT_LITEND = 16384) + + ! Number type info codes + + integer DFNT_NONE, DFNT_QUERY, DFNT_VERSION + + parameter(DFNT_NONE = 0) + parameter(DFNT_QUERY = 0) + parameter(DFNT_VERSION = 1) + + integer DFNT_FLOAT32, DFNT_FLOAT, DFNT_FLOAT64 + integer DFNT_DOUBLE, DFNT_FLOAT128 + + parameter(DFNT_FLOAT32 = 5) + parameter(DFNT_FLOAT = 5) + parameter(DFNT_FLOAT64 = 6) + parameter(DFNT_DOUBLE = 6) + parameter(DFNT_FLOAT128 = 7) + + integer DFNT_INT8, DFNT_UINT8 + integer DFNT_INT16, DFNT_UINT16 + integer DFNT_INT32, DFNT_UINT32 + integer DFNT_INT64, DFNT_UINT64 + integer DFNT_INT128,DFNT_UINT128 + + parameter(DFNT_INT8 = 20) + parameter(DFNT_UINT8 = 21) + parameter(DFNT_INT16 = 22) + parameter(DFNT_UINT16 = 23) + parameter(DFNT_INT32 = 24) + parameter(DFNT_UINT32 = 25) + parameter(DFNT_INT64 = 26) + parameter(DFNT_UINT64 = 27) + parameter(DFNT_INT128 = 28) + parameter(DFNT_UINT128 = 29) + + integer DFNT_UCHAR8, DFNT_UCHAR, DFNT_CHAR8 + integer DFNT_CHAR, DFNT_CHAR16, DFNT_UCHAR16 + + parameter(DFNT_UCHAR8 = 3) + parameter(DFNT_UCHAR = 3) + parameter(DFNT_CHAR8 = 4) + parameter(DFNT_CHAR = 4) + parameter(DFNT_CHAR16 = 42) + parameter(DFNT_UCHAR16 = 43) + + integer DFNT_NFLOAT32, DFNT_NFLOAT, DFNT_NFLOAT64 + integer DFNT_NDOUBLE, DFNT_NFLOAT128 + + parameter(DFNT_NFLOAT32 = 4101) + parameter(DFNT_NFLOAT = 4101) + parameter(DFNT_NFLOAT64 = 4102) + parameter(DFNT_NDOUBLE = 4102) + parameter(DFNT_NFLOAT128 = 4103) + + integer DFNT_NINT8, DFNT_NUINT8 + integer DFNT_NINT16, DFNT_NUINT16 + integer DFNT_NINT32, DFNT_NUINT32 + integer DFNT_NINT64, DFNT_NUINT64 + integer DFNT_NINT128,DFNT_NUINT128 + + parameter(DFNT_NINT8 = 4116) + parameter(DFNT_NUINT8 = 4117) + parameter(DFNT_NINT16 = 4118) + parameter(DFNT_NUINT16 = 4119) + parameter(DFNT_NINT32 = 4120) + parameter(DFNT_NUINT32 = 4121) + parameter(DFNT_NINT64 = 4122) + parameter(DFNT_NUINT64 = 4123) + parameter(DFNT_NINT128 = 4124) + parameter(DFNT_NUINT128 = 4125) + + integer DFNT_NUCHAR8, DFNT_NUCHAR, DFNT_NCHAR8 + integer DFNT_NCHAR, DFNT_NCHAR16, DFNT_NUCHAR16 + + parameter(DFNT_NUCHAR8 = 4099) + parameter(DFNT_NUCHAR = 4099) + parameter(DFNT_NCHAR8 = 4100) + parameter(DFNT_NCHAR = 4100) + parameter(DFNT_NCHAR16 = 4138) + parameter(DFNT_NUCHAR16 = 4139) + + integer DFNT_LFLOAT32, DFNT_LFLOAT, DFNT_LFLOAT64 + integer DFNT_LDOUBLE, DFNT_LFLOAT128 + + parameter(DFNT_LFLOAT32 = 16389) + parameter(DFNT_LFLOAT = 16389) + parameter(DFNT_LFLOAT64 = 16390) + parameter(DFNT_LDOUBLE = 16390) + parameter(DFNT_LFLOAT128 = 16391) + + integer DFNT_LINT8,DFNT_LUINT8,DFNT_LINT16,DFNT_LUINT16 + integer DFNT_LINT32,DFNT_LUINT32,DFNT_LINT64,DFNT_LUINT64 + integer DFNT_LINT128,DFNT_LUINT128 + + parameter(DFNT_LINT8 = 16404) + parameter(DFNT_LUINT8 = 16405) + parameter(DFNT_LINT16 = 16406) + parameter(DFNT_LUINT16 = 16407) + parameter(DFNT_LINT32 = 16408) + parameter(DFNT_LUINT32 = 16409) + parameter(DFNT_LINT64 = 16410) + parameter(DFNT_LUINT64 = 16411) + parameter(DFNT_LINT128 = 16412) + parameter(DFNT_LUINT128 = 16413) + + integer DFNT_LUCHAR8, DFNT_LUCHAR, DFNT_LCHAR8 + integer DFNT_LCHAR, DFNT_LCHAR16, DFNT_LUCHAR16 + + parameter(DFNT_LUCHAR8 = 16387) + parameter(DFNT_LUCHAR = 16387) + parameter(DFNT_LCHAR8 = 16388) + parameter(DFNT_LCHAR = 16388) + parameter(DFNT_LCHAR16 = 16426) + parameter(DFNT_LUCHAR16 = 16427) + + ! tags and refs + + integer DFREF_WILDCARD, DFTAG_WILDCARD, DFTAG_NULL + integer DFTAG_LINKED, DFTAG_VERSION, DFTAG_COMPRESSED + + parameter(DFREF_WILDCARD = 0, DFTAG_WILDCARD = 0) + parameter(DFTAG_NULL = 1, DFTAG_LINKED = 20) + parameter(DFTAG_VERSION = 30,DFTAG_COMPRESSED = 40) + + ! utility set + + integer DFTAG_FID, DFTAG_FD, DFTAG_TID, DFTAG_TD + integer DFTAG_DIL, DFTAG_DIA, DFTAG_NT, DFTAG_MT + + parameter(DFTAG_FID = 100, DFTAG_FD = 101) + parameter(DFTAG_TID = 102, DFTAG_TD = 103) + parameter(DFTAG_DIL = 104, DFTAG_DIA = 105) + parameter(DFTAG_NT = 106, DFTAG_MT = 107) + + ! raster-8 set + + integer DFTAG_ID8, DFTAG_IP8, DFTAG_RI8 + integer DFTAG_CI8, DFTAG_II8 + + parameter(DFTAG_ID8 = 200, DFTAG_IP8 = 201) + parameter(DFTAG_RI8 = 202, DFTAG_CI8 = 203) + parameter(DFTAG_II8 = 204) + + ! Raster Image set + + integer DFTAG_ID, DFTAG_LUT, DFTAG_RI, DFTAG_CI + + parameter(DFTAG_ID = 300, DFTAG_LUT = 301) + parameter(DFTAG_RI = 302, DFTAG_CI = 303) + + integer DFTAG_RIG, DFTAG_LD, DFTAG_MD, DFTAG_MA + integer DFTAG_CCN, DFTAG_CFM, DFTAG_AR + + parameter(DFTAG_RIG = 306, DFTAG_LD = 307) + parameter(DFTAG_MD = 308, DFTAG_MA = 309) + parameter(DFTAG_CCN = 310, DFTAG_CFM = 311) + parameter(DFTAG_AR = 312) + + integer DFTAG_DRAW, DFTAG_RUN, DFTAG_XYP, DFTAG_MTO + + parameter(DFTAG_DRAW = 400, DFTAG_RUN = 401) + parameter(DFTAG_XYP = 500, DFTAG_MTO = 501) + + ! Tektronix + + integer DFTAG_T14, DFTAG_T105 + + parameter(DFTAG_T14 = 602, DFTAG_T105 = 603) + + ! Scientific Data set + + integer DFTAG_SDG, DFTAG_SDD, DFTAG_SD, DFTAG_SDS, DFTAG_SDL + integer DFTAG_SDU, DFTAG_SDF, DFTAG_SDM, DFTAG_SDC + integer DFTAG_SDT,DFTAG_SDLNK,DFTAG_NDG + integer DFTAG_BREQ,DFTAG_EREQ,DFTAG_CAL, DFTAG_FV + + parameter(DFTAG_SDG = 700, DFTAG_SDD = 701) + parameter(DFTAG_SD = 702, DFTAG_SDS = 703) + parameter(DFTAG_SDL = 704, DFTAG_SDU = 705) + parameter(DFTAG_SDF = 706, DFTAG_SDM = 707) + parameter(DFTAG_SDC = 708, DFTAG_SDT = 709) + parameter(DFTAG_SDLNK = 710, DFTAG_NDG = 720) + parameter(DFTAG_CAL = 731, DFTAG_FV = 732) + parameter(DFTAG_BREQ = 799, DFTAG_EREQ = 780) + + ! VSets + + integer DFTAG_VG, DFTAG_VH, DFTAG_VS + + parameter(DFTAG_VG = 1965, DFTAG_VH = 1962) + parameter(DFTAG_VS = 1963) + + ! compression schemes + + integer DFTAG_RLE, DFTAG_IMC, DFTAG_IMCOMP, DFTAG_JPEG + integer DFTAG_GREYJPEG + + parameter(DFTAG_RLE =11, DFTAG_IMC =12) + parameter(DFTAG_IMCOMP =12, DFTAG_JPEG =13) + parameter(DFTAG_GREYJPEG =14) + + ! SPECIAL CODES + + integer SPECIAL_LINKED, SPECIAL_EXT + + parameter(SPECIAL_LINKED = 1, SPECIAL_EXT = 2) + + ! PARAMETERS + + integer DF_MAXFNLEN + integer SD_UNLIMITED + integer SD_DIMVAL_BW_COMP + integer SD_DIMVAL_BW_INCOMP + integer SD_FILL + integer SD_NOFILL + + parameter(DF_MAXFNLEN = 256, SD_UNLIMITED = 0) + parameter(SD_DIMVAL_BW_COMP = 1, SD_DIMVAL_BW_INCOMP = 0) + parameter(SD_FILL = 0, SD_NOFILL = 256) + + integer HDF_VDATA + + parameter(HDF_VDATA = -1) + + ! Standard return codes + integer SUCCEED, FAIL + + parameter(SUCCEED = 0, FAIL = -1) + + + ! Compression Types + + integer COMP_NONE, COMP_RLE, COMP_IMCOMP, COMP_JPEG + + parameter(COMP_NONE = 0, COMP_RLE = 11) + parameter(COMP_IMCOMP = 12, COMP_JPEG = 2) + + ! Interlace Types + + integer MFGR_INTERLACE_PIXEL, MFGR_INTERLACE_LINE + integer MFGR_INTERLACE_COMPONENT + + parameter(MFGR_INTERLACE_PIXEL = 0) + parameter(MFGR_INTERLACE_LINE = 1) + parameter(MFGR_INTERLACE_COMPONENT= 2) + + integer FULL_INTERLACE, NO_INTERLACE + + parameter(FULL_INTERLACE = 0, NO_INTERLACE = 1) + + ! Vdata fields packing types + integer HDF_VSPACK, HDF_VSUNPACK + parameter (HDF_VSPACK = 0, HDF_VSUNPACK = 1) + + ! Multi-file Annotation types + integer AN_DATA_LABEL, AN_DATA_DESC, AN_FILE_LABEL, AN_FILE_DESC + + parameter(AN_DATA_LABEL = 0, AN_DATA_DESC = 1) + parameter(AN_FILE_LABEL = 2, AN_FILE_DESC = 3) + + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !%%% %%% + !%%% Extra parameter settings begin here (bmy, 1/13/06) %%% + !%%% %%% + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Define synonym for FAIL + INTEGER, PARAMETER :: FAILURE = FAIL + + ! Machine-dependent settings +#include "He4Define.h" + + ! KIND parameter for INTEGER*4 or INTEGER*8 (depending on system) +#if defined( NEED_INT_32 ) + INTEGER, PARAMETER :: HE4_INT = KIND( 1e0 ) +#elif defined( NEED_INT_64 ) + INTEGER, PARAMETER :: HE4_INT = KIND( 1d0 ) +#endif + + !----------------------------------------------------------------- + ! NOTE: The size of the following parameters may be changed + ! arbitrarily. You need these to dimension Fortran arrays. + ! (bmy, 1/17/06) + !----------------------------------------------------------------- + + ! Max # of attributes per HDF-EOS file + INTEGER, PARAMETER :: HE4_MAX_ATRS = 100 + + ! Max character string length for HDF-EOS file routines + INTEGER, PARAMETER :: HE4_MAX_CHAR = 1999 + + ! Max # of dimensions per HDF-EOS5 file + INTEGER, PARAMETER :: HE4_MAX_DIMS = 50 + + ! Max # of fields per HDF-EOS5 file + INTEGER, PARAMETER :: HE4_MAX_FLDS = 200 + +END MODULE He4IncludeModule + diff --git a/code/obs_operators/He4SwathModule.f90 b/code/obs_operators/He4SwathModule.f90 new file mode 100644 index 0000000..1139f73 --- /dev/null +++ b/code/obs_operators/He4SwathModule.f90 @@ -0,0 +1,2203 @@ +! $Id: He4SwathModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $ +MODULE He4SwathModule + + !======================================================================== + ! Module He4SwathModule contains routines for reading data from swath + ! data structures in HDF-EOS4 data files. (bmy, 1/17/06, 4/8/08) + ! + ! Module Variables: + ! ----------------------------------------------------------------------- + ! (1 ) VERBOSE (LOGICAL ) : Flag for toggling verbose output + ! (2 ) dataTypeName (CHARACTER) : Array w/ names of HDF-EOS4 data types + ! (3 ) saveFileName (CHARACTER) : Shadow variable for filename + ! (4 ) saveSwathName (CHARACTER) : Shadow variable for swath name + ! + ! Module Routines: + ! ----------------------------------------------------------------------- + ! (1 ) He4VerboseOutput : Toggles verbose output for file I/O + ! (2 ) He4FileOpen : Opens HDF4-EOS file; gets file ID # + ! (3 ) He4FileClose : Closes HDF4-EOS file + ! (4 ) He4SwathAttach : Attaches to swath; gets swath ID # + ! (5 ) He4SwathDetach : Detaches from swath + ! (6 ) He4SwathDimInfo : Gets dimension names, types, sizes + ! (7 ) He4SwathGeoFldInfo : Gets info about swath geoloc fields + ! (8 ) He4SwathDataFldInfo : Gets info about swath data fields + ! (9 ) He4SwathFldInfo : Gets info about an individual field + ! (10) He4SwathFillValue : Gets missing data fill values + ! (11) He4SwathAttrs : Gets attributes from HDF4-EOS swath + ! (11) He4SwathReadAttrChar : Reads CHARACTER attribute from swath + ! (11) He4SwathReadAttrI2 : Reads INTEGER*2 attribute from swath + ! (11) He4SwathReadAttrI4 : Reads INTEGER*4 attribute from swath + ! (11) He4SwathReadAttrR4 : Reads REAL*4 attribute from swath + ! (11) He4SwathReadAttrR8 : Reads REAL*8 attribute from swath + ! (12) He4SwathReadData1dI2 : Reads 1-D INTEGER*2 data array + ! (12) He4SwathReadData1dI4 : Reads 1-D INTEGER*4 data array + ! (12) He4SwathReadData1dR4 : Reads 1-D REAL*4 data array + ! (13) He4SwathReadData1dR8 : Reads 1-D REAL*8 data array + ! (12) He4SwathReadData2dI2 : Reads 2-D INTEGER*2 data array + ! (12) He4SwathReadData2dI4 : Reads 2-D INTEGER*4 data array + ! (14) He4SwathReadData2dR4 : Reads 2-D REAL*4 data array + ! (15) He4SwathReadData2dR8 : Reads 2-D REAL*8 data array + ! (16) He4SwathReadData3dI2 : Reads 3-D INTEGER*2 data array + ! (17) He4SwathReadData3dI4 : Reads 3-D INTEGER*4 data array + ! (18) He4SwathReadData3dR4 : Reads 3-D REAL*4 data array + ! (19) He4SwathReadData3dR8 : Reads 3-D REAL*8 data array + ! (20) He4SwathReadData4dI2 : Reads 3-D INTEGER*2 data array + ! (21) He4SwathReadData4dI4 : Reads 3-D INTEGER*4 data array + ! (22) He4SwathReadData4dR4 : Reads 3-D REAL*4 data array + ! (23) He4SwathReadData4dR8 : Reads 3-D REAL*8 data array + ! (24) makeCharArrayFromCharList : Splits char list into char array + ! (25) He4DataTypeName : Returns data type name from type # + ! + ! Module Interfaces: + ! ----------------------------------------------------------------------- + ! (1 ) He4ReadSwathData -- overloads these routines + ! (a) He4SwathReadData1dI2 + ! (b) He4SwathReadData1dI4 + ! (c) He4SwathReadData1dR4 + ! (d) He4SwathReadData1dR8 + ! (e) He4SwathReadData2dI2 + ! (f) He4SwathReadData2dI4 + ! (g) He4SwathReadData2dR4 + ! (h) He4SwathReadData2dR8 + ! (i) He4SwathReadData3dI2 + ! (j) He4SwathReadData3dI4 + ! (k) He4SwathReadData3dR4 + ! (l) He4SwathReadData3dR8 + ! (m) He4SwathReadData4dI2 + ! (n) He4SwathReadData4dI4 + ! (o) He4SwathReadData4dR4 + ! (p) He4SwathReadData4dR8 + ! + ! (2 ) He4ReadSwathAttr -- overloads these routines + ! (a) He4SwathReadAttrChar + ! (b) He4SwathReadAttrI2 + ! (c) He4SwathReadAttrI4 + ! (d) He4SwathReadAttrR4 + ! (e) He4SwathReadAttrR8 + ! + ! Other Information: + ! ----------------------------------------------------------------------- + ! (1 ) The data type HE4-INTEGER (represented by parameter HE4_INT in + ! He4IncludeModule) is either INTEGER*4 or INTEGER*8 depending + ! on platform. However, most HDF4-EOS applications require + ! INTEGER*4 dimension variables, etc. + ! (2 ) You must select your machine type in the file "He4Define.h". + ! This will automatically set parameter HE4_INT accordingly. + ! (3 ) Data arrays which are passed to the HDF-EOS4 library function + ! SwRdFld must be dimensioned with values of type HE4_INT. + ! (4 ) Created interface for He4SwathReadAttr* functions. This is + ! necessary to read attributes directly from the HDF4-EOS swath + ! data structure. (bmy, 4/8/08) + ! + ! References: + ! ----------------------------------------------------------------------- + ! (1 ) http://hdf.ncsa.uiuc.edu/HDF4/ + ! -- HDF4 home page + ! (2 ) http://newsroom.gsfc.nasa.gov/sdptoolkit/toolkit.html + ! -- ECS toolkit home page (home of HDF-EOS4) + ! + ! NOTES: + ! (1 ) Added routines for 1dI2, IdI4, 2dI2, 2dI4, 3dI2, 3dI4 data types + ! (bmy, 8/20/07) + ! (2 ) Added routines for 4dI2, 4dI4, 4dR4, 4dR8 data types (bmy, 9/20/07) + !======================================================================== + + ! References to F90 modules + USE He4ErrorModule + USE He4IncludeModule + + ! Force explicit data types + IMPLICIT NONE + + !------------------------------------------------------------------------ + ! PRIVATE / PUBLIC DECLARATIONS + !------------------------------------------------------------------------ + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: He4VerboseOutput + PUBLIC :: He4FileOpen + PUBLIC :: He4FileClose + PUBLIC :: He4SwathAttach + PUBLIC :: He4SwathDetach + PUBLIC :: He4SwathDimInfo + PUBLIC :: He4SwathGeoFldInfo + PUBLIC :: He4SwathDataFldInfo + PUBLIC :: He4SwathFldInfo + PUBLIC :: He4SwathFillValue + PUBLIC :: He4SwathAttrs + PUBLIC :: He4SwathReadAttr + PUBLIC :: He4SwathReadData + + !------------------------------------------------------------------------ + ! MODULE VARIABLES + !------------------------------------------------------------------------ + LOGICAL :: VERBOSE = .FALSE. + CHARACTER(LEN=HE4_MAX_CHAR) :: dataTypeName(57) + CHARACTER(LEN=HE4_MAX_CHAR) :: saveFileName + CHARACTER(LEN=HE4_MAX_CHAR) :: saveSwathName + + !------------------------------------------------------------------------ + ! MODULE INTERFACES + !------------------------------------------------------------------------ + INTERFACE He4SwathReadAttr + MODULE PROCEDURE He4SwathReadAttrChar + MODULE PROCEDURE He4SwathReadAttrI2 + MODULE PROCEDURE He4SwathReadAttrI4 + MODULE PROCEDURE He4SwathReadAttrR4 + MODULE PROCEDURE He4SwathReadAttrR8 + END INTERFACE + + INTERFACE He4SwathReadData + MODULE PROCEDURE He4SwathReadData1dI2 + MODULE PROCEDURE He4SwathReadData1dI4 + MODULE PROCEDURE He4SwathReadData1dR4 + MODULE PROCEDURE He4SwathReadData1dR8 + MODULE PROCEDURE He4SwathReadData2dI2 + MODULE PROCEDURE He4SwathReadData2dI4 + MODULE PROCEDURE He4SwathReadData2dR4 + MODULE PROCEDURE He4SwathReadData2dR8 + MODULE PROCEDURE He4SwathReadData3dI2 + MODULE PROCEDURE He4SwathReadData3dI4 + MODULE PROCEDURE He4SwathReadData3dR4 + MODULE PROCEDURE He4SwathReadData3dR8 + MODULE PROCEDURE He4SwathReadData4dI2 + MODULE PROCEDURE He4SwathReadData4dI4 + MODULE PROCEDURE He4SwathReadData4dR4 + MODULE PROCEDURE He4SwathReadData4dR8 + END INTERFACE + +CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE He4VerboseOutput( v ) + + !====================================================================== + ! Subroutine He4VerboseOutput is used to trigger "extra" output from + ! the routines in this module. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) v (LOGICAL) : TRUE or FALSE value + ! + ! NOTES: + !====================================================================== + + ! Arguments + LOGICAL, INTENT(IN) :: v + + ! Set the value of verbose + VERBOSE = v + + END SUBROUTINE He4VerboseOutput + +!------------------------------------------------------------------------------ + + SUBROUTINE He4FileOpen( fileName, fId ) + + !====================================================================== + ! Subroutine He4FileOpen opens an HDF-EOS4 file and returns the + ! file Id number. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) fileName (CHARACTER) : Name of HDF-EOS4 file to open + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (2) fId (INTEGER ) : HDF-EOS4 file ID number + ! + ! NOTES: + !====================================================================== + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: fileName + INTEGER, INTENT(OUT) :: fId + + ! Local variables + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwOpen + + !-------------------------- + ! He4FileOpen begins here! + !-------------------------- + + ! Store filename in a shadow variable + saveFileName = fileName + + ! Open HDF-EOS4 file and get file ID # + fId = SwOpen( fileName, DFACC_RDONLY ) + + ! Error check + IF ( fId == FAILURE ) THEN + msg = 'Error opening file ' // TRIM( saveFileName ) + loc = 'He4FileOpen ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( saveFileName ) + WRITE( 6, 110 ) fId +100 FORMAT( '===> HDF-EOS4 file name : "', a, '"' ) +110 FORMAT( '===> HDF-EOS4 file ID : ', i10 ) + ENDIF + + END SUBROUTINE He4FileOpen + +!------------------------------------------------------------------------------ + + SUBROUTINE He4FileClose( fId ) + + !====================================================================== + ! Subroutine He4FileClose closes an HDF-EOS4 file. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) fId (INTEGER) : HDF-EOS4 file ID number + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: fId + + ! Local variables + INTEGER :: status + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwClose + + !--------------------------- + ! He4FileClose begins here! + !--------------------------- + + ! Get HDF-EOS4 file ID + status = SwClose( fId ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error closing file ' // TRIM( savefileName ) + loc = 'He4FileClose ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( saveFileName ) +100 FORMAT( '===> Closed file "', a, '"' ) + ENDIF + + END SUBROUTINE He4FileClose + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathAttach( fId, swathName, sId ) + + !====================================================================== + ! Subroutine He4SwathAttach attaches to an HDF-EOS4 swath data + ! structure and returns the swath ID number. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) fId (INTEGER) : HDF-EOS4 file ID (see He4FileOpen) + ! (2) swathName (CHARACTER) : Name of HDF-EOS4 swath to attach to + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) sId (INTEGER) : HDF-EOS4 swath ID number + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: fId + CHARACTER(LEN=*), INTENT(IN) :: swathName + INTEGER, INTENT(OUT) :: sId + + ! Local variables + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwAttach + + !----------------------------- + ! He4SwathAttach begins here! + !----------------------------- + + ! Save swathname in a shadow variable + saveSwathName = swathName + + ! Attach to swath + sId = SwAttach( fId, swathName ) + + ! Error check + IF ( sId == FAILURE ) THEN + msg = 'Error attaching to swath ' // TRIM( saveSwathName ) + loc = 'He4SwathAttach ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( saveSwathName ) + WRITE( 6, 110 ) sId +100 FORMAT( '===> HDF-EOS4 swath name: "', a, '"' ) +110 FORMAT( '===> HDF-EOS4 swath ID : ', i10 ) + ENDIF + + END SUBROUTINE He4SwathAttach + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathDetach( sId ) + + !====================================================================== + ! Subroutine He4SwathDetach detaches from an HDF-EOS4 swath + ! data structure. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER) : HDF-EOS4 swath ID number (see He4SwathAttach) + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + + ! Local variables + INTEGER :: status + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwDetach + + !----------------------------- + ! He4SwathDetach begins here! + !----------------------------- + + ! Detach from swath + status = SwDetach( sId ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error detaching from swath ' // TRIM( saveSwathName ) + loc = 'He4SwathDetach ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( saveSwathName ) +100 FORMAT( '===> Detached from swath "', a, '"' ) + ENDIF + + END SUBROUTINE He4SwathDetach + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathDimInfo( sId, nDims, dims, dimNames ) + + !====================================================================== + ! Subroutine He4SwathDetach detaches from an HDF-EOS4 swath + ! data structure. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER) : HDF-EOS4 swath ID number (see He4SwathAttach) + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER, INTENT(OUT) :: nDims + INTEGER, INTENT(OUT) :: dims(HE4_MAX_DIMS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: dimNames(HE4_MAX_DIMS) + + ! Local variables + INTEGER :: N, C + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc, dimList + + ! HDF-EOS4 library routines + INTEGER :: SwInqDims + + !------------------------------ + ! He4SwathDimInfo begins here! + !------------------------------ + + ! Initialize + nDims = 0 + dims(:) = 0 + dimNames(:) = '' + + ! Get dimension info for this swath + nDims = SwInqDims( sId, dimList, dims ) + + ! Make an array from the dimension list + CALL makeCharArrayFromCharList( dimList, ',', dimNames ) + +! Comment out for now (bmy, 8/20/07) +! ! NOTE: Sometimes every other element of DIMS is zero. +! ! I don't know why but we can just pack the array to be +! ! on the safe side. (bmy, 1/17/06) +! C = 0 +! DO N = 1, 2*nDims+1 +! IF ( dims(N) > 0 ) THEN +! C = C + 1 +! dims(C) = dims(N) +! IF ( N > 1 ) dims(N) = 0 +! ENDIF +! ENDDO + + ! Error check + IF ( nDims <= 0 ) THEN + msg = 'Error getting dim info from swath ' // TRIM( saveSwathName ) + loc = 'He4SwathDetach ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) nDims + + DO N = 1, nDims + WRITE( 6, 110 ) TRIM( dimNames(N) ), dims(N) + ENDDO + +100 FORMAT( '===> There are ', i4, ' dimensions' ) +110 FORMAT( '===> ', a25,' is of size ', i10 ) + ENDIF + + END SUBROUTINE He4SwathDimInfo + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathGeoFldInfo( sId, nGeo, geoRank, geoName, geoType ) + + !====================================================================== + ! Subroutine He4SwathGeoFieldInfo obtains information about the + ! geolocation fields in the HDF-EOS4 swath data structure. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (2) nGeo (INTEGER ) : Number of geolocation fields + ! (3) geoRank (INTEGER ) : Number of dimensions for each geoloc field + ! (4) geoName (CHARACTER) : Name of each geolocation field + ! (5) geoType (CHARACTER) : Data type of each geolocation field + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER, INTENT(OUT) :: nGeo + INTEGER, INTENT(OUT) :: geoRank(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: geoName(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: geoType(HE4_MAX_FLDS) + + ! Local variables + INTEGER :: N + INTEGER :: typeNum(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc, geoList + + ! HDF-EOS4 library routines + INTEGER :: SwInqGFlds + + !--------------------------------- + ! He4SwathGeoFldInfo begins here! + !--------------------------------- + + ! Initialize + nGeo = 0 + geoRank(:) = 0 + geoName(:) = '' + geoType(:) = '' + + ! Get number of geo fields and related info + nGeo = SwInqGFlds( sId, geoList, geoRank, typeNum ) + + ! Error check + IF ( nGeo <= 0 ) THEN + msg = 'Error getting geolocation field information!' + loc = 'He4SwathGeoFldInfo ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Separate list of field names into an array + CALL makeCharArrayFromCharList( geoList, ',', geoName ) + + ! Get HDF-EOS4 data type names for each data type number + DO N = 1, nGeo + geoType(N) = He4DataTypeName( typeNum(N) ) + ENDDO + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) nGeo + + DO N = 1, nGeo + WRITE( 6, 110 ) TRIM( geoName(N) ), geoRank(N), TRIM( geoType(N) ) + ENDDO + +100 FORMAT( '===> There are ', i4, ' Geolocation Fields' ) +110 FORMAT( '===> ', a25, ' has ', i4 , ' dimensions and is ', a ) + ENDIF + + END SUBROUTINE He4SwathGeoFldInfo + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathDataFldInfo( sId, nData, dataRank, dataName, dataType ) + + !====================================================================== + ! Subroutine He4SwathDataFieldInfo obtains information about the + ! data fields in the HDF-EOS4 swath data structure. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (2) nData (INTEGER ) : Number of data fields + ! (3) dataRank (INTEGER ) : Number of dimensions for each data field + ! (4) dataName (CHARACTER) : Name of each data field + ! (5) dataType (CHARACTER) : Data type of each data field + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER, INTENT(OUT) :: ndata + INTEGER, INTENT(OUT) :: dataRank(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: dataName(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: dataType(HE4_MAX_FLDS) + + ! Local variables + INTEGER :: N + INTEGER :: typeNum(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc, dataList + + ! HDF-EOS4 library routines + INTEGER :: SwInqDFlds + + !--------------------------------- + ! He4SwathGeoFldInfo begins here! + !--------------------------------- + + ! Initialize + nData = 0 + dataRank(:) = 0 + dataName(:) = '' + dataType(:) = '' + + ! Get number of data fields and related info + nData = SwInqDFlds( sId, dataList, dataRank, typeNum ) + + ! Error check + IF ( nData <= 0 ) THEN + msg = 'Error getting data field information!' + loc = 'He4SwathDataFldInfo ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Separate list of field names into an array + CALL makeCharArrayFromCharList( dataList, ',', dataName ) + + ! Get HDF-EOS4 data type names for each data type number + DO N = 1, nData + dataType(N) = He4DataTypeName( typeNum(N) ) + ENDDO + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) nData + + DO N = 1, nData + WRITE( 6, 110 ) TRIM( dataName(N) ), dataRank(N), TRIM( dataType(N) ) + ENDDO + +100 FORMAT( '===> There are ', i6, ' Data Fields' ) +110 FORMAT( '===> ', a40, ' has ', i4 , ' dimensions and is ', a ) + ENDIF + + END SUBROUTINE He4SwathDataFldInfo + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathFldInfo( sId, name, typeName, rank, dims, dimNames ) + + !====================================================================== + ! Subroutine He4SwathFldInfo obtains information about a particular + ! data field in the HDF-EOS4 swath data structure. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (2) nData (INTEGER ) : Number of data fields + ! (3) typeName (CHARACTER) : Name of the data type for this field + ! (4) rank (INTEGER ) : Number of dimensions for each data field + ! (4) dims (INTEGER ) : Integer containing field dimensions + ! (5) dimNames (CHARACTER) : Array containing names of each dimension + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: name + INTEGER, INTENT(OUT) :: rank + INTEGER, INTENT(OUT) :: dims(HE4_MAX_DIMS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: dimNames(HE4_MAX_DIMS) + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: typeName + + ! Local variables + INTEGER :: C, N, status, typeNum + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc, dimList + + ! HDF-EOS4 library routines + INTEGER :: SwFldInfo + + !------------------------------ + ! He4SwathFldInfo begins here! + !------------------------------ + + ! Initialize + rank = 0 + dims = 0 + dimNames = '' + + ! Get number of data fields and related info + status = SwFldInfo( sId, name, rank, dims, typeNum, dimList ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error getting info about field ' // TRIM( name ) + loc = 'He4SwathFldInfo ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Separate list of dimension names into an array + CALL makeCharArrayFromCharList( dimList, ',', dimNames ) + + ! Get HDF-EOS4 data type name + typeName = He4DataTypeName( typeNum ) + +! Comment out for now (bmy, 8/20/07) +! ! NOTE: Sometimes every other element of DIMS is zero. +! ! I don't know why but we can just pack the array to be +! ! on the safe side. (bmy, 1/17/06) +! C = 0 +! DO N = 1, HE4_MAX_DIMS +! IF ( dims(N) > 0 ) THEN +! C = C + 1 +! dims(C) = dims(N) +! IF ( N > 1 ) dims(N) = 0 +! ENDIF +! ENDDO + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( name ), rank, TRIM( typeName ) + WRITE( 6, 110 ) dims(1:rank) +100 FORMAT( '===> ', a25 ' has ', i4 , ' dimensions and is ', a ) +110 FORMAT( '===> ', 25x,' its dimensions are: ', 10i7 ) + ENDIF + + END SUBROUTINE He4SwathFldInfo + +!------------------------------------------------------------------------------ + + SUBROUTINE He4SwathFillValue( sId, dataName, dataFill ) + + !====================================================================== + ! Subroutine He4SwathFillValue reads the missing data "fill" value + ! for a field contained in the HDF-EOS4 swath data structure. + ! (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID + ! (2) dataName (CHARACTER) : Name of the field to get fill value for + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) dataFill (REAL*4 ) : Fill value for missing data + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(IN) :: dataName + REAL*4, INTENT(OUT) :: dataFill + + ! Local variables + INTEGER :: status + + ! HDF-EOS4 library routines + INTEGER :: SwGetFill + + !-------------------------------- + ! He4SwathFillValue begins here! + !-------------------------------- + + ! Get the fill value + status = SwGetFill( sId, TRIM( dataName ), dataFill ) + + ! Set fill value to zero if it does not exist + IF ( status == FAILURE ) dataFill = 0.0 + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( dataName ), dataFill +100 FORMAT( '===> Fill value for ', a, ' is ', es13.6 ) + ENDIF + + END SUBROUTINE He4SwathFillValue + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathAttrs( sId, nAttrs, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrs returns the global attributes associated + ! with the swath data structure. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (2) nAttrs (INTEGER ) : Number of swath attributes + ! (3) attrName (CHARACTER) : Array of attribute names + ! (4) attrValue (CHARACTER) : Array of attribute values + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER, INTENT(OUT) :: nAttrs + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: attrName(HE4_MAX_ATRS) + REAL*4, INTENT(OUT) :: attrValue(HE4_MAX_ATRS) + + ! Local variables + INTEGER :: N, status, strBufSize + REAL*4 :: value + CHARACTER(LEN=HE4_MAX_CHAR) :: attrList + + ! HDF_EOS5 library routines + INTEGER :: SwInqAttrs + INTEGER :: SwRdAttr + + !---------------------------- + ! He4SwathAttrs begins here! + !---------------------------- + + ! Get list of attribute names + nAttrs = SwInqAttrs( sId, attrList, strBufSize ) + + ! Separate list into array + CALL makeCharArrayFromCharList( attrList, ',', attrName ) + + ! Get the data value for each attribute + ! For each attribute + DO N = 1, nAttrs + status = SwRdAttr( sId, TRIM( attrName(N) ), attrValue ) + ENDDO + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) nAttrs + + DO N = 1, nAttrs + WRITE( 6, 110 ) TRIM( attrName(N) ), attrValue(N) + ENDDO + +100 FORMAT( '===> There are ', i6, ' Swath Attributes' ) +110 FORMAT( '===> ', a20, ' has value ', es13.6 ) + ENDIF + + END SUBROUTINE He4SwathAttrs + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadAttrChar( sId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrChar returns a global attributes of type + ! CHARACTER associated with the swath data structure. (bmy, 4/8/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (CHARACTER) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: attrName + CHARACTER(LEN=*), INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: SwRdAttr + + !----------------------------------- + ! He4SwathReadAttrChar begins here! + !----------------------------------- + + ! Read attribute + status = SwRdAttr( sId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4SwathReadAttrChar + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadAttrI2( sId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrI2 returns a global attributes of type + ! INTEGER*2 associated with the swath data structure. (bmy, 4/8/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: attrName + INTEGER*2, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: SwRdAttr + + !----------------------------------- + ! He4SwathReadAttrI2 begins here! + !----------------------------------- + + ! Read attribute + status = SwRdAttr( sId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4SwathReadAttrI2 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadAttrI4( sId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrI4 returns a global attributes of type + ! INTEGER*4 associated with the swath data structure. (bmy, 4/8/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: attrName + INTEGER, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: SwRdAttr + + !----------------------------------- + ! He4SwathReadAttrI4 begins here! + !----------------------------------- + + ! Read attribute + status = SwRdAttr( sId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4SwathReadAttrI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadAttrR4( sId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrR4 returns a global attributes of type + ! REAL*4 associated with the swath data structure. (bmy, 4/8/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: attrName + REAL*4, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: SwRdAttr + + !----------------------------------- + ! He4SwathReadAttrR4 begins here! + !----------------------------------- + + ! Read attribute + status = SwRdAttr( sId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4SwathReadAttrR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadAttrR8( sId, attrName, attrValue ) + + !====================================================================== + ! Subroutine He4SwathAttrR8 returns a global attributes of type + ! REAL*8 associated with the swath data structure. (bmy, 4/8/08) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1) sId (INTEGER ) : HDF-EOS4 swath ID number + ! (2) attrName (CHARACTER) : Name of attribute to read from file + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (3) attrValue (INTEGER*2) : Value of attribute + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + CHARACTER(LEN=*), INTENT(IN) :: attrName + REAL*8, INTENT(OUT) :: attrValue + + ! Local variables + INTEGER :: status + + ! HDF4-EOS library routines + INTEGER :: SwRdAttr + + !----------------------------------- + ! He4SwathReadAttrR8 begins here! + !----------------------------------- + + ! Read attribute + status = SwRdAttr( sId, TRIM( attrName ), attrValue ) + + END SUBROUTINE He4SwathReadAttrR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData1dI2( sId, fldName, nX, fldData ) + + !====================================================================== + ! Routine He4SwathReadData1dI2 reads a 1-D INTEGER*2 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (4 ) fldData (INTEGER*2 ) : 1-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER*2, INTENT(OUT) :: fldData(nX) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(1), stride(1), edge(1) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData1dI2 begins here! + !----------------------------------- + + ! Set up to read data for a given track + start = (/ 0 /) + stride = (/ 1 /) + edge = (/ nX /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData1dI2 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData1dI2 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData1dI4( sId, fldName, nX, fldData ) + + !====================================================================== + ! Routine He4SwathReadData1dI4 reads a 1-D INTEGER*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (4 ) fldData (REAL*4 ) : 1-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER, INTENT(OUT) :: fldData(nX) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(1), stride(1), edge(1) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData1dI4 begins here! + !----------------------------------- + + ! Set up to read data for a given track + start = (/ 0 /) + stride = (/ 1 /) + edge = (/ nX /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData1dI4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData1dI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData1dR4( sId, fldName, nX, fldData ) + + !====================================================================== + ! Routine He4SwathReadData1dR4 reads a 1-D REAL*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (4 ) fldData (REAL*4 ) : 1-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: fldData(nX) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(1), stride(1), edge(1) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData1dR4 begins here! + !----------------------------------- + + ! Set up to read data for a given track + start = (/ 0 /) + stride = (/ 1 /) + edge = (/ nX /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData1dR4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData1dR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData1dR8( sId, fldName, nX, fldData ) + + !====================================================================== + ! Routine He4SwathReadData1dR8 reads a 1-D REAL*8 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (4 ) fldData (REAL*8 ) : 1-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*8, INTENT(INOUT) :: fldData(nX) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(1), stride(1), edge(1) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData1dR8 begins here! + !----------------------------------- + + ! Set up dimension info + start = (/ 0 /) + stride = (/ 1 /) + edge = (/ nX /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData1dR8 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData1dR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData2dI2( sId, fldName, nX, nY, fldData ) + + !====================================================================== + ! Routine He4SwathReadData2dI2 reads a 2-D INTEGER*2 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (5 ) fldData (INTEGER*2 ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER*2, INTENT(OUT) :: fldData(nX,nY) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(2), stride(2), edge(2) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData2dI2 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0 /) + stride = (/ 1, 1 /) + edge = (/ nX, nY /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData2dI2 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData2dI2 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData2dI4( sId, fldName, nX, nY, fldData ) + + !====================================================================== + ! Routine He4SwathReadData2dI4 reads a 2-D INTEGER*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (5 ) fldData (INTEGER ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER, INTENT(OUT) :: fldData(nX,nY) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(2), stride(2), edge(2) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData2dI4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0 /) + stride = (/ 1, 1 /) + edge = (/ nX, nY /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData2dI4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData2dI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData2dR4( sId, fldName, nX, nY, fldData ) + + !====================================================================== + ! Routine He4SwathReadData2dR4 reads a 2-D REAL*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (5 ) fldData (REAL*4 ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: fldData(nX,nY) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(2), stride(2), edge(2) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData2dR4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0 /) + stride = (/ 1, 1 /) + edge = (/ nX, nY /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData2dR4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData2dR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData2dR8( sId, fldName, nX, nY, fldData ) + + !====================================================================== + ! Routine He4SwathReadData2dR8 reads a 2-D REAL*8 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (5 ) fldData (REAL*8 ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*8, INTENT(OUT) :: fldData(nX,nY) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(2), stride(2), count(2) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData2dR8 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0 /) + stride = (/ 1, 1 /) + count = (/ nX, nY /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, count, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData2dR8 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData2dR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData3dI2( sId, fldName, nX, nY, nZ, fldData ) + + !====================================================================== + ! Routine He4SwathReadData3dI2 reads a 3-D INTEGER*2 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 3rd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (6 ) fldData (INTEGER*2 ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER*2, INTENT(OUT) :: fldData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(3), stride(3), edge(3) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData3I2 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0 /) + stride = (/ 1, 1, 1 /) + edge = (/ nX, nY, nZ /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData3dI2 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData3dI2 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData3dI4( sId, fldName, nX, nY, nZ, fldData ) + + !====================================================================== + ! Routine He4SwathReadData3dI4 reads a 3-D INTEGER*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 8/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (6 ) fldData (INTEGER ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER, INTENT(OUT) :: fldData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(3), stride(3), edge(3) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData3dI4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0 /) + stride = (/ 1, 1, 1 /) + edge = (/ nX, nY, nZ /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData3dI4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData3dI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData3dR4( sId, fldName, nX, nY, nZ, fldData ) + + !====================================================================== + ! Routine He4SwathReadData3dR4 reads a 3-D REAL*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 2nd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (6 ) fldData (REAL*4 ) : 2-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: fldData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(3), stride(3), edge(3) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData3dR4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0 /) + stride = (/ 1, 1, 1 /) + edge = (/ nX, nY, nZ /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData3dR4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData3dR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData3dR8( sId, fldName, nX, nY, nZ, fldData ) + + !====================================================================== + ! Routine He4SwathReadData3dR8 reads a 3-D REAL*8 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 3rd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (6 ) fldData (REAL*8 ) : 3-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*8, INTENT(OUT) :: fldData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(3), stride(3), edge(3) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData3dR8 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0 /) + stride = (/ 1, 1, 1 /) + edge = (/ nX, nY, nZ /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData3dR8 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData3dR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData4dI2( sId, fldName, nX, nY, nZ, nW, fldData ) + + !====================================================================== + ! Routine He4SwathReadData4dI2 reads a 4-D INTEGER*2 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 9/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 3rd dimension of data array + ! (6 ) nW (HE4-INTEGER) : 4th dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (7 ) fldData (INTEGER*2 ) : 4-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ, nW + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER*2, INTENT(OUT) :: fldData(nX,nY,nZ,nW) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(4), stride(4), edge(4) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData4dI2 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0, 0 /) + stride = (/ 1, 1, 1, 1 /) + edge = (/ nX, nY, nZ, nW /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData4dI2 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData4dI2 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData4dI4( sId, fldName, nX, nY, nZ, nW, fldData ) + + !====================================================================== + ! Routine He4SwathReadData4dI4 reads a 4-D INTEGER*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 9/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 2nd dimension of data array + ! (6 ) nW (HE4-INTEGER) : 4th dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (7 ) fldData (INTEGER ) : 4-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ, nW + CHARACTER(LEN=*), INTENT(IN) :: fldName + INTEGER, INTENT(OUT) :: fldData(nX,nY,nZ,nW) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(4), stride(4), edge(4) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData4dI4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0, 0 /) + stride = (/ 1, 1, 1, 0 /) + edge = (/ nX, nY, nZ, nW /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData4dI4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData4dI4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData4dR4( sId, fldName, nX, nY, nZ, nW, fldData ) + + !====================================================================== + ! Routine He4SwathReadData4dR4 reads a 4-D REAL*4 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 9/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 3rd dimension of data array + ! (6 ) nW (HE4-INTEGER) : 4th dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (7 ) fldData (REAL*4 ) : 4-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ, nW + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*4, INTENT(OUT) :: fldData(nX,nY,nZ,nW) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(4), stride(4), edge(4) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData4dR4 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0, 0 /) + stride = (/ 1, 1, 1, 1 /) + edge = (/ nX, nY, nZ, nW /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData4dR4 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData4dR4 + +!----------------------------------------------------------------------------- + + SUBROUTINE He4SwathReadData4dR8( sId, fldName, nX, nY, nZ, nW, fldData ) + + !====================================================================== + ! Routine He4SwathReadData4dR8 reads a 4-D REAL*8 data block from + ! an HDF-EOS4 swath data structure. This routine is included in the + ! module interface He4SwathReadData. (bmy, 9/20/07) + ! + ! Arguments as Input: + ! --------------------------------------------------------------------- + ! (1 ) sId (INTEGER ) : HDF-EOS4 Swath ID # + ! (2 ) fldName (CHARACTER ) : Name of data array + ! (3 ) nX (HE4-INTEGER) : 1st dimension of data array + ! (4 ) nY (HE4-INTEGER) : 2nd dimension of data array + ! (5 ) nZ (HE4-INTEGER) : 3rd dimension of data array + ! (6 ) nW (HE4-INTEGER) : 3rd dimension of data array + ! + ! Arguments as Output: + ! --------------------------------------------------------------------- + ! (7 ) fldData (REAL*8 ) : 3-D array w/ data from HDF-EOS4 file + ! + ! NOTES: + !====================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: sId + INTEGER(HE4_INT), INTENT(IN) :: nX, nY, nZ, nW + CHARACTER(LEN=*), INTENT(IN) :: fldName + REAL*8, INTENT(OUT) :: fldData(nX,nY,nZ) + + ! Local variables + INTEGER :: status + INTEGER(HE4_INT) :: start(4), stride(4), edge(4) + CHARACTER(LEN=HE4_MAX_CHAR) :: msg, loc + + ! HDF-EOS4 library routines + INTEGER :: SwRdFld + + !----------------------------------- + ! He4SwathReadData4dR8 begins here! + !----------------------------------- + + ! Set up to read entire field + start = (/ 0, 0, 0, 0 /) + stride = (/ 1, 1, 1, 1 /) + edge = (/ nX, nY, nZ, nW /) + + ! Read data + status = SwRdFld( sId, fldName, start, stride, edge, fldData ) + + ! Error check + IF ( status == FAILURE ) THEN + msg = 'Error reading data for ' // TRIM( fldName ) + loc = 'HdfSwathReadData4dR8 ("He4SwathModule.f90")' + CALL He4ErrMsg( msg, loc ) + ENDIF + + ! Verbose output + IF ( VERBOSE ) THEN + WRITE( 6, 100 ) TRIM( fldName ) +100 FORMAT( '===> Successfully read data for ', a ) + ENDIF + + END SUBROUTINE He4SwathReadData4dR8 + +!----------------------------------------------------------------------------- + + SUBROUTINE makeCharArrayFromCharList( list, separator, array ) + + !===================================================================== + ! Subroutine makeCharArrayFromCharList takes a comma-separated word + ! list, and places each word into a separate element of a character + ! array. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) list (CHARACTER) : String with comma-separated words + ! (2) separator (CHARACTER) : String for separator text + ! + ! Arguments as output: + ! -------------------------------------------------------------------- + ! (3) array (CHARACTER) : Array of substrings + ! + ! NOTES: + !===================================================================== + + ! Arguments + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(IN) :: list + CHARACTER(LEN=1 ), INTENT(IN) :: separator + CHARACTER(LEN=HE4_MAX_CHAR), INTENT(OUT) :: array(:) + + ! local variables + INTEGER :: P, N, ind(255) + CHARACTER(LEN=1) :: C + + !---------------------------------------- + ! makeCharArrayFromCharList begins here! + !---------------------------------------- + + ! Initialize + N = 1 + ind(:) = 0 + + ! Find the positions of all the commas in LIST + DO P = 1, LEN( list ) + + ! Look at each character individually + C = list(P:P) + + ! If a comma... + IF ( C == separator ) THEN + + ! Increment comma + N = N + 1 + ind(N) = P + ENDIF + ENDDO + + ! Add the position of the end of the string into IND + ind(N+1) = LEN( list ) + + ! Save text between the commas into ARRAY + DO P = 1, N + IF ( P == N ) THEN + array(P) = list( ind(P)+1:ind(P+1) ) + ELSE + array(P) = list( ind(P)+1:ind(P+1)-1 ) + ENDIF + ENDDO + + END SUBROUTINE makeCharArrayFromCharList + +!------------------------------------------------------------------------------ + + FUNCTION He4DataTypeName( nType ) RESULT( typeStr ) + + !===================================================================== + ! Subroutine He4DataTypeName returns a descriptive string given a + ! HDF-EOS4 data type number. (bmy, 1/17/06) + ! + ! Arguments as Input: + ! -------------------------------------------------------------------- + ! (1) nType (INTEGER) : HDF-EOS number type + ! + ! NOTES: + !===================================================================== + + ! Arguments + INTEGER, INTENT(IN) :: nType + + ! Local varaibles + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=HE4_MAX_CHAR) :: typeStr + + !------------------------------ + ! He4DataTypeName begins here! + !------------------------------ + + ! First-time initialization + IF ( FIRST ) THEN + dataTypeName(:) = '' + dataTypeName(DFNT_INT16 ) = 'INTEGER*2' + dataTypeName(DFNT_UINT16 ) = 'Unsigned INTEGER*2' + dataTypeName(DFNT_INT32 ) = 'INTEGER*4' + dataTypeName(DFNT_UINT32 ) = 'Unsigned INTEGER*4' + dataTypeName(DFNT_INT64 ) = 'INTEGER*8' + dataTypeName(DFNT_UINT64 ) = 'Unsigned INTEGER*8' + dataTypeName(DFNT_FLOAT32 ) = 'REAL*4' + dataTypeName(DFNT_FLOAT64 ) = 'REAL*8' + dataTypeName(DFNT_FLOAT128) = 'REAL*16' + !dataTypeName(56 ) = 'LOGICAL' + !dataTypeName(67 ) = 'LOGICAL' + dataTypeName(DFNT_CHAR ) = 'CHARACTER' + dataTypeName(DFNT_CHAR16 ) = 'CHARACTER' + dataTypeName(DFNT_UCHAR16 ) = 'CHARACTER' + ENDIF + + ! Return value + typeStr = dataTypeName(nType) + + END FUNCTION He4DataTypeName + +!------------------------------------------------------------------------------ + +END MODULE He4SwathModule + + + + + + + + + diff --git a/code/obs_operators/airs_co_obs_mod.f b/code/obs_operators/airs_co_obs_mod.f new file mode 100644 index 0000000..37613d8 --- /dev/null +++ b/code/obs_operators/airs_co_obs_mod.f @@ -0,0 +1,1794 @@ +! $Id: airs_co_obs_mod.f,v 1.3 2012/03/01 22:00:27 daven Exp $ + MODULE AIRS_CO_OBS_MOD + +!****************************************************************************** +! Module AIRS_CO_OBS_MOD contains subroutines necessary to +! 1. Transform CHK_STT into AIRS space +! 2. Compute AIRS-GEOS-Chem difference, cost function and adj forcing +! 3. Transform the difference between model and AIRS back to model space +! using the adjoint of averaging kernel and interpolation code. +! +! Module Variables: +! ============================================================================ +! (1 ) COUNT_GRID : number of observations in one GC gridbox +! (2 ) invtest : array showing if observation was invertible +! (3 ) ModelPS : model surface pressure array +! (2 ) +! Module Routines: +! ============================================================================ +! (1 ) READ_AIRS_CO_FILES : Reas AIRS hdf file +! (2 ) ITS_TIME_FOR_AIRS_CO_OBS: FUNCTION that checks time vs. OBS_HOUR array +! (3 ) AIRS_FWD : Driver for fwd obs operator +! (4 ) ADJ_AIRS : Computes the adjoint of observation operator +! (5 ) READ_ERROR_VARIANCE: Reads error variance file +! (6 ) CALC_AIRS_CO_FORCE : Calculates cost function and STT_ADJ increments +! (7 ) CALC_OBS_HOUR : Calculated hour of morning obs +! +! ============================================================================ +! NOTES: +! (1 ) Filter on AIRS data: morning over pass only (in airs_mod.f) and +! only use obs that are greater than 5e17 (mak, 6/07/08) +! (2 ) Remove invtest array from the module variables, since it was only +! needed when gridding was done separately from computing the column +! (mak, 6/12/08) +! (3 ) Add adjoint code (mak, 6/17/08) +! (4 ) Update to v8 adjoint (6/20/09) +! +!****************************************************************************** + + IMPLICIT NONE + + ! Everything PRIVATE unless specified otherwise + ! PRIVATE module variables + ! PRIVATE module routines + PRIVATE + + PUBLIC :: READ_AIRS_CO_FILES, ITS_TIME_FOR_AIRS_CO_OBS + PUBLIC :: CALC_AIRS_CO_FORCE, OBS_HOUR_AIRS_CO + + REAL*4, ALLOCATABLE :: ERR_PERCENT(:,:) + INTEGER, ALLOCATABLE :: OBS_HOUR_AIRS_CO(:,:) + REAL*8, ALLOCATABLE :: AIRS_COL_GRID(:,:) + REAL*8, ALLOCATABLE :: AIRSDOF_COL_GRID(:,:) + REAL*8, ALLOCATABLE :: CHK_STT_AIRS(:,:) + REAL*8, ALLOCATABLE :: COUNT_GRID(:,:) + !INTEGER, ALLOCATABLE :: invtest(:) + REAL*4, ALLOCATABLE :: ModelPS(:,:) + REAL*4, ALLOCATABLE :: FRACTION(:,:,:,:) + REAL*8, ALLOCATABLE :: ADJ_AIRS_ALL(:,:,:) + + CONTAINS + + SUBROUTINE READ_AIRS_CO_FILES( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_AIRS_CO_FILES reads the AIRS hdf file and assigns OBS_HOUR +! array based on available data. AIRS data are stored in a 1 day/file +! frequency. (mak, 7/12/07, 6/08/08) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE AIRSv5_MOD + USE TIME_MOD, ONLY : EXPAND_DATE + USE FILE_MOD, ONLY : IOERROR + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=255) :: DIR_AIRS + CHARACTER(LEN=255) :: FILENAME_IN + CHARACTER(LEN=255) :: file + CHARACTER(LEN= 8) :: YYYYMMDDs + INTEGER :: IU_FILE, IOS, IOS1, I, as + + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! READ_AIRS_CO_FILES begins here! + !================================================================= + + CALL CLEANUP_AIRS + + ! Set date and corresponding input AIRS filename + DIR_AIRS = '/lustre/data/obs/airs/YYYY/MM/YYYYMMDD/' + !DIR_AIRS = '/san/as04/home/ctm/mak/AIRS/data_airs/' + !DIR_AIRS = '/as/data-rw/corrections/as/data/airs/' + FILENAME_IN='input.txt' + + CALL EXPAND_DATE( DIR_AIRS, YYYYMMDD, 0 ) + + print*, 'dir_airs is:', trim(dir_airs) + + ! mak debug: use just 20 files + CALL SYSTEM('ls '//trim(DIR_AIRS)//' > input.txt') + + IU_FILE=15 + OPEN( IU_FILE, FILE=FILENAME_IN, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'airs:1' ) + + ! zero counters + Nfiles = 0 + + ! Figure out how many files to read (#lines in the file): + CALL SYSTEM('wc -l '//trim(FILENAME_IN)//' > tmp.txt') + + OPEN( 5, FILE='tmp.txt', IOSTAT=IOS1 ) + IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:1' ) + + ! Read #lines + READ( 5, *, IOSTAT=IOS1 ) NFiles + IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:2' ) + + ! Close file + CLOSE( 5 ) + + ALLOCATE( iNObs (NFiles) ) + + ALLOCATE( FILENAME(NFiles) ) + DO i = 1, NFiles + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'airs:2' ) + + READ( IU_FILE,'(a)',IOSTAT=IOS) file + + IF (i .eq. 1) + & YYYYMMDDs = file(6:9)//file(11:12)//file(14:15) + + ! on ceres: + FILENAME(i)=trim(DIR_AIRS)//trim(file) + ! on prometheus and tethys: + !FILENAME(i)=trim(file) + print*, 'filename:', trim(filename(i)) + + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + !READ (YYYYMMDDs,*) YYYYMMDD + + PRINT*,'Date: ',YYYYMMDD + + IF(FIRST) THEN + ALLOCATE( OBS_HOUR_AIRS_CO( IIPAR, JJPAR ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'OBS_HOUR_AIRS_CO' ) + ALLOCATE( ERR_PERCENT( IIPAR, JJPAR ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'ERR_PERCENT' ) + !ALLOCATE( ADJ_FACTOR( IIPAR, JJPAR, LLPAR), stat=as ) + !IF ( as /= 0 ) CALL ALLOC_ERR( 'ADJ_FACTOR' ) + ALLOCATE( AIRS_COL_GRID( IIPAR, JJPAR ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AIRS_COL_GRID' ) + ALLOCATE( AIRSDOF_COL_GRID( IIPAR, JJPAR ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AIRSDOF_COL_GRID' ) + ALLOCATE( CHK_STT_AIRS( IIPAR, JJPAR ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CHK_STT_AIRS' ) + ALLOCATE ( COUNT_GRID(IIPAR, JJPAR), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'COUNT_GRID' ) + ALLOCATE( ModelPS(IIPAR,JJPAR) ,stat = as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'ModelPs' ) + ALLOCATE( FRACTION(IIPAR,JJPAR,LLPAR,NLevs), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'FRACTION' ) + ALLOCATE( ADJ_AIRS_ALL(IIPAR,JJPAR,LLPAR), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'ADJ_AIRS_ALL' ) + + FIRST = .FALSE. + ENDIF + + ! initialize some arrays, the rest is initialized before + ! relevant calculations, every hour when we have obs + + ! Get dimensions of the arrays, allocate arrays, and read AIRS file + CALL INIT_READ_AIRS + + ! Calculate hour of day when obs should be compared to model + CALL CALC_OBS_HOUR + + + END SUBROUTINE READ_AIRS_CO_FILES + +!-------------------------------------------------------------------------- + + SUBROUTINE CALC_OBS_HOUR + +!*************************************************************************** +! Subroutine CALC_OBS_HOUR computes an array of hours for each day of obs. +! If there is an obs in a particular gridbox on that day, it assigns the +! hour (0..23). If there isn't, OBS_HOUR stays initialized to -1. +! (mak, 12/14/05, 6/10/08) +!*************************************************************************** + +! USE ERROR_MOD, ONLY : ALLOC_ERR + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, + & GET_YEAR, GET_HOUR + USE AIRSV5_MOD + +# include "CMN_SIZE" + + REAL*8 :: tau0 + INTEGER :: W, I, J + INTEGER :: ilon, ilat + REAL*4 :: OBS_HOURr(IIPAR,JJPAR) + integer :: count + REAL*8 :: AirsGMT, lon15 + + ! Get TAU0 from the date (at 0GMT) + tau0 = GET_TAU0(GET_MONTH(), GET_DAY(), GET_YEAR()) + + OBS_HOUR_AIRS_CO(:,:) = -1 + OBS_HOURr(:,:) = 0 + COUNT_GRID(:,:) = 0d0 + count = 0 + + DO W = 1, Nobss + + !============================================================ + !Only consider day time AIRS measurements + ! am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) + !============================================================== + IF ( (qual(W) .eq. 0) .AND. (NTraps(W) .gt. 1) .AND. + & (DNFlag(W) .eq. 'Day') .AND. + & (Tsurf(W) .ge. 250) ) THEN + + + ! Compute local time: + ! Local Time = GMT + ( longitude / 15 ) since each hour of time + ! corresponds to 15 degrees of longitude on the globe + ! so + ! GMT = local time - (longitude/15) + !============================================================ + lon15 = longitude(w)/15. + AirsGMT = hour(w)- lon15 + if (AirsGMT .lt. 0.) AirsGMT = AirsGMT + 24 + if (AirsGMT .gt. 24.) AirsGMT = AirsGMT - 24 + + !================================================================= + ! COMPUTE LONGITUDE AND LATITUDE + !================================================================= + ! Look for model grid box corresponding to the MOPITT observation: + ! Get I corresponding to PLON(IND) + ILON = INT( ( Longitude(W) + 180d0 ) / DISIZE + 1.5d0 ) + ! Handle date line correctly (bmy, 4/23/04) + IF ( ILON > IIPAR ) ILON = ILON - IIPAR + ! Get J corresponding to PLAT(IND) + ILAT = INT( ( Latitude(W) + 90d0 ) / DJSIZE + 1.5d0 ) + if ( (ilon .eq. -999) .or. (ilat .eq. -999) ) then + print*,'ilon,ilat=',ilon,ilat + print*,'STOP' + stop + endif + + ! If there's an obs, calculate the time + IF ( (COcol(W) .gt. 0.) .and. + & (qual(W) .eq. 0) .AND. (NTraps(W) .gt. 1) .AND. + & (DNFlag(W) .eq. 'Day') .AND. + & (Tsurf(W) .ge. 250) )THEN + + COUNT_GRID(ILON,ILAT) = COUNT_GRID(ILON,ILAT) + 1. + !Add the time of obs, to be averaged and floored later + OBS_HOURr(ILON,ILAT) = OBS_HOURr(ILON,ILAT) + & + AirsGMT +! print*, 'obs hour in:', ilon, ilat, 'is:', obs_hour(ilon,ilat) + ENDIF + ENDIF !morning overpass + ENDDO + + ! average obs_hour on the grid + DO J = 1, jjPAR + DO I = 1, IIPAR + IF ( COUNT_GRID(I,J) .gt. 0. ) then + OBS_HOUR_AIRS_CO(I,J) = FLOOR(OBS_HOURr(I,J)/COUNT_GRID(I,J)) + + count = count + 1 + ENDIF + ENDDO + ENDDO + + print*, 'today we have (globally)',count,'AIRS observations.' + + END SUBROUTINE CALC_OBS_HOUR + +!------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_AIRS_CO_OBS( ) RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_AIRS_CO_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day) based on +! the OBS_HOUR_AIRS_CO array which holds the hour of obs in each gridbox +! (computed when file read in airsv5_mod.f90) (mak, 6/09/08) +! +! NOTES: +! ( 1) Also like corresponding MOPITT code +! +!****************************************************************************** +! + + USE TIME_MOD, ONLY : GET_HOUR, GET_MINUTE + +# include "CMN_SIZE" ! Size params + + ! Function value + LOGICAL :: FLAG + + INTEGER :: I,J + + !================================================================= + ! ITS_TIME_FOR_AIRS_CO_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO J = 1,JJPAR + DO I = 1,IIPAR + IF(GET_HOUR() == OBS_HOUR_AIRS_CO(I,J) + & .AND. GET_MINUTE() == 0) THEN + !print*, 'obs_hour was', get_hour(), 'in box', i, j + FLAG = .TRUE. + GOTO 11 + ENDIF + ENDDO + ENDDO + + 11 CONTINUE + END FUNCTION ITS_TIME_FOR_AIRS_CO_OBS + +!--------------------------------------------------------------------------- + + SUBROUTINE CALC_AIRS_CO_FORCE + + ! References to F90 modules + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE AIRSV5_MOD, ONLY : DOMAIN_OBS + USE TIME_MOD, ONLY : GET_HOUR, GET_NYMDe, GET_NHMSe, + & GET_MONTH + USE ADJ_ARRAYS_MOD, ONLY : SET_FORCING, SET_MOP_MOD_DIFF, + & SET_MODEL_BIAS, SET_MODEL, SET_OBS, + & GET_FORCING, COST_ARRAY, OBS_COUNT, + & SET_DOFS, IFD, JFD, LFD, NFD, COST_FUNC, + & NOBS, DAY_OF_SIM, ADJ_FORCE, STT_ADJ + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + + +# include "CMN_SIZE" ! Size parameters + + ! Internal variables + REAL*8 :: DIFF + REAL*8 :: DIFF_COST + REAL*8 :: DIFF_ADJ(LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR,NOBS) !column cost + INTEGER :: I, J, L, N, LL + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D15 + REAL*8 :: MAX_ADJ_TMP + REAL*4 :: invSy(IIPAR,JJPAR) !error variance for column + LOGICAL, SAVE :: FIRST= .TRUE. + REAL*8 :: Sy + INTEGER, SAVE :: LASTMONTH = -999 + + !================================================================ + ! CALC_MOPITT_FORCE begins here! + !================================================================ + + !initialize: + CHK_STT_AIRS(:,:) = 0d0 + AIRS_COL_GRID(:,:) = 0d0 + AIRSDOF_COL_GRID(:,:) = 0d0 + invSy(:,:) = 0d0 + NEW_COST(:,:,:) = 0d0 + + ! column AIRS data is in COTotalColumn + CALL AIRS_COMPUTE_COLUMN + + ! Read in the matrix with mean % variance to compute + ! 1/(ymod*%)^2=invSy + IF(GET_MONTH() .ne. LASTMONTH)THEN + ! using seasonal errors, but read file once month for simplicity + ! better than reading the file every time step (mak, 1/27/08) + print*, 'read error variance matrix' + CALL READ_ERROR_VARIANCE + LASTMONTH = GET_MONTH() + ENDIF + + print*, 'max AIRS value is:', maxval(AIRS_COL_GRID) + print*, 'min AIRS value is:', minval(AIRS_COL_GRID) + print*, 'max model value is:',maxval(CHK_STT_AIRS) + print*, 'min model value is:',minval(CHK_STT_AIRS) + !print*, 'max err value is:', maxval(ERR_PERCENT(:,:)) + !print*, 'min err value is:', minval(ERR_PERCENT) + + ! CHK_STT_AIRS in molec/cm2, OBS_STT in molec/cm2 + !print*, 'before loop: domain_obs is', sum(domain_obs)/30 + !print*, 'before loop, count is:', count + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, Sy) + DO J= 1,JJPAR + DO I= 1,IIPAR + + IF ((AIRS_COL_GRID(I,J) .gt. 0) .AND. + & (OBS_HOUR_AIRS_CO(I,J) .eq. GET_HOUR()).AND. + & (DOMAIN_OBS(I,J) .eq. 1) ) THEN + + Sy = ERR_PERCENT(I,J)**2 * + & AIRS_COL_GRID(I,J)**2 + invSy(I,J) = 1/Sy + + OBS_COUNT(I,J) = OBS_COUNT(I,J) + 1 + + IF ( invSy(i,j) .ge. 1 ) THEN + CALL ERROR_STOP('invSy is too big', 'airsitt_obs_mod.f') + ENDIF + ELSE + + DOMAIN_OBS(I,J)=0 + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + print*,'AIRS obs used this hour', sum(domain_obs)/30 + PRINT*, 'OBS_COUNT TOTAL:', SUM(OBS_COUNT) + print*, 'min/max of invSy:', minval(invSy), maxval(invSy) + + DO N = 1, NOBS +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J) +!!$OMP+PRIVATE( DIFF_COST ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( (AIRS_COL_GRID(I,J) .GT. 1e15) .and. + & (GET_HOUR() .EQ. OBS_HOUR_AIRS_CO(I,J)) .and. + & (DOMAIN_OBS(I,J) .eq. 1))then! .and. +! & (CHK_STT_AIRS(I,J) .GT. 0) )THEN + + + ! Determine the contribution to the cost function in each grid cell + ! from each species + DIFF_COST = ( CHK_STT_AIRS(I,J) - AIRS_COL_GRID(I,J) ) + + ! Calculate new additions to cost function + ! include all regions for which there are obs + ! NOTE: a bit of a mismatch in domain_obs in vertical + NEW_COST(I,J,N) = DOMAIN_OBS(I,J) * + ! Update to be consistent with merged APCOST routine (dkh, 01/18/12, adj32_017) + ! (DIFF_COST ** 2) * invSy(I,J) + & 0.5d0 * (DIFF_COST ** 2) * invSy(I,J) + + ! Diagnostic stuff: FORCING, MOP_MOD_DIFF, MODEL_BIAS +! CALL SET_FORCING(I,J,DAY_OF_SIM,NEW_COST(I,J,N)) +! FORCING(I,J,DAY_OQF_SIM) = FORCING(I,J,DAY_OF_SIM) +! & + NEW_COST(I,J,L,N) + + if((DOMAIN_OBS(I,J) .eq. 1) )then + CALL SET_MODEL_BIAS(I,J,DAY_OF_SIM,3,DIFF_COST/AIRS_COL_GRID(I,J)) + CALL SET_MODEL(I,J,DAY_OF_SIM,3,CHK_STT_AIRS(I,J)) + CALL SET_OBS(I,J,DAY_OF_SIM,3, AIRS_COL_GRID(I,J)) + CALL SET_DOFS(I,J,DAY_OF_SIM,3, AIRSDOF_COL_GRID(I,J)) + endif + + ! update cost array + COST_ARRAY(I,J,DAY_OF_SIM) = COST_ARRAY(I,J,DAY_OF_SIM) + + & NEW_COST(I,J,1) + + ! Check for errors +!!$OMP CRITICAL + IF ( IT_IS_NAN( NEW_COST(I,J,N) ) ) THEN + WRITE(6,*) ' Bad NEW_COST in ', I, J, L, N, + & ' from OBS, CHK, DOMAIN_OBS = ', + & AIRS_COL_GRID(I,J), CHK_STT_AIRS(I,J), + & DOMAIN_OBS(I,J), DIFF_COST, invSy(i,j) + + CALL ERROR_STOP('NEW_COST is NaN', 'adjoint_mod.f') + ENDIF +!!$OMP END CRITICAL + + !LOOP over all 30 levels + DO LL=1,LLPAR + + ! Force the adjoint variables x with dJ/dx + ! Update to be consistent with merged APCOST routine (dkh, 01/18/12, adj32_017) + !ADJ_FORCE(I,J,LL,N) = 2.0D0 * DOMAIN_OBS(I,J) + ADJ_FORCE(I,J,LL,N) = DOMAIN_OBS(I,J) + & * DIFF_COST * invSy(I,J) * ADJ_AIRS_ALL(I,J,LL) +! & * 1.0 * 1.0 + + ! Update STT_ADJ + IF ( N <= N_TRACERS ) THEN + STT_ADJ(I,J,LL,N) = STT_ADJ(I,J,LL,N) + ADJ_FORCE(I,J,LL,N) + !PRINT*, 'ADJ_FORCE,I,J,L:', I,J,LL,ADJ_FORCE(I,J,LL,N) + !print*, 'ADJ_AIRS_ALL:', ADJ_AIRS_ALL(I,J,LL) + ENDIF + ENDDO + + IF(I == IFD .AND. J == JFD) THEN + !PRINT*, 'CHK_STT:', CHK_STT(I,J,:,N) + PRINT*, 'N = ', N + PRINT*, 'CHK_STT_AIRS:', CHK_STT_AIRS(I,J) + PRINT*, 'OBS_STT:', AIRS_COL_GRID(I,J) + PRINT*, 'NEW_COST', NEW_COST(I,J,N) + PRINT*, 'DIFF_COST', DIFF_COST + PRINT*, 'DOMAIN_OBS', DOMAIN_OBS(I,J) + PRINT*, 'ADJ_FORCE:', ADJ_FORCE(I,J,:,N) + PRINT*, 'STT_ADJ:', STT_ADJ(I,J,:,N) + ENDIF + + + ENDIF + ENDDO + ENDDO +!!$OMP END PARALLEL DO + ENDDO + + !have to zero the NEW_COST that is above 7th layer + !NEW_COST(:,:,NLEV+1:LLPAR,:)=0d0 + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + ! Update cost array, uncomment if L=1,LFDSIZE +c$$$ DO L = 1, LFDSIZE +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ ! COST_ARRAY +c$$$! COST_ARRAY(I,J,DAY_OF_SIM) = COST_ARRAY(I,J,DAY_OF_SIM) + +c$$$! & NEW_COST(I,J,1,1) +c$$$ COST_ARRAY(I,J,L) = COST_ARRAY(I,J,L) + +c$$$ & NEW_COST(I,J,L,1) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO + + + ! Update cost function + !PRINT*, 'NEW_COST(FD)=', NEW_COST(IFD,JFD,LFD,NFD) + PRINT*, 'TOTAL NEW_COST = ', SUM(NEW_COST) + PRINT*, 'COST_FUNC BEFORE ADDING NEW_COST=', COST_FUNC + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Echo output to screen + IF ( LPRINTFD ) THEN + WRITE(6,*) ' ADJ_FORCE(:) = ', ADJ_FORCE(IFD,JFD,:,NFD) + WRITE(6,*) ' Using predicted value (CHK_STT_AIRS) = ' + & , CHK_STT_AIRS(IFD,JFD), '[molec/cm2]' + WRITE(6,*) ' Using observed value (OBS_STT) = ' + & , AIRS_COL_GRID(IFD,JFD), '[molec/cm2]' + WRITE(6,*) ' Using WEIGHT = ', DOMAIN_OBS (IFD,JFD) + WRITE(6,*) ' ADJ_FORCE = ' + & , ADJ_FORCE(IFD,JFD,LFD,NFD), '[1/molec/cm2]' + WRITE(6,*) ' STT_ADJ = ' + & , STT_ADJ(IFD,JFD,LFD,NFD), '[1/molec/cm2]' + WRITE(6,*) ' NEW_COST = ' + & , NEW_COST(IFD,JFD,NFD) + ENDIF + + !PRINT*, 'END CALC_AIRS_CO_FORCE' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + END SUBROUTINE CALC_AIRS_CO_FORCE + +!--------------------------------------------------------------------------- + + FUNCTION APRIORI_COMP( H2Ocd_loc, BotLev_loc) RESULT ( Xaloc ) + + !==================================================================== + ! Function APRIORI_COMP computes the a priori layer column density, + ! based on the a priori mixing ratio profile, for a given observation, + ! given the layer column density of water for the observation. + ! + ! This function is based on the subroutine coch4fg.f written by Evan + ! Manning at NASA-JPL/Caltech for AIRS Level 2 Data Processing. It + ! has been adapted for our use at Harvard. (jaf, 11/04/07) + !==================================================================== + + USE AIRSv5_MOD + + REAL*4, INTENT(IN) :: H2Ocd_loc(NLevs) + INTEGER, INTENT(IN) :: BotLev_loc + REAL*4 :: Xaloc(NLevs) + REAL*4 :: COmr(NLevs) + REAL :: LCDdry, c0, eps, delP + INTEGER :: L + + REAL*8, PARAMETER :: AVOGAD = 6.02214199D23 !molec/mol + REAL*8, PARAMETER :: WATMOL_SI=18.0152D-3 !kg/mol + REAL*8, PARAMETER :: GRAV_SI=9.80665 !m/s^2 + REAL*8, PARAMETER :: MDRYAIR_SI = 28.964D-3 !kg/mol + + ! This a priori is the MOPITT a priori from Eric Maddy + ! with AFGL profile replacing the top 21 layers + COmr = (/1751.373, 652.180, 313.65, 198.207, 132.753, + & 93.20174, 69.14629, 55.71019, 45.23621, 37.38374, + & 32.96809, 29.58296, 26.98655, 24.92291, 23.32885, + & 21.93244, 20.72882, 19.77256, 19.2927, 18.8556, + & 18.4784, 18.1747, 17.9416, 17.7607, 17.5914, + & 17.3647, 17.0681, 16.8321, 16.8665, 17.4449, + & 18.6399, 20.3268, 22.3094, 24.4428, 26.5907, + & 28.6583, 30.6771, 32.7125, 34.8565, 37.1747, + & 39.6367, 42.1871, 44.7521, 47.2370, 49.5845, + & 51.8020, 53.9116, 55.9452, 57.9489, 59.9825, + & 62.0931, 64.2530, 66.4136, 68.5153, 70.4870, + & 72.2682, 73.8662, 75.3098, 76.6364, 77.8896, + & 79.0853, 80.2262, 81.3165, 82.3502, 83.2717, + & 84.0038, 84.4653, 84.6851, 84.8021, 84.9779, + & 85.2669, 85.5724, 85.7798, 85.8779, 85.9660, + & 86.1554, 86.5235, 87.1354, 87.9981, 88.9903, + & 89.9855, 91.0270, 92.2368, 93.5934, 94.9150, + & 96.2908, 98.3620, 101.2763, 103.5686, 104.2298, + & 104.8466, 106.3291, 107.6906, 110.6079, 114.1500, + & 118.1522, 120.4714, 120.6016, 120.6461, 120.6100/) + + Xaloc(:)=0d0 + + eps = WATMOL_SI/MDRYAIR_SI + c0 = 1.e-2*AVOGAD/(MDRYAIR_SI*GRAV_SI) + DO L = 1, NLevs + IF (L .eq. 1) THEN + delP = Plev(L) - 0.005 + ELSE + delP = Plev(L) - Plev(L-1) + ENDIF + LCDdry = c0*delP - eps*H2Ocd_loc(L) + IF (L .le. BotLev_loc) THEN + Xaloc(L) = LCDdry*comr(L)*1.E-9 + ELSE + Xaloc(L) = Xaloc(BotLev_loc) + ENDIF + ENDDO + + END FUNCTION APRIORI_COMP + +!--------------------------------------------------------------------------- + + FUNCTION FMATRIX_COMP( PSurf, NTloc) RESULT( Fmatloc) + +!********************************************************************* +! FMATRIX_COMP CALCULATES THE F MATRIX NEEDED TO COMPARE GC TO AIRS +!********************************************************************* +! Note: This function is translated from the MATLAB script +! Fmatrix_comp written by Wallace McMillan (8/28/07) +!********************************************************************* + + USE AIRSv5_MOD + + REAL*4, INTENT(IN) :: Psurf + INTEGER, INTENT(IN) :: NTloc + REAL*4 :: Fmatloc(NTloc,NLevs) + INTEGER :: ind0(3),ind_end(3),ind(NTloc-2,4) + INTEGER :: I, J, P, DD + REAL*4 :: PiBot + + !===================================================== + ! FMATRIX_COMP begins here + !===================================================== + + ! First, define the sets of indice vectors used to setup a + ! vector for each trapezoid. The first and last indice vectors + ! contain only three entries because the trapezoids go to 0.5 + ! at the top and bottom of the atmosphere. + + ind0 = COlev(1:3) + DO I = 1, NTloc-2 + ind(i,:)=COlev(i:i+3) + ENDDO + ind_end=COlev(NTloc-1:NTloc+1) + + ! Construct f vectors, one for each trapezoid, and fill with zeros. + ! f vectors for ALL possible trapezoids are initially setup this way. + ! Only the f vectors corresponding to the actual trapezoids used in + ! the retrieval will be assigned non-zero values, below. + Fmatloc(:,:)=0d0 + + ! Now, compute the value of each trapezoid used in the retrieval at + ! each of the 100 AIRS levels. + + ! First, the top trapezoid must be defined from only the first three + ! entries in COlev because its value at the top of the atmosphere=0.5 + Fmatloc( 1, ind0(1):ind0(2) ) = 0.5 + Fmatloc( 1, ind0(2):ind0(3) ) = 0.5 * + & (1-(log(Plev(ind0(2):ind0(3)))-log(Plev(ind0(2)))) / + & (log(Plev(ind0(3)))-log(Plev(ind0(2))))) + + ! Next, compute the f vectors for the middle trapezoids. The first + ! trapezoid that encounters the surface must be scaled to terminate + ! at the pressure level nearest to and above the surface. + + DO I = 1, NTloc-2 + PiBot=Plev(ind(i,4)) + IF ( PiBot .le. Psurf) THEN + Fmatloc(i+1,ind(i,1):ind(i,2)) = 0.5 * + & (1-(log(Plev(ind(i,1):ind(i,2))) - + & log(Plev(ind(i,2)))) / + & (log(Plev(ind(i,1))) - log(Plev(ind(i,2))))) + Fmatloc(i+1,ind(i,2):ind(i,3)) = 0.5 + Fmatloc(i+1,ind(i,3):ind(i,4)) = 0.5 * + & (1-(log(Plev(ind(i,3):ind(i,4))) - + & log(Plev(ind(i,3)))) / + & (log(Plev(ind(i,4))) - log(Plev(ind(i,3))))) + ELSE + ! J is the first index for which Plev is gt Psurf + J = 0 + DO P = 1, NLevs + IF ( (J .eq. 0) .AND. (PLev(P) .gt. Psurf) ) J=P + ENDDO + Fmatloc(i+1,ind(i,1):ind(i,2)) = 0.5 * + & (1-(log(Plev(ind(i,1):ind(i,2))) - + & log(Plev(ind(i,2)))) / + & (log(Plev(ind(i,1))) - log(Plev(ind(i,2))))) + Fmatloc(i+1,ind(i,2):ind(i,3)) = 0.5 + + ! If the bottom trapezoid has a face that is less than one AIRS + ! layer wide, then we must make sure the next to the bottom + ! trapezoid goes to zero at the lowest level above the surface. + DD = (J-1 - ind(i,3)) + IF (DD .ne. 0) THEN + Fmatloc(i+1,ind(i,3):J-1) = 0.5 * + & (1-(log(Plev(ind(i,3):J-1)) - + & log(Plev(ind(i,3)))) / + & (log(Plev(J-1)) - log(Plev(ind(i,3))))) + ELSE + Fmatloc(i+1,ind(i,3):J-1) = 0.0 + ENDIF + ENDIF + ENDDO + + ! Then, compute the bottom trapezoid. If it encounters the surface, + ! only set it equal to 0.5 down to the lowest level above the surface. + ! Below the surface, it will remain at zero. All trapezoids below the + ! surface (i.e. not used in the retrieval) will keep zero values. + PiBot=Plev(ind_end(3)) + IF ( PiBot .gt. Psurf) THEN + ! J is the first index for which Plev is gt Psurf + J = 0 + DO P = 1, NLevs + IF ( (J .eq. 0) .AND. (PLev(P) .gt. Psurf) ) J=P + ENDDO + Fmatloc(NTloc,ind_end(1):ind_end(2)) = 0.5 * + & (1-(log(Plev(ind_end(1):ind_end(2))) - + & log(Plev(ind_end(2)))) / + & (log(Plev(ind_end(1))) - log(Plev(ind_end(2))))) + Fmatloc(NTloc,ind_end(2):J-1) = 0.5 + ELSEIF (PiBot .eq. Psurf) THEN + J = 0 + DO P = 1, NLevs + IF ( (J .eq. 0) .AND. (PLev(P) .eq. Psurf) ) J=P + ENDDO + Fmatloc(NTloc,ind_end(1):ind_end(2)) = 0.5 * + & (1-(log(Plev(ind_end(1):ind_end(2))) - + & log(Plev(ind_end(2)))) / + & (log(Plev(ind_end(1))) - log(Plev(ind_end(2))))) + Fmatloc(NTloc,ind_end(2):J) = 0.5 + ENDIF + + END FUNCTION FMATRIX_COMP + +!------------------------------------------------------------------------------ + + FUNCTION CALCtotcolden( laycolden,psurf) RESULT( totcolden) + +!********************************************************************* +! CALCtotcolden CALCULATES THE TOTAL COLUMN DENSITY +!********************************************************************* +! Note: This function is translated from the MATLAB script +! CALCtotcolden written by Wallace McMillan (11/20/07) +!********************************************************************* + + !This routine calculates total column density for a given input + !layer column density profile with specified pressures for the + !layer boundaries and an input surface pressure. For 100 layer + !column densities, there must be 101 pressure boundaries (top and + !bottom of each layer). In the case of the surface pressure lying + !in the middle of a layer (between two pressure boundaries), only + !a fraction of this lowest layer is used in computing the total column + !density. This fraction is computed in a dlogP since to account for + !the general exponential variation of pressure with altitude. + !W. McMillan, 11/12/03 + + !Correction to if statement pbound(il-1) changed to pbound(il) + ! W. McMillan, 8/22/06 + + USE AIRSv5_MOD + + REAL*4, INTENT(IN) :: psurf,laycolden(NLevs) + REAL*4 :: pbound(NLevs),totcolden + REAL*4 :: frac + INTEGER :: I,IL + + pbound=Plev + totcolden=0d0 + frac=0d0 + IL=0 + + findil: DO I=1,NLevs + IF (pbound(I) .gt. psurf) THEN + EXIT findil + ENDIF + IL=I + ENDDO findil + + IF (pbound(IL) .eq. psurf) THEN + totcolden = SUM(laycolden(1:IL+1-1)) + ELSE + frac=(LOG(psurf)-LOG(pbound(IL)))/(LOG(pbound(IL+1))- + & LOG(pbound(IL))) + totcolden = SUM(laycolden(1:IL+1-1)) + laycolden(IL+1)*frac + ENDIF + + END FUNCTION CALCtotcolden + +!------------------------------------------------------------------------------ + + SUBROUTINE AIRS_COMPUTE_COLUMN + +!********************************************************************* +! COMPUTES COLUMN FROM GEOS-CHEM OUTPUT WITH AIRS AVERAGING KERNELS +!********************************************************************* + + USE AIRSv5_MOD + USE TIME_MOD, ONLY : GET_HOUR + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" + + INTEGER :: L, W, J, I, LL + INTEGER :: ILON, ILAT + INTEGER :: NTloc + REAL*4 :: Psurf + REAL*4, ALLOCATABLE :: Ftrans(:,:), Fpi(:,:) + REAL*4, ALLOCATABLE :: Fmat(:,:) + REAL*4, ALLOCATABLE :: temp(:,:), invtemp(:,:) + REAL*4, ALLOCATABLE :: Amat(:,:) + REAL*4 :: FAFp(NLevs,NLevs) + REAL*4 :: temp3(NLevs) + REAL*4 :: temp4 + REAL*4 :: temp5(NLevs), temp6(NLevs) + REAL*4 :: Xa(NLevs) + REAL*8 :: Model_CO_layer(IIPAR, JJPAR, NLevs) + REAL*4 :: Model_lcd(IIPAR, JJPAR, NLevs) + REAL*8 :: COUNT_GRID_LOCAL(IIPAR,JJPAR) + REAL*8 :: adj_factor(IIPAR,JJPAR,NLevs) + INTEGER :: ErrorFlag + + !REAL*8, intent(in) :: Model_CO_MR(iipar,jjpar,llpar) + + !===================================================== + ! COMPUTE_COLUMN begins here + !===================================================== + + Model_CO_layer(:,:,:)=0d0 + Model_lcd(:,:,:)=0d0 + Xa(:) = 0d0 + adj_factor(:,:,:) = 0d0 + COUNT_GRID_LOCAL(:,:) = 0d0 + + ! Read and regrid input GEOS-Chem file on AIRS levels + CALL REGRIDV_AIRS(Model_CO_layer) + PRINT*,'### Model_CO_layer min, max: ',MINVAL(Model_CO_layer), + & MAXVAL(Model_CO_layer) + Model_lcd = Model_CO_layer + + + print*, 'data corrected for 10% low bias in 200405' + DO W = 1, NObss + + !print*, 'w is:', w + !print*, 'if stmt stuf:',qual(W),NTraps(W),DNFlag(W),Tsurf(W) + !call flush(6) + ! Quality control flag + ! NTraps > 1 means the averaging kernel exists + ! Select daytime only measurements (12 hours centered + ! around 1:30pm overpass time based on Colette's MOPITT code) + ! LocalT is in minutes, so this is 7:30am - 7:30pm + IF ( (qual(W) .eq. 0) .AND. (NTraps(W) .gt. 1) .AND. + & (DNFlag(W) .eq. 'Day') .AND. + & (Tsurf(W) .ge. 250) .and. (COcol(w) .gt. 0) )THEN + + !print*, 'got inside the if statement?' + !call flush(6) + + !print*, 'w is:', w + !print*, 'if stmt stuf:',qual(W),NTraps(W),DNFlag(W),Tsurf(W) + !call flush(6) + + NTloc = NTraps(W) + + ! Look for model grid box corresponding to the observation: + ! Get I corresponding to PLON(IND) + ILON = INT( ( Longitude(W) + 180d0 ) / DISIZE + 1.5d0 ) + ! Handle date line correctly (bmy, 4/23/04) + IF (ILON > IIPAR ) ILON = ILON - IIPAR + ! Get J corresponding to PLAT(IND) + ILAT = INT( ( Latitude(W) + 90d0 ) / DJSIZE + 1.5d0 ) + + IF(GET_HOUR() .EQ. OBS_HOUR_AIRS_CO(ILON,ILAT)) THEN + ALLOCATE( Ftrans (NTloc, NLevs) ) + ALLOCATE( Fpi (NTloc, NLevs) ) + ALLOCATE( Fmat (NLevs, NTloc) ) + ALLOCATE( temp (NTloc, NTloc) ) + ALLOCATE( invtemp (NTloc, NTloc) ) + ALLOCATE( Amat (NTloc, NTloc) ) + + ! Initialize variables + Ftrans(:,:) = 0d0 + Fpi(:,:)=0d0 + Fmat(:,:) = 0d0 + temp(:,:)=0d0 + invtemp(:,:)=0d0 + Amat(:,:)=0d0 + FAFp(:,:)=0d0 + Xa(:)=0d0 + temp3(:)=0d0 + temp4=0e0 + temp5(:) = 0e0 + temp6(:) = 0e0 + + Psurf = SurfPressure( W ) + Ftrans = FMATRIX_COMP( Psurf, NTloc ) + Fmat = TRANSPOSE(Ftrans) + + temp = MATMUL( Ftrans, Fmat ) + + CALL FINDINV( temp, invtemp, NTloc, ErrorFlag ) + IF (ErrorFlag .ne. 0) THEN + !invtest(W)=1 + GOTO 291 + ENDIF + + Fpi = MATMUL( invtemp, Ftrans ) + Amat(:,:) = AvgKer(1:NTloc,1:NTloc,W) + FAFp = MATMUL( MATMUL(Fmat,Amat), Fpi ) + + ! Need to use LOG(X) where X is layer column density + ! log(x')=log(x0)+FAFpi*log(x/x0) + ! x'=exp[log(x0)+FAFpi*log(x/x0)] + Xa = APRIORI_COMP( H2Ocd(:,W), BotLev(W) ) + + DO L = 1, NLevs + IF ( (Model_lcd(ILON,ILAT,L) .gt. 0) .AND. + & (Xa(L) .gt. 0) ) THEN + temp3(L)=LOG(Model_lcd(ILON,ILAT,L)/Xa(L)) + ENDIF + ENDDO + + temp3=MATMUL(FAFp,temp3) + + DO L = 1, NLevs + IF (Xa(L) .gt. 0) THEN + temp3(L)=temp3(L)+LOG(Xa(L)) + ELSE + temp3(L)=0 + ENDIF + ENDDO + + DO L = 1, NLevs + IF (temp3(L) .gt. 0) THEN + temp3(L)=EXP(temp3(L)) + ELSE + temp3(L)=0 + ENDIF + ENDDO + + ! in stand-alone code, we computed Model_col(w), + ! in the adjoint/gc code, we compute CHK_STT_AIRS(I,J) + !Model_col(W) = CALCtotcolden( temp3, PSurf) + CHK_STT_AIRS(ILON,ILAT) = CHK_STT_AIRS(ILON,ILAT) + & + CALCtotcolden( temp3, PSurf) + + AIRS_COL_GRID(ILON,ILAT) = AIRS_COL_GRID(ILON,ILAT) + & + COcol(w) + AIRSDOF_COL_GRID(ILON,ILAT) = AIRSDOF_COL_GRID(ILON,ILAT) + & + dofs(w) + + temp4 = CALCtotcolden( temp3, PSurf) + COUNT_GRID_LOCAL(ILON,ILAT) = COUNT_GRID_LOCAL(ILON,ILAT)+1 + + ! ADJOINT of AIRS retrieval (part 1 of 3) mak, 6/17/08 + DO L = 1, NLevs + if (model_lcd(ilon,ilat,l) .gt. 0 ) then + temp5(L) = temp4/model_lcd(ILON,ILAT,L) + endif + ENDDO + temp6 = MATMUL(FAFp,temp5) + adj_factor(ILON,ILAT,:) = temp6 + !print*, 'adj_factor',ilon,ilat,adj_factor(ilon,ilat,:) + !print*, 'model col:', temp4 + !print*, 'x"/x:', temp5 + !print*, 'temp6:', temp6 + +291 CONTINUE + + IF ( ALLOCATED( Ftrans) ) DEALLOCATE( Ftrans ) + IF ( ALLOCATED( Fpi ) ) DEALLOCATE( Fpi ) + IF ( ALLOCATED( Fmat ) ) DEALLOCATE( Fmat ) + IF ( ALLOCATED( temp ) ) DEALLOCATE( temp ) + IF ( ALLOCATED( invtemp)) DEALLOCATE( invtemp ) + IF ( ALLOCATED( Amat ) ) DEALLOCATE( Amat ) + + ENDIF !OBS_HOUR + ENDIF !quality flags etc + + ENDDO + + !PRINT*,'# of noninvertible matrix obs',SUM(invtest) +! print*,'min/max of CHK_STT_AIRS:',minval(chk_stt_airs), + + !======================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !======================================= + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( COUNT_GRID_LOCAL(I,J) .gt. 0. ) then + ! average AIRS + AIRS_COL_GRID(I,J) = AIRS_COL_GRID(I,J)/ + & COUNT_GRID_LOCAL(I,J) + AIRSDOF_COL_GRID(I,J) = AIRSDOF_COL_GRID(I,J)/ + & COUNT_GRID_LOCAL(I,J) + + ! average model + CHK_STT_AIRS(I,J) = CHK_STT_AIRS(I,J)/COUNT_GRID_LOCAL(I,J) + + ! average adjoint of AIRS retrieval (part 2 of 3) + adj_factor(I,J,:) = adj_factor(I,J,:)/COUNT_GRID_LOCAL(I,J) + ELSE + AIRS_COL_GRID(I,J) = -999. + AIRSDOF_COL_GRID(I,J) = -999. + CHK_STT_AIRS(I,J) = -999. + adj_factor(I,J,:) = -999. + ENDIF + ENDDO + ENDDO + + print*,'min/max of CHK_STT_AIRS:',minval(chk_stt_airs), + & maxval(chk_stt_airs) + print*,'min/max of AIRS_COL_GRID:',minval(AIRS_COL_GRID), + & maxval(airs_COL_GRID) + + ! ADJOINT of AIRS retrieval (part 3 of 3) + ADJ_AIRS_ALL(:,:,:) = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, LL ) + DO LL = 1,NLevs + DO L = 1,LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! d(CHK_STT_AIRS)/d(CHK_STT) = FAFp*(x'/x), then average + ! then multiply by unit conversion factor (kg->molec/cm2) + ! then flip the array vertically + IF (adj_factor(I,J,1) .GE. 0) THEN + + ADJ_AIRS_ALL(I,J,L) = ADJ_AIRS_ALL(I,J,L) + & + adj_factor(i,j,NLevs-LL+1) + & * ( 6.022d22 / (28.0d0 * GET_AREA_M2(J) )) + & * FRACTION(I,J,L,LL) + !print*, 'adj_airs_all,i,j,l', i,j,l,adj_airs_all + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +c$$$ DO L = 1,LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ IF(ADJ_AIRS_ALL(I,J,L) .GT. 0) THEN +c$$$ PRINT*, 'ADJ_AIRS_ALL:', I,J,L,ADJ_AIRS_ALL(I,J,L) +c$$$ ENDIF +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO + + END SUBROUTINE AIRS_COMPUTE_COLUMN + +!-------------------------------------------------------------------------- + + SUBROUTINE REGRIDV_AIRS( Model_CO_layer ) + +!********************************************************************* +! REGRIDS MODEL ARRAY FROM GEOS-CHEM LEVELS TO 100 AIRS LEVELS +!********************************************************************* +! Note: This subroutine is copied and adapted slightly from Monika +! Kopacz's REGRIDV_AIRS, which is a direct Fortran translation +! of my IDL code, which was in turn constructed from gamap's +! regridv.pro. It calls a subroutine REGRID_COLUMN, which is a +! Fortran translation of IDL code, which apparently was a +! translation of Fortran code that we can no longer locate. +! (jaf, 10/4/07) +!********************************************************************* + + USE AIRSv5_MOD + USE CHECKPT_MOD, ONLY : CHK_PSC, CHK_STT + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" ! PTOP, LLPAR, JJPAR, IIPAR + + + !REAL*8, intent(in) :: Model_CO_MR(iipar,jjpar,llpar) + REAL*8, INTENT(INOUT):: Model_CO_layer(IIPAR, JJPAR, NLevs) + REAL*8 :: STT_AIRS_VGRID(IIPAR,JJPAR,NLevs) + REAL*8 :: InPEdge(LLPAR+1) + REAL*4 :: ModelEdge(LLPAR+1) + REAL*4 :: OutPEdge(NLevs+1) + REAL*4 :: AIRSEdge(NLevs+1) + REAL*4 :: AIRSEdgePressure(NLevs+1) + !REAL*8 :: FRACTION(IIPAR,JJPAR,LLPAR,NLevs) + REAL*4 :: SurfP + !REAL*4 :: STT_KG(IIPAR,JJPAR,LLPAR) + REAL*4 :: AirMass_AIRS(NLevs) + REAL*4 :: AirMass_GC(LLPAR) + REAL*4 :: TCVV + + INTEGER I, J, Y, M, L, LL, K + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: valid = .FALSE. + + !===================================================== + ! REGRIDV_AIRS begins here + !===================================================== + + FRACTION(:,:,:,:) = 0d0 + AirMass_AIRS(:) = 0d0 + AirMass_GC(:) = 0d0 + Model_CO_layer(:,:,:)=0d0 + + ModelPS(:,:) = CHK_PSC(:,:,2) + + ! TCVV is the ratio MW air / MW tracer + TCVV = 28.97d0 / 28.0d0 + + ! Reorder pressure levels, so the first edge pressure is + ! the surface, rather than the top of the atmosphere. + AIRSEdge(1:NLevs) = Plev(NLevs:1:-1) + + !Assume first given edge is 0.01hPa + AIRSEdge(NLevs+1) = 0.01 + + !Store pressure edges + AIRSEdgePressure = AIRSEDGE + + ! Convert to sigma scale + SurfP=AIRSEdge(1) + DO k = 1,NLevs+1 + AIRSEdge(k)=AIRSEdge(k)/SurfP + ENDDO + + !------------------- + ! REGRID DATA + !------------------- + + !STT_KG(:,:,:)=0d0 + ! First need to convert input model v/v into kg, so need airmass + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1, LLPAR + InPEdge(L) = ( GET_PEDGE_JAF(I,J,L) ) + ! Need sigma grid value for kg conversion + ModelEdge(L) = InPEdge(L)/ModelPS(I,J) + ENDDO + InPEdge(LLPAR+1) = PTOP + ModelEdge(LLPAR+1) = InPEdge(LLPAR+1)/ModelPS(I,J) + AirMass_GC = RVR_GetAirMass( ModelEdge, J, ModelPS(I,J), LLPAR) + !DO L = 1, LLPAR + ! ! STT_KG = v/v * kgair / (gair/gCO) = kg CO + ! STT_KG(I,J,L) = CHK_STT(I,J,L,1)! * AirMass_GC(L) / TCVV + !ENDDO + ENDDO + ENDDO + + STT_AIRS_VGRID(:,:,:) = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + !to be safe, remove junk values: + fraction(i,j,:,:) = 0d0 + + DO L = 1, LLPAR + ! Pressure edges on INPUT and OUTPUT grids + ! both in and out pressures in hPa + InPEdge(L) = ( GET_PEDGE_JAF(I,J,L) ) + ENDDO + InPEdge(LLPAR+1) = PTOP + OutPEdge(:) = AIRSEdgePressure(:) + + !===================================================== + ! Determine fraction of each INPUT box + ! which contributes to each OUTPUT box + !===================================================== + ! Loop over INPUT layers + FIRST = .TRUE. + valid = .false. + DO L = 1, LLPAR + ! Reset VALID flag + Valid = .false. + + ! If the thickness of this pressure level is zero, then this + ! means that this pressure level lies below the surface + ! pressure (due to topography), as set up in the calling + ! program. Therefore, skip to the next INPUT level. + ! This also helps avoid divide by zero errors. (bmy, 8/6/01) + IF ( ( InPEdge(L) - InPedge(L+1) ) .lt. 1e-5 ) THEN + goto 12 !NextL + ENDIF + + ! Loop over OUTPUT layers + DO LL = 1, NLevs + + IF( OutPEdge(LL) .lt. InPEdge(L) .and. + & OutPEdge(LL) .lt. InPEdge(L+1) .and. + & (LL .eq. 1) .and. (L.eq.1) ) THEN + Fraction(i,j,L,LL) = 1d0 + ! Go to next iteration + goto 12 !NextL + ENDIF + !=================================================== + ! No contribution if: + ! ------------------- + ! Bottom of OUTPUT layer above Top of INPUT layer OR + ! Top of OUTPUT layer below Bottom of INPUT layer + ! ..unless it's the first layer in GC (mak, 8/15/07) + !=================================================== + IF ( OutPEdge(LL) .lt. InPEdge(L+1) .OR. + & OutPEdge(LL+1) .gt. InPEdge(L) ) THEN + goto 13 !NextLL + ENDIF + + !=================================================== + ! Contribution if: + ! ---------------- + ! Entire INPUT layer in OUTPUT layer + !=================================================== + IF ( OutPEdge(LL) .ge. InPEdge(L) .AND. + & OutPEdge(LL+1) .le. InPEdge(L+1) ) THEN + + Fraction(i,j,L,LL) = 1d0 + !Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + ENDIF + + !================================================== + ! Contribution if: + ! ---------------- + ! Top of OUTPUT layer in INPUT layer + !================================================== + IF ( OutPEdge(LL+1) .le. InPEdge(L) .AND. + & OutPEdge(LL) .ge. InPEdge(L) ) THEN + + Fraction(i,j,L,LL) =(InPEdge(L) - OutPEdge(LL+1)) / + & ( InPEdge(L) - InPEdge(L+1) ) + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + ENDIF + + !================================================== + ! Contribution if: + ! ---------------- + ! Entire OUTPUT layer in INPUT layer + !================================================== + IF ( OutPEdge(LL) .le. InPEdge(L) .AND. + & OutPEdge(LL+1) .ge. InPEdge(L+1) ) then + + Fraction(i,j,L,LL)=(OutPEdge(LL) - OutPEdge(LL+1))/ + & ( InPEdge(L) - InPEdge(L+1) ) + + ! Also add the to the first OUTPUT layer the fraction + ! of the first INPUT layer that is below sigma = 1.0 + ! This is a condition that can be found in GEOS-3 data. + IF ( ( First ) .AND. + & ( LL .eq. 1 ) .AND. + & ( InPEdge(L) .gt. OutPEdge(1) ) ) THEN + + Fraction(i,j,L,LL) = Fraction(i,j,L,LL) + + & ( InPEdge(L) - OutPEdge(1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! We only need to do this once... + First = .false. + ENDIF + + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + ENDIF + + !=================================================== + ! Contribution if: + ! ---------------- + ! Bottom of OUTPUT layer in INPUT layer + !=================================================== + IF ( OutPEdge(LL) .ge. InPEdge(L+1) .AND. + & OutPEdge(LL+1) .le. InPEdge(L+1) ) THEN + + Fraction(i,j,L,LL) = ( OutPEdge(LL) - InPEdge(L+1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! Also add the to the first OUTPUT layer the fraction + ! of the first INPUT layer that is below sigma = 1.0 + ! This is a condition that can be found in GEOS-3 data. + IF ( ( First ) .AND. + & ( LL .eq. 1 ) .AND. + & ( InPEdge(L) .gt. OutPEdge(1) ) ) then + + Fraction(i,j,L,LL) = Fraction(i,j,L,LL) + + & ( InPEdge(L) - OutPEdge(1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! We only need to do this once... + First = .false. + ENDIF + + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + ENDIF + + 13 CONTINUE !NextLL + + ENDDO !LL + + !====================================================== + ! Consistency Check: + ! ------------------ + ! If SUM( FRACTION(L,:) ) does not = 1, there is a problem. + ! Test those INPUT layers (L) which make a contribution to + ! OUTPUT layers (LL) for this criterion. + ! + !====================================================== + IF ( Valid ) THEN + IF ( Abs( 1e0 - sum( Fraction(i,j,L,:))) .ge. 1e-4 ) THEN + print*, 'Fraction does not add to 1' + print*, L, LL,sum( Fraction(i,j,L,:) ) + print*, 'frac(5,:):', fraction(i,j,L,:) + print*, 'InPEdge:', InPEdge + print*, 'OutPEdge:', OutPEdge + ENDIF + ENDIF + + 12 CONTINUE !NextL + + ENDDO !L + + !========================================================== + ! Compute "new" data -- multiply "old" data by fraction of + ! "old" data residing in the "new" layer + !========================================================== + ! Map CO from GC to AIRS grid + DO LL = 1 , NLevs + DO L = 1 , LLPAR + STT_AIRS_VGRID(I,J,LL) = + & STT_AIRS_VGRID(I,J,LL) + & + CHK_STT(I,J,L,1)*FRACTION(I,J,L,LL) !CHK_STT in kg + ENDDO + ENDDO + + IF(Abs( SUM(STT_AIRS_VGRID(I,J,:)) - SUM(CHK_STT(I,J,:,1))) + & /SUM(CHK_STT(I,J,:,1)) .gt. 1e-5 ) THEN + PRINT*, 'columns before and after regrid dont add up:' + PRINT*, 'columns before and after regridding:' + PRINT*, I,J,SUM(CHK_STT(I,J,:,1)),SUM(STT_AIRS_VGRID(I,J,:)) + PRINT*, 'InPEdge:', InPEdge + PRINT*, 'OutPEdge:', OutPEdge + PRINT*, 'CHK_STT' + PRINT*, CHK_STT(I,J,:,1) + PRINT*, 'STT_AIRS_VGRID:' + PRINT*, STT_AIRS_VGRID(I,J,:) + ENDIF +!!$ +!!$ ! Airmass on output grid (in kg/box in each level) +!!$ AirMass_AIRS = RVR_GetAirMass( AIRSEdge, J, SurfP, NLevs ) +!!$ +!!$ ! Convert data from kg to [v/v] +!!$ ! Model_CO_MR = kgCO * gair/gCO / kgair = [v/v] +!!$ DO LL = 1, NLevs +!!$ Model_CO_MR(I,J,LL) = STT_AIRS_VGRID(I,J,LL) * & +!!$ TCVV/AirMass_AIRS(LL) +!!$ ENDDO + + ! Need to reverse the vertical order of the array... + ! The surface should be L100 and TOA L1 + DO LL = 1, NLevs + Model_CO_layer(I,J,LL) = STT_AIRS_VGRID(I,J,NLevs-LL+1) + ENDDO + + ! Convert kg CO to layer column in molecules/cm^2 + ! Model_CO_layer = kgCO*Avogadro*(g/kg)*(m2/cm2)/[(g/mol)CO*Area] + Model_CO_layer(I,J,:) = Model_CO_layer(I,J,:) * + & 6.022d22 / (28.0d0 * GET_AREA_M2(J) ) +! Model_CO_layer(I,J,:) = STT_AIRS_VGRID(I,J,:) * & +! 6.022d22 / (28.0d0 * Area (J) ) + + + ENDDO !IIPAR + ENDDO !JJPAR + + END SUBROUTINE REGRIDV_AIRS + +!------------------------------------------------------------------------- + + FUNCTION GET_PEDGE_JAF( I, J, L ) RESULT( PEDGE ) +! +!****************************************************************************** +! Function GET_PEDGE returns the pressure at the bottom edge of level L. +! (dsa, bmy, 8/20/02, 10/24/03) +! This version has been slightly modified for use with AIRS regridding. +! (jaf, 10/04/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) P (REAL*8 ) : P_surface - P_top (PS-PTOP) +! (2 ) L (INTEGER) : Pressure will be returned at the bottom edge of level L +! +! NOTES: +! (1 ) Bug fix: use PFLT instead of PFLT-PTOP for GEOS-4 (bmy, 10/24/03) +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! LLPAR, PTOP + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local Variables + INTEGER :: AS + REAL*8, ALLOCATABLE :: AP(:) + REAL*8, ALLOCATABLE :: BP(:) + + ! Return value + REAL*8 :: PEDGE + + !================================================================= + ! GET_PEDGE_JAF begins here! + !================================================================= + ALLOCATE( AP( LLPAR + 1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AP' ) + AP = 1d0 + + ALLOCATE( BP( LLPAR + 1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BP' ) + BP = 0d0 + +#if defined( GRID30LEV ) + !---------------------- + ! GEOS-4 30 level grid + !---------------------- + + ! Ap [hPa] for 30 levels (31 edges) + AP = (/ 0.000000d0, 0.000000d0, 12.704939d0, 35.465965d0, + & 66.098427d0, 101.671654d0, 138.744400d0, 173.403183d0, + & 198.737839d0, 215.417526d0, 223.884689d0, 224.362869d0, + & 216.864929d0, 201.192093d0, 176.929993d0, 150.393005d0, + & 127.837006d0, 108.663429d0, 92.365662d0, 78.512299d0, + & 56.387939d0, 40.175419d0, 28.367815d0, 19.791553d0, + & 9.292943d0, 4.076567d0, 1.650792d0, 0.616779d0, + & 0.211349d0, 0.066000d0, 0.010000d0 /) + + ! Bp [unitless] for 30 levels (31 edges) + BP = (/ 1.000000d0, 0.985110d0, 0.943290d0, 0.867830d0, + & 0.764920d0, 0.642710d0, 0.510460d0, 0.378440d0, + & 0.270330d0, 0.183300d0, 0.115030d0, 0.063720d0, + & 0.028010d0, 0.006960d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0 /) + +#else + !---------------------- + ! GEOS-4 55 level grid + !---------------------- + + ! AP [hPa] for 55 levels (56 edges) + AP = (/ 0.000000d0, 0.000000d0, 12.704939d0, 35.465965d0, + & 66.098427d0, 101.671654d0, 138.744400d0, 173.403183d0, + & 198.737839d0, 215.417526d0, 223.884689d0, 224.362869d0, + & 216.864929d0, 201.192093d0, 176.929993d0, 150.393005d0, + & 127.837006d0, 108.663429d0, 92.365662d0, 78.512299d0, + & 66.603378d0, 56.387939d0, 47.643932d0, 40.175419d0, + & 33.809956d0, 28.367815d0, 23.730362d0, 19.791553d0, + & 16.457071d0, 13.643393d0, 11.276889d0, 9.292943d0, + & 7.619839d0, 6.216800d0, 5.046805d0, 4.076567d0, + & 3.276433d0, 2.620212d0, 2.084972d0, 1.650792d0, + & 1.300508d0, 1.019442d0, 0.795134d0, 0.616779d0, + & 0.475806d0, 0.365041d0, 0.278526d0, 0.211349d0, + & 0.159495d0, 0.119703d0, 0.089345d0, 0.066000d0, + & 0.047585d0, 0.032700d0, 0.020000d0, 0.010000d0 /) + + ! BP [unitless] for 55 levels (56 edges) + BP = (/ 1.000000d0, 0.985110d0, 0.943290d0, 0.867830d0, + & 0.764920d0, 0.642710d0, 0.510460d0, 0.378440d0, + & 0.270330d0, 0.183300d0, 0.115030d0, 0.063720d0, + & 0.028010d0, 0.006960d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0, + & 0.000000d0, 0.000000d0, 0.000000d0, 0.000000d0 /) +#endif + + ! Here Ap is in [hPa] and Bp is [unitless]. + ! For GEOS-4, we need to have PFLT as true surface pressure, + ! since Ap(1)=0 and Bp(1)=1.0. This ensures that the true + ! surface pressure will be returned for L=1. (bmy, 10/24/03) + PEDGE = AP(L) + ( BP(L) * ModelPS(I,J) ) + + IF ( ALLOCATED( AP ) ) DEALLOCATE( AP ) + IF ( ALLOCATED( BP ) ) DEALLOCATE( BP ) + + ! Return to calling program + END FUNCTION GET_PEDGE_JAF + +!------------------------------------------------------------------------------ + + FUNCTION RVR_GetAirMass( Edge, J, SurfP,Levels) RESULT(AirMassloc) + + !==================================================================== + ! Internal function RVR_GETAIRMASS returns a column vector of air + ! mass given the vertical coordinates, the surface area, + ! and surface pressure. (bmy, 12/19/03) + !==================================================================== + + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" + + INTEGER, INTENT(IN) :: J, Levels + REAL*4, INTENT(IN) :: SurfP + REAL*4 :: AirMassloc(Levels) + REAL*4, INTENT(IN) :: Edge(Levels+1) + INTEGER :: L + REAL*4 :: g100 + + AirMassloc(:) = 0d0 + + ! Constant 100/g + g100 = 100d0 / 9.8d0 + + ! Loop over levels + ! airmass(L) = hPa * m2 * 1 * 100Pa/hPa * 1/(m/s2) = + ! = N * 1/(m/s2) = kg + DO L = 1, Levels + AirMassloc(L) = SurfP * GET_AREA_M2(J) * + & ( Edge(L) - Edge(L+1) ) * g100 + ENDDO + + END FUNCTION RVR_GetAirMass + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ERROR_VARIANCE + + USE ERROR_MOD, ONLY : ERROR_STOP, GEOS_CHEM_STOP + USE BPCH2_MOD + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_TAU, EXPAND_DATE, GET_NYMD + + + IMPLICIT NONE + +!# include "define.h" +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=255) :: INPUT_FILE + INTEGER :: I, IOS, J, L + REAL*4 :: TRACER(IIPAR,JJPAR) + CHARACTER(LEN=255) :: FILENAME_err + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER :: CENTER180 + INTEGER :: NI, NJ, NL, k + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + REAL*8 :: ZTAU0, ZTAU1, TAUTMP + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + INTEGER :: IU_FILE + INTEGER :: YYYYMMDD + + INPUT_FILE = 'RRE_YYYYMMairsGlobal.bpch' + + IU_FILE = 66 + + PRINT*, 'SET ERROR TO 50% AS WE SAVE AIRS FOR RRE CALCULATION' + ERR_PERCENT(:,:) = 0.2 + GOTO 121 + !================================================================ + ! READ OLD RESTART FILE + !================================================================ + YYYYMMDD = GET_NYMD() + + FILENAME_err = TRIM( INPUT_FILE ) + + CALL EXPAND_DATE( FILENAME_err, YYYYMMDD, 0 ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'OBS ERROR FILE' + WRITE( 6, 100 ) TRIM( FILENAME_err ) + 100 FORMAT( 'READ_FILE: Reading ', a ) + + ERR_PERCENT(:,:) = -999e0 + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME_err ) + + !================================================================= + ! Read tracers -- store in the TRACER array + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:4' ) + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:5') + + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( TRACER(I,J), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:6') + + !============================================================== + ! Assign data from the TRACER array to the ERR_PERCENT array. + !============================================================== + PRINT*, 'Reading error for tau:', ztau0 + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !print*, 'inside the loop' + !print*, 'max value is:', maxval(TRACER(:,:,:)) + !print*, 'min value is:', minval(TRACER) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF(TRACER(I,J) .ge. 0.05)THEN + ERR_PERCENT(I,J) = TRACER(I,J) + + ELSEIF((TRACER(I,J).lt. 0.05).and.(TRACER(I,J).gt.0))THEN + ERR_PERCENT(I,J) = 0.05 + + ELSE + ERR_PERCENT(I,J) = TRACER(I,J) + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDDO ! infinite reading loop + + ! Close file + CLOSE( IU_FILE ) + + 121 CONTINUE + + print*, 'max err value is:', maxval(ERR_PERCENT(:,:)) + print*, 'min err value is:', minval(ERR_PERCENT) + + END SUBROUTINE READ_ERROR_VARIANCE + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_DOMAIN + + USE AIRSV5_MOD, ONLY : DOMAIN_OBS + +#include "CMN_SIZE" + + INTEGER I, J, L, N + + ALLOCATE( DOMAIN_OBS( IIPAR,JJPAR ) ) + DOMAIN_OBS(:,:) = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( +! & .and. (I .ge. 93) .and. (I .le. 144) ! MOPITT TRACE-P.. +! & .and. (J .ge. 41) .and. (J .le. 73) ! ..region 2x2.5 +! & .and. (J .ge. 40) .and. (J .le. 72) ! ..region 2x2.5 +!! & .and. (EMS_orig(I,J,NEMS) .NE. 0 ) +!! & .and. L < LPAUSE(I,J) ! Only in the troposphere +!! & .and. IS_LAND(I,J) ! Only the land species +! & .and. ( MOD( I, 2 ) == 0 ) ! Only in every other cell + & L == 1 ! Only at the surface or col +!! & .and. J >= 10 ! Not in antarctica +! & .and. L == 8 ! Only at ~500mb +! & .and. (J .ge. 24) ! only N.Hemisphere + & .and. (J .le. 38) ! not poleward of 60N + & .and. (J .ge. 9) ! not poleward of 60S + & ) THEN + + DOMAIN_OBS(I,J) = 1 + ELSE + DOMAIN_OBS(I,J) = 0 + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + PRINT*, sum(DOMAIN_obs), 'MAX observations today' + + END SUBROUTINE INIT_DOMAIN + +!----------------------------------------------------------------------------- + + END MODULE AIRS_CO_OBS_MOD + + + + + + + + diff --git a/code/obs_operators/airsv5_mod.f90 b/code/obs_operators/airsv5_mod.f90 new file mode 100644 index 0000000..c19d669 --- /dev/null +++ b/code/obs_operators/airsv5_mod.f90 @@ -0,0 +1,1017 @@ +MODULE AIRSv5_MOD + +!********************************************************************* +! Module AIRSv5_MOD contains variables for reading data from AIRS. +! Each array is used to store data read from AIRS file with data for +! 1 day (jaf, 8/20/07) +! +! Module Variables: +! ============================================================================ +! (1 ) SurfPressure : surface pressure read from file +! (2 ) COcol : columns read from AIRS file +! (3 ) qual : quality flag for CO value +! (4 ) dofs : degrees of freedom for each observation +! (5 ) Longitude : vector of longitudes read from AIRS file +! (6 ) Latitude : vector of latitudes read from AIRS file +! (7 ) YYYYMMDD : date of observation +! (8 ) FILENAME : name of input file +! (9 ) iNObs : number of observations in one file +! (10) NObss : total number of observations in one day +! (11) COlev : indices of CO trapeziods +! (12) NTraps : number of trapezoids (9) +! (13) Plev : AIRS 100 pressure levels +! (14) NLevs : number of pressure levels (100) +! (15) AvgKer : AIRS averaging kernel (on 9 trapezoids) +! (16) BotLev : Lowest level near surface (see discussion +! of nSurfSup in documentation) +! (17) LocalT : Local solar time of granule center +! +! Module subroutines: +! =========================================================================== +! (1 ) FILE_INFO --> moved to airs_co_obs_mod.f +! (2 ) INFO_AIRS +! (3 ) INIT_READ_AIRS +! (4 ) CLEANUP_AIRS +! +!********************************************************************* + IMPLICIT NONE + + ! Make everything PUBLIC + PUBLIC + + !============================================================= + ! MODULE VARIABLES + !============================================================= + + REAL*4, ALLOCATABLE :: SurfPressure(:) + REAL*4, ALLOCATABLE :: COcol(:) + REAL*4, ALLOCATABLE :: COcd(:,:) + REAL*4, ALLOCATABLE :: LandFrac(:) + REAL*4, ALLOCATABLE :: H2Ocd(:,:) + REAL*4, ALLOCATABLE :: Tsurf(:) + REAL*4, ALLOCATABLE :: AvgKer(:,:,:) + REAL*4, ALLOCATABLE :: dofs(:) + REAL*8, ALLOCATABLE :: Longitude(:) + REAL*8, ALLOCATABLE :: Latitude(:) + REAL*8, ALLOCATABLE :: Hour(:) + REAL*8, ALLOCATABLE :: Minute(:) + CHARACTER(LEN=3), ALLOCATABLE :: DNFlag(:) + INTEGER, ALLOCATABLE :: qual(:) + INTEGER*2, ALLOCATABLE :: NTraps(:) + INTEGER*2, ALLOCATABLE :: LocalT(:) + INTEGER, ALLOCATABLE :: iNObs(:) + INTEGER, ALLOCATABLE :: BotLev(:) + INTEGER :: Nobss + INTEGER :: NFiles + + ! NTraps0 is hardwired as this does not change for CO. + ! This is the ideal number of trapezoids. Some retrievals + ! will not have 9, and this is what is read by NTraps. + ! This must be changed if you use a different species. + INTEGER, PARAMETER :: NTraps0=9 + INTEGER, PARAMETER :: NLevs=100 + INTEGER*4, ALLOCATABLE :: COlev(:) + REAL*4 :: Plev(NLevs) + + ! Date Information + INTEGER :: YEAR, MONTH, DAY, IDAY + CHARACTER(LEN=255), ALLOCATABLE :: FILENAME(:) + + INTEGER, ALLOCATABLE:: DOMAIN_OBS(:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + +!!$ SUBROUTINE FILE_INFO +!!$! +!!$!****************************************************************************** +!!$! Subroutine FILE_INFO sets the directory and filename given the date. The +!!$! date is currently hardwired. (jaf, 6/1/07) +!!$!****************************************************************************** +!!$ +!!$ ! References to F90 modules +!!$ USE TIME_MOD, ONLY : EXPAND_DATE +!!$ USE FILE_MOD, ONLY : IOERROR +!!$ +!!$ ! Arguments +!!$ CHARACTER(LEN=255) :: DIR_AIRS +!!$ CHARACTER(LEN=255) :: FILENAME_IN +!!$ CHARACTER(LEN=255) :: file +!!$ CHARACTER(LEN= 8) :: YYYYMMDDs +!!$ INTEGER :: IU_FILE, IOS, IOS1, I +!!$ +!!$ !================================================================= +!!$ ! FILE_INFO begins here! +!!$ !================================================================= +!!$ +!!$ ! Set date and corresponding input AIRS filename +!!$ DIR_AIRS = '/san/as04ro/data/obs/airs/' +!!$ !DIR_AIRS = '/san/as04/home/ctm/mak/AIRS/data_airs/' +!!$ !DIR_AIRS = '/as/data-rw/corrections/as/data/airs/' +!!$ FILENAME_IN='input.txt' +!!$ +!!$ IU_FILE=15 +!!$ OPEN( IU_FILE, FILE=FILENAME_IN, IOSTAT=IOS ) +!!$ IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'airs:1' ) +!!$ +!!$ ! zero counters +!!$ Nfiles = 0 +!!$ +!!$ ! Figure out how many files to read (#lines in the file): +!!$ CALL SYSTEM('wc -l '//trim(FILENAME_IN)//' > tmp.txt') +!!$ +!!$ OPEN( 5, FILE='tmp.txt', IOSTAT=IOS1 ) +!!$ IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:1' ) +!!$ +!!$ ! Read #lines +!!$ READ( 5, *, IOSTAT=IOS1 ) NFiles +!!$ IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:2' ) +!!$ +!!$ ! Close file +!!$ CLOSE( 5 ) +!!$ +!!$ PRINT*, 'Number of Files: ', NFiles +!!$ ALLOCATE( iNObs (NFiles) ) +!!$ +!!$ ALLOCATE( FILENAME(NFiles) ) +!!$ DO i = 1, NFiles +!!$ +!!$ IF ( IOS < 0 ) EXIT +!!$ IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'airs:2' ) +!!$ +!!$ READ( IU_FILE,'(a)',IOSTAT=IOS) file +!!$ IF (i .eq. 1) & +!!$ YYYYMMDDs = file(6:9)//file(11:12)//file(14:15) +!!$ FILENAME(i)=trim(DIR_AIRS)//YYYYMMDDs//'/'//trim(file) +!!$ print*, 'filename:', trim(filename(i)) +!!$ +!!$ ENDDO +!!$ +!!$ ! Close file +!!$ CLOSE( IU_FILE ) +!!$ +!!$ READ (YYYYMMDDs,*) YYYYMMDD +!!$ +!!$ PRINT*,'Date: ',YYYYMMDD +!!$ +!!$ ! Return to calling program +!!$ END SUBROUTINE FILE_INFO +!!$ +!!$!------------------------------------------------------------------------------ + + SUBROUTINE INFO_AIRS +! +!****************************************************************************** +! Subroutine INFO_AIRS Info prints info about all VDATA and SDATA fields +! contained within the AIRS HDF file. Based on INFO_MOP02 (bmy, 7/3/03, +! 4/27/05; jaf 8/15/07) +!****************************************************************************** + + ! References to F90 modules + USE He4SwathModule + USE He4IncludeModule + + INTEGER :: fId, sId + CHARACTER(LEN=HE4_MAX_CHAR) :: swathname = & + 'L2_Support_atmospheric&surface_product' + + ! For dimension information + INTEGER :: nDims + INTEGER :: dims(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dimNames(HE4_MAX_FLDS) + + ! For swath attributes + INTEGER :: nAttrs + REAL*4 :: attrValue(HE4_MAX_ATRS) + CHARACTER(LEN=HE4_MAX_CHAR) :: attrName(HE4_MAX_ATRS) + + ! For geolocation fields + INTEGER :: nGeo + INTEGER :: geoRank(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: geoName(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: geoType(HE4_MAX_FLDS) + + ! For data fields + INTEGER :: nData + INTEGER :: dataRank(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dataName(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dataType(HE4_MAX_FLDS) + + !================================================================= + ! INFO_AIRS begins here! + !================================================================= + + ! Set verbose output + CALL He4VerboseOutput( .TRUE. ) + + ! Open HDF-EOS5 swath and get the file ID number + CALL He4FileOpen( FILENAME(1), fId ) + + ! Attach to swath and get swath ID number + CALL He4SwathAttach( fId, swathName, sId ) + + ! Get swath attributes + CALL He4SwathAttrs( sId, nAttrs, attrName, attrValue ) + + ! Get swath dimension info + CALL He4SwathDimInfo( sId, nDims, dims, dimNames ) + + ! Get information about geolocation fields + CALL He4SwathGeoFldInfo( sId, nGeo, geoRank, geoName, geoType ) + + ! Get information about data fields + CALL He4SwathDataFldInfo( sId, nData, dataRank, dataName, dataType ) + + !------------------------------------------------------------------------ + ! Cleanup and quit + !------------------------------------------------------------------------ + + ! Detach from swath + CALL He4SwathDetach( sId ) + + ! Close HDF-EOS5 file + CALL He4FileClose( fId ) + + ! Return to calling program + END SUBROUTINE INFO_AIRS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_READ_AIRS + +!******************************************************************** +! SUBROUTINE INIT_READ_AIRS allocates all module arrays and reads data +! into them from the HDF file. Based on subroutine READ_MOP02. +!********************************************************************* + + ! References to F90 modules + USE He4ErrorModule + USE He4SwathModule + USE He4GridModule + USE He4IncludeModule + USE FILE_MOD, ONLY : IOERROR + USE JULDAY_MOD, ONLY : CALDATE, JULDAY + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + ! File and Swath Info + INTEGER :: fId, sId, as + CHARACTER(LEN=HE4_MAX_CHAR) :: SWATHNAME = & + 'L2_Support_atmospheric&surface_product' + + ! For dimension information + INTEGER :: nDims + INTEGER :: dims(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dimNames(HE4_MAX_FLDS) + + ! For data fields + INTEGER :: nData + INTEGER :: dataRank(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dataName(HE4_MAX_FLDS) + CHARACTER(LEN=HE4_MAX_CHAR) :: dataType(HE4_MAX_FLDS) + + ! Fill value + CHARACTER(LEN=HE4_MAX_CHAR) :: name + REAL*4 :: dataFill + + ! For data field info + INTEGER :: fldDims(HE4_MAX_DIMS) + INTEGER :: fldRank + CHARACTER(LEN=HE4_MAX_CHAR) :: fldType + CHARACTER(LEN=HE4_MAX_CHAR) :: fldDimNames(HE4_MAX_DIMS) + + ! For swath attribute info + INTEGER :: nAttrs + CHARACTER(LEN=HE4_MAX_CHAR) :: attrName(HE4_MAX_ATRS) + INTEGER*2 :: attrValue(HE4_MAX_ATRS) + INTEGER :: status, strBufSize + CHARACTER(LEN=HE4_MAX_CHAR) :: attrList + + ! HDF_EOS5 library routines + INTEGER :: SwInqAttrs + INTEGER :: SwRdAttr + + INTEGER(HE4_INT) :: nX, nY, nZ, nW + INTEGER :: N, I, J, K + INTEGER :: YYYYMMDD_tmp,HHMMSS,SS + INTEGER*4 :: track, xtrack + REAL*4, ALLOCATABLE :: temp4(:,:) + REAL*4, ALLOCATABLE :: temp4_3d(:,:,:) + REAL*4, ALLOCATABLE :: temp4_4d(:,:,:,:) + REAL*8, ALLOCATABLE :: temp8(:,:) + INTEGER, ALLOCATABLE :: HH(:,:),MM(:,:) + INTEGER*2, ALLOCATABLE :: tempi2(:,:) + INTEGER*4, ALLOCATABLE :: tempi4(:,:) + INTEGER*4, ALLOCATABLE :: tempi_1d(:) + CHARACTER(LEN=6) :: temp_str + REAL*8, ALLOCATABLE :: Time(:) + REAL*4 :: fyr,fday + + ! For reading pressure file + CHARACTER(LEN=255) :: Pfile + INTEGER :: IU_FILE, IOS, z, s + REAL*4 :: ptemp + + !================================================================= + ! Init_Read_AIRS begins here! + !================================================================= + + + !---------------------------------------------------------------- + ! Read dimensions and allocate arrays + !---------------------------------------------------------------- + +!!$ DO I = 1, NFiles +!!$ +!!$ ! Open HDF-EOS5 swath and get the file ID number +!!$ CALL He4FileOpen( FILENAME(I), fId ) +!!$ +!!$ ! Attach to swath and get swath ID number +!!$ CALL He4SwathAttach( fId, swathName, sId ) +!!$ +!!$ ! Get swath dimension info +!!$ CALL He4SwathDimInfo( sId, nDims, dims, dimNames ) +!!$ +!!$ DO N = 1, nDims +!!$ IF ( TRIM(dimNames(N)) == 'GeoXTrack' ) xtrack = dims(N) +!!$ IF ( TRIM(dimNames(N)) == 'GeoTrack' ) track = dims(N) +!!$ ENDDO +!!$ +!!$ IF (xtrack .ne. 30) PRINT*,FILENAME(I),': xtrack=',xtrack +!!$ IF ( track .ne. 45) PRINT*,FILENAME(I),': track=',track +!!$ +!!$ ! Detach from swath +!!$ CALL He4SwathDetach( sId ) +!!$ +!!$ ! Close HDF-EOS5 file +!!$ CALL He4FileClose( fId ) +!!$ +!!$ iNObs(I) = track*xtrack +!!$ ENDDO + + iNObs(:)=1350 + Nobss = SUM(iNObs) + PRINT*,'### Number of Observations: ',Nobss + + ALLOCATE( Longitude ( Nobss) ) + ALLOCATE( Latitude ( Nobss) ) + ALLOCATE( Hour ( NObss) ) + ALLOCATE( Minute ( NObss) ) + ALLOCATE( SurfPressure( Nobss) ) + ALLOCATE( DNFlag ( NObss) ) + ALLOCATE( COcol( Nobss) ) + ALLOCATE( Tsurf( Nobss) ) + ALLOCATE( LandFrac( NObss) ) + ALLOCATE( qual( Nobss) ) + ALLOCATE( NTraps( Nobss) ) + ALLOCATE( dofs( Nobss) ) + ALLOCATE( BotLev( Nobss) ) + ALLOCATE( AvgKer( NTraps0, NTraps0, Nobss) ) + ALLOCATE( COcd( NLevs, Nobss ) ) + ALLOCATE( H2Ocd( NLevs, Nobss ) ) + ALLOCATE( LocalT( Nobss) ) + + Longitude(:) = 0d0 + Latitude(:) = 0d0 + Hour(:) = 0d0 + Minute(:) = 0d0 + SurfPressure(:)=0d0 + DNflag(:) = 'NA' + COcol(:)=0d0 + Tsurf(:)=0d0 + LandFrac(:)=0d0 + qual(:)=0 + NTraps(:)=0 + dofs(:)=0 + BotLev(:)=0 + AvgKer(:,:,:)=0d0 + LocalT(:)=0 + COcd(:,:)=0d0 + H2Ocd(:,:)=0d0 + + ! Note: Trapezoid layer indices and pressure levels do not change, + ! so these are read only once, from the first file + + ! Open HDF-EOS5 swath and get the file ID number + CALL He4FileOpen( FILENAME(1), fId ) + + ! Attach to swath and get swath ID number + CALL He4SwathAttach( fId, SWATHNAME, sId ) + + !---------------------------------------------------------------- + ! Read trapezoid layer information from HDF-EOS file (1-D INT*4) + !---------------------------------------------------------------- + ! Field name + name = 'CO_trapezoid_layers' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*4 variables BEFORE array allocation! + nX = fldDims(1) + + ! Allocate array + ALLOCATE( tempi_1d( nX ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'CO_trapezoid_layers' ) + tempi_1d = 0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, tempi_1d ) + + ALLOCATE( COlev( nX+1 ) ) + COlev=0 + COlev(1:nX)=tempi_1d + COlev(nX+1)=NLevs + + DEALLOCATE(tempi_1d) + + !---------------------------------------------------------------- + ! Read pressure level information from HDF-EOS file (1-D INT*4) + !---------------------------------------------------------------- + ! Field name + name = 'pressSupp' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*4 variables BEFORE array allocation! + nX = fldDims(1) + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, Plev ) + + ! Detach from swath + CALL He4SwathDetach( sId ) + + ! Close HDF-EOS5 file + CALL He4FileClose( fId ) + + !---------------------------------------------------------------- + ! Loop over files to read all info for one day + !---------------------------------------------------------------- + DO I = 1, NFiles + + ! Open HDF-EOS5 swath and get the file ID number + CALL He4FileOpen( FILENAME(I), fId ) + + ! Attach to swath and get swath ID number + CALL He4SwathAttach( fId, SWATHNAME, sId ) + + !---------------------------------------------------------------- + ! Read local solar time from HDF-EOS file (INTEGER*2) + ! Read day/night flag from HDF-EOS file (INTEGER*2) + !---------------------------------------------------------------- + + ! Get list of attribute names + nAttrs = SwInqAttrs( sId, attrList, strBufSize ) + ! Separate list into array + CALL makeCharArrayFromCharList( attrList, ',', attrName ) + + DO N = 1, nAttrs + status = SwRdAttr( sId, TRIM( attrName(N) ), attrValue(N) ) + ENDDO + DO N = 1, nAttrs + IF ( TRIM( attrName(N) ) .EQ. 'LocTimeGranuleCen' ) THEN + LocalT( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I))) = & + attrValue(N) + EXIT + ENDIF + ENDDO + temp_str=' ' + CALL He4SwathReadAttr( sId, 'DayNightFlag', temp_str) + DNFlag( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I))) = temp_str + temp_str=' ' + s = SUM(iNObs(1:I))-iNObs(I) + DO z = 1, 1350 + IF( DNFlag(s+z) .ne. 'Day') then + GOTO 222 + ENDIF + ENDDO + + !---------------------------------------------------------------- + ! Read latitude data from HDF-EOS file (2-D REAL*8) + !---------------------------------------------------------------- + print*, 'read other stuff before latitude' + call flush(6) + + ! Field name + name = 'Latitude' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp8( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Latitude' ) + temp8 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp8 ) + + Latitude( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp8, (/ iNObs(I) /) ) + DEALLOCATE(temp8) + + !---------------------------------------------------------------- + ! Read longitude data from HDF-EOS file (2-D REAL*8) + !---------------------------------------------------------------- + + ! Field name + name = 'Longitude' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp8( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Longitude' ) + temp8 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp8 ) + + Longitude( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp8, (/ iNObs(I) /) ) + DEALLOCATE(temp8) + + !---------------------------------------------------------------- + ! Read time data from HDF-EOS file (2-D REAL*8) + !---------------------------------------------------------------- + + ! Field name + name = 'Time' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp8( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Time' ) + ALLOCATE( HH( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Time:HH' ) + ALLOCATE( MM( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Time:MM' ) + temp8 = 0d0 + HH = 0 + MM = 0 + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp8 ) + + temp8 = JULDAY(1993,1,1d0) + (temp8 / 86400d0) + + DO J = 1, nX + DO K = 1, nY + CALL CALDATE( Temp8(J,K), YYYYMMDD_tmp, HHMMSS ) + CALL YMD_EXTRACT(HHMMSS,HH(J,K),MM(J,K),SS) + ENDDO + ENDDO + + HOUR( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( HH, (/ iNObs(I) /) ) + MINUTE( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( MM, (/ iNObs(I) /) ) + DEALLOCATE(temp8) + DEALLOCATE(HH) + DEALLOCATE(MM) + +! DEALLOCATE(Time) + + !---------------------------------------------------------------- + ! Read surface pressure data from HDF-EOS file (2-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'PSurfStd' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'PSurfStd') + temp4 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp4 ) + + SurfPressure( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4, (/ iNObs(I) /) ) + DEALLOCATE(temp4) + + !---------------------------------------------------------------- + ! Read CO column data from HDF-EOS file (2-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'CO_total_column' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'CO_total_column' ) + temp4 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp4 ) + + COcol( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4, (/ iNObs(I) /) ) + DEALLOCATE(temp4) + + !---------------------------------------------------------------- + ! Read land fraction data from HDF-EOS file (2-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'landFrac' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'landFrac' ) + temp4 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp4 ) + + LandFrac( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4, (/ iNObs(I) /) ) + DEALLOCATE(temp4) + + !---------------------------------------------------------------- + ! Read surface air temperature data from HDF-EOS file (2-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'TSurfAir' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'TSurfAir') + temp4 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp4 ) + + + Tsurf( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4, (/ iNObs(I) /) ) + DEALLOCATE(temp4) + +!!$ !---------------------------------------------------------------- +!!$ ! Read CO layer column density data from HDF-EOS file (3-D REAL*4) +!!$ !---------------------------------------------------------------- +!!$ +!!$ ! Field name +!!$ name = 'COCDSup' +!!$ +!!$ ! Get fill value (if necessary to strip out missing data values) +!!$ CALL He4SwathFillValue( sId, name, dataFill ) +!!$ +!!$ ! Get field info (array dimensions are in fldDims) +!!$ CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) +!!$ +!!$ ! Copy dims to INTEGER*8 variables BEFORE array allocation! +!!$ nX = fldDims(1) +!!$ nY = fldDims(2) +!!$ nZ = fldDims(3) +!!$ +!!$ ! Allocate array +!!$ ALLOCATE( temp4_3d( nX, nY, nZ ), stat=as ) +!!$ IF ( as /= 0 ) CALL He4AllocErr( 'COCDSup' ) +!!$ temp4_3d = 0d0 +!!$ +!!$ ! Read data from swath +!!$ CALL He4SwathReadData( sId, name, nX, nY, nZ, temp4_3d ) +!!$ +!!$ COcd( :, SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & +!!$ RESHAPE( temp4_3d, (/ NLevs, iNObs(I) /) ) +!!$ DEALLOCATE(temp4_3d) +!!$ + !---------------------------------------------------------------- + ! Read H2O layer column density data from HDF-EOS file (3-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'H2OCDSup' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + nZ = fldDims(3) + + ! Allocate array + ALLOCATE( temp4_3d( nX, nY, nZ ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'H2OCDSup' ) + temp4_3d = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, nZ, temp4_3d ) + + H2Ocd( :, SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4_3d, (/ NLevs, iNObs(I) /) ) + DEALLOCATE(temp4_3d) + + !---------------------------------------------------------------- + ! Read averaging kernel data from HDF-EOS file (4-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'CO_ave_kern' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + nZ = fldDims(3) + nW = fldDims(4) + + ! Allocate array + ALLOCATE( temp4_4d( nX, nY, nZ, nW), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'CO_ave_kern' ) + temp4_4d(:,:,:,:) = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, nZ, nW, temp4_4d ) + + AvgKer( :, :, SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4_4d, (/ NTraps0, NTraps0, iNObs(I)/) ) + + DEALLOCATE(temp4_4d) + + !---------------------------------------------------------------- + ! Read degrees of freedom data from HDF-EOS file (2-D REAL*4) + !---------------------------------------------------------------- + + ! Field name + name = 'CO_dof' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate array + ALLOCATE( temp4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'CO_dof' ) + temp4 = 0d0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, temp4 ) + + dofs( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( temp4, (/ iNObs(I) /) ) + DEALLOCATE(temp4) + + !---------------------------------------------------------------- + ! Read quality data from HDF-EOS file (2-D UNSIGNED INTEGER*4) + !---------------------------------------------------------------- + + ! Field name + name = 'Qual_CO' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate arrays + ALLOCATE( tempi2( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'Qual_CO' ) + tempi2 = 0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, tempi2 ) + + qual( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( tempi2, (/ iNObs(I) /) ) + + DEALLOCATE(tempi2) + + !---------------------------------------------------------------- + ! Read number of AK entries from HDF-EOS file (2-D INTEGER*2) + !---------------------------------------------------------------- + + ! Field name + name = 'num_CO_Func' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate arrays + ALLOCATE( tempi2( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'num_CO_Func' ) + tempi2 = 0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, tempi2 ) + + NTraps( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( tempi2, (/ iNObs(I) /) ) + + DEALLOCATE(tempi2) + + !---------------------------------------------------------------- + ! Read bottom level from HDF-EOS file (2-D INTEGER*4) + !---------------------------------------------------------------- + + ! Field name + name = 'nSurfSup' + + ! Get fill value (if necessary to strip out missing data values) + CALL He4SwathFillValue( sId, name, dataFill ) + + ! Get field info (array dimensions are in fldDims) + CALL He4SwathFldInfo( sId, name, fldType, fldRank, fldDims, fldDimNames ) + + ! Copy dims to INTEGER*8 variables BEFORE array allocation! + nX = fldDims(1) + nY = fldDims(2) + + ! Allocate arrays + ALLOCATE( tempi4( nX, nY ), stat=as ) + IF ( as /= 0 ) CALL He4AllocErr( 'nSurfSup' ) + tempi4 = 0 + + ! Read data from swath + CALL He4SwathReadData( sId, name, nX, nY, tempi4 ) + + BotLev( SUM(iNObs(1:I))-iNObs(I)+1 : SUM(iNObs(1:I)) ) = & + RESHAPE( tempi4, (/ iNObs(I) /) ) + + DEALLOCATE(tempi4) + + !---------------------------------------------------------------- + ! Cleanup and quit + !---------------------------------------------------------------- + +222 CONTINUE + + ! Detach from swath + CALL He4SwathDetach( sId ) + + ! Close HDF-EOS5 file + CALL He4FileClose( fId ) + + ENDDO + + !---------------------------------------------------------------- + ! Echo min & max values + !---------------------------------------------------------------- + PRINT*, '### Lat min, max: ', MINVAL( Latitude ), MAXVAL( Latitude ) + PRINT*, '### Lon min, max: ', MINVAL( Longitude ), MAXVAL( Longitude ) + PRINT*, '### LocalT: ', MINVAL(LocalT) + PRINT*, '### Hour min, max: ', MINVAL( Hour ), MAXVAL( Hour ) + PRINT*, '### Minute min, max: ', MINVAL( Minute ), MAXVAL( Minute ) + PRINT*, '### SurfPressure min, max:', MINVAL( SurfPressure ), & + MAXVAL( SurfPressure ) + PRINT*, '### COcol min, max: ', MINVAL( COcol ), MAXVAL( COcol ) + PRINT*, '### Tsurf min, max: ', MINVAL( Tsurf ), MAXVAL( Tsurf ) + PRINT*, '### LandFrac min, max: ', MINVAL( LandFrac ), MAXVAL( LandFrac ) + PRINT*, '### COcd min, max: ', MINVAL( COcd ), MAXVAL( COcd ) + PRINT*, '### H2Ocd min, max: ', MINVAL( H2Ocd ), MAXVAL( H2Ocd ) +! PRINT*, '### AvgKer min, max: ', MINVAL( AvgKer ), MAXVAL( AvgKer ) +! PRINT*, '### dofs min, max: ', MINVAL( dofs ), MAXVAL( dofs ) +! PRINT*, '### qual min, max: ', MINVAL( qual ), MAXVAL( qual ) +! PRINT*, '### BotLev min, max: ', MINVAL( BotLev ), MAXVAL( BotLev ) +! PRINT*, '### NTraps min, max: ', MINVAL( NTraps ), MAXVAL( NTraps ) + +! PRINT*, '### COlev: ', COlev + PRINT*, '### Plev min, max: ',Plev(1),Plev(NLevs) +! PRINT*, '### Day Night Flag: ', DNFlag(1350) + + ! Return to calling program + END SUBROUTINE INIT_READ_AIRS + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_AIRS +! +!****************************************************************************** +! Subroutine CLEANUP_AIRS deallocates all module arrays (jaf, 8/15/07) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_AIRS begins here! + !================================================================= + IF ( ALLOCATED( iNObs ) ) DEALLOCATE( iNObs ) + IF ( ALLOCATED( Filename ) ) DEALLOCATE( Filename ) + IF ( ALLOCATED( Latitude ) ) DEALLOCATE( Latitude ) + IF ( ALLOCATED( Longitude ) ) DEALLOCATE( Longitude ) + IF ( ALLOCATED( Hour ) ) DEALLOCATE( Hour ) + IF ( ALLOCATED( Minute ) ) DEALLOCATE( Minute ) + IF ( ALLOCATED( SurfPressure ) ) DEALLOCATE( SurfPressure ) + IF ( ALLOCATED( DNFlag ) ) DEALLOCATE( DNFlag ) + IF ( ALLOCATED( COcol ) ) DEALLOCATE( COcol ) + IF ( ALLOCATED( Tsurf ) ) DEALLOCATE( Tsurf ) + IF ( ALLOCATED( LandFrac ) ) DEALLOCATE( LandFrac ) + IF ( ALLOCATED( COcd ) ) DEALLOCATE( COcd ) + IF ( ALLOCATED( H2Ocd ) ) DEALLOCATE( H2Ocd ) + IF ( ALLOCATED( AvgKer ) ) DEALLOCATE( AvgKer ) + IF ( ALLOCATED( qual ) ) DEALLOCATE( qual ) + IF ( ALLOCATED( dofs ) ) DEALLOCATE( dofs ) + IF ( ALLOCATED( COlev ) ) DEALLOCATE( COlev ) + IF ( ALLOCATED( BotLev ) ) DEALLOCATE( BotLev ) + IF ( ALLOCATED( NTraps ) ) DEALLOCATE( NTraps ) + IF ( ALLOCATED( LocalT ) ) DEALLOCATE( LocalT ) + IF ( ALLOCATED( DOMAIN_OBS ) ) DEALLOCATE( DOMAIN_OBS ) + + ! Return to calling program + END SUBROUTINE CLEANUP_AIRS +!------------------------------------------------------------------------------ +! End of module +END MODULE AIRSv5_MOD diff --git a/code/obs_operators/avg_mls_hno3_obs_mod.f90 b/code/obs_operators/avg_mls_hno3_obs_mod.f90 new file mode 100644 index 0000000..c48668b --- /dev/null +++ b/code/obs_operators/avg_mls_hno3_obs_mod.f90 @@ -0,0 +1,593 @@ +MODULE MLS_HNO3_OBS_MOD + +! +! +! Module MLS_HNO3_OBS contains all subroutines and variables needed for MLS HNO3 column data +! +! +! Module Routines: +! +! (1) READ_MLS_HNO3_FILE : Read MLS hdf file + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + !PUBLIC READ_OMI_HNO3_FILE + PUBLIC READ_MLS_HNO3_FILE + PUBLIC CALC_MLS_HNO3_FORCE + + ! Module variables + + ! MLS data + REAL*8, ALLOCATABLE :: MLS_LON(:) + REAL*8, ALLOCATABLE :: MLS_LAT(:) + REAL*8, ALLOCATABLE :: MLS_TIME(:) + REAL*8, ALLOCATABLE :: MLS_HNO3(:,:) + REAL*8, ALLOCATABLE :: MLS_HNO3_STD(:,:) + REAL*8, ALLOCATABLE :: MLS_CN(:) + REAL*8, ALLOCATABLE :: MLS_CON_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_STA_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_MAIN_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_VIEW_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_PRESSURE(:) + + ! MLS grid specification + INTEGER :: N_MLS_OBS + INTEGER :: N_MLS_ALT + +CONTAINS + +!-----------------------------------------------------------------------------! + SUBROUTINE READ_MLS_HNO3_FILE ( YYYYMMDD, HHMMSS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + CHARACTER(LEN=255) :: DIR_MLS + CHARACTER(LEN=255) :: FILENAME_MLS + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + + INTEGER(HID_T) :: file_id, dset_id, dspace_id + INTEGER(HSIZE_T) :: dims(2), maxdims(2), data_dims(2) + INTEGER :: error + + CALL CLEANUP_MLS + + DIR_MLS = '/users/jk/15/xzhang/MLS_HNO3/' + FILENAME_MLS = 'MLS-Aura_L2GP-HNO3_v04-22-c01_YYYYdMMDD.he5' + + CALL EXPAND_DATE(DIR_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(FILENAME_MLS, YYYYMMDD, 0) + + FILENAME_FULL = TRIM(DIR_MLS) // TRIM(FILENAME_MLS) + + PRINT *,"READING MLS File: ", FILENAME_FULL + + ! Initialize HDF5 Interface + + PRINT *,"INITIALIZE INTERFACE" + + CALL h5open_f(error) + + ! Open HDF5 file + + PRINT *,"OPEN FILE" + + CALL h5fopen_f (FILENAME_FULL, H5F_ACC_RDONLY_F, file_id, error) + + ! Read Time array + + PRINT *,"READING TIME ARRAY" + + DSET_NAME = '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + PRINT *,"OPENING DATA SET" + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + ! open dataspace + + CALL h5dget_space_f(dset_id, dspace_id, error) + + ! read in length of data arrays + + CALL h5sget_simple_extent_dims_f(dspace_id, dims, maxdims, error) + + ! close dataspace + + CALL h5sclose_f(dspace_id, error) + + N_MLS_ALT = dims(1) + N_MLS_OBS = dims(2) + + ALLOCATE(MLS_TIME(N_MLS_OBS)) + ALLOCATE(MLS_LON(N_MLS_OBS)) + ALLOCATE(MLS_LAT(N_MLS_OBS)) + ALLOCATE(MLS_HNO3(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_CON_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_HNO3_STD(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_MAIN_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_STA_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_CN(N_MLS_OBS)) + ALLOCATE(MLS_VIEW_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_SOLAR_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_PRESSURE(N_MLS_ALT)) + + PRINT *,"ALLOCATING TIME ARRAY WITH LENGTH: ", N_MLS_OBS + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + !PRINT *, "L2gpValue", MLS_HNO3(:,N_MLS_OBS) + + ! Read Time array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Time' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_TIME, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Longitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LON, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Latitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LAT, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 Precision array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpPrecision' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3_STD, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Quality' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_MAIN_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Status array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Status' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_STA_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read ChunkNumber array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/ChunkNumber' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CN, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read LineofSightAngle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/LineOfSightAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_VIEW_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Solar zenith Angle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_SOLAR_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Convergence' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CON_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Pressure' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_PRESSURE, (/data_dims(1),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! close HDF5 file + + CALL h5fclose_f(file_id,error) + + ! close HDF5 interface + + CALL h5close_f(error) + + + END SUBROUTINE READ_MLS_HNO3_FILE +!-----------------------------------------------------------------------------! + SUBROUTINE CALC_MLS_HNO3_FORCE + +!! +!! Subroutine CALC_OMI_HNO3_FORCE computes the HNO3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_HOUR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDHNO3, IDTHNO3 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,K,L + INTEGER :: I_MLS, J_MLS, JLOOP + INTEGER :: IIJJ(2) + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_HNO3(LLPAR) + REAL*8 :: GC_HNO3_COL + REAL*8 :: GC_HNO3_ADJ(IIPAR,JJPAR,LLPAR) + REAL*8 :: CM22DU + REAL*8 :: DIFF + REAL*8 :: OBS_ERROR + + LOGICAL :: MLS_MATCH + REAL*8 :: OMI_MLS_DIST + REAl*8 :: OMI_MLS_DIST_LON + REAl*8 :: OMI_MLS_DIST_LAT + REAL*8 :: MLS_HNO3_GC(LLPAR) + REAL*8 :: MLS_HNO3_GC_STD(LLPAR) + REAL*8 :: NCP(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(IIPAR,JJPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMI(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + ! Loop through data to find observations + + CM22DU = 2.69E16 ! conversion factor for DU -> #/cm2 + + GC_HOUR = GET_HOUR() + + ! initialize needed arrays and variables + + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_HNO3 = 0d0 + GC_HNO3_ADJ = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + SOBS_COST_CONTRIBUTION = 0d0 + + OMI_MLS_DIST = 10000d0 + + DO I_MLS = 1, N_MLS_OBS + IF(MLS_TIME(I_MLS)>0) THEN + ! There is an observation in the MLS grid box. + ! Check if it was made within the current hour. + tai93 = MLS_TIME(I_MLS) + + ! Convert TAI93 to UTC + CALL TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + ( MLS_MAIN_QUAL(I_MLS) > 0.5 ) .AND. & + ( MLS_STA_QUAL(I_MLS) < 250 ) .AND. & + ( MLS_CON_QUAL(I_MLS) < 1.4 ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(MLS_LON(I_MLS),4),REAL(MLS_LAT(I_MLS),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM HNO3 values + + GC_HNO3 = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + + DO L = 1, LLPAR + + JLOOP = JLOP(I,J,L) + + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + + !IF ( JLOOP > 0 ) THEN + + !GC_HNO3(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDHNO3)) * 1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + + !GC_HNO3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + ! CHK_STT is in units of [kg/box] here. Convert to ppb + GC_HNO3(L) = CHK_STT(I,J,L,IDTHNO3) * TCVV(IDTHNO3) / AD(I,J,L) + + DO J_MLS = 1, N_MLS_ALT + + IF( ( MLS_PRESSURE(J_MLS) >= GET_PEDGE(I,J,L+1) ) .AND. & + ( MLS_PRESSURE(J_MLS) < GET_PEDGE(I,J,L) ) .AND. & + ( MLS_PRESSURE(J_MLS) < 151 ) .AND. & + ( MLS_PRESSURE(J_MLS) > 15 ) .AND. & + ( MLS_HNO3(J_MLS,I_MLS) > 0 ) ) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L) + MLS_HNO3(J_MLS,I_MLS) + + MLS_HNO3_GC_STD(L) = MLS_HNO3_GC_STD(L) + MLS_HNO3_STD(J_MLS,I_MLS)**2 + + NCP(L) = NCP(L) + 1 + ENDIF + ENDDO + + IF (NCP(L)>0) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L)/NCP(L) + MLS_HNO3_GC_STD(L) = (MLS_HNO3_GC_STD(L)**(0.5))/NCP(L) + OBS_ERROR = MLS_HNO3_GC_STD(L) + DIFF = GC_HNO3(L) - MLS_HNO3_GC(L) + COST_CONTRIB = 0.5 * (DIFF/OBS_ERROR)**2 + IF + IF (SUPER_OBS) THEN + NEW_COST(I,J,L) = NEW_COST(I,J,L) + COST_CONTRIB + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * TCVV(IDTHNO3) / AD(I,J,L) + ENDIF + ENDIF + ENDIF + + ENDDO + !PRINT *, "MODELLED HNO3", GC_HNO3 + !PRINT *, "OBSERVED HNO3", MLS_HNO3_GC + + ! Compute stratospheric HNO3 column value [v/v*cm] + + !GC_HNO3_COL = SUM(GC_HNO3(:) * BXHEIGHT(I,J,:) * 100d0) + + !PRINT *, "GC_HNO3_COL", GC_HNO3_COL + + !PRINT *, "MLS_HNO3_COL", MLS_HNO3_COL(I_MLS) + + !DIFF = GC_HNO3_COL - MLS_HNO3_COL(I_MLS) + + !OBS_ERROR = (MLS_HNO3_COL_STD(I_MLS))**0.5 + + !DO L = 1, LLPAR + !IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + !IF (SUPER_OBS) THEN + + !SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + !ELSE + !STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + + !ENDIF + !ENDIF + !ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + ! update cost function + IF (SUPER_OBS) THEN + + !SOBS_COST_CONTRIBUTION(I,J) = SOBS_COST_CONTRIBUTION(I,J) + 0.5 * (DIFF/OBS_ERROR) ** 2 + + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + + !ELSE + + !COST_FUNC = COST_FUNC + 0.5 * (DIFF/OBS_ERROR)**2 + ENDIF + ENDIF + + ENDIF + ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L = 1,LLPAR + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + SOBS_COST_CONTRIBUTION(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ENDIF + + PRINT *, "COST FUNCTION OF MLS HNO3", COST_FUNC + + END SUBROUTINE CALC_MLS_HNO3_FORCE + +!----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_MLS + + IF (ALLOCATED( MLS_LON )) DEALLOCATE( MLS_LON ) + IF (ALLOCATED( MLS_LAT )) DEALLOCATE( MLS_LAT ) + IF (ALLOCATED( MLS_TIME )) DEALLOCATE( MLS_TIME ) + IF (ALLOCATED( MLS_HNO3 )) DEALLOCATE( MLS_HNO3 ) + IF (ALLOCATED( MLS_HNO3_STD )) DEALLOCATE( MLS_HNO3_STD ) + IF (ALLOCATED( MLS_CON_QUAL )) DEALLOCATE( MLS_CON_QUAL ) + IF (ALLOCATED( MLS_MAIN_QUAL )) DEALLOCATE( MLS_MAIN_QUAL ) + IF (ALLOCATED( MLS_STA_QUAL )) DEALLOCATE( MLS_STA_QUAL ) + IF (ALLOCATED( MLS_CN )) DEALLOCATE( MLS_CN ) + IF (ALLOCATED( MLS_SOLAR_ZENITH )) DEALLOCATE( MLS_SOLAR_ZENITH ) + IF (ALLOCATED( MLS_VIEW_ZENITH )) DEALLOCATE( MLS_VIEW_ZENITH ) + IF (ALLOCATED( MLS_PRESSURE )) DEALLOCATE( MLS_PRESSURE ) + + END SUBROUTINE CLEANUP_MLS + +!-----------------------------------------------------------------------------! + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=7 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + +END MODULE MLS_HNO3_OBS_MOD + diff --git a/code/obs_operators/avg_mopitt_obs_mod.f b/code/obs_operators/avg_mopitt_obs_mod.f new file mode 100644 index 0000000..683e78f --- /dev/null +++ b/code/obs_operators/avg_mopitt_obs_mod.f @@ -0,0 +1,1664 @@ + MODULE MOPITT_OBS_MOD +!***************************************************************************** +! Module MOPITT_OBS_MOD contains all the subroutines for the using of MOPITT +! observation (version 3 and version 4).(zhe 1/19/11) +! Remove the support to MOPITT v3 and v4. Now support v5 and v6. (Zhe 1/20/14) +! Module Routines: +! ============================================================================ +! (1 ) READ_MOPITT_FILE : Read MOPITT hdf file +! (2 ) CALC_MOPITT_FORCE : Calculates cost function and STT_ADJ increments +! (3 ) CALC_AVGKER : Construct the averging kernel matrix +! (4 ) BIN_DATA : Interpolation between different vertical resolutions +! (5 ) INIT_DOMAIN : Define the observation window +! (6 ) CALC_OBS_HOUR : Calculated hour of morning obs +! (7 ) ITS_TIME_FOR_MOPITT_OBS: FUNCTION that checks time vs. OBS_HOUR array +! (8 ) READ_MOP02 : Reads MOPITT data fields from the HDF-EOS file +! (9) INFO_MOP02 : Prints name, dims, type, etc. of MOPITT data fields +! (10) CLEANUP_MOP02 : Deallocates all module arrays +! ============================================================================= + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "../adjoint/define_adj.h" + + PRIVATE + + PUBLIC OBS_HOUR_MOPITT + PUBLIC COUNT_TOTAL + PUBLIC ITS_TIME_FOR_MOPITT_OBS + PUBLIC READ_MOPITT_FILE + PUBLIC CALC_MOPITT_FORCE + + !============================================================================= + ! MODULE VARIABLES + !============================================================================= + + INTEGER :: OBS_HOUR_MOPITT(IIPAR,JJPAR) + INTEGER :: DOMAIN_OBS(IIPAR,JJPAR) + REAL*8 :: COUNT_TOTAL + + REAL*4 :: ERR_PERCENT(IIPAR,JJPAR) + REAL*4, ALLOCATABLE :: A(:,:) + REAL*4, ALLOCATABLE :: T(:) + REAL*4, ALLOCATABLE :: XA(:) + REAL*8, ALLOCATABLE :: AC(:) + + ! MOPITT dimension fields + INTEGER :: T_DIM, Z_DIM + REAL*4, ALLOCATABLE :: LATITUDE(:) + REAL*4, ALLOCATABLE :: LONGITUDE(:) + REAL*4, ALLOCATABLE :: PRESSURE(:) + REAL*4, ALLOCATABLE :: SECONDS_IN_DAY(:) + REAL*4, ALLOCATABLE :: MOPITT_GMT(:) + REAL*8, ALLOCATABLE :: TAU(:) + + ! MOPITT data quantities + REAL*4, ALLOCATABLE :: BOTTOM_PRESSURE(:) + REAL*4, ALLOCATABLE :: CO_MIXING_RATIO(:,:,:) + REAL*4, ALLOCATABLE :: CO_RET_BOT_MIXING_RATIO(:,:) + REAL*4, ALLOCATABLE :: CO_TOTAL_COLUMN(:,:) + REAL*4, ALLOCATABLE :: AVGKER(:,:,:) + REAL*4, ALLOCATABLE :: RET_ERR_COV(:,:,:) + INTEGER, ALLOCATABLE :: CLOUD_DES(:) + INTEGER, ALLOCATABLE :: SURFACE_INDEX(:) + + ! MOPITT a priori + INTEGER :: NLEV_AP + REAL*4, ALLOCATABLE :: PLEV_AP(:) + REAL*4, ALLOCATABLE :: CO_MR_AP(:,:,:) + REAL*4, ALLOCATABLE :: CO_MR_AP_BOTTOM(:,:) + + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_MOPITT_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_MOPITT_FILE reads the MOPITT hdf file. +! (mak, 7/12/07, zhe 1/19/11) +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +!****************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, AS + CHARACTER(LEN=255) :: DIR_MOPITT + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: FILENAMEM + CHARACTER(LEN=255) :: FILENAME2 + LOGICAL :: IT_EXISTS + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! READ_MOPITT_FILE begins here! + !================================================================= +#if defined( MOPITT_V5_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v5/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V10.1.3.beta.hdf' +#endif +#if defined( MOPITT_V6_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v6/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V16.2.3.he5' +#endif +#if defined( MOPITT_V7_CO_OBS ) + DIR_MOPITT = '/users/jk/15/xzhang/MOPITT/' + DIR_MONTH = '/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V17.9.3.he5' +#endif + + IF ( FIRST ) THEN + ERR_PERCENT(:,:) = 0.0 + COUNT_TOTAL = 0 + FIRST = .FALSE. + ENDIF + + OBS_HOUR_MOPITT(:,:) = -99 + + CALL EXPAND_DATE( FILENAMEM, YYYYMMDD, 0 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 0 ) + + FILENAME2 = TRIM( DIR_MOPITT ) // TRIM( DIR_MONTH ) // FILENAMEM + PRINT*, '=== Reading ===:', TRIM( FILENAME2 ) + + INQUIRE( FILE = FILENAME2, EXIST = IT_EXISTS ) + IF (IT_EXISTS) THEN + + !CALL INFO_MOP02(FILENAME2) + + CALL READ_MOP02( FILENAME2 ) + + CALL INIT_DOMAIN + + ! Calculate hour of day when obs should be compared to model + CALL CALC_OBS_HOUR + + ENDIF + + !CALL READ_ERROR_VARIANCE + !We assume 20% uniform observation error + ERR_PERCENT(:,:) = 0.2/LOG(10d0) + + END SUBROUTINE READ_MOPITT_FILE +!------------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_MOPITT_FORCE + +!****************************************************************************** +! CALC_MOPITT_FORCE calculate cost function and STT_ADJ increments +! (zhe 1/19/11) +!****************************************************************************** + + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_AP, GET_BP + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, GET_YEAR + USE TIME_MOD, ONLY : GET_HOUR + USE CHECKPT_MOD, ONLY : CHK_STT + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDTCO + USE DAO_MOD, ONLY : AD, IS_LAND + USE ADJ_ARRAYS_MOD, ONLY : SET_FORCING, SET_MOP_MOD_DIFF, + & SET_MODEL_BIAS, SET_MODEL, SET_OBS, + & COST_ARRAY, DAY_OF_SIM, IFD, JFD, LFD, NFD, + & COST_FUNC, ADJ_FORCE, STT_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD, LDCOSAT + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY: DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY: N_CALC, EXPAND_NAME + USE TROPOPAUSE_MOD, ONLY: ITS_IN_THE_TROP + + LOGICAL, SAVE :: SECOND = .TRUE. + CHARACTER(LEN=255) :: FILENAME + + ! Local Variables + INTEGER :: W, I, J, Z, ZZ, L,LL,IOS + INTEGER :: LON15, IIJJ(2) + INTEGER :: NLEV_RET + + REAL*4 :: RETLEV(Z_DIM+1) + REAL*8 :: P_EDGE(Z_DIM+2), MODEL_COL, MOPITT_COL + REAL*8 :: UTC, TAU0 + REAL*8 :: MODEL_P(LLPAR), MODEL_CO_MR(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: COUNT(IIPAR,JJPAR) + REAL*8 :: MOP_COL_GRID(IIPAR,JJPAR) + REAL*8 :: MODEL_COL_GRID(IIPAR,JJPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: + REAL*8 :: ADJ_F(LLPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) + REAL*8 :: SY + REAL*8 :: COST_CONTRIB(LLPAR) + REAL*8 :: MODEL_P_EDGE(LLPAR+1) + !REAL*8 :: DIFF_COST + REAL*4 :: MOP_CO_BIAS(IIPAR,JJPAR,11) + REAL*4 :: MOP_BIAS_COUNT(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_BIAS_SOBS(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ_SOBS(IIPAR,JJPAR,11) + + REAL*8, ALLOCATABLE :: GEOS_RAW(:) + REAL*8, ALLOCATABLE :: MOP_CO(:) + REAL*8, ALLOCATABLE :: DIFF_ADJ(:) + REAL*8, ALLOCATABLE :: GEOS_CO(:) + REAL*8, ALLOCATABLE :: DIFF_COST(:) + + + !================================================================= + ! CALC_MOPITT_FORCE begins here! + !================================================================= + + TAU0 = GET_TAU0( GET_MONTH(), GET_DAY(), GET_YEAR() ) + + COUNT_GRID(:,:) = 0d0 + COUNT(:,:) = 0d0 + SOBS_COUNT(:,:) = 0d0 + MOP_COL_GRID(:,:) = -999.0 + MODEL_COL_GRID(:,:) = -999.0 + ADJ_FORCE(:,:,:,:) = 0d0 + NEW_COST(:,:) = 0d0 + MOP_CO_BIAS(:,:,:) = 0d0 + MOP_BIAS_COUNT(:,:,:) = 0d0 + MOP_CO_CHI_SQ(:,:,:) = 0d0 + MOP_CO_BIAS_SOBS(:,:,:) = 0d0 + MOP_CO_CHI_SQ_SOBS(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + SOBS_ADJ_FORCE(:,:,:) = 0d0 + + IF ( SECOND ) THEN + FILENAME = 'co_bias_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 201, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'co_chi_square_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 202, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lat_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 203, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lon_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 204, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + !================================================================= + ! Loop over MOPITT data + !================================================================= + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + LON15 = LONGITUDE(W) / 15. + UTC = TAU(W) - TAU0 + LON15 + IF (UTC < 0. ) UTC = UTC + 24 + IF (UTC > 24.) UTC = UTC - 24 + + + !Only consider day time MOPITT measurements + ! am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + + ! Get grid box + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + !================================================================= + ! Data selection + !================================================================= + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & CLOUD_DES(W) == 2.0 .and. + & CO_TOTAL_COLUMN(1,W) > 5E17 .and. + & DOMAIN_OBS(I,J) == 1 ) THEN + +! IF ( (IS_LAND(I,J) .AND. +! & LATITUDE(W) .GE. -52 .AND. LATITUDE(W) .LE. 52 ) .OR. !52S-52N +! & (LATITUDE(W) .GE. -40 .AND. LATITUDE(W) .LE. 40) ) THEN !40S-40N + + RETLEV(:) = -999.0 + MODEL_COL = 0D0 + MOPITT_COL = 0D0 + + ! Create pressure profile + RETLEV(1) = BOTTOM_PRESSURE(W) + + ZZ = 0 + ! Loop over Mopitt levels + DO Z = 1, Z_DIM + ! Always start from the bottom pressure, + ! even if it means skipping a MOPITT pressure level + IF ( PRESSURE(Z) >= RETLEV(1) ) THEN + ZZ = ZZ + 1 + CYCLE + ENDIF + ! Save into profile + RETLEV(Z+1-ZZ) = PRESSURE(Z) + ENDDO + NLEV_RET = Z_DIM+1 - ZZ + + DO L = 1, NLEV_RET + P_EDGE(L) = RETLEV(L) + ENDDO + P_EDGE(NLEV_RET+1) = 36 + + ALLOCATE( XA( NLEV_RET ) ) + ALLOCATE( T( NLEV_RET ) ) + ALLOCATE( A( NLEV_RET,NLEV_RET ) ) + ALLOCATE( AC( NLEV_RET ) ) + ALLOCATE( MOP_CO( NLEV_RET ) ) + ALLOCATE( GEOS_RAW( NLEV_RET ) ) + ALLOCATE( DIFF_ADJ( NLEV_RET ) ) + ALLOCATE( GEOS_CO( NLEV_RET ) ) + ALLOCATE( DIFF_COST( NLEV_RET ) ) + + ! MOPITT CO vertical profile + MOP_CO(1) = CO_RET_BOT_MIXING_RATIO(1,W) + MOP_CO(2:NLEV_RET) = CO_MIXING_RATIO(1,11-NLEV_RET:9,W) + MOP_CO = MOP_CO * 1E-9 + + ! COMPUTE AVERAGING KERNEL + CALL CALC_AVGKER(NLEV_RET, W, RETLEV, MOP_CO) + + !USE MOPITT SURFACE PRESSURE + !DO L=1, LLPAR + 1 + ! MODEL_P_EDGE(L) = GET_AP(L) + GET_BP(L) * RETLEV(1) + !ENDDO + + DO L = 1, LLPAR + !MOPITT PRESSURE LEVEL + !MODEL_P(L) = (MODEL_P_EDGE(L) + MODEL_P_EDGE(L+1)) / 2 + + ! Get GC pressure levels (mbar) + MODEL_P(L) = GET_PCENTER(I,J,L) + + ! Obtain archieved forward model results + ! kg -> v/v + MODEL_CO_MR(L) = CHK_STT(I,J,L,IDTCO) * + & TCVV(IDTCO) / AD(I,J,L) + ENDDO + + ! Interplote the model to MOPITT vertical grids + CALL BIN_DATA(MODEL_P, P_EDGE, MODEL_CO_MR(:), + & GEOS_RAW, NLEV_RET, 1) + + !================================================================= + ! Apply MOPITT observation operator + !================================================================= + + ! Total Column: C = T * XA + AC * ( Xm - XA ) + ! Stratosphere Levels are removed + !DO L = 1, NLEV_RET + DO L = 1, NLEV_RET - 2 + MODEL_COL = MODEL_COL + & + T(L) * XA(L) + & + AC(L) * (LOG10(GEOS_RAW(L)) + & - LOG10(XA(L))) + !MOPITT_COL = MOPITT_COL + T(L) * MOP_CO(L) + ENDDO + + MOPITT_COL = CO_TOTAL_COLUMN(1,W) + + GEOS_CO(:) = 0d0 + ! Smoothed Profile: X_hat = XA + A * ( Xm - XA ) + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + GEOS_CO(L) = GEOS_CO(L) + & + A(L,LL) + & * (LOG10( GEOS_RAW(LL) ) - LOG10( XA(LL) )) + ENDDO + GEOS_CO(L) = LOG10( XA(L) ) + GEOS_CO(L) + ENDDO + + !================================================================= + ! COST FUNCTION + !================================================================= + !SY = ( ERR_PERCENT(I,J) * MOPITT_COL )**2 + !DIFF_COST = MODEL_COL - MOPITT_COL + !NEW_COST(I,J) = NEW_COST(I,J) + 0.5 * (DIFF_COST ** 2) / SY + !COUNT(I,J) = COUNT(I,J) +1 + DIFF_COST(:) = 0D0 + COST_CONTRIB(:) = 0D0 + SY = ERR_PERCENT(I,J) **2 + DO L = 1, NLEV_RET - 2 + DIFF_COST(L) = GEOS_CO(L) - LOG10( MOP_CO(L) ) + COST_CONTRIB(L) = 0.5d0 * ( DIFF_COST(L)**2 ) / SY + COUNT(I,J) = COUNT(I,J) + 1 + MOP_CO_BIAS(I,J,L) = MOP_CO_BIAS(I,J,L) + + & 10**(GEOS_CO(L)) - MOP_CO(L) + MOP_CO_CHI_SQ(I,J,L) = MOP_CO_CHI_SQ(I,J,L) + + & (DIFF_COST(L))**2/ SY + MOP_BIAS_COUNT(I,J,L) = MOP_BIAS_COUNT(I,J,L) + 1d0 + ENDDO + !================================================================= + ! adjoint operator + !================================================================= + DIFF_ADJ(:) = 0D0 + !DO L = 1, NLEV_RET + !DIFF_ADJ(L) = DIFF_COST * AC(L) / SY + !DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10.0)) + !ENDDO + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + DIFF_ADJ(L) = DIFF_ADJ(L) + & + A(LL,L) * DIFF_COST(LL) / SY + ENDDO + ! fwd code: LOG(GEOS_RAW) - LOG(XA) + ! mkeller: this is just plain wrong! + ! the forward code is LOG10(GEOS_RAW) - LOG10(XA) + ! a factor of 1/LOG(10) is missing + !DIFF_ADJ(L) = DIFF_ADJ(L) / GEOS_RAW(L) + DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10d0)) + ENDDO + + + CALL BIN_DATA( MODEL_P, P_EDGE, ADJ_F, + & DIFF_ADJ, NLEV_RET, -1 ) + + ! adjoint FORCE + DO L = 1, LLPAR + IF (ITS_IN_THE_TROP(I,J,L)) THEN + !v/v->kg + ADJ_FORCE(I,J,L,IDTCO) = ADJ_FORCE(I,J,L,IDTCO) + & + ADJ_F(L) * TCVV(IDTCO)/ AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1 + ENDIF + ENDDO + + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1.d0 + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + MOPITT_COL + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + MODEL_COL + + IF ( ALLOCATED( GEOS_RAW ) ) DEALLOCATE( GEOS_RAW ) + IF ( ALLOCATED( MOP_CO ) ) DEALLOCATE( MOP_CO ) + IF ( ALLOCATED( DIFF_ADJ ) ) DEALLOCATE( DIFF_ADJ ) + IF ( ALLOCATED( A ) ) DEALLOCATE( A ) + IF ( ALLOCATED( AC ) ) DEALLOCATE( AC ) + IF ( ALLOCATED( T ) ) DEALLOCATE( T ) + IF ( ALLOCATED( XA ) ) DEALLOCATE( XA ) + IF ( ALLOCATED( GEOS_CO ) ) DEALLOCATE( GEOS_CO ) + IF ( ALLOCATED( DIFF_COST) ) DEALLOCATE( DIFF_COST) + + !ENDIF !IS_LAND + + ENDIF !OBS_HOUR + + ENDIF !local time + + ENDDO !loop over MOPITT data + + !================================================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !================================================================= + DO I = 1, IIPAR + DO J = 1, JJPAR + + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + !The mean value in the grid + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + & / COUNT_GRID(I,J) + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + & / COUNT_GRID(I,J) + DO L = 1, LLPAR + IF (ITS_IN_THE_TROP(I,J,L)) THEN + COST_FUNC = COST_FUNC + + & NEW_COST(I,J,L)/GC_ADJ_COUNT(I,J,L) + STT_ADJ(I,J,L,IDTCO) = STT_ADJ(I,J,L,IDTCO) + + & ADJ_FORCE(I,J,L,IDTCO)/GC_ADJ_COUNT(I,J,L) + ENDIF + ENDDO + ! Diagnostic stuff: FORCING, MOP_MOD_DIFF, MODEL_BIAS + IF( LDCOSAT )THEN + + CALL SET_FORCING( I, J, DAY_OF_SIM, + & ADJ_FORCE(I,J,1,IDTCO) ) + CALL SET_MOP_MOD_DIFF( I, J, DAY_OF_SIM, + & MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) + + CALL SET_MODEL_BIAS( I, J, DAY_OF_SIM, 1, + & ( MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) / + & MOP_COL_GRID(I,J) ) + CALL SET_MODEL ( I, J, DAY_OF_SIM, 1, + & MODEL_COL_GRID(I,J) ) + CALL SET_OBS ( I, J, DAY_OF_SIM, 1, + & MOP_COL_GRID(I,J) ) + + COST_ARRAY(I,J,DAY_OF_SIM) = + & COST_ARRAY(I,J,DAY_OF_SIM) + NEW_COST(I,J) + + ENDIF + + IF ( IT_IS_NAN( NEW_COST(I,J) ) ) THEN + PRINT*, 'I=', I, 'J=', J + CALL ERROR_STOP( 'NEW_COST is NaN', + & 'CALC_MOPITT_FORCE') + ENDIF + + ENDIF !COUNT_GRID + !DO L=1,NLEV_RET + IF (MOP_BIAS_COUNT(I,J,6) > 0d0) THEN + MOP_CO_BIAS_SOBS(I,J,6) = + & MOP_CO_BIAS(I,J,6)/MOP_BIAS_COUNT(I,J,6) + !PRINT *, "MOP_CO_BIAS", MOP_CO_BIAS_SOBS(I,J,6) + MOP_CO_CHI_SQ_SOBS(I,J,6) = + & MOP_CO_CHI_SQ(I,J,6)/MOP_BIAS_COUNT(I,J,6) + WRITE(201,110) (1e12*MOP_CO_BIAS_SOBS(I,J,6)) + WRITE(202,110) (MOP_CO_CHI_SQ_SOBS(I,J,6)) + WRITE(203,110) (GET_XMID(I)) + WRITE(204,110) (GET_YMID(J)) + ENDIF + !ENDDO + ENDDO + ENDDO + 110 FORMAT(F18.6,1X) + IF (LPRINTFD) THEN + PRINT*, 'IFD, JFD= ', IFD, JFD + PRINT*, 'MODEL_STT:', MODEL_COL_GRID(IFD,JFD) + PRINT*, 'OBS_STT:', MOP_COL_GRID(IFD,JFD) + PRINT*, 'NEW_COST', NEW_COST(IFD,JFD) + PRINT*, 'ADJ_FORCE:', ADJ_FORCE(IFD,JFD,:,IDTCO) + PRINT*, 'STT_ADJ:', STT_ADJ(IFD,JFD,:,IDTCO) + ENDIF + + ! Update cost function + !PRINT*, 'TOTAL NEW_COST = ', SUM(NEW_COST) + !PRINT*, 'COST_FUNC BEFORE ADDING NEW_COST=', COST_FUNC + !COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + !COUNT_TOTAL = COUNT_TOTAL + SUM ( COUNT ) + !PRINT*, 'Total observation number:', COUNT_TOTAL + + ! Return to calling program + END SUBROUTINE CALC_MOPITT_FORCE +!-------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_AVGKER( NLEV_RET, W, RETLEV, MOP_CO ) + +!****************************************************************************** +! SUBROUTINE CALC_AVGKER construct the averging kernel matrix +! (zhe 1/19/11) +!****************************************************************************** + + INTEGER :: ILEV, JLEV, ILEV2, JLEV2, Z, W + INTEGER :: NLEV_RET + REAL*4 :: DELP(NLEV_RET) + REAL*4 :: RETLEV(NLEV_RET) + REAL*8 :: MOP_CO(NLEV_RET) + REAL*8, PARAMETER :: log10e = LOG10(2.71828183) + + !================================================================= + ! CALC_AVGKER begins here! + !================================================================= + + A(:,:) = 0d0 + AC(:) = 0d0 + + XA(1) = CO_MR_AP_BOTTOM(1, W) + XA(2:NLEV_RET) = CO_MR_AP(1,11-NLEV_RET:9,W) + XA = XA * 1E-9 + + !Remove bad levels from averging kernel matrix + IF ( NLEV_RET < 10 ) THEN + DO ILEV = 1, NLEV_RET + ILEV2 = ILEV + ( 10 - NLEV_RET ) + DO JLEV =1, NLEV_RET + JLEV2 = JLEV + ( 10 - NLEV_RET) + A(ILEV,JLEV) = + & AVGKER(ILEV2,JLEV2,W) + ENDDO + ENDDO + ELSE + A(:,:) = AVGKER(:,:,W) + ENDIF + + DELP(1) = RETLEV(1) - RETLEV(2) + DELP(2:NLEV_RET-1) = 100D0 + DELP(NLEV_RET) = 74D0 + + ! transfer function [v/v -> molec/cm2] + T = 2.12E+22 * DELP + + ! Convert to column averaging kernel + DO JLEV = 1, NLEV_RET + DO ILEV = 1, NLEV_RET + AC(JLEV) = AC(JLEV) + DELP(ILEV) * MOP_CO(ILEV) + & * A(ILEV,JLEV) + ENDDO + AC(JLEV) = (2.12E+22 / log10e ) * AC(JLEV) + ENDDO + + + END SUBROUTINE CALC_AVGKER +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_DATA( P_MODEL, P_EDGE, DATA_MODEL, DATA_MOP, + & NLEV_RET, FB ) + +!****************************************************************************** +!Based on the code from Monika. (zhe 1/19/11) +!FB = 1 for forward +!FB = -1 for adjoint +!****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: NLEV_RET, NB + REAL*8 :: P_MODEL(LLPAR) + REAL*8 :: DATA_MODEL(LLPAR), DATA_MOP(NLEV_RET), DATA_TEM + REAL*8 :: P_EDGE(NLEV_RET+1) + + !================================================================= + ! BIN_DATA begins here! + !================================================================= + + IF (FB > 0) THEN + + DO L = 1, NLEV_RET + DO LL = 1, LLPAR + IF ( P_MODEL(LL) <= P_EDGE(L) ) THEN + DATA_MOP(L) = DATA_MODEL(LL) + EXIT + ENDIF + ENDDO + ENDDO + + DO L = 1, NLEV_RET + NB = 0 + DATA_TEM = 0 + DO LL = 1, LLPAR + IF ( ( P_MODEL(LL) <= P_EDGE(L)) .and. + & ( P_MODEL(LL) > P_EDGE(L+1)) ) THEN + DATA_TEM = DATA_TEM + DATA_MODEL(LL) + NB = NB + 1 + ENDIF + ENDDO + IF (NB > 0) DATA_MOP(L) = DATA_TEM / NB + ENDDO + + ELSE + + DATA_MODEL(:) = 0. + DO L = 1, LLPAR + DO LL = 1, NLEV_RET + IF ( ( P_MODEL(L) <= P_EDGE(LL)) .and. + & ( P_MODEL(L) > P_EDGE(LL+1)) ) THEN + DATA_MODEL(L) = DATA_MOP(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_DATA +!----------------------------------------------------------------------------------- + + SUBROUTINE INIT_DOMAIN + +!****************************************************************************** +!Define the observatio region +!****************************************************************************** +# include "CMN_SIZE" ! Size parameters + + !local variables + INTEGER :: I, J + + !================================================================= + ! INIT_DOMAIN begins here! + !================================================================= + + DOMAIN_OBS(:,:) = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined( GRID05x0666 ) +! The surrounding region is used as cushion +! (zhe 11/28/10) + IF ( J >= 8 .and. J <= JJPAR-7 .and. + & I >= 7 .and. I <= IIPAR-6 +#elif defined( GRID2x25 ) + IF ( J >= 16 .and. J <= 76 !60S-60N +#elif defined( GRID4x5 ) + IF ( J >= 9 .and. J <= 39 !60S-60N +#endif + & ) DOMAIN_OBS(I,J) = 1d0 + + ENDDO + ENDDO + + PRINT*, sum(DOMAIN_obs), 'MAX observations today' + + END SUBROUTINE INIT_DOMAIN + +!----------------------------------------------------------------------------- + + SUBROUTINE CALC_OBS_HOUR + +!*************************************************************************** +! Subroutine CALC_OBS_HOUR computes an array of hours for each day of obs. +! If there is an obs in a particular gridbox on that day, it assigns the +! hour (0..23). If there isn't, OBS_HOUR stays initialized to -1. +! (mak, 12/14/05) +!*************************************************************************** + + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, + & GET_YEAR, GET_HOUR + USE GRID_MOD, ONLY : GET_IJ + +# include "CMN_SIZE" + + REAL*4 :: OBS_HOUR(IIPAR,JJPAR) + REAL*8 :: TAU0, UTC + INTEGER :: W, I, J + INTEGER :: LON15, IIJJ(2) + INTEGER :: COUNT_GRID(IIPAR,JJPAR) + + !================================================================= + ! CALC_OBS_HOUR begins here! + !================================================================= + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0(GET_MONTH(), GET_DAY(), GET_YEAR()) + + OBS_HOUR_MOPITT(:,:) = -1 + OBS_HOUR(:,:) = 0 + COUNT_GRID(:,:) = 0 + + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + !============================================================ + LON15 = LONGITUDE(W) / 15d0 + UTC = TAU(W) - TAU0 + LON15 + IF ( UTC < 0d0 ) UTC = UTC + 24 + IF ( UTC > 24d0 ) UTC = UTC - 24 + + !Only consider day time MOPITT measurements + !am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + + ! Get grid box of current record + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + ! If there's an obs, calculate the time + IF ( CO_TOTAL_COLUMN(1,W) > 0d0 ) THEN + + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1d0 + !Add the time of obs, to be averaged and floored later + OBS_HOUR(I,J) = OBS_HOUR(I,J) + MOPITT_GMT(W) + + ENDIF + ENDIF + ENDDO + + ! average obs_hour on the grid + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + OBS_HOUR_MOPITT(I,J) = + & FLOOR( OBS_HOUR(I,J) / COUNT_GRID(I,J) ) + + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CALC_OBS_HOUR + +!---------------------------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_MOPITT_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_MOPITT_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day) based on +! the OBS_HOUR_MOPITT array which holds the hour of obs in each gridbox +! (computed when file read in mop02_mod.f) (mak, 7/12/07) +!****************************************************************************** + + USE TIME_MOD, ONLY : GET_HOUR, GET_MINUTE + +# include "CMN_SIZE" ! Size params + + ! Function value + LOGICAL :: FLAG + + INTEGER :: I,J + + !================================================================= + ! ITS_TIME_FOR_MOPITT_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO J = 1,JJPAR + DO I = 1,IIPAR + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & GET_MINUTE() == 0 ) THEN + + PRINT*, 'obs_hour was', get_hour(), 'in box', I, J + FLAG = .TRUE. + + !GOTO 11 + RETURN + + ENDIF + ENDDO + ENDDO + + END FUNCTION ITS_TIME_FOR_MOPITT_OBS + +!---------------------------------------------------------------------------- + + SUBROUTINE READ_MOP02( FILENAME ) + +!****************************************************************************** +! Subroutine READ_MOP02 allocates all module arrays and reads data into +! them from the HDF file. (bmy, 7/2/03, zhe 1/19/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** + + ! References to F90 modules +#if defined( MOPITT_V5_CO_OBS ) + USE HdfSdModule + USE HdfVdModule +#endif + USE BPCH2_MOD, ONLY : GET_TAU0 + USE ERROR_MOD, ONLY : ALLOC_ERR + + ! Local variables + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + INTEGER :: as, i, year, month, day + REAL*8 :: TAU0 + +#if defined( MOPITT_V5_CO_OBS ) + INTEGER :: sId, vId, vSize, nDims, dims(4) +#endif +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + INTEGER :: he5_swopen, he5_swattach, he5_swfldinfo, + & he5_swrdfld, he5_swdetach, he5_swclose + + INTEGER :: N, fId, swathid, rank + INTEGER :: ntype(4) + INTEGER*8 :: dims8(4) + INTEGER*8 :: START1(1), STRIDE1(1), EDGE1(1) + INTEGER*8 :: START2(2), STRIDE2(2), EDGE2(2) + INTEGER*8 :: START3(3), STRIDE3(3), EDGE3(3) + INTEGER, PARAMETER :: HE5F_ACC_RDONLY=101 + character*72 dimlist, maxdimlist + +#endif + + !================================================================= + ! Mop02Read begins here! + !================================================================= + + ! Deallocate arrays + CALL CLEANUP_MOP02 + + ! Get date from filename (next to the '-' character) + i = INDEX( FILENAME, '-' ) + READ( FILENAME(i+1:i+4), '(i4)' ) year + READ( FILENAME(i+5:i+6), '(i2)' ) month + READ( FILENAME(i+7:i+8), '(i2)' ) day + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0( month, day, year ) + +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + ! Opening an HDF-EOS5 swath file + fId = he5_swopen(FILENAME, HE5F_ACC_RDONLY) + + ! Attaching to a swath object + swathid = he5_swattach(fId, 'MOP02' ) + + !================================================================= + ! Seconds in day (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SecondsinDay", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SecondsinDay', + & START1, STRIDE1, EDGE1, SECONDS_IN_DAY) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = dims8(1) + + !================================================================= + ! LONGITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Longitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LONGITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Longitude', + & START1, STRIDE1, EDGE1, LONGITUDE) + + !================================================================= + ! LATITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Latitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LATITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Latitude', + & START1, STRIDE1, EDGE1, LATITUDE) + + !================================================================= + ! PRESSURE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Pressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Pressure', + & START1, STRIDE1, EDGE1, PRESSURE) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = dims8(1) + + !================================================================= + ! Cloud Description (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "CloudDescription", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CLOUD_DES( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'CloudDescription', + & START1, STRIDE1, EDGE1, CLOUD_DES) + + !================================================================= + ! Surface Index (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfaceIndex", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(SURFACE_INDEX( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfaceIndex', + & START1, STRIDE1, EDGE1, SURFACE_INDEX) + + !================================================================= + ! Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfacePressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(BOTTOM_PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfacePressure', + & START1, STRIDE1, EDGE1, BOTTOM_PRESSURE) + + !================================================================= + ! CO Mixing Ratio (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims8(1), dims8(2), dims8(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MIXING_RATIO) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_RET_BOT_MIXING_RATIO) + + !================================================================= + ! CO Total Column (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOTotalColumn", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOTotalColumn', + & START2, STRIDE2, EDGE2, CO_TOTAL_COLUMN) + + !================================================================= + ! Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievalAveragingKernelMatrix", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( AVGKER( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievalAveragingKernelMatrix', + & START3, STRIDE3, EDGE3, AVGKER) + + !================================================================= + ! A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MR_AP) + + !================================================================= + ! A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims8(1), dims8(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_MR_AP_BOTTOM) + + ! Detaching from the swath object + as = he5_swdetach(swathid) + + ! Closing the file + as = he5_swclose(fId) + + +#endif !MOPITT v6 + +#if defined( MOPITT_V5_CO_OBS ) + + ! Open file for HDF-VDATA interface + CALL vdOpen( FILENAME ) + + !================================================================= + ! VDATA field: Time (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Seconds in Day', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + ! Read data + CALL vdGetData( vId, vSize, SECONDS_IN_DAY ) + + ! Close field + CALL vdCloseField( vId ) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = vSize + + !================================================================= + ! VDATA field: LONGITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Longitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LONGITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LONGITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: LATITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Latitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LATITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LATITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Cloud Description (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Cloud Description', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( CLOUD_DES( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + ! Read data + CALL vdGetData( vId, vSize, CLOUD_DES ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Surface Index (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Index', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( SURFACE_INDEX( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + ! Read data + CALL vdGetData( vId, vSize, SURFACE_INDEX ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: PRESSURE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Pressure Grid', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = vSize + + !================================================================= + ! VDATA field: Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Pressure', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( BOTTOM_PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, BOTTOM_PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Close HDF-VDATA interface + CALL vdClose( FILENAME ) + + + + ! Open file for HDF-SDATA interface + CALL sdOpen( FILENAME ) + + !================================================================= + ! SDATA field: CO Mixing Ratio (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims(1), dims(2), dims(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), + & CO_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_RET_BOT_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Total Column (2-D) + !================================================================= + + ! Open field + + CALL sdOpenFieldByName( 'Retrieved CO Total Column', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_TOTAL_COLUMN ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieval Averaging Kernel Matrix', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( AVGKER( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), AVGKER ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), CO_MR_AP ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims(1), dims(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_MR_AP_BOTTOM ) + + ! Close field + CALL sdCloseField( sId ) + + ! Close file and quit + CALL sdClose( FILENAME ) + +#endif !MOPITT v5 + + ! Return to calling program + END SUBROUTINE READ_MOP02 + +!------------------------------------------------------------------------------------ + + SUBROUTINE READ_ERROR_VARIANCE +! +!****************************************************************************** +! Subroutine READ_ERROR_VARIANCE reads observation error from binary punch files +! (zhe 4/20/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE TIME_MOD, ONLY : GET_TAUb + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_ERROR_VARIANCE begins here! + !================================================================= + + ! Filename + FILENAME = TRIM( 'OBS_ERR_' ) // GET_RES_EXT() + + ! Echo some information to the standard output + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_ERROR_VARIANCE: Reading ERR_PERCENT + & from: ', a ) + + ! Read data from the binary punch file + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & GET_TAUb(), IGLOB, JGLOB, + & 1, ERR_PERCENT, QUIET=.TRUE. ) + + ! Return to calling program + END SUBROUTINE READ_ERROR_VARIANCE + +!------------------------------------------------------------------------------ + + SUBROUTINE INFO_MOP02( FILENAME ) +! +!****************************************************************************** +! Subroutine INFO_MOP02 Info prints info about all VDATA and SDATA fields +! contained within the MOPITT HDF file. (bmy, 7/3/03, 4/27/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE HdfSdModule + USE HdfVdModule + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + + !================================================================= + ! INFO_MOP02 begins here! + !================================================================= + + ! Print HDF-VDATA variables + CALL vdOpen( FILENAME ) + CALL vdPrintInfo + CALL vdClose( FILENAME ) + + ! Print HDF-SDATA variables + CALL sdOpen( FILENAME ) + CALL sdPrintInfo + CALL sdClose( FILENAME ) + + ! Return to calling program + END SUBROUTINE INFO_MOP02 + +!----------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_MOP02 +! +!****************************************************************************** +! Subroutine CLEANUP_MOP02 deallocates all module arrays (bmy, 4/27/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_MOP02 begins here! + !================================================================= + IF ( ALLOCATED( LATITUDE ) ) DEALLOCATE( LATITUDE ) + IF ( ALLOCATED( LONGITUDE ) ) DEALLOCATE( LONGITUDE ) + IF ( ALLOCATED( PRESSURE ) ) DEALLOCATE( PRESSURE ) + IF ( ALLOCATED( CLOUD_DES ) ) DEALLOCATE( CLOUD_DES ) + IF ( ALLOCATED( SURFACE_INDEX ) ) DEALLOCATE( SURFACE_INDEX ) + IF ( ALLOCATED( TAU ) ) DEALLOCATE( TAU ) + IF ( ALLOCATED( SECONDS_IN_DAY ) ) DEALLOCATE( SECONDS_IN_DAY ) + IF ( ALLOCATED( MOPITT_GMT ) ) DEALLOCATE( MOPITT_GMT ) + IF ( ALLOCATED( BOTTOM_PRESSURE ) ) DEALLOCATE( BOTTOM_PRESSURE ) + IF ( ALLOCATED( CO_MIXING_RATIO ) ) DEALLOCATE( CO_MIXING_RATIO ) + + IF ( ALLOCATED( CO_RET_BOT_MIXING_RATIO)) THEN + DEALLOCATE( CO_RET_BOT_MIXING_RATIO ) + ENDIF + + IF ( ALLOCATED( CO_TOTAL_COLUMN ) ) DEALLOCATE( CO_TOTAL_COLUMN ) + IF ( ALLOCATED( AVGKER ) ) DEALLOCATE( AVGKER ) + IF ( ALLOCATED( PLEV_AP ) ) DEALLOCATE( PLEV_AP ) + IF ( ALLOCATED( CO_MR_AP ) ) DEALLOCATE( CO_MR_AP ) + IF ( ALLOCATED( CO_MR_AP_BOTTOM ) ) DEALLOCATE( CO_MR_AP_BOTTOM ) + + ! Return to calling program + END SUBROUTINE CLEANUP_MOP02 + +!--------------------------------------------------------------------------------------------------- + + + END MODULE MOPITT_OBS_MOD diff --git a/code/obs_operators/avg_osiris_obs_mod.f90 b/code/obs_operators/avg_osiris_obs_mod.f90 new file mode 100644 index 0000000..0d0f2e9 --- /dev/null +++ b/code/obs_operators/avg_osiris_obs_mod.f90 @@ -0,0 +1,659 @@ +! $Id: osiris_obs_mod.f,v 1.0 2012/02/23 06:47:07 twalker Exp $ +MODULE OSIRIS_OBS_MOD + +!****************************************************************************** +! Module OSIRIS_OBS_MOD contains subroutines necessary to +! 1. Read OSIRIS (ASCII) file with O3 observations, preprocessed onto model grid +! 2. Determine when OSIRIS O3 obs are available +! 3. Compute adjoint forcing in model space +! +! Module Variables: +! ============================================================================ +! (1 ) OSIRIS_DATA : OSIRIS data pre-averaged onto 4x5 grid +! (2 ) ADJ_FORCE_OSIRIS : Adjoint forcing +! (3 ) LOCATION_DATA : Array of locations and times of observations +! (4 ) FILEDATE : Date associated with file currently read +! (5 ) COUNT_TOTAL : Number of observations +! (6 ) OSIRIS_ERR : OSIRIS error values pre-averaged onto 4x5 grid +! +! Module Routines: +! ============================================================================ +! (1 ) READ_OSIRIS_FILE : Read OSIRIS ASCII file +! (2 ) ITS_TIME_FOR_OSIRIS_OBS : Checks model time +! (3 ) CALC_OSIRIS_FORCE : Calculates cost fnc and ADJ_STT increments +! (4 ) INIT_OSIRIS : Allocates memory of arrays +! (5 ) CLEANUP_OSIRIS : Deallocates memory of arrays +! (6 ) IS_OSIRIS_NONZERO : Determines if OSIRIS observed a grid +! +! ============================================================================ +! NOTES: +! (1 ) Based on obs operators implemented in v8 adjoint. (tww, 20120223) +! +!****************************************************************************** + + IMPLICIT NONE + +#include "CMN_SIZE" ! Size parameters + + ! Everything PRIVATE unless specified otherwise + ! PRIVATE module variables + ! PRIVATE module routines + PRIVATE + + PUBLIC :: READ_OSIRIS_FILE + PUBLIC :: ITS_TIME_FOR_OSIRIS_OBS + PUBLIC :: CALC_OSIRIS_FORCE + PUBLIC :: COUNT_TOTAL + PUBLIC :: IS_OSIRIS_NONZERO + PUBLIC :: CALC_GC_O3 + + REAL*8, ALLOCATABLE :: OSIRIS_DATA(:,:) + REAL*8, ALLOCATABLE :: OSIRIS_ERR(:,:) + REAL*8, ALLOCATABLE :: ADJ_FORCE_OSIRIS(:,:,:) + INTEGER, ALLOCATABLE :: LOCATION_DATA(:,:) + INTEGER, ALLOCATABLE :: TIME_DATA(:) + + INTEGER :: FILEDATE + INTEGER :: NOCC + REAL*8 :: COUNT_TOTAL + INTEGER, PARAMETER :: MAX_OBS_PER_DAY=1000 + +CONTAINS + + +!---------------------------------------------------------------------- + + SUBROUTINE READ_OSIRIS_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_OSIRIS_FILE reads an ASCII file containing OSIRIS data +! for the given day. Data are already averaged onto 4x5 grid, but are given +! every km altitude from 0.5km to 64.5km. (tww, 20120223) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : Hour-Min-Sec +! + + USE DAO_MOD, ONLY : BXHEIGHT + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + +#include "CMN_SIZE" ! size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + CHARACTER(LEN=255) :: DIR_OSIRIS + CHARACTER(LEN=255) :: FILENAME_OSIRIS + CHARACTER(LEN=255) :: FILENAME + + CHARACTER(LEN=*), PARAMETER :: FMT1 = "(I8,I5,I5,I5,F8.2,F8.2,F8.2,I9)" + INTEGER, PARAMETER :: OSIRIS_LVL=65 + + REAL*8 :: TEMPALT(OSIRIS_LVL) + REAL*8 :: TEMPO3DATA(OSIRIS_LVL) + REAL*8 :: TEMPO3ERR(OSIRIS_LVL) + REAL*8 :: TEMPLAT, TEMPLON, TEMPH, Z1, Z2 + INTEGER :: IU_FILE, IOS + INTEGER :: NOBS, I, J, L, K + INTEGER :: OCCID, OLMAX, LATIND, LONIND + INTEGER :: TEMPYMD + INTEGER :: NDAT + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=255) :: FILENAME_DIAG + + + !================================================================= + ! READ_OSIRIS_FILE begins here! + !================================================================= + + !============================= + ! FIRST CLEANUP IF NECESSARY: + !============================= + CALL CLEANUP_OSIRIS + CALL INIT_OSIRIS + + IF ( FIRST ) THEN + COUNT_TOTAL = 0 + + FILENAME_DIAG = 'lat_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 405, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME_DIAG = 'lon_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 406, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FIRST = .FALSE. + ENDIF + + !======================== + ! FILENAME + !========================= + + DIR_OSIRIS = '/users/jk/15/xzhang/OSIRIS_O3/' + FILENAME_OSIRIS = TRIM( 'OSIRIS_507_4x5_YYYYMMDD_O3.data' ) + ! FILENAME_OSIRIS = TRIM( 'osiristestfile_YYYYMMDD.data' ) + IU_FILE = 15 + ! EXPAND_DATE replaces tokens like 'YYYY' with the year + CALL EXPAND_DATE( FILENAME_OSIRIS, YYYYMMDD, HHMMSS ) + FILENAME = TRIM( DIR_OSIRIS ) // FILENAME_OSIRIS + + WRITE(6,*) ' - READ_OSIRIS_FILE: reading: ', FILENAME + + NOCC = 0 + + ! Open file + OPEN( IU_FILE, FILE=FILENAME, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:1' ) + + !======================== + ! Read in data blocks + !======================== + ! Needs to be true until end of file + DO I = 1, MAX_OBS_PER_DAY + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:2' ) + + ! Read meta data line (OCCID, RETLVLS, LONIND, + ! LATIND, LON, LAT, HH, YMD) + READ( IU_FILE, FMT1, IOSTAT=IOS) OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:3' ) + + !DEBUG, tww + !print*, 'METADATA is: ', OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + LOCATION_DATA(I,1) = LONIND + LOCATION_DATA(I,2) = LATIND + TIME_DATA(I) = FLOOR(TEMPH)*10000d0 + + ! Read altitude, ozone and error profiles + READ( IU_FILE, * )(TEMPALT(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3DATA(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3ERR(K), K=1,OLMAX) + + ! OSIRIS data comes every km + ! Compute average of data on each GEOS-Chem vertical level + Z1 = 0d0 + Z2 = 0d0 + DO L = 1, LLPAR + Z1 = Z2 + Z2 = Z1 + BXHEIGHT(LONIND,LATIND,L)/1000d0 + NDAT = 0 + DO K = 1, OSIRIS_LVL + IF (TEMPALT(K) > Z1 .AND. TEMPALT(K) <=Z2) THEN + IF (TEMPO3DATA(K)>0d0) THEN + OSIRIS_DATA( I, L ) = OSIRIS_DATA( I, L ) + TEMPO3DATA( K ) + OSIRIS_ERR( I, L ) = OSIRIS_ERR( I, L ) + TEMPO3ERR( K ) ** 2 + NDAT = NDAT + 1 + ENDIF + ELSEIF (TEMPALT(K) > Z2) THEN + EXIT + ENDIF + ENDDO + IF (NDAT>0) THEN + OSIRIS_DATA(I,L) = OSIRIS_DATA(I,L)/NDAT + OSIRIS_ERR(I,L) = SQRT(OSIRIS_ERR(I,L))/NDAT + ENDIF + ENDDO + + NOCC = NOCC + 1 + !debug, tww + !print*, 'o3data read: ', TEMPO3DATA + !print*, 'o3err read: ', TEMPO3ERR + WRITE(405,118) ( TEMPLAT ) + WRITE(406,118) ( TEMPLON ) +118 FORMAT(F18.6,1X) + ENDDO + + FILEDATE = TEMPYMD !- 10000 + + ! Close file + CLOSE( IU_FILE ) + + ! DEBUG, tww + !print*, 'FINISHED READING OSIRIS FILE' + !print*, 'NOCC = ', NOCC + !print*, 'FILEDATE = ', FILEDATE + !print*, 'LOCATIONS = ', LOCATION_DATA + !print*, 'TIMES = ', TIME_DATA + !print*, 'OSIRIS_DATA = ', OSIRIS_DATA(1:3,:) + !print*, 'OSIRIS_ERR = ', OSIRIS_ERR(1:3,:) + + END SUBROUTINE READ_OSIRIS_FILE + + +!---------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_OSIRIS_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_OSIRIS_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day). (tww, 20120223) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + INTEGER :: N + + !================================================================= + ! ITS_TIME_FOR_OSIRIS_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + ! Observation times on this day are stored in TIME_DATA + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + ! DEBUG + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found at: ',N + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found: ', GET_NHMS() + FLAG = .TRUE. + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', FILEDATE + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION ITS_TIME_FOR_OSIRIS_OBS + + +!---------------------------------------------------------------------- + + FUNCTION IS_OSIRIS_NONZERO( I,J,L ) RESULT ( FLAG ) + +!****************************************************************************** +! Function IS_OSIRIS_NONZERO returns TRUE if there are observations +! available for particular location. (tww, 20120229) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + ! Arguments + INTEGER :: I, J, L + + INTEGER :: N + + !================================================================= + ! IS_OSIRIS_NONZERO begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + IF ( ( LOCATION_DATA(N,1)==I ) .AND. & + ( LOCATION_DATA(N,2)==J ) .AND. & + ( OSIRIS_DATA(N,L) > 0 )) THEN + WRITE(6,*) 'IS_OSIRIS_NONZERO - yes, at: ', I, J, L + FLAG = .TRUE. + ENDIF + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', FILEDATE + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION IS_OSIRIS_NONZERO + + +!---------------------------------------------------------------------- + + SUBROUTINE CALC_OSIRIS_FORCE( COST_FUNC ) + +!****************************************************************************** +! Subroutine CALC_OSIRIS_FORCE (tww, 20120223) +! + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE TIME_MOD, ONLY : GET_NHMS + USE TRACERID_MOD, ONLY : IDTOX + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Parameters + REAL*8, PARAMETER :: ADJ_TCVVOX = 28.97d0/48.d0 + + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PRES(LLPAR), DIFF(LLPAR) + REAL*8 :: OBS_ERRCOV(LLPAR) + REAL*8 :: GC_O3(LLPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR), COST_CONT(LLPAR) + INTEGER :: I, J, L, N + INTEGER :: THISYMD + + LOGICAL :: SUPER_OBS = .TRUE. + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'gc_press_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 401, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 402, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 403, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_adj_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 404, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'obs_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 409, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'err_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 412, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'cfn_l_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 413, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ENDIF + + !================================================================ + ! CALC_OSIRIS_FORCE begins here! + !================================================================ + +! this comes from old CALC_ADJ_FORCE, same for v7 and v8 (tww, 20101027) + + ! Initialize to be safe + NEW_COST(:,:,:) = 0d0 + SOBS_COUNT(:,:) = 0d0 + SOBS_ADJ_FORCE(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + + + + + DO N = 1, NOCC + + DIFF(:) = 0d0 + OBS_ERRCOV(:) = 0d0 + GC_PRES(:) = 0d0 + GC_O3(:) = 0d0 + GC_STT_ADJ(:) =0d0 + COST_CONT = 0d0 + + ! Only get obs at this time + IF( TIME_DATA(N) == GET_NHMS() ) THEN + + I = LOCATION_DATA(N,1) + J = LOCATION_DATA(N,2) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ! DEBUG, tww + !print*, 'ADDING FORCING AT: ', I, J, L + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + ! Make sure data and error are not zero or fill + IF( ( OSIRIS_DATA(N,L) > 0d0 ) .AND. & + ( OSIRIS_ERR(N,L) > 0d0 ) ) THEN + ! Only force below level 40 (about 25km) + ! Try without this condition (tww, 20120317) + !IF( L < 40 ) THEN + ! Condition data with very small errors + ! errors smaller than 1% on a single obs are removed + + IF( OSIRIS_DATA(N,L) < 100d0 * OSIRIS_ERR(N,L) ) THEN + ! CHK_STT is in units of [kg/box] here. Convert to ppb + DIFF(L) = ( GC_O3(L) - OSIRIS_DATA(N,L) * 1d9 ) + + ! Get obs error covariance + OBS_ERRCOV(L) = OSIRIS_ERR(N,L) * OSIRIS_ERR(N,L) * 1d18 + + COST_CONT(L) = 0.5d0 * (DIFF(L) ** 2)/ OBS_ERRCOV(L) + ! Calculate new additions to cost function + IF ( ( COST_CONT(L) > 0d0) .AND. & + ( GET_PCENTER(I,J,L) < 300d0) ) THEN + NEW_COST(I,J,L) = NEW_COST(I,J,L) + COST_CONT(L) + + ! Force the adjoint variables x with dJ/dx + ! Change to get units right [kg/box] + ADJ_FORCE_OSIRIS(I,J,L) = DIFF(L) / OBS_ERRCOV(L) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + ADJ_FORCE_OSIRIS(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + ADJ_FORCE_OSIRIS(I,J,L) + ENDIF + ENDIF + ELSE + !print*, 'removed outlier at ', N, L + !print*, 'outlier is ', OSIRIS_DATA(N,L) + !print*, 'outlier error is ', OSIRIS_ERR(N,L) + ENDIF + !ENDIF + ENDIF + + ENDDO + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + !WRITE(6,102) (DIFF(L), L=LLPAR,1,-1) +102 FORMAT(1X,d14.6) + !WRITE(401,110) ( GC_PRES(L), L=LLPAR,1,-1 ) + !WRITE(402,110) ( DIFF(L), L=LLPAR,1,-1 ) + !WRITE(403,110) ( GC_O3(L), L=LLPAR,1,-1 ) + !WRITE(404,110) ( GC_STT_ADJ(L), L=LLPAR,1,-1 ) + !WRITE(409,110) ( OSIRIS_DATA(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(412,110) ( OSIRIS_ERR(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(413,110) ( COST_CONT(L), L=LLPAR,1,-1 ) + +110 FORMAT(F18.6,1X) + ENDIF + ENDDO + IF (SUPER_OBS) THEN + DO I=1,IIPAR + DO J=1,JJPAR + IF ( SOBS_COUNT(I,J) > 0d0 ) THEN + DO L=1,LLPAR + IF ( ( GET_PCENTER(I,J,L) < 300d0 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0d0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + COST_FUNC = COST_FUNC + NEW_COST(I,J,L)/GC_ADJ_COUNT(I,J,L) + ENDIF + + ENDDO + !COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ELSE + WRITE(6,*) ' CALC_OSIRIS_FORCE: NEW_COST = ', SUM( NEW_COST(:,:,:)) + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST(:,:,:) ) + COUNT_TOTAL = COUNT_TOTAL + SUM (SOBS_COUNT(:,:) ) + print*, ' Total observation number = ', COUNT_TOTAL + ENDIF + ! dkh debug + !print*, ' CHK_STT = ', CHK_STT(25,35,1:8,IDTOX) + !print*, ' AD = ', AD(25,35,1:8) + !print*, ' OSIRIS_DATA = ', OSIRIS_DATA(25,35,1:8) + !print*, ' OSIRIS_ERR = ', OSIRIS_ERR(25,35,1:8) + !print*, ' NEW_COST = ', NEW_COST(25,35,1:8) + + ! Error check + IF ( IT_IS_NAN( COST_FUNC ) ) THEN + CALL ERROR_STOP( 'COST_FUNC IS NaN', 'CALC_OSIRIS_FORCE') + ENDIF + + END SUBROUTINE CALC_OSIRIS_FORCE + + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_OSIRIS +! +!***************************************************************************** +! Subroutine INIT_OSIRIS allocates all module arrays. (dkh, 11/16/06) +! +! NOTES: +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +#include "CMN_SIZE" ! IIPAR, JJPAR, LLPAR + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_OSIRIS begins here + !================================================================= + ALLOCATE( LOCATION_DATA( MAX_OBS_PER_DAY, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOCATION_DATA' ) + LOCATION_DATA = 0 + + ALLOCATE( TIME_DATA( MAX_OBS_PER_DAY ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TIME_DATA' ) + TIME_DATA = 0 + + ALLOCATE( OSIRIS_DATA( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_DATA' ) + OSIRIS_DATA = 0d0 + + ALLOCATE( OSIRIS_ERR( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_ERR' ) + OSIRIS_ERR = 0d0 + + ALLOCATE( ADJ_FORCE_OSIRIS( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_FORCE_OSIRIS' ) + ADJ_FORCE_OSIRIS = 0d0 + + FILEDATE = 0 + NOCC = 0 + + END SUBROUTINE INIT_OSIRIS + + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_OSIRIS + +!****************************************************************************** +! Deallocate all memory (done before reading each monthly file) +! + + ! Deallocate + IF ( ALLOCATED( LOCATION_DATA ) ) DEALLOCATE( LOCATION_DATA ) + IF ( ALLOCATED( TIME_DATA ) ) DEALLOCATE( TIME_DATA ) + IF ( ALLOCATED( OSIRIS_DATA ) ) DEALLOCATE( OSIRIS_DATA ) + IF ( ALLOCATED( OSIRIS_ERR ) ) DEALLOCATE( OSIRIS_ERR ) + IF ( ALLOCATED( ADJ_FORCE_OSIRIS ) ) DEALLOCATE( ADJ_FORCE_OSIRIS ) + + END SUBROUTINE CLEANUP_OSIRIS + +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------------- + + SUBROUTINE CALC_GC_O3 + +!! +!! Subroutine CALC_OMI_O3_FORCE computes the O3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE TIME_MOD, ONLY : GET_HOUR + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TRACER_MOD, ONLY : TCVV + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,L + + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_O3(LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'stt_o3_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 407, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + GC_HOUR = GET_HOUR() + GC_O3 = 0d0 + + DO I = 1, IIPAR + DO J = 1, JJPAR + GC_O3 = 0d0 + DO L = 1, LLPAR + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) * 1d9 + ENDDO + !WRITE(407,117) ( GC_O3(L), L=LLPAR,1,-1 ) +117 FORMAT(F18.6,1X) + ENDDO + ENDDO + + END SUBROUTINE CALC_GC_O3 + +!--------------------------------------------------------------------------------------------------------------------------- + +END MODULE OSIRIS_OBS_MOD diff --git a/code/obs_operators/findinv.f b/code/obs_operators/findinv.f new file mode 100644 index 0000000..8ace084 --- /dev/null +++ b/code/obs_operators/findinv.f @@ -0,0 +1,109 @@ +!Subroutine to find the inverse of a square matrix +!Author : Louisda16th a.k.a Ashwith J. Rego +!Reference : Algorithm has been well explained in: +!http://math.uww.edu/~mcfarlat/inverse.htm +!http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html + SUBROUTINE FINDInv(matrix, inverse, n, errorflag) + + IMPLICIT NONE + + !Declarations + INTEGER, INTENT(IN) :: n + INTEGER, INTENT(OUT) :: errorflag !Return error status. + !-1 for error, 0 for normal + REAL, INTENT(IN), DIMENSION(n,n) :: matrix !Input matrix + REAL, INTENT(OUT), DIMENSION(n,n) :: inverse !Inverted matrix + + LOGICAL :: FLAGr, FLAGc + INTEGER :: i, j, k, l + REAL :: m + REAL, DIMENSION(n,2*n) :: augmatrix !augmented matrix + + !Augment input matrix with an identity matrix + DO i = 1, n + DO j = 1, 2*n + IF (j <= n ) THEN + augmatrix(i,j) = matrix(i,j) + ELSE IF ((i+n) == j) THEN + augmatrix(i,j) = 1 + ELSE + augmatrix(i,j) = 0 + ENDIF + END DO + END DO + !Ensure diagonal elements are non-zero + DO k = 1, n-1 + DO j = k+1,n + IF (augmatrix(k,k) == 0) THEN + DO i = k+1, n + IF (augmatrix(i,k) /= 0) THEN + DO l = 1, 2* n + augmatrix(k,l) = augmatrix(k,l)+augmatrix(i,l) + END DO + ENDIF + END DO + ENDIF + END DO + END DO + + !Augment input matrix with an identity matrix + DO i = 1, n + DO j = 1, 2*n + IF (j <= n ) THEN + augmatrix(i,j) = matrix(i,j) + ELSE IF ((i+n) == j) THEN + augmatrix(i,j) = 1 + ELSE + augmatrix(i,j) = 0 + ENDIF + END DO + END DO + !Ensure diagonal elements are non-zero + + !Reduce augmented matrix to upper traingular form + DO k =1, n-1 + DO j = k+1, n + m = augmatrix(j,k)/augmatrix(k,k) + DO i = k, 2*n + augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i) + END DO + END DO + END DO + + !Test for invertibility + DO i = 1, n + IF (augmatrix(i,i) == 0) THEN +!!! PRINT*, "Matrix is non - invertible" + inverse = 0 + errorflag = -1 + return + ENDIF + END DO + + !Make diagonal elements as 1 + DO i = 1 , n + m = augmatrix(i,i) + DO j = i , (2 * n) + augmatrix(i,j) = (augmatrix(i,j) / m) + END DO + END DO + + !Reduced right side half of augmented matrix to identity matrix + DO k = n-1, 1, -1 + DO i =1, k + m = augmatrix(i,k+1) + DO j = k, (2*n) + augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m + END DO + END DO + END DO + + !store answer + DO i =1, n + DO j = 1, n + inverse(i,j) = augmatrix(i,j+n) + END DO + END DO + errorflag = 0 + + END SUBROUTINE FINDinv diff --git a/code/obs_operators/gaussj.f b/code/obs_operators/gaussj.f new file mode 100644 index 0000000..5279865 --- /dev/null +++ b/code/obs_operators/gaussj.f @@ -0,0 +1,152 @@ + SUBROUTINE gaussj( IA, NA, NB, A, B, SINGLR, FAIL, ERRMSG ) +C +C VERSION +C 10-JAN-94 RJW Remove non-ANSI common block WORKER +C 18-JAN-90 RJW Increased IAMAX to 200 +C 08-JUN-89 AD +C +C DESCRIPTION +C General Purpose Matrix routine. +C Invert Matrix A: B = A**-1 +C Using A as the output matrix is also possible: A = A**-1 +C This routine uses Gauss-Jordan Elimination with full pivoting, based on +C the routine GAUSSJ given on pp 28-29 of Numerical Recipes. +C This routine is no quicker than using MTXLEQ but saves having to construct +C an Identity matrix. +C There is probably scope for some more optmisation in this routine. +C +C Ref: Numerical Recipes (Press et al.) + IMPLICIT NONE +C +C ARGUMENTS + INTEGER IA ! I order of matrix A + INTEGER NA ! I 1st index of A as declared externally + INTEGER NB ! I 1st index of B as declared externally + REAL*8 A(NA,IA) ! I + REAL*8 B(NB,IA) ! I Note: NA,NB >= IA is required + LOGICAL SINGLR ! O Set TRUE if A is singular + LOGICAL FAIL ! O Set TRUE if a Fatal Error is detected + CHARACTER*80 ERRMSG ! O Error message written if FAIL is TRUE +C +C LOCAL CONSTANTS + INTEGER IAMAX ! Largest expected value of IA + PARAMETER ( IAMAX = 3000 ) +C +C LOCAL VARIABLES + INTEGER IPIV(IAMAX) ! Workspace + INTEGER INDXR(IAMAX) + INTEGER INDXC(IAMAX) + INTEGER I, J, K ! counters + INTEGER IROW, ICOL ! store pivot row/column + REAL*4 BIG, DUM, PIVINV +C + 1000 FORMAT ( A, I11, A, I11 ) +C +C- EXECUTABLE CODE ------------------------------------------------------------ +C + +C Initialise B + DO I = 1, NB + DO J = 1, IA + B(I,J) = 0.0 + ENDDO + ENDDO + +C Check parameters + IF ( IA .GT. IAMAX ) THEN ! Matrix A too large + WRITE ( ERRMSG, 1000 ) + & 'F-MTXINV: IA =', IA, ' exceeds IAMAX =', IAMAX + FAIL = .TRUE. + RETURN ! Exit with Fatal Error + END IF +C + IF ( IA .GT. NA ) THEN ! Inconsistent parameters + WRITE ( ERRMSG, 1000 ) + & 'F-MTXINV: IA =', IA, ' exceeds NA =', NA + FAIL = .TRUE. + RETURN ! Exit with Fatal Error + END IF +C + FAIL = .FALSE. ! no further Fatal errors, only singular matrices + SINGLR = .FALSE. ! set TRUE if a Singular Matrix is detected +C + DO I = 1, IA + DO J = 1, IA + B(J,I) = A(J,I) ! copy matrix A to B (may not be necessary here?) + END DO + IPIV (I) = 0 + IF (B(I,I) .EQ. 0.0) THEN + PRINT *, 'B EQ TO ZERO IN INPUT!!',I,B(I,I) +! STOP 'B ZERO' + ENDIF + END DO + +C + DO I = 1, IA ! Main loop over columns to be reduced + BIG = 0.0 + DO J = 1, IA ! Outer loop of search for a pivot element + IF ( IPIV(J) .NE. 1 ) THEN + DO K = 1, IA + IF ( IPIV(K) .EQ. 0 ) THEN + IF ( ABS(B(J,K)) .GE. BIG ) THEN + BIG = ABS(B(J,K)) + IROW = J + ICOL = K + END IF + ELSE IF ( IPIV(K) .GT. 1 ) THEN + print*,'SING 1!' + SINGLR = .TRUE. + RETURN ! Exit for Singular Matrix + END IF + END DO + END IF + END DO + IPIV(ICOL) = IPIV(ICOL) + 1 +C + IF ( IROW .NE. ICOL ) THEN +C got pivot element so interchange rows if reqd to put pivot on diagonal + DO J = 1, IA + DUM = B(IROW,J) + B(IROW,J) = B(ICOL,J) + B(ICOL,J) = DUM +c print *, 'irow,icol, j, b(irow,j),b(icol,j)',irow,icol, j, +c & b(irow,j),b(icol,j) + END DO + END IF + INDXR(I) = IROW + INDXC(I) = ICOL + IF ( B(ICOL,ICOL) .EQ. 0.0 ) THEN + print*,'SING 2!' + SINGLR = .TRUE. + RETURN ! Exit for Singular Matrix + END IF + + + PIVINV = 1.0/B(ICOL,ICOL) ! Now divide pivot row by pivot element + B(ICOL,ICOL) = 1.0 + DO J = 1, IA + B(ICOL,J) = B(ICOL,J)*PIVINV + END DO + DO J = 1, IA ! Reduce Rows except for pivot row + IF ( J .NE. ICOL ) THEN + DUM = B(J,ICOL) + B(J,ICOL) = 0.0 + DO K = 1, IA + B(J,K) = B(J,K)-B(ICOL,K)*DUM + END DO + END IF + END DO + END DO ! end of loop over column reduction +C + DO J = IA, 1, -1 ! unscramble column changes + IF ( INDXR(J) .NE. INDXC(J) ) THEN + DO K = 1, IA + DUM = B(K,INDXR(J)) + B(K,INDXR(J)) = B(K,INDXC(J)) + B(K,INDXC(J)) = DUM + END DO + END IF + END DO +C + END + diff --git a/code/obs_operators/geocape_ch4_mod.f b/code/obs_operators/geocape_ch4_mod.f new file mode 100644 index 0000000..e2741b8 --- /dev/null +++ b/code/obs_operators/geocape_ch4_mod.f @@ -0,0 +1,1428 @@ +!$Id: geocape_ch4_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE GEOCAPE_CH4_MOD +! +!****************************************************************************** +! Module GEOCAPE_CH4_MOD for GEO-CAPE CH4 observations. +! By kjw, added adj32_023 (dkh, 02/12/12) +! +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: LLGEOCAPE = 13 + INTEGER, PARAMETER :: MAXGEOCAPE = 639059 + + + ! Record to store information about the new instrument + REAL*8 :: AVGKERNEL( LLGEOCAPE, LLGEOCAPE ) + REAL*8 :: OBSERROR( LLGEOCAPE, LLGEOCAPE ) + REAL*8 :: OBSERROR_INV( LLGEOCAPE, LLGEOCAPE ) + REAL*8 :: TOTERROR_INV( LLGEOCAPE, LLGEOCAPE ) + REAL*8 :: PRESSURE( LLGEOCAPE ) + REAL*8 :: PRESSURE_EDGE( LLGEOCAPE ) + REAL*8 :: RANDNUM( MAXGEOCAPE ) + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_GEOCAPE_INFO +! +!****************************************************************************** +! Subroutine READ_GEOCAPE_INFO reads and stores information about the new +! instrument, specifically AK, pressure levels and error covariance matrices. +! (kjw, 07/24/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHAR) : GEOCAPE filename to read +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_NYMD + + ! Arguments + CHARACTER(LEN=255) :: FILENAME + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + + ! netCDF id's + INTEGER :: NCID, LG, LN + INTEGER :: nobs_id, yyyymmdd_id, hhmmss_id + INTEGER :: qflag_id, xch4_id, ch4ak_id + INTEGER :: ch4pres_id, ch4prior_id + INTEGER :: gcii_id, gcjj_id, gcfrac_id + + ! Loop indexes, and error handling. + INTEGER :: IOS, IU_IN + + + + !================================================================= + ! READ_GEOCAPE_CH4_OBS begins here! + !================================================================= + + ! Initialize module variabl + AVGKERNEL(:,:) = 0d0 + OBSERROR(:,:) = 0d0 + OBSERROR_INV(:,:) = 0d0 + TOTERROR_INV(:,:) = 0d0 + PRESSURE(:) = 0d0 + PRESSURE_EDGE(:) = 0d0 + RANDNUM(:) = 0d0 + + + ! Read and store one variable at a time + + ! ------ Averaging Kernel Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/geocape/' ) // + & 'data/' // TRIM( 'geocape_AK.txt' ) + WRITE(6,*) ' - READ_GEOCAPE_AK: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_avg_kernel:1' ) + + ! Read File and save info into module variable AVGKERNEL(:,:) + DO LN=1,LLGEOCAPE + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) AVGKERNEL(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_GEOCAPE_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_avg_kernel:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/geocape/' ) // + & 'data/' // TRIM( 'geocape_obs_error.txt' ) + WRITE(6,*) ' - READ_GEOCAPE_OBSERROR: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR(:,:) + DO LN=1,LLGEOCAPE + READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) OBSERROR(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_GEOCAPE_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Inverse of Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/geocape/' ) // + & 'data/' // TRIM( 'geocape_obs_error_inv.txt' ) + WRITE(6,*) ' - READ_GEOCAPE_OBSERROR_INV: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR_INV(:,:) + DO LN=1,LLGEOCAPE + READ( IU_IN, '(13F18.6)', IOSTAT=IOS ) OBSERROR_INV(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_GEOCAPE_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + +! ! ------ Total Error Covariance Matrix ------ +! ! Filename to read +! READ_FILENAME = TRIM( '/home/kjw/new_satellites/geocape/' ) // +! & 'data/' // TRIM( 'geocape_total_error_inv.txt' ) +! WRITE(6,*) ' - READ_GEOCAPE_TOTERROR: reading file: ', +! & TRIM(READ_FILENAME) +! +! +! ! Open file +! OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), +! & STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_tot_error:1' ) +! +! ! Read File and save info into module variable OBSERROR(:,:) +! DO LN=1,LLGEOCAPE +! READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) TOTERROR_INV(LN,:) +! +! ! IO status +! IF ( IOS < 0 ) THEN +! WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' +! WRITE( 6, '(a)' ) 'STOP in READ_GEOCAPE_CH4' +! ENDIF +! IF ( IOS > 0 ) THEN +! CALL IOERROR(IOS, IU_IN, 'read_tot_error:2') +! ENDIF +! ENDDO +! +! ! Close file +! CLOSE( IU_IN ) + + + ! ------ Pressure Levels ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/geocape/' ) // + & 'data/' // TRIM( 'geocape_pressure.txt' ) + WRITE(6,*) ' - READ_GEOCAPE_PRESSURE: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_pressure:1' ) + + ! Read File and save info into module variable PRESSURE(:) + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) PRESSURE(:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_GEOCAPE_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_pressure:2') + ENDIF + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Pressure Edges ------ + ! By finite difference on log(pressure) grid + PRESSURE_EDGE(1) = PRESSURE(1) + PRESSURE_EDGE(LLGEOCAPE) = 0. + DO LN=2,LLGEOCAPE-1 + PRESSURE_EDGE(LN) = exp( log(pressure(LN+1)) + + & ( log(PRESSURE(LN)) - log(PRESSURE(LN+1)) ) / 2. ) + ENDDO + + + ! Return to calling program + END SUBROUTINE READ_GEOCAPE_INFO +!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_GEOCAPE_CH4_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_GEOCAPE_CH4_FORCE calculates the adjoint forcing from the GEOCAPE +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER, SAVE :: NT ! # observations processed this day + INTEGER :: LG, LN, LLN, II, JJ, NB, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP, NTh + INTEGER, SAVE :: NTT + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: CH4_PRIOR(IIPAR,JJPAR,LLGEOCAPE) + REAL*4 :: DUMMY_PRIOR(IIPAR,JJPAR,LLGEOCAPE) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GC_CH4_onGEOCAPE(LLGEOCAPE) + REAL*8 :: GC_CH4_onGEOCAPE_OB(LLGEOCAPE) + REAL*8 :: GRIDMAP(LLPAR,LLGEOCAPE) + REAL*8 :: CH4_HAT(LLGEOCAPE) + REAL*8 :: CH4_HAT_OB(LLGEOCAPE) + REAL*8 :: CH4_HAT_ADJ(LLGEOCAPE) + REAL*8 :: CH4_HAT_werr(LLGEOCAPE) + REAL*8 :: CH4_HAT_werr_ADJ(LLGEOCAPE) + REAL*8 :: CH4_PERT(LLGEOCAPE) + REAL*8 :: CH4_PERT_OB(LLGEOCAPE) + REAL*8 :: CH4_PERT_ADJ(LLGEOCAPE) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: DIFF(LLGEOCAPE) + REAL*8 :: FORCE(LLGEOCAPE) + REAL*8 :: DIFF_ADJ(LLGEOCAPE) + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_CH4_onGEOCAPE_ADJ(LLGEOCAPE) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXGEOCAPE) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + ! Variables for FD testing + REAL*8 :: cost_func_pos, cost_func_neg + REAL*8 :: cost_func_0 + REAL*8 :: PERT(LLPAR) + REAL*8 :: ADJ_SAVE(LLPAR) + REAL*8 :: ADJ(LLPAR) + REAL*8 :: FD_CEN(LLPAR) + REAL*8 :: FD_POS(LLPAR) + REAL*8 :: FD_NEG(LLPAR) + REAL*8 :: DOFS + + + !================================================================= + ! CALC_GEOCAPE_CH4_FORCE begins here! + !================================================================= + + NEW_COST(:) = 0d0 + + + ! Open files for output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_nh3_pert.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat_dbl.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + !kjw for testing adjoint of obs operator + FILENAME = 'test_adjoint_obs.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 116, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! Read CH4 data + CALL READ_GEOCAPE_INFO + + ! Initialize counter for total number of observations processed + NTT = 0 + + + FIRST = .FALSE. ! only open files on first call to + ENDIF + + +! ! Open file for this hour's satellite diagnostics +! FILENAME = 'diag_sat.YYYYMMDD.hhmm.NN' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Read "TRUE" state for this time step [kg/box] + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 + FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // + & 'ch4/geocape/' // GET_RES_EXT() // '/adjtmp/' // + & 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + !FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE , QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + ! Read a priori vertical profiles from file + FILENAME = '/home/kjw/new_satellites/geocape/data/' // + & 'geocape_prior.' // GET_RES_EXT() // '.bpch' + XTAU = GET_TAU0( 1, 1, 1985 ) + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IIPAR, JJPAR, + & LLGEOCAPE, DUMMY_PRIOR, QUIET=.TRUE. ) + CH4_PRIOR(:,:,:) = DUMMY_PRIOR(:,:,:) + + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LLNT, IIJJ, I, J, L, LL ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CH4, DIFF ) +!!$OMP+PRIVATE( GC_CH4_NATIVE, CH4_PERT, CH4_HAT, FORCE ) +!!$OMP+PRIVATE( ADJ_GC_CH4_NATIVE, ADJ_GC_CH4 ) +!!$OMP+PRIVATE( ADJ_CH4_PERT, ADJ_CH4_HAT ) +!!$OMP+PRIVATE( ADJ_DIFF ) + + ! If new day of observations initialize count + IF ( GET_NHMS() .EQ. 230000 ) THEN + NT = 0 + + ! ------ Random Numbers ------ + ! Open and read random number file. mean = 0, stddev = 1 + FILENAME = '/home/kjw/new_satellites/geocape/data/' // + & 'randnums/random.YYYYMMDD.txt' + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 0 ) + OPEN( IU_IN, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + DO LG=1,MAXGEOCAPE + READ(IU_IN,'(F13.6)') RANDNUM(LG) + ENDDO + CLOSE(IU_IN) + + ENDIF + + ! Begin counter for number of observations processed this hour + NTh = 0 + + ! Information for spatial criteria for observations + latmin = 40.0 + + ! Determine minimum JJ index over which to look for observations + DO JJ=1, JJPAR-1 + IF ( ( GET_YEDGE(JJ) .LE. latmin ) .AND. + & ( GET_YEDGE(JJ+1) .GT. latmin ) ) THEN + JMIN = JJ + Jfrac_min = ( GET_YEDGE(JJ+1) - latmin ) / + & ( GET_YEDGE(JJ+1) - GET_YEDGE(JJ) ) + ENDIF + ENDDO + + print*, ' - CALC_GEOCAPE_CH4_FORCE ', GET_NYMD(), GET_NHMS() + + + ! Loop over each grid box north of the minimum latitude + ! 1. Determine number of observations in the current grid box + ! 2. Make obseravations + DO II = 1, IIPAR + + ! If not 1400 <= local time < 1500, cycle to next II value + IF ( ( GET_LOCALTIME( II ) .LT. 14.00 ) .OR. + & ( GET_LOCALTIME( II ) .GE. 15.00 ) ) CYCLE + + ! It is 1400-1500 local time, so let's make observations! + DO JJ = JMIN, JJPAR + + ! For safety, initilize these variables + nobs = 0 + cloud_frac = 0. + box_area = 0. + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onGEOCAPE(:) = 0d0 + GC_CH4_onGEOCAPE_OB(:) = 0d0 + + + ! Fraction of grid box above minimum latitude + Jfrac = 1. + IF ( JJ .EQ. JMIN ) Jfrac = Jfrac_min + + ! Determine number of observations in this grid box + ! # obs = box_area * (1-cloud_fraction) * Jfrac / 100 + ! divide by 100 because each observation takes up 100 km2 + box_area = GET_AREA_M2( JJ ) * 1d-6 ! [m2] --> [km2] + cloud_frac = CLDFRC( II, JJ ) + nobs = NINT( ( (1-cloud_frac) * box_area * Jfrac ) / 100. ) + + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1 ) + & * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < GEOCAPE pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLGEOCAPE + 1 - nlev ! minimum vertical index on GEOCAPE grid + + + ! Get interpolation matrix that maps GEOS-Chem to GEOCAPE grid + GRIDMAP(1:LLPAR, 1:LLGEOCAPE) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + ! Interpolate GEOS-Chem CH4 column and observation to GEOCAPE grid + ! Column in [v/v] + DO LN = lind, LLGEOCAPE + GC_CH4_onGEOCAPE(LN) = 0d0 + GC_CH4_onGEOCAPE_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onGEOCAPE(LN) = GC_CH4_onGEOCAPE(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onGEOCAPE_OB(LN) = GC_CH4_onGEOCAPE_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + + !-------------------------------------------------------------- + ! Apply GEOCAPE observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by GEOCAPE [molec/cm2] + ! x_a = GEOCAPE apriori column [molec/cm2] + ! x_m = GC modeled column on GEOCAPE grid [molec/cm2] + ! A = GEOCAPE averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLGEOCAPE + GC_CH4_onGEOCAPE(LN) =MAX(GC_CH4_onGEOCAPE(LN), 1d-10) + GC_CH4_onGEOCAPE_OB(LN)=MAX(GC_CH4_onGEOCAPE_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onGEOCAPE(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onGEOCAPE_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + DO LN = lind, LLGEOCAPE + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLGEOCAPE + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) +LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN)= CH4_HAT_OB(LN)+LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + + ! Loop over number of observations in this grid box + DO OB=1,NOBS + + ! Increment number of observations + NTh = NTh + 1 ! processed this hour + NT = NT + 1 ! processed today + NTT = NTT + 1 ! processed total + + !print*, ' - CALC_GEOCAPE_CH4_FORCE ', OB, ' of ',NOBS + + + ! For safety, initialize these up to LLGEOCAPE + CH4_HAT_werr(:) = 0d0 + DIFF(:) = 0d0 + FORCE(:) = 0d0 + NEW_COST(:) = 0d0 + + ! Add random error to this observation + DO LN = lind, LLGEOCAPE + + CH4_HAT_werr(LN) = CH4_HAT(LN) + + DO LLN = lind, LLGEOCAPE + CH4_HAT_werr(LN) = CH4_HAT_werr(LN) + + & CH4_HAT(LN) * RANDNUM(NT) * OBSERROR(LN,LLN) + ENDDO + ENDDO + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO LN = lind, LLGEOCAPE + DIFF(LN) = CH4_HAT_werr(LN) - CH4_HAT_OB(LN) + ENDDO + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + DO LN = lind, LLGEOCAPE + DO LLN = lind, LLGEOCAPE + FORCE(LN) = FORCE(LN) + + & 2d0 * OBSERROR_INV(LN,LLN) * DIFF(LLN) + ENDDO + NEW_COST(LN) = NEW_COST(LN) + 0.5*DIFF(LN)*FORCE(LN) + ENDDO + + + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug +! print*, 'DIFF , FORCE, Sobs ' +! WRITE(6,102) (DIFF, FORCE, Sobs) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = 2. * FORCE(:) + + ! Adjoint of GEOS-Chem - Observation difference + CH4_HAT_werr_ADJ(:) = DIFF_ADJ(:) + + ! Adjoint of adding random error to observation + DO LN=lind,LLGEOCAPE + CH4_HAT_ADJ(LN) = 0d0 + + DO LLN=lind,LLGEOCAPE + CH4_HAT_ADJ(LN) = CH4_HAT_ADJ(LN) + + & CH4_HAT_ADJ(LLN) * RANDNUM(NT) * OBSERROR(LLN,LN) + ENDDO + ENDDO + + ! Adjoint of GEOCAPE observation operator + DO LN=lind,LLGEOCAPE + CH4_PERT_ADJ(LN) = 0D0 + + DO LLN=lind,LLGEOCAPE + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLGEOCAPE + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onGEOCAPE(LN) > 1d-10 ) THEN + GC_CH4_onGEOCAPE_ADJ(LN) = 1d0 / GC_CH4_onGEOCAPE(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onGEOCAPE_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + + ! Adjoint of interpolation + DO LN=lind,LLGEOCAPE + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onGEOCAPE_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + STT_ADJ(II,JJ,LG,1) = STT_ADJ(II,JJ,LG,1) + + & GC_CH4_NATIVE_ADJ(LG) + ENDDO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(:)) + + ENDDO ! End looping over each observation in this grid box + ENDDO ! End looping over each grid box JJ + ENDDO ! End looping over each grid box II + +!!$OMP END PARALLEL DO + + +! ----------------------------------------------------------------------- +! Use this section to test the adjoint of the GEOCAPE_CH4 operator by +! slightly perturbing model [CH4] and recording resultant change +! in calculated contribution to the cost function. +! +! This routine will write the following information for each observation +! to rundir/diagadj/test_adjoint_obs.NN.m +! +! The adjoint of the observation operator has been tested and validated +! as of 7/20/10, kjw. +! + IF ( DO_FDTEST ) THEN + WRITE(116,210) ' LG' , ' TROP', ' GC_PRES', + & ' FD_POS', ' FD_NEG', ' FD_CEN', + & ' ADJ', ' COST_POS', ' COST_NEG', + & ' FD_POS/ADJ', ' FD_NEG/ADJ', ' FD_CEN/ADJ' + PERT(:) = 0D0 + + COST_FUNC_0 = 0d0 + CALL CALC_GEOCAPE_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ ) + ADJ_SAVE(:) = ADJ(:) + + DO LN=lind,LLGEOCAPE + DOFS = DOFS + AVGKERNEL(LN,LN) + ENDDO + + ! Write identifying information to top of satellite diagnostic file + WRITE(116,212) 'COST_FUNC_0:',( COST_FUNC_0 ) + WRITE(116,212) 'RANDOM ERROR',RANDNUM(NT) + WRITE(116,212) 'DOFS ',DOFS + !WRITE(116,*) (AVGKERNEL(1,LN),LN=1,13) + !WRITE(116,*) (OBSERROR(1,LN),LN=1,13) + + + ! Perform finite difference testing at each vertical level + DO LG = 1, 47 + + ! Positive perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = 0.001 + COST_FUNC_pos = 0D0 + CALL CALC_GEOCAPE_CH4_FORCE_FD( COST_FUNC_pos, PERT, ADJ ) + + ! Negative perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = -0.001 + COST_FUNC_neg = 0D0 + CALL CALC_GEOCAPE_CH4_FORCE_FD( COST_FUNC_neg, PERT, ADJ ) + + ! Calculate dJ/dCH4 from perturbations + FD_CEN(LG) = ( COST_FUNC_pos - COST_FUNC_neg ) / 0.2d0 + FD_POS(LG) = ( COST_FUNC_pos - COST_FUNC_0 ) / 0.1d0 + FD_NEG(LG) = ( COST_FUNC_0 - COST_FUNC_neg ) / 0.1d0 + + ! Write information to satellite diagnostic file + WRITE(116, 211) LG, GC_PCENTER(LG), + & FD_POS(LG), FD_NEG(LG), + & FD_CEN(LG), ADJ_SAVE(LG), + & COST_FUNC_pos, COST_FUNC_neg, + & FD_POS(LG)/ADJ_SAVE(LG), + & FD_NEG(LG)/ADJ_SAVE(LG), + & FD_CEN(LG)/ADJ_SAVE(LG) + ENDDO + + + WRITE(116,'(a)') '----------------------------------------------' + + 210 FORMAT(A4,2x,A6,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x, + & A12,2x,A12,2x,A12,2x,A12,2x) + 211 FORMAT(I4,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6, + & 2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6) + 212 FORMAT(A12,F22.6) + 213 FORMAT(A12,I4) + 214 FORMAT(I4,2x,F18.6,2x,F18.6) +! ----------------------------------------------------------------------- + DO_FDTEST = .FALSE. + ENDIF ! IF ( DO_FDTEST ) + + + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(:)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' GEOCAPE contribution this hour = ', COST_FUNC - OLD_COST + print*, ' # Obs analyzed this hour = ', NTh + print*, ' # Obs analyzed today = ', NT + print*, ' # Obs analyzed total = ', NTT + + + + ! Return to calling program + END SUBROUTINE CALC_GEOCAPE_CH4_FORCE + +!------------------------------------------------------------------------------ + + + + SUBROUTINE CALC_GEOCAPE_CH4_FORCE_FD( COST_FUNC_A, PERT, ADJ ) +! +!****************************************************************************** +! Subroutine CALC_GEOCAPE_CH4_FORCE calculates the adjoint forcing from the GEOCAPE +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC_A (REAL*8) : Cost funciton (INOUT) [unitless] +! (2 ) PERT (Real*8) : Array of perturbations to CH4 column (+/- 0.1, for ex.) +! (5 ) ADJ (REAL*8) : Array of adjoint forcings (OUT) +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC_A + REAL*8, INTENT(OUT) :: ADJ(LLPAR) + REAL*8, INTENT(IN) :: PERT(LLPAR) + + + ! Local variables + INTEGER :: NT + INTEGER :: LG, LN, LLN, II, JJ, NB, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: CH4_PRIOR(IIPAR,JJPAR,LLGEOCAPE) + REAL*4 :: DUMMY_PRIOR(IIPAR,JJPAR,LLGEOCAPE) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GC_CH4_onGEOCAPE(LLGEOCAPE) + REAL*8 :: GC_CH4_onGEOCAPE_OB(LLGEOCAPE) + REAL*8 :: GRIDMAP(LLPAR,LLGEOCAPE) + REAL*8 :: CH4_HAT(LLGEOCAPE) + REAL*8 :: CH4_HAT_OB(LLGEOCAPE) + REAL*8 :: CH4_HAT_ADJ(LLGEOCAPE) + REAL*8 :: CH4_HAT_werr(LLGEOCAPE) + REAL*8 :: CH4_HAT_werr_ADJ(LLGEOCAPE) + REAL*8 :: CH4_PERT(LLGEOCAPE) + REAL*8 :: CH4_PERT_OB(LLGEOCAPE) + REAL*8 :: CH4_PERT_ADJ(LLGEOCAPE) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: DIFF(LLGEOCAPE) + REAL*8 :: FORCE(LLGEOCAPE) + REAL*8 :: DIFF_ADJ(LLGEOCAPE) + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_CH4_onGEOCAPE_ADJ(LLGEOCAPE) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXGEOCAPE) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + + + !================================================================= + ! CALC_GEOCAPE_CH4_FORCE_FD begins here! + !================================================================= + + print*, ' - CALC_GEOCAPE_CH4_FORCE_FD ' + + NEW_COST(:) = 0d0 + + + ! Read "TRUE" state for this time step + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 +! FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // +! & 'ch4/geocape/' // GET_RES_EXT() // '/adjtmp/' // +! & 'gctm.obs.YYYYMMDD.hhmm' + FILENAME_OBS = 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE, QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + ! Read a priori vertical profiles from file + FILENAME = '/home/kjw/new_satellites/geocape/data/' // + & 'geocape_prior.' // GET_RES_EXT() // '.bpch' + XTAU = GET_TAU0( 1, 1, 1985 ) + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IGLOB, JGLOB, + & LLGEOCAPE, DUMMY_PRIOR, QUIET=.TRUE. ) + CH4_PRIOR(:,:,:) = DUMMY_PRIOR(:,:,:) + + + + ! Select arbitrary II, JJ and NT value + II=40 + JJ=JJPAR-10 + NT=100 + + ! Initialize variables + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onGEOCAPE(:) = 0d0 + GC_CH4_onGEOCAPE_OB(:) = 0d0 + CH4_HAT_werr(:) = 0d0 + DIFF(:) = 0d0 + FORCE(:) = 0d0 + + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1) + & * (1+PERT(LG)) * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < GEOCAPE pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLGEOCAPE + 1 - nlev ! minimum vertical index on GEOCAPE grid + + ! Get interpolation matrix that maps GEOS-Chem to GEOCAPE grid + GRIDMAP(1:LLPAR, 1:LLGEOCAPE) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + + ! Interpolate GEOS-Chem CH4 column and observation to GEOCAPE grid + ! Column in [v/v] + DO LN = lind, LLGEOCAPE + GC_CH4_onGEOCAPE(LN) = 0d0 + GC_CH4_onGEOCAPE_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onGEOCAPE(LN) = GC_CH4_onGEOCAPE(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onGEOCAPE_OB(LN) = GC_CH4_onGEOCAPE_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + + + !-------------------------------------------------------------- + ! Apply GEOCAPE observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by GEOCAPE [molec/cm2] + ! x_a = GEOCAPE apriori column [molec/cm2] + ! x_m = GC modeled column on GEOCAPE grid [molec/cm2] + ! A = GEOCAPE averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLGEOCAPE + GC_CH4_onGEOCAPE(LN) =MAX(GC_CH4_onGEOCAPE(LN), 1d-10) + GC_CH4_onGEOCAPE_OB(LN)=MAX(GC_CH4_onGEOCAPE_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onGEOCAPE(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onGEOCAPE_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + CH4_HAT(:)=CH4_PERT(:) + DO LN = lind, LLGEOCAPE + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLGEOCAPE + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + + ! For safety, initialize these up to LLGEOCAPE + + ! Add random error to this observation + CH4_HAT_werr(:) = CH4_HAT(:) + DO LN = lind, LLGEOCAPE + + CH4_HAT_werr(LN) = CH4_HAT(LN) + DO LLN = lind, LLGEOCAPE + CH4_HAT_werr(LN) = CH4_HAT_werr(LN) + + & CH4_HAT(LN) * RANDNUM(NT) * OBSERROR(LN,LLN) + ENDDO + ENDDO + + + !------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO LN = lind, LLGEOCAPE + DIFF(LN) = CH4_HAT_werr(LN) - CH4_HAT_OB(LN) + ENDDO + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + DO LN = lind, LLGEOCAPE + DO LLN = lind, LLGEOCAPE + FORCE(LN) = FORCE(LN) + + & 2d0 * OBSERROR_INV(LN,LLN) * DIFF(LLN) + ENDDO + NEW_COST(LN) = NEW_COST(LN) + 0.5*DIFF(LN)*FORCE(LN) + ENDDO + + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + ! Adjoint of GEOS-Chem - Observation difference + CH4_HAT_werr_ADJ(:) = DIFF_ADJ(:) + + ! Adjoint of adding random error to observation + DO LN=lind,LLGEOCAPE + CH4_HAT_ADJ(LN) = 0d0 + + DO LLN=lind,LLGEOCAPE + CH4_HAT_ADJ(LN) = CH4_HAT_ADJ(LN) + + & CH4_HAT_werr_ADJ(LLN) * RANDNUM(NT) * OBSERROR(LLN,LN) + ENDDO + ENDDO + CH4_HAT_ADJ(:) = CH4_HAT_werr_ADJ(:) + + ! Adjoint of GEOCAPE observation operator + CH4_PERT_ADJ(:) = CH4_HAT_ADJ(:) + DO LN=lind,LLGEOCAPE + CH4_PERT_ADJ(LN) = 0D0 + + DO LLN=lind,LLGEOCAPE + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLGEOCAPE + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onGEOCAPE(LN) > 1d-10 ) THEN + GC_CH4_onGEOCAPE_ADJ(LN) = 1d0 / GC_CH4_onGEOCAPE(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onGEOCAPE_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + + ! Adjoint of interpolation + DO LN=lind,LLGEOCAPE + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onGEOCAPE_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) * CHK_STT(II,JJ,LG,1) + ENDDO + + ! Update cost function + COST_FUNC_A = COST_FUNC_A + SUM(NEW_COST(:)) + + + ! Return to calling program + END SUBROUTINE CALC_GEOCAPE_CH4_FORCE_FD + + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( GC_PEDGE, GEOCAPE_PEDGE, nlev ) + & RESULT ( M ) +! +!****************************************************************************** +! Function GET_INTMAP creates the matrix that places GEOS-Chem column methane +! [molec/cm2] onto the 13-level pressure grid used by theoretical instrument, M. +! GC[1x47] * M[47x13] = GEOCAPE[1x13] (kjw, 7/21/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) GC_PEDGE (REAL*8) : LLPAR bottom pressure edges of GEOS-Chem column +! (2 ) SCIA_PEDGE (REAL*8) : LLGEOCAPE pressure edges of GEOCAPE column +! (3 ) nlev (REAL*8) : Number of GEOCAPE pressure levels to use +! +! Arguments as Output: +! ============================================================================ +! (1 ) M (REAL*8) : Interpolation matrix that maps GEOS-Chem to GEOCAPE grid +! +! NOTES: +! (1 ) Based on GET_INTMAP in scia_ch4_mod.f +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GEOCAPE_PEDGE(LLGEOCAPE) + INTEGER :: nlev + + ! Return value + REAL*8 :: M(LLPAR,LLGEOCAPE) + + ! Local variables + INTEGER :: LGC, LTM, LS, LG, LN, LIND + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: GUP, GLO, NUP, NLO + REAL*8 :: column_total(LLGEOCAPE) + + !================================================================= + ! GET_INTMAP begins here! + !================================================================= + + ! Initialize output + M(:,:) = 0D0 + + ! Minimum GEOCAPE vertical level to use + lind = LLGEOCAPE + 1 - nlev + + ! Loop over each pressure level of GEOS-Chem and GEOCAPE grids + DO LG=1,LLPAR-1 + + ! Get upper and lower pressure edges of GEOS-Chem box + GUP = GC_PEDGE( LG+1 ) + GLO = GC_PEDGE( LG ) + + DO LN=lind,LLGEOCAPE-1 + + ! Get top and bottom pressures of GEOCAPE box + NUP = GEOCAPE_PEDGE( LN+1 ) + NLO = GEOCAPE_PEDGE( LN ) + + ! If both GEOS-Chem edges are within the GEOCAPE box, map value = 1 + IF ( ( GUP .gt. NUP ) .AND. ( GLO .lt. NLO ) ) THEN + M(LG,LN) = 1 + ENDIF + + ! If both GEOS-Chem stradles a GEOCAPE pressure level, interpolate + IF ( ( GUP .lt. NUP ) .AND. ( GLO .gt. NUP ) ) THEN + DIFF = GLO - GUP + M(LG,LN+1) = ( NUP - GUP ) / DIFF + M(LG,LN ) = ( GLO - NUP ) / DIFF + ENDIF + + ENDDO + ENDDO + + ! Add value for uppermost GEOS-Chem grid box + M(LLPAR,LLGEOCAPE) = 1 + + + ! Correct for case in which GEOS-Chem pressure is higher than GEOCAPE + IF ( GC_PEDGE(1) .GT. GEOCAPE_PEDGE(1) ) THEN + + + ! If any part of GEOS-Chem box are under GEOCAPE_PEDGE(1), let + ! this GEOS-Chem grid box contribute to the observation because + ! GEOCAPE and GEOS-Chem should have same surface pressure. map value = 1 + DO LG=1,LLPAR-1 + + ! If GEOS-Chem box entirely below GEOCAPE surface pressure + IF ( ( GC_PEDGE(LG) .GT. GEOCAPE_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .GT. GEOCAPE_PEDGE(1) ) ) THEN + M(LG,1) = 1 + ENDIF + + ! If GEOS-Chem box straddles GEOCAPE surface pressure + IF ( ( GC_PEDGE(LG) .GT. GEOCAPE_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .LT. GEOCAPE_PEDGE(1) ) ) THEN + DIFF = GC_PEDGE(LG) - GC_PEDGE( LG+1 ) + M(LG,1) = ( GEOCAPE_PEDGE(1) - GC_PEDGE(LG+1) ) / DIFF + ENDIF + + ENDDO + ENDIF + + + ! Correct for case in which GEOS-Chem surface pressure is within 2nd GEOCAPE + ! pressure level. + IF ( GC_PEDGE(1) .LT. GEOCAPE_PEDGE(2) ) THEN + M(1,1) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 3rd GEOCAPE + ! pressure level. + IF ( GC_PEDGE(1) .LT. GEOCAPE_PEDGE(3) ) THEN + M(1,2) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 4th GEOCAPE + ! pressure level. + IF ( GC_PEDGE(1) .LT. GEOCAPE_PEDGE(4) ) THEN + M(1,3) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 5th GEOCAPE + ! pressure level. + IF ( GC_PEDGE(1) .LT. GEOCAPE_PEDGE(5) ) THEN + M(1,4) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 6th GEOCAPE + ! pressure level. + IF ( GC_PEDGE(1) .LT. GEOCAPE_PEDGE(6) ) THEN + M(1,5) = 0. + ENDIF + + ! Normalize each column of M to 1 so that we are not creating any molecules + ! when mapping from GEOS-Chem to GEOCAPE grids. + + ! DO NOT do this since we are mapping molc/cm2, not + ! Initialize to be safe and calculate column total + column_total(:) = 0d0 + column_total(:) = SUM( M, DIM=1 ) + + ! Normalize columns to column_total + DO LN=1,LLGEOCAPE + IF ( column_total(LN) .EQ. 0. ) CYCLE + M(:,LN) = M(:,LN) / column_total(LN) + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + + +!----------------------------------------------------------------------------- + + + + END MODULE GEOCAPE_CH4_MOD diff --git a/code/obs_operators/gosat_co2_mod.f b/code/obs_operators/gosat_co2_mod.f new file mode 100644 index 0000000..313d06c --- /dev/null +++ b/code/obs_operators/gosat_co2_mod.f @@ -0,0 +1,2261 @@ +!$Id: gosat_co2_mod.f,v 1.2 2011/02/23 00:08:48 daven Exp $ + MODULE GOSAT_CO2_MOD + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 20 + INTEGER, PARAMETER :: MAXGOS = 2000 + + + ! Record to store data from each GOS obs + TYPE GOS_CO2_OBS + INTEGER :: LGOS(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: CO2(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + INTEGER :: QF(1) + ENDTYPE GOS_CO2_OBS + + TYPE(GOS_CO2_OBS) :: GOS(MAXGOS) + + ! IDTCO2 isn't defined in tracerid_mod because people just assume + ! it is one. Define it here for now as a temporary patch. + INTEGER, PARAMETER :: IDTCO2 = 1 + ! Same thing for TCVV(IDTCO2) + REAL*8, PARAMETER :: TCVV_CO2 = 28.97d0 / 44d0 + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_GOS_CO2_OBS( YYYYMMDD, NGOS ) +! +!****************************************************************************** +! Subroutine READ_GOS_CO2_OBS reads the file and passes back info contained +! therein. (dkh, 10/12/10) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NGOS (INTEGER) : Number of GOS retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) GOS (GOS_CO2_OBS) : CO2 retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LGOS + INTEGER :: NGOS + INTEGER :: START0(1), COUNT0(1) + INTEGER :: START1(2), COUNT1(2) + INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, J + INTEGER :: NT_ID + INTEGER :: CO2_ID + INTEGER :: PS_ID + INTEGER :: AK_ID + INTEGER :: OE_ID + INTEGER :: AP_ID + INTEGER :: LA_ID + INTEGER :: LO_ID + INTEGER :: DY_ID + INTEGER :: TM_ID + INTEGER :: LV_ID + INTEGER :: OI_ID + INTEGER :: QF_ID + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_GOS_CO2_OBS begins here! + !================================================================= + + ! filename root + READ_FILENAME = TRIM( 'acos-v27-YYYYMMDD.nc' ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + READ_FILENAME = TRIM( DATA_DIR ) // TRIM( '../GOSAT_CO2/' ) // + & TRIM( READ_FILENAME ) + + + WRITE(6,*) ' - READ_GOSAT_CO2_OBS: reading file: ', + & READ_FILENAME + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "nSamples", NT_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "species", CO2_ID ), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "averagingKernel", AK_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) +! CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", +! & OE_ID ), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "date", DY_ID ), 110 ) + CALL CHECK( NF90_INQ_VARID( FID, "time", TM_ID ), 111 ) + CALL CHECK( NF90_INQ_VARID( FID, "invCovariance", + & OI_ID ), 112 ) + CALL CHECK( NF90_INQ_VARID( FID, "lev", LV_ID ), 113 ) + + + ! READ number of retrievals, NGOS + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NT_ID, TMP, NGOS), 202 ) + + ! READ quality flag + CALL CHECK( NF90_INQ_VARID( FID, "usability", QF_ID ), 114 ) + + print*, ' NGOS = ', NGOS + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! define record size + START0 = (/1/) + COUNT0 = (/1/) + + ! loop over records + DO N = 1, NGOS + + ! Update starting index + START0(1) = N + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LA_ID, + & GOS(N)%LAT, START0, COUNT0 ), 301 ) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LO_ID, + & GOS(N)%LON, START0, COUNT0 ), 302 ) + + ! READ time + CALL CHECK( NF90_GET_VAR ( FID, TM_ID, + & GOS(N)%TIME, START0, COUNT0 ), 303 ) + + ! for GOSAT CO2, need to convert from HH.hour_frac to fraction of day + GOS(N)%TIME(1) = GOS(N)%TIME(1) / 24d0 + + ! READ levels + CALL CHECK( NF90_GET_VAR ( FID, LV_ID, + & GOS(N)%LGOS, START0, COUNT0 ), 304 ) + + ! READ quality flag aka "usability" + CALL CHECK( NF90_GET_VAR ( FID, QF_ID, + & GOS(N)%QF, START0, COUNT0 ), 305 ) + + + ENDDO + + ! debuggg + print*, ' passed 0-D' + + print*, ' lev read in = ', GOS(1)%LGOS + + !-------------------------------- + ! Find # of good levels for each + !-------------------------------- + + ! define record size + START1 = (/1, 1/) + COUNT1 = (/MAXLEV, 1/) + + ! loop over records + DO N = 1, NGOS + + ! Update starting index + START1(2) = N + + ! READ CO2 column, CO2 + CALL CHECK( NF90_GET_VAR ( FID, CO2_ID, + & GOS(N)%CO2(1:MAXLEV), START1, COUNT1 ), 401 ) + + ! For CO2, we now read the number of good levels in from the data file itself +! ! Now determine how many of the levels in CO2 are +! ! 'good' and how many are just FILL. +! J = 1 +! DO WHILE ( J .le. MAXLEV ) +! +! ! check if the value is good +! IF ( GOS(N)%CO2(J) > FILL ) THEN +! +! ! save the number of good levels as LGOS +! GOS(N)%LGOS = MAXLEV - J + 1 +! +! ! and now we can exit the while loop +! J = MAXLEV + 1 +! +! ! otherwise this level is just filler +! ELSE +! +! ! so proceed to the next one up +! J = J + 1 +! +! ENDIF +! +! ENDDO + + ENDDO + + ! debuggg + print*, ' passed 1-D a' + print*, ' lev calc = ', GOS(1)%LGOS + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! loop over records + DO N = 1, NGOS + + ! J is number of good levels + J = GOS(N)%LGOS(1) + + ! define record size + ! for CO2, filler values are at the end, not the beginning + !START1 = (/MAXLEV - J + 1, 1/) + START1 = (/1, 1/) + COUNT1 = (/J, 1/) + + ! Update starting index + START1(2) = N + + ! READ CO2 column, CO2 + CALL CHECK( NF90_GET_VAR ( FID, CO2_ID, + & GOS(N)%CO2(1:J), START1, COUNT1 ), 401 ) + + + ! READ pressure levels, PRES + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & GOS(N)%PRES(1:J), START1, COUNT1 ), 402 ) + + ! READ apriori CO2 column, PRIOR + CALL CHECK( NF90_GET_VAR ( FID, AP_ID, + & GOS(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) + + + ENDDO + + ! debuggg + print*, ' passed 1-D b' + + + !-------------------------------- + ! Read 2D Data + !-------------------------------- + + ! loop over records + DO N = 1, NGOS + + ! J is number of good levels + J = GOS(N)%LGOS(1) + + ! define record size + ! for CO2, filler values are at the end, not the beginning + !START2 = (/MAXLEV - J + 1, MAXLEV - J + 1, 1/) + START2 = (/1, 1, 1/) + COUNT2 = (/J, J, 1/) + + ! Update starting index + START2(3) = N + + ! READ averaging kernal, AVG_KERNEL + CALL CHECK( NF90_GET_VAR ( FID, AK_ID, + & GOS(N)%AVG_KERNEL(1:J,1:J), START2, COUNT2), 501 ) + +! ! READ observational error covariance +! CALL CHECK( NF90_GET_VAR ( FID, OE_ID, +! & GOS(N)%S_OER(1:J,1:J), START2, COUNT2), 502 ) + + ! READ observational error covariance inverse + CALL CHECK( NF90_GET_VAR ( FID, OI_ID, + & GOS(N)%S_OER_INV(1:J,1:J), START2, COUNT2), 503 ) + + ENDDO + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + ! debuggg + print*, ' passed 2-D ' + + print*, ' CO2 prof = ', GOS(1)%CO2(:) + print*, ' CO2 levels = ', GOS(1)%LGOS(1) + print*, ' CO2 time = ', GOS(1)%TIME(1) + + +! !-------------------------------- +! ! Calculate S_OER_INV +! !-------------------------------- +! +! ! loop over records +! DO N = 1, NGOS +! +! J = GOS(N)%LGOS(1) +! +! ! add regularization +! DO II=1,J +! GOS(N)%S_OER(II,II) = GOS(N)%S_OER(II,II)+ 0.001D0 +! ENDDO +! +! CALL DGESVD_EXAMPLE +! +! CALL SVD( GOS(N)%S_OER(1:J,1:J), J, +! & U(1:J,1:J), S(1:J), +! & VT(1:J,1:J) ) +! +! ! debuggg +! print*, ' passed SVD 1' +! +! ! U = S^-1 * U^T +! DO I = 1, J +! DO II = 1, J +! TEST(I,II) = U(II,I) / S(I) +! ENDDO +! ENDDO +! U = TEST +! TEST = 0d0 +! +! ! debuggg +! print*, ' passed SVD 2' +! +! ! S_OER_INV = V * S^-1 * U^T +! DO I = 1, J +! DO II = 1, J +! TMP1 = 0d0 +! DO III = 1, J +! TMP1 = TMP1 + VT(III,I) * U(III,II) +! ENDDO +! GOS(N)%S_OER_INV(I,II) = TMP1 +! ENDDO +! ENDDO +! +! ! debuggg +! print*, ' passed SVD 3' +! +! ! TEST: calculate 2-norm of I - S_OER_INV * S_OER +! DO I = 1, J +! DO II = 1, J +! TMP1 = 0d0 +! DO III = 1, J +! TMP1 = TMP1 +! & + GOS(N)%S_OER_INV(III,I) * GOS(N)%S_OER(III,II) +! ENDDO +! TEST(I,II) = - TMP1 +! ENDDO +! TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 +! ENDDO +! +! ! debuggg +! print*, ' passed SVD 4' +! +! +! IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN +! print*, ' WARNING: inversion error for retv N = ', +! & SUM(TEST(1:J,1:J)), N +! print*, ' in GOS obs ', READ_FILENAME +! ENDIF +! +! ENDDO ! N +! +! ! debuggg +! print*, ' passed SVD f' + + + ! Return to calling program + END SUBROUTINE READ_GOS_CO2_OBS +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_nh3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_GOS_CO2_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_GOS_CO2_FORCE calculates the adjoint forcing from the GOSAT +! CO2 observations and updates the cost function. (dkh, 10/12/10) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : CSPEC, JLOP + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LGOS + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CO2_NATIVE(LLPAR) + REAL*8 :: GC_CO2(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: CO2_HAT(MAXLEV) + REAL*8 :: CO2_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV) + REAL*8 :: NEW_COST(MAXGOS) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXGOS) + INTEGER,SAVE :: NGOS + + REAL*8 :: GC_CO2_NATIVE_ADJ(LLPAR) + REAL*8 :: CO2_HAT_ADJ(MAXLEV) + REAL*8 :: CO2_PERT_ADJ(MAXLEV) + REAL*8 :: GC_CO2_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ(MAXLEV) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + + + !================================================================= + ! CALC_GOS_CO2_FORCE begins here! + !================================================================= + + print*, ' - CALC_GOS_CO2_FORCE ' + + ! Reset + NEW_COST = 0D0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_co2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_co2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'co2_pert_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_co2_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_co2_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_co2_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_co2_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_co2_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the GOS CO2 file for this day + CALL READ_GOS_CO2_OBS( GET_NYMD(), NGOS ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + ! Don't need to adjust this for GOSAT CO2, for which TIME is already + ! just the time fraction. + TIME_FRAC(1:NGOS) = GOS(1:NGOS)%TIME(1) + + ENDIF + + ! Get the range of GOS retrievals for the current hour + CALL GET_NT_RANGE( NGOS, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching GOS CO2 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LGOS, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CO2, DIFF ) +!!$OMP+PRIVATE( GC_CO2_NATIVE, CO2_PERT, CO2_HAT, FORCE ) +!!$OMP+PRIVATE( GC_CO2_NATIVE_ADJ, GC_CO2_ADJ ) +!!$OMP+PRIVATE( CO2_PERT_ADJ, CO2_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_GOS_CO2_FORCE: analyzing record ', NT + + ! quality screening + IF ( GOS(NT)%QF(1) == 0 ) THEN + print*, ' BAD QF, skipping record ', NT + CYCLE + ENDIF + + ! skip antarctica + IF ( GOS(NT)%LAT(1) < -60d0 ) THEN + print*, ' Skipp all data with latitude < 50 S ', NT + CYCLE + ENDIF + + ! For safety, initialize these up to LLGOS + GC_CO2(:) = 0d0 + MAP(:,:) = 0d0 + CO2_HAT_ADJ(:) = 0d0 + FORCE(:) = 0d0 + + + ! Copy LGOS to make coding a bit cleaner + LGOS = GOS(NT)%LGOS(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(GOS(NT)%LON(1),4), REAL(GOS(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + ! dkh debug + print*, 'I,J = ', I, J + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LGOS) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LGOS, GOS(NT)%PRES(1:LGOS), GC_PSURF ) + + + ! Get CO2 values at native model resolution + GC_CO2_NATIVE(:) = CHK_STT(I,J,:,IDTCO2) + + ! Convert from kg/box to v/v + GC_CO2_NATIVE(:) = GC_CO2_NATIVE(:) * TCVV_CO2 + & / AD(I,J,:) + + + ! Interpolate GC CO2 column to TES grid + DO LL = 1, LGOS + GC_CO2(LL) = 0d0 + DO L = 1, LLPAR + GC_CO2(LL) = GC_CO2(LL) + & + MAP(L,LL) * GC_CO2_NATIVE(L) + ENDDO + ENDDO + + ! dkh debug: compare profiles: + print*, ' GC_PRES, GC_native_CO2 [ppm] ' + WRITE(6,100) (GC_PRES(L), GC_CO2_NATIVE(L)*1d6, + & L = LLPAR, 1, -1 ) + print*, ' GOS_PRES, GC_CO2 ' + WRITE(6,100) (GOS(NT)%PRES(LL), + & GC_CO2(LL)*1d6, LL = LGOS, 1, -1 ) + 100 FORMAT(1X,F16.8,1X,F20.8) + + + !-------------------------------------------------------------- + ! Apply GOS observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [vmr] + ! x_a = GOS apriori column [vmr] + ! x_m = GC modeled column [vmr] + ! A_k = GOS averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LGOS + CO2_PERT(L) = GC_CO2(L) - GOS(NT)%PRIOR(L) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LGOS + CO2_HAT(L) = 0d0 + DO LL = 1, LGOS + CO2_HAT(L) = CO2_HAT(L) + & + GOS(NT)%AVG_KERNEL(L,LL) * CO2_PERT(LL) + ENDDO + CO2_HAT(L) = CO2_HAT(L) + GOS(NT)%PRIOR(L) + ENDDO + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error in vmr + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO L = 1, LGOS + DIFF(L) = CO2_HAT(L) - GOS(NT)%CO2(L) + ENDDO + + ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + DO L = 1, LGOS + FORCE(L) = 0d0 + DO LL = 1, LGOS + FORCE(L) = FORCE(L) + GOS(NT)%S_OER_INV(L,LL) * DIFF(LL) + ENDDO + NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + ENDDO + + ! dkh debug: compare profiles: + print*, ' TES_PRIOR, CO2_HAT, CO2_GOS [ppm], diag(S^-1)' + WRITE(6,101) ( 1d6 * GOS(NT)%PRIOR(L), + & 1d6 * CO2_HAT(L), + & 1d6 * GOS(NT)%CO2(L), + & GOS(NT)%S_OER_INV(L,L), + & L, L = LGOS, 1, -1 ) + + 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug + print*, 'DIFF , FORCE ' + WRITE(6,102) (DIFF(L), FORCE(L), + & L = LGOS, 1, -1 ) + 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LGOS)))) + !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) + + ! Adjoint of difference + DO L = 1, LGOS + CO2_HAT_ADJ(L) = DIFF_ADJ(L) + ENDDO + + ! adjoint of TES operator + DO L = 1, LGOS + CO2_PERT_ADJ(L) = 0d0 + DO LL = 1, LGOS + CO2_PERT_ADJ(L) = CO2_PERT_ADJ(L) + & + GOS(NT)%AVG_KERNEL(LL,L) + & * CO2_HAT_ADJ(LL) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO L = 1, LGOS + ! fwd code: + !CO2_PERT(L) = GC_CO2(L) - GOS(NT)%PRIOR(L) + ! adj code: + GC_CO2_ADJ(L) = CO2_PERT_ADJ(L) + ENDDO + + ! dkh debug + print*, 'CO2_HAT_ADJ, CO2_PERT_ADJ, GC_CO2_ADJ' + WRITE(6,103) (CO2_HAT_ADJ(L), CO2_PERT_ADJ(L), GC_CO2_ADJ(L), + & L = LGOS, 1, -1 ) + 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_CO2_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LGOS + GC_CO2_NATIVE_ADJ(L) = GC_CO2_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_CO2_ADJ(LL) + ENDDO + ENDDO + + WRITE(114,112) ( GC_CO2_NATIVE_ADJ(L), L=LLPAR,1,-1) + + ! Adjoint of unit conversion + GC_CO2_NATIVE_ADJ(:) = GC_CO2_NATIVE_ADJ(:) * TCVV_CO2 + & / AD(I,J,:) + + + ! Pass adjoint back to adjoint tracer array + STT_ADJ(I,J,:,IDTCO2) = STT_ADJ(I,J,:,IDTCO2) + & + GC_CO2_NATIVE_ADJ(:) + + ! dkh debug + print*, 'GC_CO2_NATIVE_ADJ conv ' + WRITE(6,104) (GC_CO2_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + 104 FORMAT(1X,d14.6) + + + WRITE(101,110) ( GOS(NT)%PRES(LL), LL=LGOS,1,-1) + WRITE(102,110) ( 1d6 * GC_CO2(LL), LL=LGOS,1,-1) + WRITE(103,110) ( 1d6 * GOS(NT)%CO2(LL), LL=LGOS,1,-1) + WRITE(104,110) ( 1d6 * GOS(NT)%PRIOR(LL), LL=LGOS,1,-1) + WRITE(105,110) ( DIFF(LL), LL=LGOS,1,-1) + WRITE(106,112) ( FORCE(LL), LL=LGOS,1,-1) + WRITE(107,111) NT, LGOS + WRITE(108,112) ( CO2_PERT_ADJ(LL), LL=LGOS,1,-1) + WRITE(109,112) ( GC_CO2_ADJ(LL), LL=LGOS,1,-1) + WRITE(110,110) ( 1d6 * CO2_HAT(LL), LL=LGOS,1,-1) + WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) + WRITE(112,110) ( 1d6 * GC_CO2_NATIVE(L), L=LLPAR,1,-1) + WRITE(113,110) ( 1d6 * GC_CO2(LL), LL=LGOS,1,-1) + 110 FORMAT(F18.6,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + + ENDDO ! NT +!!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + IF ( FIRST ) FIRST = .FALSE. + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' GOS contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_GOS_CO2_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_O3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine CALC_TES_O3_FORCE_FD tests the adjoint of CALC_TES_O3_FORCE +!! (dkh, 05/05/10) +!! +!! Can be driven with: +!! PERT(:) = 1D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, 30 +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!! +!! +!! +!! Arguments as Input/Output: +!! ============================================================================ +!! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +!! +!! +!! NOTES: +!! (1 ) Updated to GCv8 (dkh, 10/07/09) +!! (1 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE +! USE DAO_MOD, ONLY : AD +! USE DAO_MOD, ONLY : AIRDEN +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : XNUMOLAIR +! USE TRACERID_MOD, ONLY : IDO3 +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +! +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LGOS +! INTEGER :: JLOOP +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_O3_NATIVE(LLPAR) +! REAL*8 :: GC_O3(MAXLEV) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,MAXLEV) +! REAL*8 :: O3_HAT(MAXLEV) +! REAL*8 :: O3_PERT(MAXLEV) +! REAL*8 :: FORCE(MAXLEV) +! REAL*8 :: DIFF(MAXLEV) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! REAL*8, SAVE :: TIME_FRAC(MAXTES) +! INTEGER,SAVE :: NTES +! +! REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) +! REAL*8 :: CO2_HAT_ADJ(MAXLEV) +! REAL*8 :: O3_PERT_ADJ(MAXLEV) +! REAL*8 :: GC_O3_ADJ(MAXLEV) +! REAL*8 :: DIFF_ADJ(MAXLEV) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_O3_FORCE_FD begins here! +! !================================================================= +! +! print*, ' - CALC_TES_O3_FORCE_FD ' +! +! NEW_COST = 0D0 +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_press.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_on_tes.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Check if it is the last hour of a day +!! IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN +! IF ( FIRST ) THEN +! +! ! Read the TES O3 file for this day +! CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +! FIRST = .FALSE. +! ENDIF +! +!! ! Get the range of TES retrievals for the current hour +!! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES O3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +!! & TIME_FRAC(NTSTOP) +!! print*, ' found record range: ', NTSTART, NTSTOP +! +! NTSTART = 1590 +! NTSTOP = 1590 +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LGOS, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!!$OMP+PRIVATE( O3_PERT_ADJ, CO2_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT +! +! ! For safety, initialize these up to LLGOS +! GC_O3(:) = 0d0 +! MAP(:,:) = 0d0 +! CO2_HAT_ADJ(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LGOS to make coding a bit cleaner +! LGOS = TES(NT)%LGOS(1) +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) +! I = IIJJ(1) +! J = IIJJ(2) +! +! print*, 'I,J = ', I, J +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LGOS) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LGOS, TES(NT)%PRES(1:LGOS), GC_PSURF ) +! +! +! ! Get O3 values at native model resolution +! DO L = 1, LLPAR +! +! +! ! check if in trop +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! ! get O3 from tropospheric array +! IF ( JLOOP > 0 ) THEN +! GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) * PERT(L) +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! ENDIF +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! +! ENDIF +! +! ! Convert from #/cm3 to v/v +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! ENDDO +! +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LGOS +! GC_O3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_O3(LL) = GC_O3(LL) +! & + MAP(L,LL) * GC_O3_NATIVE(L) +! ENDDO +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LGOS, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LGOS +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LGOS +! O3_HAT(L) = 0d0 +! DO LL = 1, LGOS +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LGOS +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LGOS +! FORCE(L) = 0d0 +! DO LL = 1, LGOS +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LGOS, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LGOS, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LGOS, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !ADJ_DIFF(:) = 1d0 +! !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LGOS)))) +! !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) +! !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) +! +! ! Adjoint of difference +! DO L = 1, LGOS +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! CO2_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LGOS +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LGOS +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * CO2_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LGOS +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO +! +! ! dkh debug +! print*, 'CO2_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (CO2_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LGOS, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! GC_O3_NATIVE_ADJ(L) = 0d0 +! DO LL = 1, LGOS +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) +! & + MAP(L,LL) * GC_O3_ADJ(LL) +! ENDDO +! ENDDO +! +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! DO L = 1, LLPAR +! +! ! Adjoint of unit conversion +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! IF ( JLOOP > 0 ) THEN +! +! ! Pass adjoint back to adjoint tracer array +! CSPEC_ADJ_FORCE(JLOOP,IDO3) = +! & CSPEC_ADJ_FORCE(JLOOP,IDO3) + GC_O3_NATIVE_ADJ(L) +! +! ADJ(L) = GC_O3_NATIVE_ADJ(L) * CSPEC(JLOOP,IDO3) +! +! ENDIF +! +! ENDIF +! +! ENDDO +! +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LGOS,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LGOS,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LGOS,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LGOS,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LGOS,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LGOS,1,-1) +! WRITE(107,111) NT, LGOS +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LGOS,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LGOS,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LGOS,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LGOS,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_O3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES - 100 + + print*, ' co2 hack : skip lat 100 records, where out of order' + print*, ' co2 hack : skip lat 100 records, where out of order' + print*, ' co2 hack : skip lat 100 records, where out of order' + print*, ' co2 hack : skip lat 100 records, where out of order' + print*, ' co2 hack : skip lat 100 records, where out of order' + + + + print*, ' GET_NT_RANGE for ', HHMMSS + print*, ' NTSAVE ', NTSAVE + print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! dkh debug + print*, ' co2 time frac = ', TIME_FRAC + + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Bug fix: a more general version allows for multiples TES pressure + ! levels to exist below the lowest GC pressure. (dm, dkh, 09/30/10) + ! OLD code: + !IF ( TM_PRESC(1) > GC_PRESC(1) ) THEN + ! HINTERPZ(1,1) = 1D0 + ! HINTERPZ(2:LGC_TOP,1) = 0D0 + !ENDIF + ! New code: + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(1,LTM) = 1D0 + HINTERPZ(2:LGC_TOP,LTM) = 0D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ +! SUBROUTINE MAKE_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_O3_FILE saves O3 profiles that correspond to time and +!! place of TES O3 obs. (dkh, 03/01/09) +!! +!! Module variables as Input: +!! ============================================================================ +!! (1 ) O3_SAVE (REAL*8) : O3 profiles [ppmv] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE +! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J, I0, J0, L, NT +! CHARACTER(LEN=120) :: FILENAME +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! INTEGER, PARAMETER :: IUN = 88 +! +! ! For binary punch file, version 2.0 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! !================================================================= +! ! MAKE_O3_FILE begins here! +! !================================================================= +! +! FILENAME = TRIM( 'nh3.bpch' ) +! +! ! Append data directory prefix +! FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'O3 profile ' +! CATEGORY = 'IJ-AVE-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! UNIT = 'ppmv' +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the checkpoint file for output -- binary punch format +! !================================================================= +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_O3_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) +! +! ! Temporarily store data in DAT as REAL4 +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT ) +! DO NT = 1, MAXTES +! +! DAT(1,:,NT) = REAL(O3_SAVE(:,NT)) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, 1d0, 1d0, RESERVED, +! & 1, LLPAR, MAXTES, I0+1, +! & J0+1, 1, DAT ) +! +! ! Close file +! CLOSE( IUN ) +! +! print*, ' O3_SAVE sum write = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE MAKE_O3_FILE +! +!!------------------------------------------------------------------------------ +! SUBROUTINE READ_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine READ_O3_FILE reads the GC modeled O3 profiles that correspond +!! to the TES O3 times and locations. (dkh, 03/01/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( ADJTMP_DIR ) // +! & 'nh3.bpch' +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_O3_FILE: Reading ', a ) +! +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, +! & 1d0, 1, LLPAR, +! & MAXTES, DAT, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! O3_SAVE(:,:) = DAT(1,:,:) +! +! print*, ' O3_SAVE sum read = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE READ_O3_FILE +! +!!----------------------------------------------------------------------------- +! FUNCTION GET_DOUBLED_O3( NYMD, NHMS, LON, LAT ) RESULT( O3_DBL ) +!! +!!****************************************************************************** +!! Subroutine GET_DOUBLED_O3 reads and returns the nh3 profiles from +!! model run with doubled emissions. (dkh, 11/08/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TIME_MOD, ONLY : GET_TAU +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER :: NYMD, NHMS +! REAL*4 :: LON, LAT +! +! ! Function arg +! REAL*8 :: O3_DBL(LLPAR) +! +! ! Local variables +! REAL*4 :: DAT(144,91,20) +! CHARACTER(LEN=255) :: FILENAME +! INTEGER :: IIJJ(2) +! +! !================================================================= +! ! GET_DOUBLED_O3 begins here! +! !================================================================= +! +! ! filename +! FILENAME = 'nh3.YYYYMMDD.hhmm' +! +! ! Expand filename +! CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) +! +! ! Full path to file +! FILENAME = TRIM( DATA_DIR ) // +! & 'doubled_nh3/' // +! & TRIM( FILENAME ) // +! & TRIM( '00' ) +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - GET_DOUBLED_O3: Reading ', a ) +! +! ! dkh debug +! print*, ' GET_TAU() = ', GET_TAU() +! +! ! Get data +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, +! & GET_TAU(), 144, 91, +! & 20, DAT, QUIET=.FALSE. ) +! +! IIJJ = GET_IJ_2x25( LON, LAT ) +! +! print*, ' found doubled in I/J = ', IIJJ +! +! ! just the column for the present location, and convert ppb to ppm +! O3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 +! O3_DBL(21:LLPAR) = 0d0 +! +! print*, ' O3_DBL = ', O3_DBL +! +! ! Return to calling program +! END FUNCTION GET_DOUBLED_O3 +! +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!------------------------------------------------------------------------------ + + SUBROUTINE SVD(A,N,U,S,VT) +! +!****************************************************************************** +! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) A (REAL*8) : N x N matrix to decompose +! (2 ) N (INTEGER) : N is dimension of A +! +! Arguments as Output: +! ============================================================================ +! (1 ) U (REAL*8) : Array of left singular vectors +! (2 ) S (REAL*8) : Vector of singular values +! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +! +! +! NOTES: +! +* Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +* The information and material ("Material") provided below is owned by Intel +* Corporation or its suppliers or licensors, and title to such Material remains +* with Intel Corporation or its suppliers or licensors. The Material contains +* proprietary information of Intel or its suppliers and licensors. The Material +* is protected by worldwide copyright laws and treaty provisions. No part of +* the Material may be copied, reproduced, published, uploaded, posted, +* transmitted, or distributed in any way without Intel's prior express written +* permission. No license under any patent, copyright or other intellectual +* property rights in the Material is granted to or conferred upon you, either +* expressly, by implication, inducement, estoppel or otherwise. Any license +* under such intellectual property rights must be express and approved by Intel +* in writing. +* ============================================================================= +* +* DGESVD Example. +* ============== +* +* Program computes the singular value decomposition of a general +* rectangular matrix A: +* +* 8.79 9.93 9.83 5.45 3.16 +* 6.11 6.91 5.04 -0.27 7.98 +* -9.15 -7.93 4.86 4.85 3.01 +* 9.57 1.64 8.83 0.74 5.80 +* -3.49 4.02 9.80 10.00 4.27 +* 9.84 0.15 -8.99 -6.02 -5.31 +* +* Description. +* ============ +* +* The routine computes the singular value decomposition (SVD) of a real +* m-by-n matrix A, optionally computing the left and/or right singular +* vectors. The SVD is written as +* +* A = U*SIGMA*VT +* +* where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +* diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +* is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +* are the singular values of A; they are real and non-negative, and are +* returned in descending order. The first min(m, n) columns of U and V are +* the left and right singular vectors of A. +* +* Note that the routine returns VT, not V. +* +* Example Program Results. +* ======================== +* +* DGESVD Example Program Results +* +* Singular values +* 27.47 22.64 8.56 5.99 2.01 +* +* Left singular vectors (stored columnwise) +* -0.59 0.26 0.36 0.31 0.23 +* -0.40 0.24 -0.22 -0.75 -0.36 +* -0.03 -0.60 -0.45 0.23 -0.31 +* -0.43 0.24 -0.69 0.33 0.16 +* -0.47 -0.35 0.39 0.16 -0.52 +* 0.29 0.58 -0.02 0.38 -0.65 +* +* Right singular vectors (stored rowwise) +* -0.25 -0.40 -0.69 -0.37 -0.41 +* 0.81 0.36 -0.25 -0.37 -0.10 +* -0.26 0.70 -0.22 0.39 -0.49 +* 0.40 -0.45 0.25 0.43 -0.62 +* -0.22 0.14 0.59 -0.63 -0.44 +* ============================================================================= +!****************************************************************************** +! + ! Arguements + INTEGER,INTENT(IN) :: N + REAL*8, INTENT(IN) :: A(N,N) + REAL*8, INTENT(OUT) :: U(N,N) + REAL*8, INTENT(OUT) :: S(N) + REAL*8, INTENT(OUT) :: VT(N,N) + + ! Local variables + INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 + INTEGER :: INFO, LWORK + DOUBLE PRECISION :: WORK( LWMAX ) + +* .. External Subroutines .. + EXTERNAL :: DGESVD + +* .. Intrinsic Functions .. + INTRINSIC :: INT, MIN + + !================================================================= + ! SVD begins here! + !================================================================= + +* .. Executable Statements .. + !WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + print*, ' here 1 ' + LWORK = -1 + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + print*, ' here 2 ' + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + print*, ' here 3 ' + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF + +! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +! +! Print singular values. +! + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +! +! Print left singular vectors. +! + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ N, N, U, N ) +! +! Print right singular vectors. +! + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, N ) + + ! Return to calling program + END SUBROUTINE SVD +!------------------------------------------------------------------------------ + SUBROUTINE DGESVD_EXAMPLE + +* .. Parameters .. + INTEGER M, N + PARAMETER ( M = 6, N = 5 ) + INTEGER LDA, LDU, LDVT + PARAMETER ( LDA = M, LDU = M, LDVT = N ) + INTEGER LWMAX + PARAMETER ( LWMAX = 1000 ) +* +* .. Local Scalars .. + INTEGER INFO, LWORK +* +* .. Local Arrays .. + DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), + $ WORK( LWMAX ) + DATA A/ + $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, + $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, + $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, + $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, + $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 + $ / +* +* .. External Subroutines .. + EXTERNAL DGESVD + !EXTERNAL PRINT_MATRIX +* +* .. Intrinsic Functions .. + INTRINSIC INT, MIN +* +* .. Executable Statements .. + WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF +* +* Print singular values. +* + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +* +* Print left singular vectors. +* + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ M, N, U, LDU ) +* +* Print right singular vectors. +* + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, LDVT ) + +* +* End of DGESVD Example. + END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +* +* Auxiliary routine: printing a matrix. +* + SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) + CHARACTER*(*) DESC + INTEGER M, N, LDA + DOUBLE PRECISION A( LDA, * ) +* + INTEGER I, J +* + WRITE(*,*) + WRITE(*,*) DESC + DO I = 1, M + WRITE(*,9998) ( A( I, J ), J = 1, N ) + END DO +* +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) + 9998 FORMAT( 11(:,1X,E14.8) ) + RETURN + + END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + END MODULE GOSAT_CO2_MOD diff --git a/code/obs_operators/gvchsq.f b/code/obs_operators/gvchsq.f new file mode 100644 index 0000000..4365afb --- /dev/null +++ b/code/obs_operators/gvchsq.f @@ -0,0 +1,122 @@ + SUBROUTINE GVCHSQ ( DEGFRE, LEVEL, CHISQR, FAIL, ERRMSG ) +C +C VERSION +C 08-MAY-90 AD Correct Error Message for wrong LEVEL +C More rigorous checks for LEVEL close to nominal values +C 02-AUG-89 RJW Remove unused variable +C 29-JAN-89 CJM 1st delivery +C +C DESCRIPTION +C Returns the value of chi-squared at DEGFRE degrees of freedom +C and at the LEVEL (%) confidence level. +C Uses table from "Statistical and Computational methods in data +C analysis" by Brandt (North Holland Pub. Corp.): for DEGFRE < 31 +C the table is looked up directly, for 30 < DEGFRE < 101 the +C results are interpolated from the table, and for DEGFRE >100 we +C use the result on P58 of "Statistics for Physicists" by Martin +C (Academic Press). +C + IMPLICIT NONE +C +C ARGUMENTS + INTEGER DEGFRE ! I Number of degrees of freedom + REAL*4 LEVEL ! I %level of test + ! (only 90.0,95.0,99.0,99.5,99.9) + REAL*4 CHISQR ! O chi-squared(DEGFREE,LEVEL) + LOGICAL FAIL ! O Routine Error flag + CHARACTER*80 ERRMSG ! O Error message +C +C LOCAL CONSTANTS + REAL*4 DIFMIN ! Tolerance allowed between LEVEL and list + PARAMETER (DIFMIN = 0.00001) ! list of nominal values +C +C LOCAL VARIABLES + INTEGER LVINDX ! Index set 1,2,3 if LEVEL is 90,95 or 99 + INTEGER I1 ! Index of C for interpolation + REAL*4 ALPHA ! Interpolation coefficient +C +C DATA STATEMENTS + REAL*4 C(37,5) ! Table of Chi-squared as a function of the + ! degrees of freedom and % levels + ! 90.0, 95.0, 99.0, 99.5, 99.9 + ! The 37 degrees of freedom are 1,2,3...30,40,50..100 + ! From table F5 of Brandt + DATA C/2.71, 4.61, 6.25, 7.78, 9.24,10.64,12.02,13.36,14.68, + & 15.99,17.27,18.55,19.81,21.06,22.31,23.54,24.77,25.99,27.20, + & 28.41,29.61,30.81,32.01,33.20,34.38,35.56,36.74,37.92,39.09, + & 40.26,51.80,63.17,74.40,85.53,96.58, 107.56, 118.50, + & 3.84, 5.99, 7.81, 9.49,11.07,12.59,14.07,15.51,16.92,18.31, + & 19.68,21.03,22.36,23.68,25.00,26.30,27.59,28.87,30.14,31.41, + & 32.67,33.92,35.17,36.42,37.65,38.89,40.11,41.34,42.56,43.77, + & 55.76,67.51,79.08,90.53, 101.88, 113.15, 124.34, + & 6.63, 9.21,11.34,13.28,15.09,16.81,18.48,20.09,21.67,23.21, + & 24.72,26.22,27.69,29.14,30.58,32.00,33.41,34.81,36.19,37.57, + & 38.93,40.29,41.64,42.98,44.31,45.64,46.96,48.28,49.59,50.89, + & 63.70,76.16,88.38, 100.43, 112.33, 124.12, 135.81, + & 7.88,10.60,12.84,14.86,16.75,18.55,20.28,21.95,23.59,25.19, + & 26.76,28.30,29.82,31.32,32.80,34.27,35.72,37.16,38.58,40.00, + & 41.40,42.80,44.18,45.56,46.93,48.29,49.64,50.99,52.34,53.67, + & 66.76,79.49,91.95, 104.21, 116.32, 128.30, 140.17, + & 10.83,13.82,16.27,18.47,20.51,22.46,24.32,26.12,27.88,29.59, + & 31.26,32.91,34.53,36.12,37.70,39.25,40.79,42.31,43.82,45.31, + & 46.80,48.27,49.73,51.18,52.62,54.05,55.48,56.89,58.30,59.70, + & 73.39, 86.66,99.61, 112.32, 124.84, 137.21, 149.45 / + SAVE C +C + REAL*4 G(5) ! Values X of Normalised Gaussian variable x such + ! that the probability of x FILL ) THEN + ! save the number of good levels as LTES + IASI_CO_LVL(N) = N_IASI_NLA - J + 1 + ! and now we can exit the while loop + J = N_IASI_NLA + 1 + ! otherwise this level is just filler + ELSE + ! so proceed to the next one up + J = J + 1 + ENDIF + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE READ_IASI_CO_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'IASI_o3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_IASI_CO_FORCE( COST_FUNC ) + ! +!****************************************************************************** +! Subroutine CALC_IASI_CO_FORCE calculaIASI the adjoint forcing from the IASI +! CO observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost function [unitless] +! +! +! NOIASI: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled CO (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + !USE ADJ_ARRAYS_MOD, ONLY : CO_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP, VOLUME + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_HOUR + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDTCO + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT, I_IASI + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LIASI, L0 + INTEGER :: JLOOP + INTEGER :: GC_HOUR + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CO_NATIVE(LLPAR) + REAL*8 :: GC_CO(N_IASI_NLA), IASI_APR_WEB(N_IASI_NLA) + REAL*8 :: GC_PSURF, IASI_PSURF, GC_ALT(IIPAR, JJPAR, LLPAR+1) + REAL*8 :: CO_HAT(N_IASI_NLA) + REAL*8 :: SOBS_CO_AVK(IIPAR,JJPAR,N_IASI_NLA) + REAL*8 :: CO_PERT(N_IASI_NLA), SOBS_AVK_TOT(IIPAR,JJPAR,N_IASI_NLA) + REAL*8 :: FORCE, IASI_RATIO(N_IASI_NLA) + REAL*8 :: DIFF, CO_COL_OBS, CO_COL_HAT + REAL*8 :: IASI_PCENTER(N_IASI_NLA) + REAL*8 :: IASI_APR(N_IASI_NLA) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: OLD_COST + REAL*8 :: XNUAIR, SOBS_RAND + REAL*8, SAVE :: TIME_FRAC(MAXIASI) + REAL*8 :: ALT_SURF(IIPAR,JJPAR) + REAL*8 :: SOBS_CO_STD, SOBS_CO_COL + REAL*8 :: SOBS_CO_NORM(IIPAR,JJPAR), SOBS_CO_MEAN(IIPAR,JJPAR) + REAL*8 :: SOBS_CO_TOT(IIPAR,JJPAR), SOBS_CO_AVG(IIPAR,JJPAR) + REAL*8 :: SOBS_CO(IIPAR,JJPAR), SOBS_VAR + REAL*8 :: SOBS_CO_ERR(IIPAR,JJPAR), SOBS_CO_VAR(IIPAR,JJPAR) + REAL*8 :: SOBS_ERR, SOBS_VAR_LIMIT, SOBS_CO_HAT(IIPAR,JJPAR) + REAL*8 :: SOBS_HAT(IIPAR,JJPAR) + + + REAL*8 :: GC_CO_NATIVE_ADJ(LLPAR) + REAL*8 :: CO_HAT_ADJ + REAL*8 :: CO_PERT_ADJ(N_IASI_NLA) + REAL*8 :: GC_CO_ADJ(N_IASI_NLA) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IU_FILE, IU_DATA, IOS + CHARACTER(LEN=255) :: FILENAME_ALT, ALT_PATH, FILE_ALT, FILENAME + + + !================================================================= + ! CALC_IASI_CO_FORCE begins here! + !================================================================= + + print*, ' - CALC_IASI_CO_FORCE ' + CALL RAND + ! Reset + IASI_APR(1:N_IASI_NLA) = (/10.161773,9.485584,9.1867937,8.9939589,8.8739,8.8418514,8.7545818, & + 8.6420669,8.3986495,8.0001663,7.5277656,6.9161481,6.3326457,5.7343264, & + 5.1686031,4.6027417,4.1054126,3.6674835,12.211041/) + XNUAIR = 28.964d-3 + NEW_COST = 0D0 + SOBS_COUNT = 0d0 + ADJ_FORCE = 0d0 + IASI_RATIO = 0d0 + GC_ADJ_TEMP_COST = 0d0 + SOBS_CO_NORM = 0d0 + SOBS_CO_MEAN = 0d0 + SOBS_CO_TOT = 0d0 + SOBS_CO_AVG = 0d0 + SOBS_CO = 0d0 + SOBS_CO_ERR = 0d0 + SOBS_CO_VAR = 0d0 + + GC_HOUR = GET_HOUR() + SOBS_VAR_LIMIT = 2.5e17 + ! Save a value of the cost function first + OLD_COST = COST_FUNC + ALT_PATH = '/users/jk/07/xzhang/met_field/' + FILE_ALT = '20000101.cn.4x5.dat' + + FILENAME_ALT = TRIM(ALT_PATH) // TRIM(FILE_ALT) + OPEN(UNIT = 13, FILE = "/users/jk/07/xzhang/met_field/20000101.cn.4x5.dat", STATUS="old",ACTION="read") + READ(13,*) ALT_SURF + CLOSE(13) + PRINT *, "GET_NHMS", GET_NHMS() + IF ( SECOND ) THEN + FILENAME = 'lat_orb_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 901, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 902, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'co_chi_sq_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 904, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 912, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the IASI CO file for this day + CALL READ_IASI_CO_OBS( GET_NYMD(), N_IASI_NOB ) + !PRINT *, "N_IASI", N_IASI_NOB + !PRINT *, "TIME", IASI_TIME(N_IASI_NOB-1000:N_IASI_NOB) + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:N_IASI_NOB) = IASI_TIME(1:N_IASI_NOB)/240000d0 + ENDIF + + !IF(.NOT. DATA_PRESENT) THEN + !PRINT *,"No IASI data present for this day, nothing to do here." + !RETURN + !ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( N_IASI_NOB, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching IASI CO obs for this hour' + RETURN + ENDIF + + !print*, ' for hour range: ', GET_NHMS(), IASI_TIME(NTSTART), IASI_TIME(NTSTOP) + !print*, ' found record range: ', NTSTART, NTSTOP + + + DO I_IASI = NTSTART, NTSTOP, -1 + IF ( (IASI_QUAL_FLAG(I_IASI) .EQ. 0d0 ) .AND. & + (IASI_CLOUD_COVER(I_IASI) .EQ. 0d0) .AND. & + ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_CO(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + GC_CO = 0d0 + IASI_APR_WEB= 0d0 + CO_PERT = 0d0 + CO_HAT = 0d0 + IASI_RATIO = 0d0 + + LIASI = IASI_CO_LVL(I_IASI) + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + I = IIJJ(1) + J = IIJJ(2) + L0 = N_IASI_NLA - LIASI + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + GC_ALT(I,J,1) = ALT_SURF(I,J)*1d-3 + + DO L = 1, LLPAR + JLOOP = JLOP(I,J,L) + GC_PRES(L) = GET_PCENTER(I,J,L) + GC_ALT(I,J,L+1) = (SUM(BXHEIGHT(I,J,1:L)) + ALT_SURF(I,J))*1d-3 + GC_CO_NATIVE(L) = CHK_STT(I,J,L,IDTCO) * TCVV(IDTCO)* XNUMOLAIR* BXHEIGHT(I,J,L) *100d0 /(AIRVOL(I,J,L)* 1d6) + ENDDO + !PRINT *, "GC_ALT", GC_ALT(I,J,:) + !PRINT *, "IASI_ALT", IASI_ALT(:) + !PRINT *, "GC_CO_NATIVE", SUM(GC_CO_NATIVE(:)) + CALL BIN_DATA_IASI(GC_ALT(I,J,:),IASI_ALT(L0+1:L0+LIASI),GC_CO_NATIVE(:), GC_CO, IASI_APR(L0+1:L0+LIASI),LIASI, 1) + !PRINT *, "GC_ALT", GC_ALT(I,J,:) + !PRINT *, "IASI_ALT", IASI_ALT(L0+1:L0+LIASI) + !PRINT *, " GC_CO_NATIVE", GC_CO_NATIVE(:) + !PRINT *, " GC_CO", GC_CO(:) + !-------------------------------------------------------------- + ! Apply IASI CO observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by IASI [lnvmr] + ! x_a = IASI apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = IASI averaging kernel + ! + ! OR + ! + ! x_smoothed = A_k*x_m + (I-A_k)*x_a + ! where + ! x_smoothed = GC modeled column smoothed by IASI [vmr] + ! x_a = IASI apriori partial column [vmr] + ! x_m = GC modeled profile [vmr] + ! A_k = IASI averaging kernel + !-------------------------------------------------------------- + ! x_m - x_a + ! x_a + A_k * ( x_m - x_a ) + !PRINT *, "GC_CO", SUM(GC_CO(:)) + !PRINT *, "IASI_CO_AVK", IASI_CO_AVK(I_IASI,:) + DO L = 1, LIASI + IF ( (IASI_CO_APR(I_IASI,L+L0) > 0) .AND. & + (GC_CO(L) > 0) ) THEN + IASI_APR_WEB(L) = IASI_APR(L+L0) * AIRDEN(L,I,J) * XNUMOLAIR * 1d-14 * 1d5 + !IASI_RATIO(L) = IASI_CO_APR(I_IASI,L+L0)/IASI_APR_WEB(L) + !CO_PERT(L) = IASI_RATIO(L)*GC_CO(L) - IASI_CO_APR(I_IASI,L+L0) + CO_PERT(L) = GC_CO(L) - IASI_CO_APR(I_IASI,L+L0) + CO_HAT(L) = IASI_CO_APR(I_IASI,L+L0) + IASI_CO_AVK(I_IASI,L0+L) * CO_PERT(L) + ENDIF + ! actual comparison + ENDDO + CO_COL_HAT = SUM(CO_HAT(1:LIASI)) + SOBS_CO_STD = (1d0 - IASI_CO_STD(I_IASI)/IASI_CO(I_IASI))**2 + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + SOBS_CO_NORM(I,J) = SOBS_CO_NORM(I,J) + SOBS_CO_STD + SOBS_CO_MEAN(I,J) = SOBS_CO_MEAN(I,J) + IASI_CO(I_IASI) * SOBS_CO_STD + SOBS_CO_TOT(I,J) = SOBS_CO_TOT(I,J) + IASI_CO(I_IASI) + SOBS_CO_HAT(I,J) = SOBS_CO_HAT(I,J) + CO_COL_HAT + SOBS_AVK_TOT(I,J,:) = SOBS_AVK_TOT(I,J,:) + IASI_CO_AVK(I_IASI,:) * SOBS_CO_STD + !PRINT *, "SOBS_CO_STD", SOBS_CO_STD + ENDIF + ENDDO + DO I = 1, IIPAR + DO J = 1, JJPAR + IF ( ( SOBS_CO_NORM(I,J) > 0d0 ) .AND. & + ( SOBS_COUNT(I,J) > 0d0 ) ) THEN + SOBS_CO(I,J) = SOBS_CO_MEAN(I,J)/SOBS_CO_NORM(I,J) + SOBS_CO_AVG(I,J) = SOBS_CO_TOT(I,J)/SOBS_COUNT(I,J) + SOBS_CO_AVK(I,J,:) = SOBS_AVK_TOT(I,J,:)/SOBS_CO_NORM(I,J) + SOBS_HAT(I,J) = SOBS_CO_HAT(I,J)/SOBS_COUNT(I,J) + SOBS_CO_ERR(I,J) = SOBS_CO(I,J)*(1d0 - SQRT(SOBS_CO_NORM(I,J)/SOBS_COUNT(I,J))) + ENDIF + ENDDO + ENDDO + DO I_IASI = NTSTART, NTSTOP, -1 + IF ( (IASI_QUAL_FLAG(I_IASI) .EQ. 0d0 ) .AND. & + (IASI_CLOUD_COVER(I_IASI) .EQ. 0d0) .AND. & + ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_CO(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + I = IIJJ(1) + J = IIJJ(2) + + IF ( ( SOBS_CO_NORM(I,J) > 0d0 ) .AND. & + ( SOBS_COUNT(I,J) > 0d0 ) ) THEN + SOBS_CO_VAR(I,J) = SOBS_CO_VAR(I,J) + (IASI_CO(I_IASI) - SOBS_CO_AVG(I,J))**2 + ENDIF + ENDIF + ENDDO + + DO I=1,IIPAR + DO J=1,JJPAR + FORCE = 0d0 + DIFF = 0d0 + CO_PERT_ADJ = 0d0 + IF ( SOBS_COUNT(I,J) > 3d0 ) THEN + SOBS_VAR = SOBS_CO_VAR(I,J)/SOBS_COUNT(I,J) + SOBS_VAR = MIN(SOBS_VAR,SOBS_VAR_LIMIT) + SOBS_ERR = SQRT(SOBS_CO_ERR(I,J)**2/SOBS_COUNT(I,J)+SOBS_VAR) + IF ( SOBS_ERR/SOBS_CO(I,J) < 0.025 ) THEN + SOBS_ERR = 0.025*SOBS_CO(I,J) + ENDIF + CALL RANDOM_NUMBER(SOBS_RAND) + SOBS_CO_COL = SOBS_CO(I,J) !- SQRT(SOBS_VAR)*SOBS_RAND + DIFF = SOBS_HAT(I,J) - SOBS_CO_COL + FORCE = DIFF/SOBS_ERR**2 + NEW_COST(I,J) = 0.5 * DIFF * FORCE + !PRINT *, "FORCE", FORCE + !PRINT *, "CO_COL_HAT", SOBS_HAT(I,J) + !PRINT *, "SOBS_CO_COL", SOBS_CO_COL + !PRINT *, "SOBS_ERR", SOBS_ERR + WRITE(912,110) (DIFF/1d12) + WRITE(902,110) (GET_XMID(I)) + WRITE(901,110) (GET_YMID(J)) + WRITE(904,110) (2*NEW_COST(I,J)) + + !DO L = 1, LIASI + ! adjoint of IASI operator + !CO_PERT_ADJ(L) = SOBS_CO_AVK(I,J,L) * FORCE + !CO_PERT_ADJ(L) = CO_PERT_ADJ(L)*IASI_RATIO(L) + !ENDDO + !CALL BIN_DATA_IASI(GC_ALT(I,J,:),IASI_ALT(:),GC_CO_NATIVE_ADJ(:), CO_PERT_ADJ, IASI_APR(1+L0:L0+LIASI), LIASI, -1) + !PRINT *, "CO_PERT_ADJ", CO_PERT_ADJ(:) + !PRINT *, "GC_CO_NATIVE_ADJ(:)", GC_CO_NATIVE_ADJ(:) + + DO L = 1, LLPAR + ! Adjoint of unit conversion + ADJ_FORCE(I,J,L,IDTCO) = FORCE * TCVV(IDTCO) * BXHEIGHT(I,J,L) * 100d0 * XNUMOLAIR / (1d6 *AIRVOL(I,J,L)) + !PRINT *, "ADJ_FORCE", ADJ_FORCE(I,J,L,IDTCO) + !PRINT *, "BXHEIGHT", BXHEIGHT(I,J,L)/AIRVOL(I,J,L) + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + STT_ADJ(I,J,L,IDTCO) = STT_ADJ(I,J,L,IDTCO) + ADJ_FORCE(I,J,L,IDTCO) + ENDIF + ENDDO + !PRINT *, "ADJ_FORCE", ADJ_FORCE(I,J,:,IDTCO) + COST_FUNC = COST_FUNC + NEW_COST(I,J) + ENDIF + ENDDO + ENDDO + +110 FORMAT(F18.6,1X) + !PRINT *, "GC_ADJ_TEMP", GC_ADJ_TEMP(:,:,5) + !PRINT *, "STT_ADJ BEFORE", STT_ADJ(:,:,5,IDTCO) + !PRINT *, "GC_ADJ_TEMP", GC_ADJ_TEMP(:,:,5)/SOBS_COUNT(:,:) + !PRINT *, "STT_ADJ AFTER",STT_ADJ(:,:,5,IDTCO) + + + IF ( FIRST ) FIRST = .FALSE. + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' IASI CO contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_IASI_CO_FORCE + +!---------------------------------------------------------------------------- + SUBROUTINE CLEANUP_IASI + + IF(ALLOCATED(IASI_LON)) DEALLOCATE(IASI_LON) + IF(ALLOCATED(IASI_LAT)) DEALLOCATE(IASI_LAT) + IF(ALLOCATED(IASI_TIME)) DEALLOCATE(IASI_TIME) + IF(ALLOCATED(IASI_CO_AVK)) DEALLOCATE(IASI_CO_AVK) + IF(ALLOCATED(IASI_CO_APR)) DEALLOCATE(IASI_CO_APR) + IF(ALLOCATED(IASI_CO_STD)) DEALLOCATE(IASI_CO_STD) + IF(ALLOCATED(IASI_CO)) DEALLOCATE(IASI_CO) + IF(ALLOCATED(IASI_ALT)) DEALLOCATE(IASI_ALT) + IF(ALLOCATED(IASI_SOLAR_ZENITH)) DEALLOCATE(IASI_SOLAR_ZENITH) + IF(ALLOCATED(IASI_CLOUD_COVER)) DEALLOCATE(IASI_CLOUD_COVER) + IF(ALLOCATED(IASI_QUAL_FLAG)) DEALLOCATE(IASI_QUAL_FLAG) + IF(ALLOCATED(IASI_CO_LVL)) DEALLOCATE(IASI_CO_LVL) + !IF(ALLOCATED(TEMPDATA)) DEALLOCATE(TEMPDATA) + !IF(ALLOCATED(TIME_FRAC)) DEALLOCATE(TIME_FRAC) + END SUBROUTINE CLEANUP_IASI +!------------------------------------------------------------------------------ + SUBROUTINE GET_NT_RANGE( N_IASI_NOB, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_IASI_NOB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(N_IASI_NOB) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS, FOUND_BAD_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + FOUND_BAD_RECORDS = .TRUE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) THEN + NTSAVE = N_IASI_NOB + IF ( NTSAVE > 1 ) THEN + DO WHILE (FOUND_BAD_RECORDS == .TRUE.) + IF (TIME_FRAC(NTSAVE) > 0.5d0) THEN + FOUND_BAD_RECORDS = .FALSE. + ELSE + NTSAVE = NTSAVE - 1 + ENDIF + ENDDO + ENDIF + ENDIF + + DO WHILE (TIME_FRAC(NTSAVE) < 0) + NTSAVE = NTSAVE -1 + IF (NTSAVE == 0) EXIT + ENDDO + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' N_IASI_NOB ', N_IASI_NOB + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + ! one hour as a fraction of day + H1_FRAC = 0d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + !print*, 'All records have been read already ' + RETURN + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE) + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + !ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_DATA_IASI( GC_EDGE, OBS_EDGE, DATA_MODEL, DATA_IASI, OBS_IASI, LIASI, FB ) + +!****************************************************************************** +!Based on the code from Monika. (zhe 1/19/11) +!FB = 1 for forward +!FB = -1 for adjoint +!****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: LIASI, NB, LVL_CRT1, LVL_CRT2 + REAL*8 :: ALT_MODEL(LLPAR), GC_EDGE(LLPAR+1), HI, LOW + REAL*8 :: DATA_MODEL(LLPAR), BIN_IASI(LLPAR,LIASI), DIFF_BIN + REAL*8 :: OBS_EDGE(LIASI+1), DATA_IASI(LIASI), OBS_IASI(LIASI) + BIN_IASI(:,:) = 0d0 + LVL_CRT1 = 0 + LVL_CRT2 = 0 + !================================================================= + ! BIN_DATA_V4 begins here! + !================================================================= + DO L = 1, LLPAR + ALT_MODEL(L) = 0.5d0*(GC_EDGE(L)+GC_EDGE(L+1)) + ENDDO + IF (FB > 0) THEN + + !DO L = 1, LIASI + !DO LL = 1, LLPAR + !IF ( ALT_MODEL(LL) >= OBS_EDGE(L) ) THEN + !DATA_IASI(L) = DATA_MODEL(LL) + !EXIT + !ENDIF + !ENDDO + !ENDDO + + DO L = 1, LIASI + DO LL = 1, LLPAR + LOW = GC_EDGE(LL) + HI = GC_EDGE(LL+1) + IF ( GC_EDGE(LL) >= OBS_EDGE(L)) THEN + IF ( GC_EDGE(LL+1) <= OBS_EDGE(L+1) ) THEN + BIN_IASI(LL,L) = 1d0 + !NB = NB + 1 + ELSEIF (GC_EDGE(LL) <= OBS_EDGE(L+1)) THEN + DIFF_BIN = HI - LOW + BIN_IASI(LL,L) = ( OBS_EDGE(L+1) - LOW)/DIFF_BIN + BIN_IASI(LL,L+1) = ( HI - OBS_EDGE(L+1))/DIFF_BIN + ELSEIF (GC_EDGE(LL) > OBS_EDGE(LIASI+1)) THEN + BIN_IASI(LL,LIASI) = 1d0 + ENDIF + ELSEIF (GC_EDGE(LL) < OBS_EDGE(1) ) THEN + BIN_IASI(LL,1) = 1D0 + ENDIF + ENDDO + !IF (NB > 0) DATA_IASI(L) = DATA_TEM !/ NB + ENDDO + + DO L = 1, LIASI + DATA_IASI(L) = 0d0 + DO LL = 1, LLPAR + DATA_IASI(L) = DATA_IASI(L) + BIN_IASI(LL,L) * DATA_MODEL(LL) + ENDDO + ENDDO + DO L = 2, LIASI-1 + IF (DATA_IASI(L) == 0d0) THEN + IF ( DATA_IASI(L-1) > 0d0) THEN + LVL_CRT1 = L-1 + !PRINT *, "DATA_IASI1", DATA_IASI(L-1) + ENDIF + IF (DATA_IASI(L+1) > 0d0) THEN + LVL_CRT2 = L+1 + !PRINT *, "DATA_IASI2", DATA_IASI(L+1) + ENDIF + IF (REAL(LVL_CRT1)*REAL(LVL_CRT2) > 0D0) THEN + DO LL = LVL_CRT1, LVL_CRT2 + DATA_IASI(LL) = ((DATA_IASI(LVL_CRT1)+DATA_IASI(LVL_CRT2))/SUM(OBS_IASI(LVL_CRT1:LVL_CRT2)))*OBS_IASI(LL) + ENDDO + !PRINT *, "OBS_IASI", SUM(OBS_IASI(LVL_CRT1:LVL_CRT2)) + LVL_CRT1 = 0 + LVL_CRT2 = 0 + ENDIF + ENDIF + ENDDO + + ELSE + + DATA_MODEL(:) = 0. + DO L = 1, LLPAR + DO LL = 1, LIASI + IF ( ( ALT_MODEL(L) >= OBS_EDGE(LL)) .and. ( ALT_MODEL(L) < OBS_EDGE(LL+1)) ) THEN + DATA_MODEL(L) = DATA_IASI(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_DATA_IASI + + + + + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 +!------------------------------------------------------------------- + + END MODULE IASI_CO_OBS_MOD diff --git a/code/obs_operators/iasi_co_obs_mod.f90~ b/code/obs_operators/iasi_co_obs_mod.f90~ new file mode 100644 index 0000000..0237e64 --- /dev/null +++ b/code/obs_operators/iasi_co_obs_mod.f90~ @@ -0,0 +1,970 @@ +!$Id: IASI_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ +MODULE IASI_CO_OBS_MOD + + IMPLICIT NONE + + !mkeller +#include "CMN_SIZE" + !#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_IASI_CO_OBS + PUBLIC CALC_IASI_CO_FORCE + + ! Parameters + INTEGER, PARAMETER :: N_IASI_NLA = 19 + INTEGER, PARAMETER :: N_IASI_NPR = 20 + INTEGER, PARAMETER :: MAXIASI = 2000000 + INTEGER, PARAMETER :: IASI_COL = 60!59 + + ! Module variables + + ! IASI data + REAL*8, ALLOCATABLE :: IASI_LON(:) + REAL*8, ALLOCATABLE :: IASI_LAT(:) + REAL*8, ALLOCATABLE :: IASI_TIME(:) + REAL*8, ALLOCATABLE :: IASI_CO(:) + REAL*8, ALLOCATABLE :: IASI_CO_STD(:) + REAL*8, ALLOCATABLE :: IASI_ALT(:) + REAL*8, ALLOCATABLE :: IASI_CO_APR(:,:) + REAL*8, ALLOCATABLE :: IASI_CO_AVK(:,:) + REAL*8, ALLOCATABLE :: IASI_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: IASI_CLOUD_COVER(:) + REAL*8, ALLOCATABLE :: IASI_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: IASI_CO_LVL(:) + !REAL*8, ALLOCATABLE :: TIME_FRAC(:) + !REAL*8, ALLOCATABLE :: TEMPDATA(:,:) + + ! MLS grid specification + INTEGER :: N_IASI_NOB, N_IASI_DATA + + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT +CONTAINS + !------------------------------------------------------------------------------ + + SUBROUTINE READ_IASI_CO_OBS( YYYYMMDD, N_IASI_NOB ) + ! +!****************************************************************************** +! Subroutine READ_IASI_CO_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_IASI_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NIASI (INTEGER) : Number of IASI retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) IASI (IASI_CO_OBS) : IASI retrieval for current day +! +! NOIASI: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : EXPAND_DATE + USE FILE_MOD, ONLY : IOERROR + +#include "CMN_SIZE" ! size parameters + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LIASI + INTEGER :: N_IASI_NOB + INTEGER :: N, J + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: TMP1 + REAL*8 :: DUMMY(IASI_COL) + REAL*8 :: TEMPDATA(MAXIASI, IASI_COL) + INTEGER :: I, II, III, K + INTEGER :: IU_FILE, IU_DATA, IOS + + + !================================================================= + ! READ_IASI_CO_OBS begins here! + !================================================================= + CALL CLEANUP_IASI + ! filename root + READ_FILENAME = TRIM( 'iasi_CO_LATMOS_ULB_YYYYMMDD_v20140922.txt' ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + ! READ_FILENAME = TRIM( DATA_DIR ) // TRIM( 'IASI_CO/' ) // + ! & TRIM( READ_FILENAME ) + READ_FILENAME = '/users/jk/15/xzhang/IASI_CO/' // TRIM( READ_FILENAME ) + WRITE(6,*) ' - READ_IASI_CO_OBS: reading file: ', READ_FILENAME + IU_FILE = 67 + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"IASI file", TRIM(READ_FILENAME), " not found, "// "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"IASI file found!" + ENDIF + + OPEN(IU_FILE, FILE=READ_FILENAME, IOSTAT=IOS) + N_IASI_DATA = 0 + N_IASI_NOB = 0 + DO + READ(IU_FILE, *, IOSTAT=IOS) DUMMY + IF (IOS /= 0) EXIT + N_IASI_DATA = N_IASI_DATA + 1 + I = I + 1 + TEMPDATA(I,:) = DUMMY(:) + ENDDO + CLOSE(IU_FILE) + + DO I = 1, N_IASI_DATA + IF (TEMPDATA(I,3) .EQ. REAL(YYYYMMDD)) THEN + N_IASI_NOB = N_IASI_NOB + 1 + ENDIF + ENDDO + + ALLOCATE(IASI_LAT(N_IASI_NOB)) + ALLOCATE(IASI_LON(N_IASI_NOB)) + ALLOCATE(IASI_TIME(N_IASI_NOB)) + ALLOCATE(IASI_SOLAR_ZENITH(N_IASI_NOB)) + ALLOCATE(IASI_QUAL_FLAG(N_IASI_NOB)) + ALLOCATE(IASI_CLOUD_COVER(N_IASI_NOB)) + ALLOCATE(IASI_CO(N_IASI_NOB)) + ALLOCATE(IASI_CO_STD(N_IASI_NOB)) + ALLOCATE(IASI_CO_APR(N_IASI_NOB, N_IASI_NLA)) + ALLOCATE(IASI_CO_AVK(N_IASI_NOB, N_IASI_NLA)) + ALLOCATE(IASI_ALT(N_IASI_NPR)) + ALLOCATE(IASI_CO_LVL(N_IASI_NOB)) + + DO I = 1, N_IASI_NOB + IASI_LAT(I) = TEMPDATA(I,1) + IASI_LON(I) = TEMPDATA(I,2) + IASI_TIME(I) = TEMPDATA(I,4) + IASI_SOLAR_ZENITH(I) = TEMPDATA(I,5) + IASI_QUAL_FLAG(I) = TEMPDATA(I,16)!15) + !PRINT *, "IASI_QUAL_FLAG", IASI_QUAL_FLAG(I) + IASI_CLOUD_COVER(I) = TEMPDATA(I,17)!16) + !READ(IU_FILE, *) (TEMPDATA(K), K=19,IASI_COL) + IASI_CO(I) = TEMPDATA(I,21)!20) + IASI_CO_STD(I) = TEMPDATA(I,21)*TEMPDATA(I,22)*0.5 + DO J = 1, N_IASI_NLA + IASI_CO_APR(I,J) = TEMPDATA(I,22+J) !21 + IASI_CO_AVK(I,J) = TEMPDATA(I,41+J) !40 + !IASI_ALT(J) = REAL(J)-1d0 + ENDDO + !IASI_ALT(N_IASI_NLA+1) = 60d0 + ENDDO + DO J = 1, N_IASI_NLA + IASI_ALT(J) = REAL(J) -1d0 + ENDDO + + IASI_ALT(N_IASI_NPR) = 60d0 + !PRINT *, "TEMPDATA", TEMPDATA(:) + !PRINT *, "IASI_TIME", TEMPDATA(N_IASI_NOB-10000:N_IASI_NOB,3) + !PRINT *, "IASI_CO_APR", IASI_CO_APR(1,:), "LEVEL2", IASI_CO_APR(2,:) + !PRINT *, "IASI_CO_AVK", IASI_CO_AVK(1,:), "LEVEL2", IASI_CO_AVK(2,:) + !PRINT *, "IASI_CO", IASI_CO(1:10) + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + ! Now determine how many of the levels in CO are + ! 'good' and how many are just FILL. + !ALLOCATE(IASI_CO_LVL(N_IASI_NOB)) + DO N = 1, N_IASI_NOB + J = 1 + DO WHILE ( J .le. N_IASI_NLA ) + ! check if the value is good + IF (IASI_CO_APR(N,J) > FILL ) THEN + ! save the number of good levels as LTES + IASI_CO_LVL(N) = N_IASI_NLA - J + 1 + ! and now we can exit the while loop + J = N_IASI_NLA + 1 + ! otherwise this level is just filler + ELSE + ! so proceed to the next one up + J = J + 1 + ENDIF + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE READ_IASI_CO_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'IASI_o3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_IASI_CO_FORCE( COST_FUNC ) + ! +!****************************************************************************** +! Subroutine CALC_IASI_CO_FORCE calculaIASI the adjoint forcing from the IASI +! CO observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost function [unitless] +! +! +! NOIASI: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled CO (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + !USE ADJ_ARRAYS_MOD, ONLY : CO_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP, VOLUME + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_HOUR + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDTCO + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT, I_IASI + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LIASI, L0 + INTEGER :: JLOOP + INTEGER :: GC_HOUR + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CO_NATIVE(LLPAR) + REAL*8 :: GC_CO(N_IASI_NLA), IASI_APR_WEB(N_IASI_NLA) + REAL*8 :: GC_PSURF, IASI_PSURF, GC_ALT(IIPAR, JJPAR, LLPAR+1) + REAL*8 :: CO_HAT(N_IASI_NLA) + REAL*8 :: SOBS_CO_AVK(IIPAR,JJPAR,N_IASI_NLA) + REAL*8 :: CO_PERT(N_IASI_NLA), SOBS_AVK_TOT(IIPAR,JJPAR,N_IASI_NLA) + REAL*8 :: FORCE, IASI_RATIO(N_IASI_NLA) + REAL*8 :: DIFF, CO_COL_OBS, CO_COL_HAT + REAL*8 :: IASI_PCENTER(N_IASI_NLA) + REAL*8 :: IASI_APR(N_IASI_NLA) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: OLD_COST + REAL*8 :: XNUAIR, SOBS_RAND + REAL*8, SAVE :: TIME_FRAC(MAXIASI) + REAL*8 :: ALT_SURF(IIPAR,JJPAR) + REAL*8 :: SOBS_CO_STD, SOBS_CO_COL + REAL*8 :: SOBS_CO_NORM(IIPAR,JJPAR), SOBS_CO_MEAN(IIPAR,JJPAR) + REAL*8 :: SOBS_CO_TOT(IIPAR,JJPAR), SOBS_CO_AVG(IIPAR,JJPAR) + REAL*8 :: SOBS_CO(IIPAR,JJPAR), SOBS_VAR + REAL*8 :: SOBS_CO_ERR(IIPAR,JJPAR), SOBS_CO_VAR(IIPAR,JJPAR) + REAL*8 :: SOBS_ERR, SOBS_VAR_LIMIT, SOBS_CO_HAT(IIPAR,JJPAR) + REAL*8 :: SOBS_HAT(IIPAR,JJPAR) + + + REAL*8 :: GC_CO_NATIVE_ADJ(LLPAR) + REAL*8 :: CO_HAT_ADJ + REAL*8 :: CO_PERT_ADJ(N_IASI_NLA) + REAL*8 :: GC_CO_ADJ(N_IASI_NLA) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IU_FILE, IU_DATA, IOS + CHARACTER(LEN=255) :: FILENAME_ALT, ALT_PATH, FILE_ALT, FILENAME + + + !================================================================= + ! CALC_IASI_CO_FORCE begins here! + !================================================================= + + print*, ' - CALC_IASI_CO_FORCE ' + CALL RAND + ! Reset + IASI_APR(1:N_IASI_NLA) = (/10.161773,9.485584,9.1867937,8.9939589,8.8739,8.8418514,8.7545818, & + 8.6420669,8.3986495,8.0001663,7.5277656,6.9161481,6.3326457,5.7343264, & + 5.1686031,4.6027417,4.1054126,3.6674835,12.211041/) + XNUAIR = 28.964d-3 + NEW_COST = 0D0 + SOBS_COUNT = 0d0 + ADJ_FORCE = 0d0 + IASI_RATIO = 0d0 + GC_ADJ_TEMP_COST = 0d0 + SOBS_CO_NORM = 0d0 + SOBS_CO_MEAN = 0d0 + SOBS_CO_TOT = 0d0 + SOBS_CO_AVG = 0d0 + SOBS_CO = 0d0 + SOBS_CO_ERR = 0d0 + SOBS_CO_VAR = 0d0 + + GC_HOUR = GET_HOUR() + SOBS_VAR_LIMIT = 2.5e17 + ! Save a value of the cost function first + OLD_COST = COST_FUNC + ALT_PATH = '/users/jk/07/xzhang/met_field/' + FILE_ALT = '20000101.cn.4x5.dat' + + FILENAME_ALT = TRIM(ALT_PATH) // TRIM(FILE_ALT) + OPEN(UNIT = 13, FILE = "/users/jk/07/xzhang/met_field/20000101.cn.4x5.dat", STATUS="old",ACTION="read") + READ(13,*) ALT_SURF + CLOSE(13) + PRINT *, "GET_NHMS", GET_NHMS() + IF ( SECOND ) THEN + FILENAME = 'lat_orb_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 901, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 902, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'co_chi_sq_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 904, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 912, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the IASI CO file for this day + CALL READ_IASI_CO_OBS( GET_NYMD(), N_IASI_NOB ) + !PRINT *, "N_IASI", N_IASI_NOB + !PRINT *, "TIME", IASI_TIME(N_IASI_NOB-1000:N_IASI_NOB) + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:N_IASI_NOB) = IASI_TIME(1:N_IASI_NOB)/240000d0 + ENDIF + + !IF(.NOT. DATA_PRESENT) THEN + !PRINT *,"No IASI data present for this day, nothing to do here." + !RETURN + !ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( N_IASI_NOB, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching IASI CO obs for this hour' + RETURN + ENDIF + + !print*, ' for hour range: ', GET_NHMS(), IASI_TIME(NTSTART), IASI_TIME(NTSTOP) + !print*, ' found record range: ', NTSTART, NTSTOP + + + DO I_IASI = NTSTART, NTSTOP, -1 + IF ( (IASI_QUAL_FLAG(I_IASI) .EQ. 0d0 ) .AND. & + (IASI_CLOUD_COVER(I_IASI) .EQ. 0d0) .AND. & + ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_CO(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + GC_CO = 0d0 + IASI_APR_WEB= 0d0 + CO_PERT = 0d0 + CO_HAT = 0d0 + IASI_RATIO = 0d0 + + LIASI = IASI_CO_LVL(I_IASI) + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + I = IIJJ(1) + J = IIJJ(2) + L0 = N_IASI_NLA - LIASI + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + GC_ALT(I,J,1) = ALT_SURF(I,J)*1d-3 + + DO L = 1, LLPAR + JLOOP = JLOP(I,J,L) + GC_PRES(L) = GET_PCENTER(I,J,L) + GC_ALT(I,J,L+1) = (SUM(BXHEIGHT(I,J,1:L)) + ALT_SURF(I,J))*1d-3 + GC_CO_NATIVE(L) = CHK_STT(I,J,L,IDTCO) * TCVV(IDTCO)* XNUMOLAIR* BXHEIGHT(I,J,L) *100d0 /(AIRVOL(I,J,L)* 1d6) + ENDDO + !PRINT *, "GC_ALT", GC_ALT(I,J,:) + !PRINT *, "IASI_ALT", IASI_ALT(:) + !PRINT *, "GC_CO_NATIVE", SUM(GC_CO_NATIVE(:)) + CALL BIN_DATA_IASI(GC_ALT(I,J,:),IASI_ALT(L0+1:L0+LIASI),GC_CO_NATIVE(:), GC_CO, IASI_APR(L0+1:L0+LIASI),LIASI, 1) + !PRINT *, "GC_ALT", GC_ALT(I,J,:) + !PRINT *, "IASI_ALT", IASI_ALT(L0+1:L0+LIASI) + !PRINT *, " GC_CO_NATIVE", GC_CO_NATIVE(:) + !PRINT *, " GC_CO", GC_CO(:) + !-------------------------------------------------------------- + ! Apply IASI CO observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by IASI [lnvmr] + ! x_a = IASI apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = IASI averaging kernel + ! + ! OR + ! + ! x_smoothed = A_k*x_m + (I-A_k)*x_a + ! where + ! x_smoothed = GC modeled column smoothed by IASI [vmr] + ! x_a = IASI apriori partial column [vmr] + ! x_m = GC modeled profile [vmr] + ! A_k = IASI averaging kernel + !-------------------------------------------------------------- + ! x_m - x_a + ! x_a + A_k * ( x_m - x_a ) + !PRINT *, "GC_CO", SUM(GC_CO(:)) + !PRINT *, "IASI_CO_AVK", IASI_CO_AVK(I_IASI,:) + DO L = 1, LIASI + IF ( (IASI_CO_APR(I_IASI,L+L0) > 0) .AND. & + (GC_CO(L) > 0) ) THEN + IASI_APR_WEB(L) = IASI_APR(L+L0) * AIRDEN(L,I,J) * XNUMOLAIR * 1d-14 * 1d5 + !IASI_RATIO(L) = IASI_CO_APR(I_IASI,L+L0)/IASI_APR_WEB(L) + !CO_PERT(L) = IASI_RATIO(L)*GC_CO(L) - IASI_CO_APR(I_IASI,L+L0) + CO_PERT(L) = GC_CO(L) - IASI_CO_APR(I_IASI,L+L0) + CO_HAT(L) = IASI_CO_APR(I_IASI,L+L0) + IASI_CO_AVK(I_IASI,L0+L) * CO_PERT(L) + ENDIF + ! actual comparison + ENDDO + CO_COL_HAT = SUM(CO_HAT(1:LIASI)) + SOBS_CO_STD = (1d0 - IASI_CO_STD(I_IASI)/IASI_CO(I_IASI))**2 + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + SOBS_CO_NORM(I,J) = SOBS_CO_NORM(I,J) + SOBS_CO_STD + SOBS_CO_MEAN(I,J) = SOBS_CO_MEAN(I,J) + IASI_CO(I_IASI) * SOBS_CO_STD + SOBS_CO_TOT(I,J) = SOBS_CO_TOT(I,J) + IASI_CO(I_IASI) + SOBS_CO_HAT(I,J) = SOBS_CO_HAT(I,J) + CO_COL_HAT + SOBS_AVK_TOT(I,J,:) = SOBS_AVK_TOT(I,J,:) + IASI_CO_AVK(I_IASI,:) * SOBS_CO_STD + !PRINT *, "SOBS_CO_STD", SOBS_CO_STD + ENDIF + ENDDO + DO I = 1, IIPAR + DO J = 1, JJPAR + IF ( ( SOBS_CO_NORM(I,J) > 0d0 ) .AND. & + ( SOBS_COUNT(I,J) > 0d0 ) ) THEN + SOBS_CO(I,J) = SOBS_CO_MEAN(I,J)/SOBS_CO_NORM(I,J) + SOBS_CO_AVG(I,J) = SOBS_CO_TOT(I,J)/SOBS_COUNT(I,J) + SOBS_CO_AVK(I,J,:) = SOBS_AVK_TOT(I,J,:)/SOBS_CO_NORM(I,J) + SOBS_HAT(I,J) = SOBS_CO_HAT(I,J)/SOBS_COUNT(I,J) + SOBS_CO_ERR(I,J) = SOBS_CO(I,J)*(1d0 - SQRT(SOBS_CO_NORM(I,J)/SOBS_COUNT(I,J))) + ENDIF + ENDDO + ENDDO + DO I_IASI = NTSTART, NTSTOP, -1 + IF ( (IASI_QUAL_FLAG(I_IASI) .EQ. 0d0 ) .AND. & + (IASI_CLOUD_COVER(I_IASI) .EQ. 0d0) .AND. & + ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_CO(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + I = IIJJ(1) + J = IIJJ(2) + + IF ( ( SOBS_CO_NORM(I,J) > 0d0 ) .AND. & + ( SOBS_COUNT(I,J) > 0d0 ) ) THEN + SOBS_CO_VAR(I,J) = SOBS_CO_VAR(I,J) + (IASI_CO(I_IASI) - SOBS_CO_AVG(I,J))**2 + ENDIF + ENDIF + ENDDO + + DO I=1,IIPAR + DO J=1,JJPAR + FORCE = 0d0 + DIFF = 0d0 + CO_PERT_ADJ = 0d0 + IF ( SOBS_COUNT(I,J) > 3d0 ) THEN + SOBS_VAR = SOBS_CO_VAR(I,J)/SOBS_COUNT(I,J) + SOBS_VAR = MIN(SOBS_VAR,SOBS_VAR_LIMIT) + SOBS_ERR = SQRT(SOBS_CO_ERR(I,J)**2/SOBS_COUNT(I,J)+SOBS_VAR) + CALL RANDOM_NUMBER(SOBS_RAND) + SOBS_CO_COL = SOBS_CO(I,J) !- SQRT(SOBS_VAR)*SOBS_RAND + DIFF = SOBS_HAT(I,J) - SOBS_CO_COL + FORCE = DIFF/SOBS_ERR**2 + NEW_COST(I,J) = 0.5 * DIFF * FORCE + !PRINT *, "FORCE", FORCE + !PRINT *, "CO_COL_HAT", SOBS_HAT(I,J) + !PRINT *, "SOBS_CO_COL", SOBS_CO_COL + !PRINT *, "SOBS_ERR", SOBS_ERR + WRITE(912,110) (DIFF/1d12) + WRITE(902,110) (GET_XMID(I)) + WRITE(901,110) (GET_YMID(J)) + WRITE(904,110) (2*NEW_COST(I,J)) + + !DO L = 1, LIASI + ! adjoint of IASI operator + !CO_PERT_ADJ(L) = SOBS_CO_AVK(I,J,L) * FORCE + !CO_PERT_ADJ(L) = CO_PERT_ADJ(L)*IASI_RATIO(L) + !ENDDO + !CALL BIN_DATA_IASI(GC_ALT(I,J,:),IASI_ALT(:),GC_CO_NATIVE_ADJ(:), CO_PERT_ADJ, IASI_APR(1+L0:L0+LIASI), LIASI, -1) + !PRINT *, "CO_PERT_ADJ", CO_PERT_ADJ(:) + !PRINT *, "GC_CO_NATIVE_ADJ(:)", GC_CO_NATIVE_ADJ(:) + DO L = 1, LLPAR + ! Adjoint of unit conversion + ADJ_FORCE(I,J,L,IDTCO) = FORCE * TCVV(IDTCO) * BXHEIGHT(I,J,L) * 100d0 * XNUMOLAIR / (1d6 *AIRVOL(I,J,L)) + !PRINT *, "ADJ_FORCE", ADJ_FORCE(I,J,L,IDTCO) + !PRINT *, "BXHEIGHT", BXHEIGHT(I,J,L)/AIRVOL(I,J,L) + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + STT_ADJ(I,J,L,IDTCO) = STT_ADJ(I,J,L,IDTCO) + ADJ_FORCE(I,J,L,IDTCO) + ENDIF + ENDDO + !PRINT *, "ADJ_FORCE", ADJ_FORCE(I,J,:,IDTCO) + COST_FUNC = COST_FUNC + NEW_COST(I,J) + ENDIF + ENDDO + ENDDO + +110 FORMAT(F18.6,1X) + !PRINT *, "GC_ADJ_TEMP", GC_ADJ_TEMP(:,:,5) + !PRINT *, "STT_ADJ BEFORE", STT_ADJ(:,:,5,IDTCO) + !PRINT *, "GC_ADJ_TEMP", GC_ADJ_TEMP(:,:,5)/SOBS_COUNT(:,:) + !PRINT *, "STT_ADJ AFTER",STT_ADJ(:,:,5,IDTCO) + + + IF ( FIRST ) FIRST = .FALSE. + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' IASI CO contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_IASI_CO_FORCE + +!---------------------------------------------------------------------------- + SUBROUTINE CLEANUP_IASI + + IF(ALLOCATED(IASI_LON)) DEALLOCATE(IASI_LON) + IF(ALLOCATED(IASI_LAT)) DEALLOCATE(IASI_LAT) + IF(ALLOCATED(IASI_TIME)) DEALLOCATE(IASI_TIME) + IF(ALLOCATED(IASI_CO_AVK)) DEALLOCATE(IASI_CO_AVK) + IF(ALLOCATED(IASI_CO_APR)) DEALLOCATE(IASI_CO_APR) + IF(ALLOCATED(IASI_CO_STD)) DEALLOCATE(IASI_CO_STD) + IF(ALLOCATED(IASI_CO)) DEALLOCATE(IASI_CO) + IF(ALLOCATED(IASI_ALT)) DEALLOCATE(IASI_ALT) + IF(ALLOCATED(IASI_SOLAR_ZENITH)) DEALLOCATE(IASI_SOLAR_ZENITH) + IF(ALLOCATED(IASI_CLOUD_COVER)) DEALLOCATE(IASI_CLOUD_COVER) + IF(ALLOCATED(IASI_QUAL_FLAG)) DEALLOCATE(IASI_QUAL_FLAG) + IF(ALLOCATED(IASI_CO_LVL)) DEALLOCATE(IASI_CO_LVL) + !IF(ALLOCATED(TEMPDATA)) DEALLOCATE(TEMPDATA) + !IF(ALLOCATED(TIME_FRAC)) DEALLOCATE(TIME_FRAC) + END SUBROUTINE CLEANUP_IASI +!------------------------------------------------------------------------------ + SUBROUTINE GET_NT_RANGE( N_IASI_NOB, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_IASI_NOB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(N_IASI_NOB) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS, FOUND_BAD_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + FOUND_BAD_RECORDS = .TRUE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) THEN + NTSAVE = N_IASI_NOB + IF ( NTSAVE > 1 ) THEN + DO WHILE (FOUND_BAD_RECORDS == .TRUE.) + IF (TIME_FRAC(NTSAVE) > 0.5d0) THEN + FOUND_BAD_RECORDS = .FALSE. + ELSE + NTSAVE = NTSAVE - 1 + ENDIF + ENDDO + ENDIF + ENDIF + + DO WHILE (TIME_FRAC(NTSAVE) < 0) + NTSAVE = NTSAVE -1 + IF (NTSAVE == 0) EXIT + ENDDO + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' N_IASI_NOB ', N_IASI_NOB + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + ! one hour as a fraction of day + H1_FRAC = 0d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + !print*, 'All records have been read already ' + RETURN + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE) + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + !ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_DATA_IASI( GC_EDGE, OBS_EDGE, DATA_MODEL, DATA_IASI, OBS_IASI, LIASI, FB ) + +!****************************************************************************** +!Based on the code from Monika. (zhe 1/19/11) +!FB = 1 for forward +!FB = -1 for adjoint +!****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: LIASI, NB, LVL_CRT1, LVL_CRT2 + REAL*8 :: ALT_MODEL(LLPAR), GC_EDGE(LLPAR+1), HI, LOW + REAL*8 :: DATA_MODEL(LLPAR), BIN_IASI(LLPAR,LIASI), DIFF_BIN + REAL*8 :: OBS_EDGE(LIASI+1), DATA_IASI(LIASI), OBS_IASI(LIASI) + BIN_IASI(:,:) = 0d0 + LVL_CRT1 = 0 + LVL_CRT2 = 0 + !================================================================= + ! BIN_DATA_V4 begins here! + !================================================================= + DO L = 1, LLPAR + ALT_MODEL(L) = 0.5d0*(GC_EDGE(L)+GC_EDGE(L+1)) + ENDDO + IF (FB > 0) THEN + + !DO L = 1, LIASI + !DO LL = 1, LLPAR + !IF ( ALT_MODEL(LL) >= OBS_EDGE(L) ) THEN + !DATA_IASI(L) = DATA_MODEL(LL) + !EXIT + !ENDIF + !ENDDO + !ENDDO + + DO L = 1, LIASI + DO LL = 1, LLPAR + LOW = GC_EDGE(LL) + HI = GC_EDGE(LL+1) + IF ( GC_EDGE(LL) >= OBS_EDGE(L)) THEN + IF ( GC_EDGE(LL+1) <= OBS_EDGE(L+1) ) THEN + BIN_IASI(LL,L) = 1d0 + !NB = NB + 1 + ELSEIF (GC_EDGE(LL) <= OBS_EDGE(L+1)) THEN + DIFF_BIN = HI - LOW + BIN_IASI(LL,L) = ( OBS_EDGE(L+1) - LOW)/DIFF_BIN + BIN_IASI(LL,L+1) = ( HI - OBS_EDGE(L+1))/DIFF_BIN + ELSEIF (GC_EDGE(LL) > OBS_EDGE(LIASI+1)) THEN + BIN_IASI(LL,LIASI) = 1d0 + ENDIF + ELSEIF (GC_EDGE(LL) < OBS_EDGE(1) ) THEN + BIN_IASI(LL,1) = 1D0 + ENDIF + ENDDO + !IF (NB > 0) DATA_IASI(L) = DATA_TEM !/ NB + ENDDO + + DO L = 1, LIASI + DATA_IASI(L) = 0d0 + DO LL = 1, LLPAR + DATA_IASI(L) = DATA_IASI(L) + BIN_IASI(LL,L) * DATA_MODEL(LL) + ENDDO + ENDDO + DO L = 2, LIASI-1 + IF (DATA_IASI(L) == 0d0) THEN + IF ( DATA_IASI(L-1) > 0d0) THEN + LVL_CRT1 = L-1 + !PRINT *, "DATA_IASI1", DATA_IASI(L-1) + ENDIF + IF (DATA_IASI(L+1) > 0d0) THEN + LVL_CRT2 = L+1 + !PRINT *, "DATA_IASI2", DATA_IASI(L+1) + ENDIF + IF (REAL(LVL_CRT1)*REAL(LVL_CRT2) > 0D0) THEN + DO LL = LVL_CRT1, LVL_CRT2 + DATA_IASI(LL) = ((DATA_IASI(LVL_CRT1)+DATA_IASI(LVL_CRT2))/SUM(OBS_IASI(LVL_CRT1:LVL_CRT2)))*OBS_IASI(LL) + ENDDO + !PRINT *, "OBS_IASI", SUM(OBS_IASI(LVL_CRT1:LVL_CRT2)) + LVL_CRT1 = 0 + LVL_CRT2 = 0 + ENDIF + ENDIF + ENDDO + + ELSE + + DATA_MODEL(:) = 0. + DO L = 1, LLPAR + DO LL = 1, LIASI + IF ( ( ALT_MODEL(L) >= OBS_EDGE(LL)) .and. ( ALT_MODEL(L) < OBS_EDGE(LL+1)) ) THEN + DATA_MODEL(L) = DATA_IASI(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_DATA_IASI + + + + + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 +!------------------------------------------------------------------- + + END MODULE IASI_CO_OBS_MOD diff --git a/code/obs_operators/iasi_o3_obs_mod.f90 b/code/obs_operators/iasi_o3_obs_mod.f90 new file mode 100644 index 0000000..392ef28 --- /dev/null +++ b/code/obs_operators/iasi_o3_obs_mod.f90 @@ -0,0 +1,1137 @@ +!$Id: IASI_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ +MODULE IASI_O3_OBS_MOD + + IMPLICIT NONE + + !mkeller +#include "CMN_SIZE" + !#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_IASI_O3_OBS + PUBLIC CALC_IASI_O3_FORCE + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 41 + INTEGER, PARAMETER :: MAXIASI = 500000 + + ! Module variables + + ! IASI data + REAL*8, ALLOCATABLE :: IASI_LON(:) + REAL*8, ALLOCATABLE :: IASI_LAT(:) + REAL*8, ALLOCATABLE :: IASI_TIME(:) + REAL*8, ALLOCATABLE :: IASI_O3(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_STD(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_APR(:,:) + REAL*8, ALLOCATABLE :: IASI_AIR_DEN(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_AVK(:,:,:) + REAL*8, ALLOCATABLE :: IASI_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: IASI_CLOUD_COVER(:) + REAL*8, ALLOCATABLE :: IASI_SATELLITE_ZENITH(:) + REAL*8, ALLOCATABLE :: IASI_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: IASI_PRESSURE(:,:) + REAL*8, ALLOCATABLE :: IASI_DOFS(:) + REAL*8, ALLOCATABLE :: IASI_O3_LVL(:) + + ! MLS grid specification + INTEGER :: N_IASI_NLA + INTEGER :: N_IASI_NPR + INTEGER :: N_IASI_NOB + + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT +CONTAINS + !------------------------------------------------------------------------------ + + SUBROUTINE READ_IASI_O3_OBS( YYYYMMDD, N_IASI_NOB ) + ! +!****************************************************************************** +! Subroutine READ_IASI_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_IASI_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NIASI (INTEGER) : Number of IASI retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) IASI (IASI_O3_OBS) : IASI retrieval for current day +! +! NOIASI: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + +#include "CMN_SIZE" ! size parameters + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LIASI + INTEGER :: N_IASI_NOB + INTEGER :: N, J + INTEGER :: NLA_ID, NPR_ID, NOB_ID + INTEGER :: O3_ID, AVK_ID, PRE_ID, O3E_ID, APR_ID + INTEGER :: LAT_ID, LON_ID, TIM_ID, DOF_ID + INTEGER :: SAZ_ID, SOZ_ID, CLR_ID, QUA_ID, APC_ID + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: FILENAME_IASIO3 + CHARACTER(LEN=255) :: DIR_IASIO3 + CHARACTER(LEN=255) :: DIR_MONTH_IASIO3 + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_IASI_O3_OBS begins here! + !================================================================= + CALL CLEANUP_IASI + ! filename root + DIR_IASIO3 = '/users/jk/15/xzhang/IASI_O3/' + DIR_MONTH_IASIO3 = '/YYYY/MM/' + FILENAME_IASIO3 = 'IASI_FORLI_O3_metopa_YYYYMMDD_v20151001.nc' + + ! Expand date tokens in filename + CALL EXPAND_DATE( DIR_MONTH_IASIO3, YYYYMMDD, 9999) + CALL EXPAND_DATE( FILENAME_IASIO3, YYYYMMDD, 9999 ) + + ! Construct complete filename + ! READ_FILENAME = TRIM( DATA_DIR ) // TRIM( 'IASI_O3/' ) // + ! & TRIM( READ_FILENAME ) + READ_FILENAME = TRIM(DIR_IASIO3) // TRIM(DIR_MONTH_IASIO3) // TRIM( FILENAME_IASIO3 ) + + WRITE(6,*) ' - READ_IASI_O3_OBS: reading file: ', READ_FILENAME + + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"IASI file '", TRIM(READ_FILENAME), " not found, "// "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"IASI file found!" + ENDIF + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 800 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "nlayers", NLA_ID), 811 ) + CALL CHECK( NF90_INQ_DIMID( FID, "npressures", NPR_ID), 812 ) + CALL CHECK( NF90_INQ_DIMID( FID, "nobservations", NOB_ID), 813 ) + + CALL CHECK( NF90_INQ_VARID( FID, "ozone_partial_column_profile", O3_ID ), 821 ) + CALL CHECK( NF90_INQ_VARID( FID, "averaging_kernels_matrix", AVK_ID ), 822 ) + CALL CHECK( NF90_INQ_VARID( FID, "atmosphere_pressure_grid", PRE_ID ), 823 ) + CALL CHECK( NF90_INQ_VARID( FID, "ozone_partial_column_error", O3E_ID ), 824 ) + CALL CHECK( NF90_INQ_VARID( FID, "ozone_apriori_partial_column_profile",APR_ID ), 825 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LAT_ID ), 826 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LON_ID ), 827 ) + CALL CHECK( NF90_INQ_VARID( FID, "time", TIM_ID ), 828 ) + CALL CHECK( NF90_INQ_VARID( FID, "sun_zen_angle", SOZ_ID ), 829 ) + CALL CHECK( NF90_INQ_VARID( FID, "satellite_zen_angle", SAZ_ID ), 830 ) + CALL CHECK( NF90_INQ_VARID( FID, "cloud_cover", CLR_ID ), 831 ) + CALL CHECK( NF90_INQ_VARID( FID, "retrieval_quality_flag", QUA_ID ), 832 ) + CALL CHECK( NF90_INQ_VARID( FID, "air_partial_column_profile", APC_ID ), 833 ) + CALL CHECK( NF90_INQ_VARID( FID, "dofs", DOF_ID ), 834 ) + + ! READ number of retrievals, NIASI + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NLA_ID, TMP, N_IASI_NLA), 841 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NPR_ID, TMP, N_IASI_NPR), 842 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NOB_ID, TMP, N_IASI_NOB), 843 ) + + + print*, 'IASI dimensions on layers, pressures and observations are ', N_IASI_NLA, N_IASI_NPR, N_IASI_NOB + + ALLOCATE(IASI_O3(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, O3_ID, IASI_O3), 851) + ALLOCATE(IASI_O3_STD(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, O3E_ID, IASI_O3_STD), 852) + ALLOCATE(IASI_O3_APR(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, APR_ID, IASI_O3_APR), 858) + ALLOCATE(IASI_AIR_DEN(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, APC_ID, IASI_AIR_DEN), 859) + ALLOCATE(IASI_SOLAR_ZENITH(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, SOZ_ID, IASI_SOLAR_ZENITH), 853) + ALLOCATE(IASI_SATELLITE_ZENITH(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, SAZ_ID, IASI_SATELLITE_ZENITH), 861) + ALLOCATE(IASI_PRESSURE(N_IASI_NPR, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, PRE_ID, IASI_PRESSURE), 854) + ALLOCATE(IASI_LAT(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, LAT_ID, IASI_LAT), 855) + ALLOCATE(IASI_LON(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, LON_ID, IASI_LON), 856) + ALLOCATE(IASI_TIME(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, TIM_ID, IASI_TIME), 857) + !PRINT *, "IASI_TIME", IASI_TIME(1:N_IASI_NOB) + ALLOCATE(IASI_O3_AVK(N_IASI_NLA, N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, AVK_ID, IASI_O3_AVK), 860) + ALLOCATE(IASI_QUAL_FLAG(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, QUA_ID, IASI_QUAL_FLAG), 862) + ALLOCATE(IASI_CLOUD_COVER(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, CLR_ID, IASI_CLOUD_COVER), 863) + ALLOCATE(IASI_DOFS(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, DOF_ID, IASI_DOFS), 864) + ALLOCATE(IASI_O3_LVL(N_IASI_NOB)) + CALL CHECK( NF90_CLOSE( FID ), 899) + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + !ALLOCATE(IASI_O3_LVL(N_IASI_NOB)) + DO N = 1, N_IASI_NOB + J = 1 + DO WHILE ( J .le. MAXLEV ) + ! check if the value is good + IF (IASI_O3(J,N) > FILL ) THEN + ! save the number of good levels as LTES + IASI_O3_LVL(N) = MAXLEV - J + 1 + ! and now we can exit the while loop + J = MAXLEV + 1 + ! otherwise this level is just filler + ELSE + ! so proceed to the next one up + J = J + 1 + ENDIF + ENDDO + ENDDO + + !print*, ' IASI TEST ', IASI(N)%O3 + !print*, ' IASI good ', IASI(N)%LIASI + !print*, ' IASI pres ', IASI(N)%PRES(1:J) + + ! Add a bit to the diagonal to regularize the inversion + ! (ks, ml, dkh, 11/18/10) + ! mkeller: this makes no sense to me. + !DO II=1,J + ! IASI(N)%S_OER(II,II) = IASI(N)%S_OER(II,II)+ 0.001D0 + !ENDDO + + !CALL SVD( IASI(N)%S_OER(1:J,1:J), J, + !& U(1:J,1:J), S(1:J), + !& VT(1:J,1:J) ) + + ! U = S^-1 * U^T + !TEST = 0d0 + !DO I = 1, J + + ! mkeller: regularize matrix inverse by ignoring all singular values below a certain cutoff. + ! This is horrendously inefficient, but should work for now. In the + ! future, Thikonov regularization should be implemented instead. + ! xzhang: svd TEST critical value changes from 1e-2 to 5e-2 + !IF ( S(I)/S(1) < 1e-2 ) THEN + !S(I) = 1e-2 * S(1) + !ENDIF + !DO II = 1, J + !TEST(I,II) = U(II,I) / S(I) + !ENDDO + !ENDDO + + !TEST = 0d0 + !U = TEST + !TEST = 0d0 + + + ! S_OER_INV = V * S^-1 * U^T + !DO I = 1, J + !DO II = 1, J + !TMP1 = 0d0 + !DO III = 1, J + !TMP1 = TMP1 + VT(III,I) * U(III,II) + !ENDDO + !IASI(N)%S_OER_INV(I,II) = TMP1 + !ENDDO + !ENDDO + + ! TEST: calculate 2-norm of I - S_OER_INV * S_OER + ! mkeller: comment this out for now; pointless given the regularization + ! performed above. + ! Need to come up with an alternative TEST in the future. + !DO I = 1, J + ! DO II = 1, J + ! TMP1 = 0d0 + ! DO III = 1, J + ! TMP1 = TMP1 + !& + IASI(N)%S_OER_INV(III,I) * IASI(N)%S_OER(III,II) + !ENDDO + !TEST(I,II) = - TMP1 + !ENDDO + !TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 + !ENDDO + + !IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN + ! print*, ' WARNING: inversion error for retv N = ', + !& SUM(TEST(1:J,1:J)), N + ! print*, ' in IASI obs ', READ_FILENAME + ! ENDIF + + !ENDDO ! N + + ! Return to calling program + END SUBROUTINE READ_IASI_O3_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'IASI_o3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_IASI_O3_FORCE( COST_FUNC ) + ! +!****************************************************************************** +! Subroutine CALC_IASI_O3_FORCE calculaIASI the adjoint forcing from the IASI +! O3 observations and updaIASI the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost function [unitless] +! +! +! NOIASI: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_HOUR + USE TRACER_MOD, ONLY : XNUMOLAIR, STT + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT, I_IASI + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LIASI, L0 + INTEGER :: JLOOP + INTEGER :: GC_HOUR + INTEGER :: LVL_CRT1, LVL_CRT2 + REAL*8 :: GC_PRES(LLPAR+1) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF, IASI_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV), GC_O3_CONTRIB(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV), COST_CONTRIB(MAXLEV), COST_CONTRIB_COL + REAL*8 :: DIFF_COL, FORCE_COL, IASI_O3_STD_COL + REAL*8 :: IASI_PCENTER(MAXLEV) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: OLD_COST + REAL*8 :: XNUAIR + REAL*8, SAVE :: TIME_FRAC(MAXIASI) + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + REAL*8 :: IASI_O3_BIAS(IIPAR,JJPAR), IASI_O3_BIAS_FILT(IIPAR,JJPAR) + REAL*8 :: IASI_O3_CHI_SQ(IIPAR,JJPAR), IASI_O3_CHI_SQ_FILT(IIPAR,JJPAR) + REAL*8 :: IASI_O3_BIAS_SOBS(IIPAR,JJPAR), IASI_O3_BIAS_FILT_SOBS(IIPAR,JJPAR) + REAL*8 :: IASI_O3_CHI_SQ_SOBS(IIPAR,JJPAR), IASI_O3_CHI_SQ_FILT_SOBS(IIPAR,JJPAR) + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! CALC_IASI_O3_FORCE begins here! + !================================================================= + + print*, ' - CALC_IASI_O3_FORCE ' + + ! Reset + XNUAIR = 28.9644d-3 + NEW_COST = 0d0 + SOBS_COUNT = 0d0 + GC_ADJ_TEMP = 0d0 + GC_ADJ_TEMP_COST = 0d0 + GC_ADJ_COUNT = 0d0 + IASI_O3_BIAS = 0d0 + IASI_O3_BIAS_FILT = 0d0 + IASI_O3_CHI_SQ = 0d0 + IASI_O3_CHI_SQ_FILT = 0d0 + IASI_O3_BIAS_SOBS = 0d0 + IASI_O3_BIAS_FILT_SOBS = 0d0 + IASI_O3_CHI_SQ_SOBS = 0d0 + IASI_O3_CHI_SQ_FILT_SOBS = 0d0 + GC_HOUR = GET_HOUR() + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + PRINT *, "GET_NHMS", GET_NHMS() + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the IASI O3 file for this day + CALL READ_IASI_O3_OBS( GET_NYMD(), N_IASI_NOB ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:N_IASI_NOB) = IASI_TIME(1:N_IASI_NOB)/240000d0 + ENDIF + IF ( FIRST ) THEN + FILENAME = 'chi_sq2_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 801, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 802, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'chi_sq2_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 803, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff2_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 804, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 805, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 806, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 813, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 814, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( N_IASI_NOB, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching IASI O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), IASI_TIME(NTSTART), IASI_TIME(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + + + DO I_IASI = NTSTART, NTSTOP, -1 + !PRINT *, "IASI_TIME", IASI_TIME(I_IASI) + IF ( ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_QUAL_FLAG(I_IASI) == 0d0 ) .AND. & + ( IASI_SOLAR_ZENITH(I_IASI) < 80d0 ) .AND. & + ( IASI_DOFS(I_IASI) > 2.75 ) .AND. & + ( IASI_CLOUD_COVER(I_IASI) < 13d0 ) ) THEN + + !( IASI_SATELLITE_ZENITH(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + GC_O3_CONTRIB(:,:) = 0d0 + FORCE(:) = 0d0 + DIFF(:) = 0d0 + COST_CONTRIB(:) = 0d0 + COST_CONTRIB_COL = 0d0 + DIFF_COL = 0d0 + IASI_O3_STD_COL = 0d0 + FORCE_COL = 0d0 + LVL_CRT1 = 0 + LVL_CRT2 = 0 + LIASI = IASI_O3_LVL(I_IASI) + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + IASI_PCENTER = 0d0 + I = IIJJ(1) + J = IIJJ(2) + + L0 = MAXLEV - IASI_O3_LVL(I_IASI) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR+1 + GC_PRES(L) = GET_PEDGE(I,J,L) + ENDDO + DO L = 1, LIASI + IASI_PCENTER(L) = 0.5d0*(IASI_PRESSURE(L+L0,I_IASI)+IASI_PRESSURE(L+L0+1,I_IASI)) + ENDDO + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + IASI_PSURF = IASI_PRESSURE(1+L0,I_IASI) + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LIASI) = GET_INTMAP( LLPAR, GC_PRES, GC_PSURF, & + LIASI, IASI_PRESSURE(1+L0:LIASI+L0,I_IASI), IASI_PSURF ) + DO L = 1, LLPAR + IF ( GC_PRES(L) > 300d0 ) THEN + GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) * BXHEIGHT(I,J,L)/(AIRVOL(I,J,L)*XNUAIR) + ELSE + GC_O3_NATIVE(L) = STT(I,J,L,IDTOX) * TCVV(IDTOX) * BXHEIGHT(I,J,L)/(AIRVOL(I,J,L)*XNUAIR) + ENDIF + ENDDO + !PRINT *, "IASI_PCENTER", IASI_PCENTER + !PRINT *, "GC_PRES", GC_PRES + !PRINT *, " GC_O3_NATIVE", GC_O3_NATIVE + ! Interpolate GC O3 column to TES grid + DO L = 1, LIASI + GC_O3(L) = 0d0 + DO LL = 1, LLPAR + GC_O3_CONTRIB(LL,L) = MAP(LL,L) * GC_O3_NATIVE(LL) + GC_O3(L) = GC_O3(L) + MAP(LL,L) * GC_O3_NATIVE(LL) + ENDDO + ENDDO + DO L = 2, LIASI-1 + IF (GC_O3(L) == 0d0) THEN + IF (GC_O3(L-1) > 0d0) THEN + LVL_CRT1 = L-1 + ENDIF + IF (GC_O3(L+1) > 0d0) THEN + LVL_CRT2 = L+1 + ENDIF + IF (REAL(LVL_CRT1)*REAL(LVL_CRT2)>0d0) THEN + DO LL = LVL_CRT1,LVL_CRT2 + GC_O3(LL) = ((GC_O3(LVL_CRT1)+GC_O3(LVL_CRT2))/SUM(IASI_O3(LVL_CRT1+L0:LVL_CRT2+L0,I_IASI)))* & + IASI_O3(LL+L0,I_IASI) + ENDDO + LVL_CRT1 = 0 + LVL_CRT2 = 0 + ENDIF + ENDIF + ENDDO + !PRINT *, " GC_O3", GC_O3 + !-------------------------------------------------------------- + ! Apply IASI O3 observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by IASI [lnvmr] + ! x_a = IASI apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = IASI averaging kernel + ! + ! OR + ! + ! x_smoothed = A_k*x_m + (I-A_k)*x_a + ! where + ! x_smoothed = GC modeled column smoothed by IASI [vmr] + ! x_a = IASI apriori partial column [vmr] + ! x_m = GC modeled profile [vmr] + ! A_k = IASI averaging kernel + !-------------------------------------------------------------- + ! x_m - x_a + DO L = 1, LIASI + IF (IASI_O3_APR(L+L0,I_IASI) > 0) THEN + GC_O3(L) = MAX(GC_O3(L), 1d-4) + O3_PERT(L) = GC_O3(L) - IASI_O3_APR(L+L0,I_IASI) + ENDIF + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LIASI + O3_HAT(L) = 0d0 + FORCE(L) = 0d0 + IF (IASI_O3_APR(L+L0,I_IASI) > 0) THEN + DO LL = 1, LIASI + O3_HAT(L) = O3_HAT(L) + IASI_O3_AVK(LL+L0,L0+L,I_IASI) * O3_PERT(LL) + ENDDO + O3_HAT(L) = O3_HAT(L) + IASI_O3_APR(L+L0,I_IASI) + ENDIF + ! actual comparison with bias correction information + IF ( ( IASI_O3(L+L0,I_IASI) > 0d0 ) .AND. & + ( O3_HAT(L) > 0d0 ) .AND. & + ( IASI_O3(L+L0,I_IASI) < 100d0 * IASI_O3_STD(L+L0,I_IASI) ) ) THEN + IF ( REAL(IASI_LAT(I_IASI)) >= 60d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.049 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.805 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.975 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= 30d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.132 + ELSEIF (IASI_PCENTER(L) >=150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.018 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.921 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= 0d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.142 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.934 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.876 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -30d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.122 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.963 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.886 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -60d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.12 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.994 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.94 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -90d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.98 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.765 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.71 + ENDIF + ENDIF + !PRINT *, "DIFF", DIFF(L) + ELSE + DIFF(L) = 0d0 + ENDIF + !PRINT *, "O3_HAT", O3_HAT(L) + !PRINT *, "IASI_O3", IASI_O3(L+L0,I_IASI) + !PRINT *, "IASI_O3_STD", IASI_O3_STD(L+L0, I_IASI) + ! Forcing is computed in profile and in columns + FORCE(L) = DIFF(L)/(0.5*IASI_O3_STD(L+L0,I_IASI))**2 + COST_CONTRIB(L) = 0.5d0 * DIFF(L) * FORCE(L) + IF ( ( IASI_PCENTER(L) >= 300d0 ) ) THEN + DIFF_COL = DIFF_COL + DIFF(L) + IASI_O3_STD_COL = IASI_O3_STD_COL + IASI_O3_STD(L+L0,I_IASI)**2 + ENDIF + ENDDO + + FORCE_COL = DIFF_COL/IASI_O3_STD_COL + ! Diagnostics of chi square and model-obs biases + IF ( ( IASI_PCENTER(8) >= 300d0 ).AND. & + ( SQRT(COST_CONTRIB(8)) < 10d0 ) .AND. & + ( SQRT(COST_CONTRIB(8)) > 0d0 ) ) THEN + IASI_O3_BIAS_FILT(I,J) = IASI_O3_BIAS_FILT(I,J)+ DIFF(8) + IASI_O3_CHI_SQ_FILT(I,J) = IASI_O3_CHI_SQ_FILT(I,J) + 2*COST_CONTRIB(8) + ENDIF + COST_CONTRIB_COL = 0.5d0 * DIFF_COL * FORCE_COL + IF ( ( COST_CONTRIB_COL > 0d0) .AND. & + ( COST_CONTRIB_COL < 200d0) ) THEN + ! adjoint of interpolation + DO L = 1, LLPAR + ! Adjoint of unit conversion + GC_O3_NATIVE_ADJ(L) = FORCE_COL * TCVV(IDTOX) * BXHEIGHT(I,J,L)/ (XNUAIR*AIRVOL(I,J,L)) + GC_ADJ_TEMP(I,J,L) = GC_ADJ_TEMP(I,J,L) + GC_O3_NATIVE_ADJ(L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1d0 + ENDDO + + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL!0.5 * DIFF_COL * FORCE_COL + IF (SUPER_OBS) THEN + !IF (COST_CONTRIB_COL > 0d0) THEN + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + IASI_O3_BIAS(I,J) = IASI_O3_BIAS(I,J) + DIFF(8) + IASI_O3_CHI_SQ(I,J) = IASI_O3_CHI_SQ(I,J) + 2*COST_CONTRIB(8) + !ENDIF + ENDIF + ENDIF + + 110 FORMAT(F18.6,1X) +640 ENDIF + ENDDO ! NT + + ! Compute adjoint forcing and cost function in superobservation + IF (SUPER_OBS) THEN + DO I=1,IIPAR + DO J=1,JJPAR + IF ( SOBS_COUNT(I,J) > 0d0 ) THEN + DO L=1,LLPAR + IF ( ( GET_PCENTER(I,J,L) >= 300d0 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0d0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + ENDIF + + ENDDO + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + IASI_O3_BIAS_SOBS(I,J) = IASI_O3_BIAS(I,J)/SOBS_COUNT(I,J) + IASI_O3_CHI_SQ_SOBS(I,J) = IASI_O3_CHI_SQ(I,J)/SOBS_COUNT(I,J) + ENDIF + IF (GC_ADJ_COUNT(I,J,8) > 0d0) THEN + IASI_O3_BIAS_FILT_SOBS(I,J) = IASI_O3_BIAS_FILT(I,J)/GC_ADJ_COUNT(I,J,8) + IASI_O3_CHI_SQ_FILT_SOBS(I,J) = IASI_O3_CHI_SQ_FILT(I,J)/GC_ADJ_COUNT(I,J,8) + ENDIF + WRITE(801,110)(IASI_O3_CHI_SQ_SOBS(I,J)) + WRITE(802,110)(1e6*IASI_O3_BIAS_SOBS(I,J)) + WRITE(803,110)(IASI_O3_CHI_SQ_FILT_SOBS(I,J)) + WRITE(804,110)(1e6*IASI_O3_BIAS_FILT_SOBS(I,J)) + WRITE(805,110)(SOBS_COUNT(I,J)) + WRITE(806,110)(GC_ADJ_COUNT(I,J,8)) + WRITE(813,110)(GET_XMID(I)) + WRITE(814,110)(GET_YMID(J)) + ENDDO + ENDDO + ENDIF + + + + IF ( FIRST ) FIRST = .FALSE. + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' IASI contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_IASI_O3_FORCE + +!---------------------------------------------------------------------------- + SUBROUTINE CLEANUP_IASI + + IF(ALLOCATED(IASI_LON)) DEALLOCATE(IASI_LON) + IF(ALLOCATED(IASI_LAT)) DEALLOCATE(IASI_LAT) + IF(ALLOCATED(IASI_TIME)) DEALLOCATE(IASI_TIME) + IF(ALLOCATED(IASI_O3_AVK)) DEALLOCATE(IASI_O3_AVK) + IF(ALLOCATED(IASI_O3_APR)) DEALLOCATE(IASI_O3_APR) + IF(ALLOCATED(IASI_O3_STD)) DEALLOCATE(IASI_O3_STD) + IF(ALLOCATED(IASI_O3)) DEALLOCATE(IASI_O3) + IF(ALLOCATED(IASI_SATELLITE_ZENITH)) DEALLOCATE(IASI_SATELLITE_ZENITH) + IF(ALLOCATED(IASI_SOLAR_ZENITH)) DEALLOCATE(IASI_SOLAR_ZENITH) + IF(ALLOCATED(IASI_CLOUD_COVER)) DEALLOCATE(IASI_CLOUD_COVER) + IF(ALLOCATED(IASI_QUAL_FLAG)) DEALLOCATE(IASI_QUAL_FLAG) + IF(ALLOCATED(IASI_AIR_DEN)) DEALLOCATE(IASI_AIR_DEN) + IF(ALLOCATED(IASI_PRESSURE)) DEALLOCATE(IASI_PRESSURE) + IF(ALLOCATED(IASI_O3_LVL)) DEALLOCATE(IASI_O3_LVL) + IF(ALLOCATED(IASI_DOFS)) DEALLOCATE(IASI_DOFS) + END SUBROUTINE CLEANUP_IASI +!------------------------------------------------------------------------------ + SUBROUTINE GET_NT_RANGE( N_IASI_NOB, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_IASI_NOB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(N_IASI_NOB) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = N_IASI_NOB + + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' N_IASI_NOB ', N_IASI_NOB + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + ! one hour as a fraction of day + H1_FRAC = 0d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + !ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, LTM_TOP, TM_PRESC, TM_SURFP ) RESULT( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOIASI: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP+1) + REAL*8 :: TM_PRESC(LTM_TOP+1) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LGC = 1, LGC_TOP + + ! Find the levels from GC that bracket level LTM + DO LTM = 1, LTM_TOP + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( GC_PRESC(LGC) <= TM_PRESC(LTM ) ) THEN + IF (GC_PRESC(LGC+1) >= TM_PRESC(LTM+1)) THEN + HINTERPZ(LGC,LTM) = 1D0 + ELSEIF (GC_PRESC(LGC) >= TM_PRESC(LTM+1)) THEN + DIFF = HI - LOW + HINTERPZ(LGC,LTM) = ( HI - TM_PRESC(LTM+1) ) / DIFF + HINTERPZ(LGC,LTM+1) = ( TM_PRESC(LTM+1) - LOW ) / DIFF + ENDIF + ELSEIF (GC_PRESC(LGC) > TM_PRESC(1) ) THEN + HINTERPZ(LGC,1) = 1D0 + ENDIF + + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where IASI pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + !DO LTM = 1, LTM_TOP + !IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + !HINTERPZ(:,LTM) = 0D0 + !HINTERPZ(LTM,LTM) = 1D0 + !ENDIF + !ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + + + + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 +!------------------------------------------------------------------- + + END MODULE IASI_O3_OBS_MOD diff --git a/code/obs_operators/iasi_o3_obs_mod.f90~ b/code/obs_operators/iasi_o3_obs_mod.f90~ new file mode 100644 index 0000000..50d4e2c --- /dev/null +++ b/code/obs_operators/iasi_o3_obs_mod.f90~ @@ -0,0 +1,1134 @@ +!$Id: IASI_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ +MODULE IASI_O3_OBS_MOD + + IMPLICIT NONE + + !mkeller +#include "CMN_SIZE" + !#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_IASI_O3_OBS + PUBLIC CALC_IASI_O3_FORCE + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 41 + INTEGER, PARAMETER :: MAXIASI = 500000 + + ! Module variables + + ! IASI data + REAL*8, ALLOCATABLE :: IASI_LON(:) + REAL*8, ALLOCATABLE :: IASI_LAT(:) + REAL*8, ALLOCATABLE :: IASI_TIME(:) + REAL*8, ALLOCATABLE :: IASI_O3(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_STD(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_APR(:,:) + REAL*8, ALLOCATABLE :: IASI_AIR_DEN(:,:) + REAL*8, ALLOCATABLE :: IASI_O3_AVK(:,:,:) + REAL*8, ALLOCATABLE :: IASI_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: IASI_CLOUD_COVER(:) + REAL*8, ALLOCATABLE :: IASI_SATELLITE_ZENITH(:) + REAL*8, ALLOCATABLE :: IASI_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: IASI_PRESSURE(:,:) + REAL*8, ALLOCATABLE :: IASI_DOFS(:) + REAL*8, ALLOCATABLE :: IASI_O3_LVL(:) + + ! MLS grid specification + INTEGER :: N_IASI_NLA + INTEGER :: N_IASI_NPR + INTEGER :: N_IASI_NOB + + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT +CONTAINS + !------------------------------------------------------------------------------ + + SUBROUTINE READ_IASI_O3_OBS( YYYYMMDD, N_IASI_NOB ) + ! +!****************************************************************************** +! Subroutine READ_IASI_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_IASI_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NIASI (INTEGER) : Number of IASI retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) IASI (IASI_O3_OBS) : IASI retrieval for current day +! +! NOIASI: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + +#include "CMN_SIZE" ! size parameters + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LIASI + INTEGER :: N_IASI_NOB + INTEGER :: N, J + INTEGER :: NLA_ID, NPR_ID, NOB_ID + INTEGER :: O3_ID, AVK_ID, PRE_ID, O3E_ID, APR_ID + INTEGER :: LAT_ID, LON_ID, TIM_ID, DOF_ID + INTEGER :: SAZ_ID, SOZ_ID, CLR_ID, QUA_ID, APC_ID + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: FILENAME_IASIO3 + CHARACTER(LEN=255) :: DIR_IASIO3 + CHARACTER(LEN=255) :: DIR_MONTH_IASIO3 + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_IASI_O3_OBS begins here! + !================================================================= + CALL CLEANUP_IASI + ! filename root + DIR_IASIO3 = '/users/jk/15/xzhang/IASI_O3/' + DIR_MONTH_IASIO3 = '/YYYY/MM/' + FILENAME_IASIO3 = 'IASI_FORLI_O3_metopa_YYYYMMDD_v20151001.nc' + + ! Expand date tokens in filename + CALL EXPAND_DATE( DIR_MONTH_IASIO3, YYYYMMDD, 9999) + CALL EXPAND_DATE( FILENAME_IASIO3, YYYYMMDD, 9999 ) + + ! Construct complete filename + ! READ_FILENAME = TRIM( DATA_DIR ) // TRIM( 'IASI_O3/' ) // + ! & TRIM( READ_FILENAME ) + READ_FILENAME = TRIM(DIR_IASIO3) // TRIM(DIR_MONTH_IASIO3) // TRIM( FILENAME_IASIO3 ) + + WRITE(6,*) ' - READ_IASI_O3_OBS: reading file: ', READ_FILENAME + + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"IASI file '", TRIM(READ_FILENAME), " not found, "// "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"IASI file found!" + ENDIF + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 800 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "nlayers", NLA_ID), 811 ) + CALL CHECK( NF90_INQ_DIMID( FID, "npressures", NPR_ID), 812 ) + CALL CHECK( NF90_INQ_DIMID( FID, "nobservations", NOB_ID), 813 ) + + CALL CHECK( NF90_INQ_VARID( FID, "ozone_partial_column_profile", O3_ID ), 821 ) + CALL CHECK( NF90_INQ_VARID( FID, "averaging_kernels_matrix", AVK_ID ), 822 ) + CALL CHECK( NF90_INQ_VARID( FID, "atmosphere_pressure_grid", PRE_ID ), 823 ) + CALL CHECK( NF90_INQ_VARID( FID, "ozone_partial_column_error", O3E_ID ), 824 ) + CALL CHECK( NF90_INQ_VARID( FID, "ozone_apriori_partial_column_profile",APR_ID ), 825 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LAT_ID ), 826 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LON_ID ), 827 ) + CALL CHECK( NF90_INQ_VARID( FID, "time", TIM_ID ), 828 ) + CALL CHECK( NF90_INQ_VARID( FID, "sun_zen_angle", SOZ_ID ), 829 ) + CALL CHECK( NF90_INQ_VARID( FID, "satellite_zen_angle", SAZ_ID ), 830 ) + CALL CHECK( NF90_INQ_VARID( FID, "cloud_cover", CLR_ID ), 831 ) + CALL CHECK( NF90_INQ_VARID( FID, "retrieval_quality_flag", QUA_ID ), 832 ) + CALL CHECK( NF90_INQ_VARID( FID, "air_partial_column_profile", APC_ID ), 833 ) + CALL CHECK( NF90_INQ_VARID( FID, "dofs", DOF_ID ), 834 ) + + ! READ number of retrievals, NIASI + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NLA_ID, TMP, N_IASI_NLA), 841 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NPR_ID, TMP, N_IASI_NPR), 842 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NOB_ID, TMP, N_IASI_NOB), 843 ) + + + print*, 'IASI dimensions on layers, pressures and observations are ', N_IASI_NLA, N_IASI_NPR, N_IASI_NOB + + ALLOCATE(IASI_O3(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, O3_ID, IASI_O3), 851) + ALLOCATE(IASI_O3_STD(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, O3E_ID, IASI_O3_STD), 852) + ALLOCATE(IASI_O3_APR(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, APR_ID, IASI_O3_APR), 858) + ALLOCATE(IASI_AIR_DEN(N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, APC_ID, IASI_AIR_DEN), 859) + ALLOCATE(IASI_SOLAR_ZENITH(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, SOZ_ID, IASI_SOLAR_ZENITH), 853) + ALLOCATE(IASI_SATELLITE_ZENITH(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, SAZ_ID, IASI_SATELLITE_ZENITH), 861) + ALLOCATE(IASI_PRESSURE(N_IASI_NPR, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, PRE_ID, IASI_PRESSURE), 854) + ALLOCATE(IASI_LAT(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, LAT_ID, IASI_LAT), 855) + ALLOCATE(IASI_LON(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, LON_ID, IASI_LON), 856) + ALLOCATE(IASI_TIME(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, TIM_ID, IASI_TIME), 857) + !PRINT *, "IASI_TIME", IASI_TIME(1:N_IASI_NOB) + ALLOCATE(IASI_O3_AVK(N_IASI_NLA, N_IASI_NLA, N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, AVK_ID, IASI_O3_AVK), 860) + ALLOCATE(IASI_QUAL_FLAG(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, QUA_ID, IASI_QUAL_FLAG), 862) + ALLOCATE(IASI_CLOUD_COVER(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, CLR_ID, IASI_CLOUD_COVER), 863) + ALLOCATE(IASI_DOFS(N_IASI_NOB)) + CALL CHECK( NF90_GET_VAR(FID, DOF_ID, IASI_DOFS), 864) + ALLOCATE(IASI_O3_LVL(N_IASI_NOB)) + CALL CHECK( NF90_CLOSE( FID ), 899) + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + !ALLOCATE(IASI_O3_LVL(N_IASI_NOB)) + DO N = 1, N_IASI_NOB + J = 1 + DO WHILE ( J .le. MAXLEV ) + ! check if the value is good + IF (IASI_O3(J,N) > FILL ) THEN + ! save the number of good levels as LTES + IASI_O3_LVL(N) = MAXLEV - J + 1 + ! and now we can exit the while loop + J = MAXLEV + 1 + ! otherwise this level is just filler + ELSE + ! so proceed to the next one up + J = J + 1 + ENDIF + ENDDO + ENDDO + + !print*, ' IASI TEST ', IASI(N)%O3 + !print*, ' IASI good ', IASI(N)%LIASI + !print*, ' IASI pres ', IASI(N)%PRES(1:J) + + ! Add a bit to the diagonal to regularize the inversion + ! (ks, ml, dkh, 11/18/10) + ! mkeller: this makes no sense to me. + !DO II=1,J + ! IASI(N)%S_OER(II,II) = IASI(N)%S_OER(II,II)+ 0.001D0 + !ENDDO + + !CALL SVD( IASI(N)%S_OER(1:J,1:J), J, + !& U(1:J,1:J), S(1:J), + !& VT(1:J,1:J) ) + + ! U = S^-1 * U^T + !TEST = 0d0 + !DO I = 1, J + + ! mkeller: regularize matrix inverse by ignoring all singular values below a certain cutoff. + ! This is horrendously inefficient, but should work for now. In the + ! future, Thikonov regularization should be implemented instead. + ! xzhang: svd TEST critical value changes from 1e-2 to 5e-2 + !IF ( S(I)/S(1) < 1e-2 ) THEN + !S(I) = 1e-2 * S(1) + !ENDIF + !DO II = 1, J + !TEST(I,II) = U(II,I) / S(I) + !ENDDO + !ENDDO + + !TEST = 0d0 + !U = TEST + !TEST = 0d0 + + + ! S_OER_INV = V * S^-1 * U^T + !DO I = 1, J + !DO II = 1, J + !TMP1 = 0d0 + !DO III = 1, J + !TMP1 = TMP1 + VT(III,I) * U(III,II) + !ENDDO + !IASI(N)%S_OER_INV(I,II) = TMP1 + !ENDDO + !ENDDO + + ! TEST: calculate 2-norm of I - S_OER_INV * S_OER + ! mkeller: comment this out for now; pointless given the regularization + ! performed above. + ! Need to come up with an alternative TEST in the future. + !DO I = 1, J + ! DO II = 1, J + ! TMP1 = 0d0 + ! DO III = 1, J + ! TMP1 = TMP1 + !& + IASI(N)%S_OER_INV(III,I) * IASI(N)%S_OER(III,II) + !ENDDO + !TEST(I,II) = - TMP1 + !ENDDO + !TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 + !ENDDO + + !IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN + ! print*, ' WARNING: inversion error for retv N = ', + !& SUM(TEST(1:J,1:J)), N + ! print*, ' in IASI obs ', READ_FILENAME + ! ENDIF + + !ENDDO ! N + + ! Return to calling program + END SUBROUTINE READ_IASI_O3_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'IASI_o3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_IASI_O3_FORCE( COST_FUNC ) + ! +!****************************************************************************** +! Subroutine CALC_IASI_O3_FORCE calculaIASI the adjoint forcing from the IASI +! O3 observations and updaIASI the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost function [unitless] +! +! +! NOIASI: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_HOUR + USE TRACER_MOD, ONLY : XNUMOLAIR, STT + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT, I_IASI + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LIASI, L0 + INTEGER :: JLOOP + INTEGER :: GC_HOUR + INTEGER :: LVL_CRT1, LVL_CRT2 + REAL*8 :: GC_PRES(LLPAR+1) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF, IASI_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV), GC_O3_CONTRIB(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV), COST_CONTRIB(MAXLEV), COST_CONTRIB_COL + REAL*8 :: DIFF_COL, FORCE_COL, IASI_O3_STD_COL + REAL*8 :: IASI_PCENTER(MAXLEV) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: OLD_COST + REAL*8 :: XNUAIR + REAL*8, SAVE :: TIME_FRAC(MAXIASI) + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + REAL*8 :: IASI_O3_BIAS(IIPAR,JJPAR), IASI_O3_BIAS_FILT(IIPAR,JJPAR) + REAL*8 :: IASI_O3_CHI_SQ(IIPAR,JJPAR), IASI_O3_CHI_SQ_FILT(IIPAR,JJPAR) + REAL*8 :: IASI_O3_BIAS_SOBS(IIPAR,JJPAR), IASI_O3_BIAS_FILT_SOBS(IIPAR,JJPAR) + REAL*8 :: IASI_O3_CHI_SQ_SOBS(IIPAR,JJPAR), IASI_O3_CHI_SQ_FILT_SOBS(IIPAR,JJPAR) + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! CALC_IASI_O3_FORCE begins here! + !================================================================= + + print*, ' - CALC_IASI_O3_FORCE ' + + ! Reset + XNUAIR = 28.9644d-3 + NEW_COST = 0d0 + SOBS_COUNT = 0d0 + GC_ADJ_TEMP = 0d0 + GC_ADJ_TEMP_COST = 0d0 + GC_ADJ_COUNT = 0d0 + IASI_O3_BIAS = 0d0 + IASI_O3_BIAS_FILT = 0d0 + IASI_O3_CHI_SQ = 0d0 + IASI_O3_CHI_SQ_FILT = 0d0 + IASI_O3_BIAS_SOBS = 0d0 + IASI_O3_BIAS_FILT_SOBS = 0d0 + IASI_O3_CHI_SQ_SOBS = 0d0 + IASI_O3_CHI_SQ_FILT_SOBS = 0d0 + GC_HOUR = GET_HOUR() + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + PRINT *, "GET_NHMS", GET_NHMS() + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the IASI O3 file for this day + CALL READ_IASI_O3_OBS( GET_NYMD(), N_IASI_NOB ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:N_IASI_NOB) = IASI_TIME(1:N_IASI_NOB)/240000d0 + ENDIF + IF ( FIRST ) THEN + FILENAME = 'chi_sq2_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 801, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 802, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'chi_sq2_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 803, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff2_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 804, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 805, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_filt_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 806, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 813, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 814, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( N_IASI_NOB, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching IASI O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), IASI_TIME(NTSTART), IASI_TIME(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + + + DO I_IASI = NTSTART, NTSTOP, -1 + !PRINT *, "IASI_TIME", IASI_TIME(I_IASI) + IF ( ( IASI_LAT(I_IASI) > -60d0 ) .AND. & + ( IASI_LAT(I_IASI) < 75d0 ) .AND. & + ( IASI_QUAL_FLAG(I_IASI) == 0d0 ) .AND. & + ( IASI_SOLAR_ZENITH(I_IASI) < 80d0 ) .AND. & + ( IASI_DOFS(I_IASI) > 2.75 ) .AND. & + ( IASI_CLOUD_COVER(I_IASI) < 13d0 ) ) THEN + + !( IASI_SATELLITE_ZENITH(I_IASI) > 0d0 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + GC_O3_CONTRIB(:,:) = 0d0 + FORCE(:) = 0d0 + DIFF(:) = 0d0 + COST_CONTRIB(:) = 0d0 + COST_CONTRIB_COL = 0d0 + DIFF_COL = 0d0 + IASI_O3_STD_COL = 0d0 + FORCE_COL = 0d0 + LVL_CRT1 = 0 + LVL_CRT2 = 0 + LIASI = IASI_O3_LVL(I_IASI) + IIJJ = GET_IJ(REAL(IASI_LON(I_IASI),4),REAL(IASI_LAT(I_IASI),4)) + IASI_PCENTER = 0d0 + I = IIJJ(1) + J = IIJJ(2) + + L0 = MAXLEV - IASI_O3_LVL(I_IASI) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR+1 + GC_PRES(L) = GET_PEDGE(I,J,L) + ENDDO + DO L = 1, LIASI + IASI_PCENTER(L) = 0.5d0*(IASI_PRESSURE(L+L0,I_IASI)+IASI_PRESSURE(L+L0+1,I_IASI)) + ENDDO + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + IASI_PSURF = IASI_PRESSURE(1+L0,I_IASI) + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LIASI) = GET_INTMAP( LLPAR, GC_PRES, GC_PSURF, & + LIASI, IASI_PRESSURE(1+L0:LIASI+L0,I_IASI), IASI_PSURF ) + DO L = 1, LLPAR + IF ( GC_PRES(L) > 300d0 ) THEN + GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) * BXHEIGHT(I,J,L)/(AIRVOL(I,J,L)*XNUAIR) + ELSE + GC_O3_NATIVE(L) = STT(I,J,L,IDTOX) * TCVV(IDTOX) * BXHEIGHT(I,J,L)/(AIRVOL(I,J,L)*XNUAIR) + ENDIF + ENDDO + !PRINT *, "IASI_PCENTER", IASI_PCENTER + !PRINT *, "GC_PRES", GC_PRES + !PRINT *, " GC_O3_NATIVE", GC_O3_NATIVE + ! Interpolate GC O3 column to TES grid + DO L = 1, LIASI + GC_O3(L) = 0d0 + DO LL = 1, LLPAR + GC_O3_CONTRIB(LL,L) = MAP(LL,L) * GC_O3_NATIVE(LL) + GC_O3(L) = GC_O3(L) + MAP(LL,L) * GC_O3_NATIVE(LL) + ENDDO + ENDDO + DO L = 2, LIASI-1 + IF (GC_O3(L) == 0d0) THEN + IF (GC_O3(L-1) > 0d0) THEN + LVL_CRT1 = L-1 + ENDIF + IF (GC_O3(L+1) > 0d0) THEN + LVL_CRT2 = L+1 + ENDIF + IF (REAL(LVL_CRT1)*REAL(LVL_CRT2)>0d0) THEN + DO LL = LVL_CRT1,LVL_CRT2 + GC_O3(LL) = ((GC_O3(LVL_CRT1)+GC_O3(LVL_CRT2))/SUM(IASI_O3(LVL_CRT1+L0:LVL_CRT2+L0,I_IASI)))* & + IASI_O3(LL+L0,I_IASI) + ENDDO + LVL_CRT1 = 0 + LVL_CRT2 = 0 + ENDIF + ENDIF + ENDDO + !PRINT *, " GC_O3", GC_O3 + !-------------------------------------------------------------- + ! Apply IASI O3 observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by IASI [lnvmr] + ! x_a = IASI apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = IASI averaging kernel + ! + ! OR + ! + ! x_smoothed = A_k*x_m + (I-A_k)*x_a + ! where + ! x_smoothed = GC modeled column smoothed by IASI [vmr] + ! x_a = IASI apriori partial column [vmr] + ! x_m = GC modeled profile [vmr] + ! A_k = IASI averaging kernel + !-------------------------------------------------------------- + ! x_m - x_a + DO L = 1, LIASI + IF (IASI_O3_APR(L+L0,I_IASI) > 0) THEN + GC_O3(L) = MAX(GC_O3(L), 1d-4) + O3_PERT(L) = GC_O3(L) - IASI_O3_APR(L+L0,I_IASI) + ENDIF + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LIASI + O3_HAT(L) = 0d0 + FORCE(L) = 0d0 + IF (IASI_O3_APR(L+L0,I_IASI) > 0) THEN + DO LL = 1, LIASI + O3_HAT(L) = O3_HAT(L) + IASI_O3_AVK(LL+L0,L0+L,I_IASI) * O3_PERT(LL) + ENDDO + O3_HAT(L) = O3_HAT(L) + IASI_O3_APR(L+L0,I_IASI) + ENDIF + ! actual comparison + IF ( ( IASI_O3(L+L0,I_IASI) > 0d0 ) .AND. & + ( O3_HAT(L) > 0d0 ) .AND. & + ( IASI_O3(L+L0,I_IASI) < 100d0 * IASI_O3_STD(L+L0,I_IASI) ) ) THEN + IF ( REAL(IASI_LAT(I_IASI)) >= 60d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.049 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.805 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.975 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= 30d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.132 + ELSEIF (IASI_PCENTER(L) >=150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.018 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.921 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= 0d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.142 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.934 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.876 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -30d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.122 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.963 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.886 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -60d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*1.12 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.994 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.94 + ENDIF + ELSEIF ( REAL(IASI_LAT(I_IASI)) >= -90d0 ) THEN + IF (IASI_PCENTER(L) >= 300d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.98 + ELSEIF (IASI_PCENTER(L) >= 150d0) THEN + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.765 + ELSE + DIFF(L) = O3_HAT(L) - IASI_O3(L+L0,I_IASI)*0.71 + ENDIF + ENDIF + !PRINT *, "DIFF", DIFF(L) + ELSE + DIFF(L) = 0d0 + ENDIF + !PRINT *, "O3_HAT", O3_HAT(L) + !PRINT *, "IASI_O3", IASI_O3(L+L0,I_IASI) + !PRINT *, "IASI_O3_STD", IASI_O3_STD(L+L0, I_IASI) + FORCE(L) = DIFF(L)/(0.5*IASI_O3_STD(L+L0,I_IASI))**2 + COST_CONTRIB(L) = 0.5d0 * DIFF(L) * FORCE(L) + IF ( ( IASI_PCENTER(L) >= 300d0 ) ) THEN + DIFF_COL = DIFF_COL + DIFF(L) + IASI_O3_STD_COL = IASI_O3_STD_COL + IASI_O3_STD(L+L0,I_IASI)**2 + ENDIF + ENDDO + + FORCE_COL = DIFF_COL/IASI_O3_STD_COL + + IF ( ( IASI_PCENTER(8) >= 300d0 ).AND. & + ( SQRT(COST_CONTRIB(8)) < 10d0 ) .AND. & + ( SQRT(COST_CONTRIB(8)) > 0d0 ) ) THEN + IASI_O3_BIAS_FILT(I,J) = IASI_O3_BIAS_FILT(I,J)+ DIFF(8) + IASI_O3_CHI_SQ_FILT(I,J) = IASI_O3_CHI_SQ_FILT(I,J) + 2*COST_CONTRIB(8) + ENDIF + COST_CONTRIB_COL = 0.5d0 * DIFF_COL * FORCE_COL + IF ( ( COST_CONTRIB_COL > 0d0) .AND. & + ( COST_CONTRIB_COL < 200d0) ) THEN + ! adjoint of interpolation + DO L = 1, LLPAR + ! Adjoint of unit conversion + GC_O3_NATIVE_ADJ(L) = FORCE_COL * TCVV(IDTOX) * BXHEIGHT(I,J,L)/ (XNUAIR*AIRVOL(I,J,L)) + GC_ADJ_TEMP(I,J,L) = GC_ADJ_TEMP(I,J,L) + GC_O3_NATIVE_ADJ(L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1d0 + ENDDO + + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL!0.5 * DIFF_COL * FORCE_COL + IF (SUPER_OBS) THEN + !IF (COST_CONTRIB_COL > 0d0) THEN + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + IASI_O3_BIAS(I,J) = IASI_O3_BIAS(I,J) + DIFF(8) + IASI_O3_CHI_SQ(I,J) = IASI_O3_CHI_SQ(I,J) + 2*COST_CONTRIB(8) + !ENDIF + ENDIF + ENDIF + + 110 FORMAT(F18.6,1X) +640 ENDIF + ENDDO ! NT + IF (SUPER_OBS) THEN + DO I=1,IIPAR + DO J=1,JJPAR + IF ( SOBS_COUNT(I,J) > 0d0 ) THEN + DO L=1,LLPAR + IF ( ( GET_PCENTER(I,J,L) >= 300d0 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0d0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + ENDIF + + ENDDO + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + IASI_O3_BIAS_SOBS(I,J) = IASI_O3_BIAS(I,J)/SOBS_COUNT(I,J) + IASI_O3_CHI_SQ_SOBS(I,J) = IASI_O3_CHI_SQ(I,J)/SOBS_COUNT(I,J) + ENDIF + IF (GC_ADJ_COUNT(I,J,8) > 0d0) THEN + IASI_O3_BIAS_FILT_SOBS(I,J) = IASI_O3_BIAS_FILT(I,J)/GC_ADJ_COUNT(I,J,8) + IASI_O3_CHI_SQ_FILT_SOBS(I,J) = IASI_O3_CHI_SQ_FILT(I,J)/GC_ADJ_COUNT(I,J,8) + ENDIF + WRITE(801,110)(IASI_O3_CHI_SQ_SOBS(I,J)) + WRITE(802,110)(1e6*IASI_O3_BIAS_SOBS(I,J)) + WRITE(803,110)(IASI_O3_CHI_SQ_FILT_SOBS(I,J)) + WRITE(804,110)(1e6*IASI_O3_BIAS_FILT_SOBS(I,J)) + WRITE(805,110)(SOBS_COUNT(I,J)) + WRITE(806,110)(GC_ADJ_COUNT(I,J,8)) + WRITE(813,110)(GET_XMID(I)) + WRITE(814,110)(GET_YMID(J)) + ENDDO + ENDDO + ENDIF + + + + IF ( FIRST ) FIRST = .FALSE. + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' IASI contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_IASI_O3_FORCE + +!---------------------------------------------------------------------------- + SUBROUTINE CLEANUP_IASI + + IF(ALLOCATED(IASI_LON)) DEALLOCATE(IASI_LON) + IF(ALLOCATED(IASI_LAT)) DEALLOCATE(IASI_LAT) + IF(ALLOCATED(IASI_TIME)) DEALLOCATE(IASI_TIME) + IF(ALLOCATED(IASI_O3_AVK)) DEALLOCATE(IASI_O3_AVK) + IF(ALLOCATED(IASI_O3_APR)) DEALLOCATE(IASI_O3_APR) + IF(ALLOCATED(IASI_O3_STD)) DEALLOCATE(IASI_O3_STD) + IF(ALLOCATED(IASI_O3)) DEALLOCATE(IASI_O3) + IF(ALLOCATED(IASI_SATELLITE_ZENITH)) DEALLOCATE(IASI_SATELLITE_ZENITH) + IF(ALLOCATED(IASI_SOLAR_ZENITH)) DEALLOCATE(IASI_SOLAR_ZENITH) + IF(ALLOCATED(IASI_CLOUD_COVER)) DEALLOCATE(IASI_CLOUD_COVER) + IF(ALLOCATED(IASI_QUAL_FLAG)) DEALLOCATE(IASI_QUAL_FLAG) + IF(ALLOCATED(IASI_AIR_DEN)) DEALLOCATE(IASI_AIR_DEN) + IF(ALLOCATED(IASI_PRESSURE)) DEALLOCATE(IASI_PRESSURE) + IF(ALLOCATED(IASI_O3_LVL)) DEALLOCATE(IASI_O3_LVL) + IF(ALLOCATED(IASI_DOFS)) DEALLOCATE(IASI_DOFS) + END SUBROUTINE CLEANUP_IASI +!------------------------------------------------------------------------------ + SUBROUTINE GET_NT_RANGE( N_IASI_NOB, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_IASI_NOB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(N_IASI_NOB) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = N_IASI_NOB + + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' N_IASI_NOB ', N_IASI_NOB + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + ! one hour as a fraction of day + H1_FRAC = 0d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + !ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, LTM_TOP, TM_PRESC, TM_SURFP ) RESULT( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOIASI: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP+1) + REAL*8 :: TM_PRESC(LTM_TOP+1) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LGC = 1, LGC_TOP + + ! Find the levels from GC that bracket level LTM + DO LTM = 1, LTM_TOP + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( GC_PRESC(LGC) <= TM_PRESC(LTM ) ) THEN + IF (GC_PRESC(LGC+1) >= TM_PRESC(LTM+1)) THEN + HINTERPZ(LGC,LTM) = 1D0 + ELSEIF (GC_PRESC(LGC) >= TM_PRESC(LTM+1)) THEN + DIFF = HI - LOW + HINTERPZ(LGC,LTM) = ( HI - TM_PRESC(LTM+1) ) / DIFF + HINTERPZ(LGC,LTM+1) = ( TM_PRESC(LTM+1) - LOW ) / DIFF + ENDIF + ELSEIF (GC_PRESC(LGC) > TM_PRESC(1) ) THEN + HINTERPZ(LGC,1) = 1D0 + ENDIF + + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where IASI pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + !DO LTM = 1, LTM_TOP + !IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + !HINTERPZ(:,LTM) = 0D0 + !HINTERPZ(LTM,LTM) = 1D0 + !ENDIF + !ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + + + + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOIASI: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 +!------------------------------------------------------------------- + + END MODULE IASI_O3_OBS_MOD diff --git a/code/obs_operators/improve_bc_mod.f b/code/obs_operators/improve_bc_mod.f new file mode 100644 index 0000000..5be4d1f --- /dev/null +++ b/code/obs_operators/improve_bc_mod.f @@ -0,0 +1,1838 @@ +!$Id: improve_bc_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE IMPROVE_BC_MOD +! +!****************************************************************************** +! Mdoule IMPROVE_BC_MOD contains subroutines necessary to assimilate +! observations of BC and OC from the IMPROVE network. +! (yhmao, dkh, 01/13/12, adj32_013) +! +! Notes +! (1 ) Based on the v6 adjoint improve obs operator +! +!****************************************************************************** + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + INTEGER, PARAMETER :: IU_IMPRV_ASCI = 901 + INTEGER, PARAMETER :: IU_IMPRV_BPCH = 902 + INTEGER, PARAMETER :: IU_AEROAVE = 903 + INTEGER, PARAMETER :: IU_JSAVE = 923 + + INTEGER, PARAMETER :: LLAVE = 1 + + LOGICAL :: DURING_IMPRV_OBS + + + REAL*8, ALLOCATABLE :: IMPRV_BC(:,:,:) + !REAL*8, ALLOCATABLE :: IMPRV_OC(:,:,:) + REAL*8, ALLOCATABLE :: AVE_BCPI(:,:) + !REAL*8, ALLOCATABLE :: AVE_OCPI(:,:) + REAL*8, ALLOCATABLE :: AVE_BCPO(:,:) + !REAL*8, ALLOCATABLE :: AVE_OCPO(:,:) + REAL*8, ALLOCATABLE :: ADJ_AVE_BCPI(:,:) + !REAL*8, ALLOCATABLE :: ADJ_AVE_OCPI(:,:) + REAL*8, ALLOCATABLE :: ADJ_AVE_BCPO(:,:) + !REAL*8, ALLOCATABLE :: ADJ_AVE_OCPO(:,:) + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE IMPROVE_DATAPROC(YYYYMMDD) +! +!****************************************************************************** +! Subroutine IMPROVE_DATAPROC +! - this routine reads in raw IMPROVE data from a text file and puts in +! on a GEOS-Chem grid. It assumes that the text file has a row for +! each station, and is all of the data for a singe day. Currently, +! it is set for "imprv.20050730", which would by july 30th 2005. I +! would change this string to correspond to the name of your data text +! file, and rerun just this subroutine. You'll have to call it once for +! every day of text data you need to process, so maybe put it in a loop. +! - The columns of the text file are: YYYYMMDD, Lat, Lon, BCrate concentration, +! BCrate uncertainty, BCrate detection limit +! - the result is a bpch file with IMPROVE data. +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD (INTEGER) : Current date +! +! NOTES: +! (1 ) Now add model resultion extension to binary file name. (dkh, 11/28/06) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_IJ, GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" +!# include "CMN_SETUP" ! DATA_DIR + + INTEGER, INTENT(IN) :: YYYYMMDD + ! Arguments + + ! Local variables + INTEGER :: I, J, I0, J0, IIJJ(2), HHMMSS_dum + CHARACTER(LEN=120) :: FILENAME, FILENAME1 + CHARACTER(LEN=120) :: READ_FILENAME, WRITE_FILENAME + REAL*8 :: BC_BAR(IIPAR,JJPAR)!, OC_BAR(IIPAR,JJPAR) + REAL*8 :: SBC_MES(IIPAR,JJPAR)!, SOC_MES(IIPAR,JJPAR) + !REAL*8 :: SBC_REP(IIPAR,JJPAR), SOC_REP(IIPAR,JJPAR) + REAL*8 :: SBC_RES(IIPAR,JJPAR)!, SOC_RES(IIPAR,JJPAR) + REAL*8 :: BC_MMDL(IIPAR,JJPAR)!, OC_MMDL(IIPAR,JJPAR) + REAL*8 :: DELTA_BC!, DELTA_OC + INTEGER :: N(IIPAR,JJPAR), IOS + LOGICAL :: EOF + REAL*4 :: DAT(IIPAR,JJPAR,4) + + ! For binary punch file, version 2.0 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UBC + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + ! Variables read from file + INTEGER :: YYYYMMDD1 + REAL*4 :: LAT, LON + REAL*4 :: BC, BC_UNC, BC_MDL + !REAL*4 :: OC, OC_UNC, OC_MDL + + !================================================================= + ! IMPROVE_DATAPROC begins here! + !================================================================= + BC_BAR(:,:) = 0d0 + !OC_BAR(:,:) = 0d0 + !SBC_REP(:,:) = 0d0 + !SOC_REP(:,:) = 0d0 + SBC_MES(:,:) = 0d0 + SBC_MES(:,:) = 0D0 + BC_MMDL(:,:) = 0d0 + !OC_MMDL(:,:) = 0D0 + SBC_RES(:,:) = 0d0 + !SOC_RES(:,:) = 0d0 + N(:,:) = 0d0 + EOF = .FALSE. + + print*,2 !yhmao + FILENAME = TRIM( 'imprv.YYYYMMDD' ) + ! ####### + ! manually enter the name of the file to process here + ! ( also have to enter it in CALC_SRES ) + ! ####### + CALL EXPAND_DATE( FILENAME, YYYYMMDD,HHMMSS_dum ) + ! Add input file suffix (confusingly named .out) + FILENAME1='/qb6/yhmao/geos-chem/adjoint/new/gcadj_std/obsdata/'// + &TRIM( FILENAME ) + READ_FILENAME =TRIM( FILENAME1 ) // TRIM( '.txt' ) + + + print*,3 !yhmao + WRITE(6,*) ' IMPROVE_DATAPROC: reading file: ', READ_FILENAME + + OPEN( IU_IMPRV_ASCI, FILE = TRIM( READ_FILENAME ), + & STATUS = 'OLD', IOSTAT = IOS ) + + DO WHILE (.not. EOF ) + + ! Read ascii text file + READ( IU_IMPRV_ASCI, *, IOSTAT = IOS ) + & YYYYMMDD1, LAT, LON, + & BC, BC_UNC, BC_MDL!, + !& OC, OC_UNC, OC_MDL + + ! dkh debug + print*, ' YYYYMMDD = ', YYYYMMDD1 + print*, ' LAT = ', LAT + print*, ' LON = ', LON + print*, ' BC = ', BC + print*, ' BC_UN = ', BC_UNC + print*, ' BC_MDL = ', BC_MDL + !print*, ' OC = ', OC + !print*, ' OC_UN = ', OC_UNC + !print*, ' OC_MDL = ', OC_MDL + print*, ' IOS = ', IOS + + IF ( IOS < 0 ) THEN + + EOF = .TRUE. + + ELSEIF( IOS > 0 ) THEN + + CALL ERROR_STOP( 'Error reading improve.out file', + & 'improve_mod.f' ) + + ENDIF + + ! Quality check + IF ( + & BC < 0 .or. + !& OC < 0 .or. + & BC < BC_MDL .or. + !& OC < OC_MDL .or. + & BC < BC_UNC !.or. + !& OC < OC_UNC + & ) CYCLE + + + ! Get grid box + IIJJ = GET_IJ( LON, LAT) + I = IIJJ(1) + J = IIJJ(2) + + ! Update local count + N(I,J) = N(I,J) + 1 + + ! dkh debug + print*, 'LON, LAT, I, J, N' , LON, LAT, I, J, N(I,J) + print*, 'BC, BC_UNC, BC_MDL', BC, BC_UNC, BC_MDL + !print*, 'OC, OC_UNC, OC_MDL', OC, OC_UNC, OC_MDL + + ! Update mean + DELTA_BC = BC - BC_BAR(I,J) + !DELTA_OC = OC - OC_BAR(I,J) + + BC_BAR(I,J) = BC_BAR(I,J) + DELTA_BC / N(I,J) + !OC_BAR(I,J) = OC_BAR(I,J) + DELTA_OC / N(I,J) + + ! Update representational error +! SBC_REP(I,J) = SBC_REP(I,J) +! & + DELTA_BC * ( BC - BC_BAR(I,J)) +! SOC_REP(I,J) = SOC_REP(I,J) +! & + DELTA_OC * ( OC - OC_BAR(I,J)) + + ! Update the maximum minimum detection limit + BC_MMDL(I,J) = MAX(BC_MMDL(I,J),BC_MDL) + !OC_MMDL(I,J) = MAX(OC_MMDL(I,J),OC_MDL) + + ! Update measurement error + ! These are already variances, no need to square + ! them. (dkh, 04/28/08) + !SBC_MES(I,J) = SBC_MES(I,J) + BC_UNC ** 2 + !SOC_MES(I,J) = SOC_MES(I,J) + OC_UNC ** 2 + SBC_MES(I,J) = SBC_MES(I,J) + BC_UNC ** 2 + !SOC_MES(I,J) = SOC_MES(I,J) + OC_UNC ** 2 + + + + + IF ( IOS < 0 ) THEN + + EOF = .TRUE. + + ELSEIF( IOS > 0 ) THEN + + CALL ERROR_STOP( 'Error reading improve.out file', + & 'improve_mod.f' ) + + ENDIF + + ENDDO + + + ! Close file + CLOSE( IU_IMPRV_ASCI ) + + WRITE(6,*) 'Done reading improve data file ' + WRITE(6,*) 'Number of good data points found: ', SUM(N(:,:)) + + + ! Finalize Statistical quantities +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + IF ( N(I,J) /= 0 ) THEN + + !IF ( N(I,J) > 1 ) THEN + ! + ! SBC_REP(I,J) = SBC_REP(I,J) / ( N(I,J) - 1 ) + ! SOC_REP(I,J) = SOC_REP(I,J) / ( N(I,J) - 1 ) + ! + !ENDIF + + !SBC_MES(I,J) = SBC_MES(I,J) / ( N(I,J) ** 2 ) + !SOC_MES(I,J) = SOC_MES(I,J) / ( N(I,J) ** 2 ) + !SBC_MES(I,J) = SQRT( SBC_MES(I,J) ) / N(I,J) + !SOC_MES(I,J) = SQRT( SOC_MES(I,J) ) / N(I,J) + SBC_MES(I,J) = SBC_MES(I,J) / N(I,J) + !SOC_MES(I,J) = SOC_MES(I,J) / N(I,J) + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Get resolution error + !CALL CALC_SRES(N, SBC_RES, SOC_RES) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'Improve data file ' + CATEGORY = 'IJ-IMP-$' + LONRES = DISIZE + LATRES = DJSIZE + UBC = 'ug/m3' + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + ! Add ADJ_DIR prefix to filename + !WRITE_FILENAME = TRIM( FILENAME ) // TRIM('.bpch.') // + WRITE_FILENAME = TRIM( FILENAME1 ) // + & TRIM('.v2') // + & TRIM('.bpch.') // + & GET_RES_EXT() + + WRITE( 6, 100 ) TRIM( WRITE_FILENAME ) + 100 FORMAT( ' - IMPROVE_DATAPROC: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_IMPRV_BPCH, WRITE_FILENAME, TITLE ) + + ! BC + ! Temporarily store data in DAT +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + DAT(I,J,1) = BC_BAR(I,J) + !DAT(I,J,2) = SBC_REP(I,J) + DAT(I,J,2) = BC_MMDL(I,J) + DAT(I,J,3) = SBC_MES(I,J) + DAT(I,J,4) = SBC_RES(I,J) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_IMPRV_BPCH, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UBC, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 4, I0+1, + & J0+1, 1, DAT ) + + ! dkh debug + print*, 'TOTAL BC : ', SUM(DAT(:,:,:)) + + ! OC + ! Temporarily store data in DAT +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) + !DO J = 1, JJPAR + !DO I = 1, IIPAR + + !DAT(I,J,1) = OC_BAR(I,J) + !DAT(I,J,2) = SOC_REP(I,J) + !DAT(I,J,2) = OC_MMDL(I,J) + !DAT(I,J,3) = SOC_MES(I,J) + !DAT(I,J,4) = SOC_RES(I,J) + + !ENDDO + !ENDDO +!!$OMP END PARALLEL DO + + !CALL BPCH2( IU_IMPRV_BPCH, MODELNAME, LONRES, LATRES, + !& HALFPOLAR, CENTER180, CATEGORY, 2, + !& UBC, GET_TAU(), GET_TAU(), RESERVED, + !& IIPAR, JJPAR, 4, I0+1, + !& J0+1, 1, DAT ) + + ! dkh debug + !print*, 'TOTAL OC : ', SUM(DAT(:,:,:)) + !print*, 'TOTAL OCa : ', SUM(OC_BAR(:,:)) + !print*, 'TOTAL OCb : ', SUM(SOC_REP(:,:)) + !print*, 'TOTAL OCm : ', SUM(OC_MMDL(:,:)) + !print*, 'TOTAL OCc : ', SUM(SOC_MES(:,:)) + + + ! Close file + CLOSE( IU_IMPRV_BPCH ) + + ! Return to calling program + END SUBROUTINE IMPROVE_DATAPROC + +!------------------------------------------------------------------------------ + + + + SUBROUTINE READ_IMPRV_BPCH( YYYYMMDD ) +! +!****************************************************************************** +! Subroutine READ_IMPRV_BPCH +! - reads in the IMPROVE bpch files that were made in SUBROUTINE +! IMPROVE_DATAPROC +! +! Arguments as Input: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! Arguments as Output: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ, GET_RES_EXT + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" +!# include "CMN_SETUP" ! DATA_DIR + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! Local variables + INTEGER :: IOS, I, J, L, HHMMSS_dum + CHARACTER(LEN=120) :: FILENAME, READ_FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES, TEMP4(IIPAR,JJPAR,4) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UBC + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_IMPRV_BPCH begins here! + !================================================================= + FILENAME = TRIM( 'imprv.YYYYMMDD' ) + + ! Replace token with actual year, month and day. + ! Also pass a dummy integer for HHMMSS, but it won't be used + ! since the filename does not depend upon HHMMSS + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) + + READ_FILENAME = '/qb6/yhmao/geos-chem/adjoint/new/gcadj_std/ +! & TRIM( 'improve_2006/' ) // +! & TRIM( FILENAME ) // TRIM( '.bpch.' ) // + &obsdata/' //TRIM( FILENAME ) // + & TRIM( '.v2' ) // + & TRIM( '.bpch.' ) // + & GET_RES_EXT() + + print*, 'READ_IMPRV_BPCH: reading file : ', READ_FILENAME + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_IMPRV_BPCH, READ_FILENAME ) + + !------------------ + ! BC + !------------------ + READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_imprv_bpch:4' ) + + READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + & CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + print*, 'ntracer = ', ntracer + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_imprv_bpch:5') + + READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + & ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IMPRV_BC(:,:,:) = TEMP4(:,:,:) + + !IF ( IOS /= 0 ) THEN + print*, 'ios = ', IOS + print*, 'NI, NJ, NL = ', NI, NJ, NL + print*, 'SUM BC = ', SUM(IMPRV_BC(:,:,:)) + !print*, ' BC = ', IMPRV_BC(25,65,:) + !print*, ' TEMP4 = ', TEMP4(25,65,:) + + + !CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_imprv_bpch:6') + !ENDIF + + ! Only process improve data + IF ( CATEGORY(1:8) /= 'IJ-IMP-$' ) THEN + CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + ENDIF + + + !------------------ + ! OC + !------------------ + !READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + !& MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + !IF ( IOS > 0 ) + !& CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_checkpt_file:4' ) + + !READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + !& CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + !& NI, NJ, NL, IFIRST, JFIRST, LFIRST, + !& NSKIP + + !IF ( IOS /= 0 ) + !& CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_checkpt_file:5') + + !READ( IU_IMPRV_BPCH, IOSTAT=IOS ) + !& ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + !IMPRV_OC(:,:,:) = TEMP4(:,:,:) + +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_IMPRV_BPCH,'read_checkpt_file:6') + + ! Only process improve data + !IF ( CATEGORY(1:8) /= 'IJ-IMP-$' ) THEN + ! CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + !ENDIF + + + +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + ! dkh debug + print*, 'TOTAL BC = ', SUM(IMPRV_BC(:,:,:)) + !print*, 'TOTAL OC = ', SUM(IMPRV_OC(:,:,:)) + !print*, 'TOTAL OCa : ', SUM(IMPRV_OC(:,:,1)) + !print*, 'TOTAL OCm : ', SUM(IMPRV_OC(:,:,2)) + !print*, 'TOTAL OCc : ', SUM(IMPRV_OC(:,:,3)) + + + ! Return to calling program + END SUBROUTINE READ_IMPRV_BPCH + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_AEROAVE_FILE( YYYYMMDD ) +! +!****************************************************************************** +! Subroutine MAKE_AEROAVE_FILE saves daily average concentrations of +! OC and BC aerosol. (dkh, 11/18/06) +! - makes a bpch file with model values that match the time and +! locations of the IMPROVE data. This is called during the +! forward part of the inverse model, from geos_chem_mod.f +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD (INTEGER) : Date of average [uBC] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : GET_TAU, EXPAND_DATE + +# include "CMN_SIZE" ! Size params +!# include "CMN_ADJ" ! ADJ_DIR + + ! Arguments + INTEGER :: YYYYMMDD + + ! Local variables + INTEGER :: I, J, I0, J0, HHMMSS_dum + CHARACTER(LEN=120) :: FILENAME + REAL*4 :: DAT(IIPAR,JJPAR,LLAVE) + + ! For binary punch file, version 2.0 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UBC + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + !================================================================= + ! MAKE_AEROAVE_FILE begins here! + !================================================================= + + FILENAME = TRIM( 'aero.ave.YYYYMMDD' ) + + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum) + + ! Append data directory prefix + FILENAME = '/qb6/yhmao/geos-chem/adjoint/new/gcadj_std/obsdata/'// + & TRIM( FILENAME ) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'Average Aerosol data file ' + CATEGORY = 'IJ-AVE-$' + LONRES = DISIZE + LATRES = DJSIZE + UBC = 'ug/m3' + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_AEROAVE_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_AEROAVE, FILENAME, TITLE ) + + ! BC + ! Temporarily store data in DAT +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + DAT(I,J,1) = AVE_BCPI(I,J) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_AEROAVE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UBC, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLAVE, I0+1, + & J0+1, 1, DAT ) + + ! dkh debug + print*, 'SUM AVE_BCPI : ', SUM(DAT(:,:,:)) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + DAT(I,J,1) = AVE_BCPO(I,J) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_AEROAVE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2, + & UBC, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLAVE, I0+1, + & J0+1, 1, DAT ) + + ! dkh debug + print*, 'SUM AVE_BCPO : ', SUM(DAT(:,:,:)) + + ! OC + ! Temporarily store data in DAT +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) + !DO J = 1, JJPAR + !DO I = 1, IIPAR + + ! DAT(I,J,1) = AVE_OCPI(I,J) + + !ENDDO + !ENDDO +!!$OMP END PARALLEL DO + + ! CALL BPCH2( IU_AEROAVE, MODELNAME, LONRES, LATRES, + !& HALFPOLAR, CENTER180, CATEGORY, 3, + !& UBC, GET_TAU(), GET_TAU(), RESERVED, + !& IIPAR, JJPAR, LLAVE, I0+1, + !& J0+1, 1, DAT ) + +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) + !DO J = 1, JJPAR + !DO I = 1, IIPAR + + ! DAT(I,J,1) = AVE_OCPO(I,J) + + !ENDDO + !ENDDO +!!$OMP END PARALLEL DO + + !CALL BPCH2( IU_AEROAVE, MODELNAME, LONRES, LATRES, + !& HALFPOLAR, CENTER180, CATEGORY, 4, + !& UBC, GET_TAU(), GET_TAU(), RESERVED, + !& IIPAR, JJPAR, LLAVE, I0+1, + !& J0+1, 1, DAT ) + + + ! Close file + CLOSE( IU_AEROAVE ) + + ! Return to calling program + END SUBROUTINE MAKE_AEROAVE_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_AEROAVE_FILE( YYYYMMDD ) +! +!****************************************************************************** +! Subroutine READ_AEROAVE_FILE +! - called during the adjoint part of the inverse model. Reads in the +! 24h average concentrations saved from the forward part that were +! written during MAKE_AEROAVE_FILE +! +! Arguments as Input: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! Arguments as Output: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" ! Size params +!# include "CMN_ADJ" ! ADJ_DIR + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! Local variables + INTEGER :: IOS, I, J, L, HHMMSS_dum + CHARACTER(LEN=120) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES, TEMP4(IIPAR,JJPAR,3) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UBC + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_AEROAVE_FILE begins here! + !================================================================= + FILENAME = TRIM( 'aero.ave.YYYYMMDD' ) + + ! Replace token with actual year, month and day. + ! Also pass a dummy integer for HHMMSS, but it won't be used + ! since the filename does not depend upon HHMMSS + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) + + FILENAME = '/qb6/yhmao/geos-chem/adjoint/new/gcadj_std/obsdata/'// + & TRIM( FILENAME ) + + print*, 'READ_AEROAVE_FILE: reading file - ', FILENAME + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_AEROAVE, FILENAME ) + + !------------------ + ! BC + !------------------ + READ( IU_AEROAVE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:4' ) + + READ( IU_AEROAVE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + print*, 'ntracer = ', ntracer + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:5') + + READ( IU_AEROAVE, IOSTAT=IOS ) + & ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + AVE_BCPI(:,:) = TEMP4(:,:,1) + + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:6') + ENDIF + + ! Only process improve data + IF ( CATEGORY(1:8) /= 'IJ-AVE-$' ) THEN + CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + ENDIF + + !BCPO + READ( IU_AEROAVE, IOSTAT=IOS ) + &MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:4' ) + + READ( IU_AEROAVE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + print*, 'ntracer = ', ntracer + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:5') + + READ( IU_AEROAVE, IOSTAT=IOS ) + & ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + AVE_BCPO(:,:) = TEMP4(:,:,1) + + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS,IU_AEROAVE,'read_imprv_bpch:6') + ENDIF + + ! Only process improve data + IF ( CATEGORY(1:8) /= 'IJ-AVE-$' ) THEN + CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + ENDIF + + !------------------ + ! OC + !------------------ + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + !IF ( IOS > 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:4' ) + + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + !& NI, NJ, NL, IFIRST, JFIRST, LFIRST, + !& NSKIP + + !IF ( IOS /= 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:5') + + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + !AVE_OCPI(:,:) = TEMP4(:,:,1) + + ! IF ( IOS /= 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:6') + + ! Only process improve data + !IF ( CATEGORY(1:8) /= 'IJ-AVE-$' ) THEN + ! CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + !ENDIF + + !OCPO + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + !IF ( IOS > 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:4' ) + + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& CATEGORY, NTRACER, UBC, ZTAU0, ZTAU1, RESERVED, + !& NI, NJ, NL, IFIRST, JFIRST, LFIRST, + !& NSKIP + + !IF ( IOS /= 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:5') + + !READ( IU_AEROAVE, IOSTAT=IOS ) + !& ( ( (TEMP4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + !AVE_OCPO(:,:) = TEMP4(:,:,1) + + !IF ( IOS /= 0 ) + !& CALL IOERROR( IOS,IU_AEROAVE,'read_checkpt_file:6') + + ! Only process improve data + !IF ( CATEGORY(1:8) /= 'IJ-AVE-$' ) THEN + ! CALL ERROR_STOP( 'Wrong data type', 'read_imprv_bpch') + !ENDIF + !------------------ + + + ! dkh debug + print*, 'SUM AVE_BCPI = ', SUM(AVE_BCPI(:,:)) + !print*, 'SUM AVE_OCPI = ', SUM(AVE_OCPI(:,:)) + print*, 'SUM AVE_BCPO = ', SUM(AVE_BCPO(:,:)) + !print*, 'SUM AVE_OCPO = ', SUM(AVE_OCPO(:,:)) + + + IF ( NL /= 1 ) CALL ERROR_STOP( 'wrong dimension', + & 'read_aerosave') + + ! Close file + CLOSE( IU_AEROAVE ) + + ! Return to calling program + END SUBROUTINE READ_AEROAVE_FILE + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_IMPRV_OBS_START( DIRECTION ) RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_IMPRV_OBS returns TRUE if it is the start of a day +! for which we have improve observations. (dkh, 11/18/06) +! - determines wether or not the simulation is at the beginning of a +! day where there are IMPROVE observations. Based on the months that +! you choose to analyze, you will need to adjust this line: +! IF ( MOD( DATE(1) - 20050400 + 3, 3 ) == 0 ) THEN +! FLAG = .TRUE. +! so that it is looking at the correct 1-out-of-3 days for your time period. +! - assumes the entire dataset is in the same time zone, which I think is +! reasonable for 24 hour average measurements over just the continental US. +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_NYMDb + + ! Function arguments + INTEGER :: DIRECTION + + ! Function value + LOGICAL :: FLAG + + ! Local variables + INTEGER :: DATE(2) + + !================================================================= + ! ITS_TIME_FOR_IMPRV_OBS_START begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + DURING_IMPRV_OBS = .FALSE. + + ! Get time in midwest + DATE = GET_TIME_AHEAD( - 7 * 60 ) + + ! Check if it's midnight + IF ( DATE(2) == 00 ) THEN + + ! Check if its a day where we have observations + ! for 200201: + !IF ( MOD( DATE(1) - 20020100 + 1, 3 ) == 0 ) THEN + ! for 200104: + !IF ( MOD( DATE(1) - 20010400 + 2, 3 ) == 0 ) THEN + ! for 200107: + !IF ( MOD( DATE(1) - 20010400 + 3, 3 ) == 0 ) THEN + ! for 200507: + IF ( MOD( DATE(1) - 20060701 + 3, 3 ) == 0 ) THEN + FLAG = .TRUE. + + WRITE(6,*) ' ITS_TIME_FOR_IMPRV_OBS_START at ', + & DATE(1), DATE(2) + + ! forward calculation + IF ( DIRECTION > 0 ) THEN + + ! moving into new measurement period + DURING_IMPRV_OBS = .TRUE. + + ! backward calculation + ELSEIF ( DIRECTION < 0 ) THEN + + ! leaving measurement period + DURING_IMPRV_OBS = .FALSE. + + ENDIF + ! ELSE + ! DURING_IMPRV_OBS = .FALSE. + ENDIF + !ELSE + ! DURING_IMPRV_OBS = .FALSE. + ENDIF + + print*, 'TIME_FOR_IMPRV_OBS_START: DATE = ', DATE, + & DURING_IMPRV_OBS + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_IMPRV_OBS_START + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_IMPRV_OBS() RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_IMPRV_OBS returns TRUE if it is during a day in which +! we have improve measurements. (dkh, 11/18/06) +! +! NOTES: +! - returns TRUE if the simulation is currently in within a day for +! which there are IMPROVE observations +!****************************************************************************** +! + !USE TIME_MOD, ONLY : GET_TIME_AHEAD + + + + ! Local variables + !INTEGER :: DATE(2) + + ! Function value + LOGICAL :: FLAG + + !================================================================= + ! ITS_TIME_FOR_IMPRV_OBS begins here! + !================================================================= + + !FLAG = .FALSE. + + ! DATE = GET_TIME_AHEAD( - 7 * 60 ) + ! Check if it's midnight + !IF ( DATE(2) == 00 ) THEN + !IF ( MOD( DATE(1) - 20060102 + 3, 3 ) == 0 ) THEN + ! FLAG = .TRUE. + !ENDIF + !ENDIF + FLAG = DURING_IMPRV_OBS + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_IMPRV_OBS + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_IMPRV_OBS_STOP( DIRECTION ) RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_IMPRV_OBS returns TRUE if it is the end of a day for +! which we have improve observations. (dkh, 11/18/06) +! +! NOTES: +! - determines if it is the end of a day for which there are IMPROVE +! observations. Like ITS_TIME_FOR_IMPRV_OBS_START, you will need to +! modify the exact date range here. +! - also assumes the entire dataset is in the same time zone,which I +! think is reasonable for 24 hour average measurements. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_NYMDb + + ! Function argument + INTEGER :: DIRECTION + + ! Function value + LOGICAL :: FLAG + + ! Local variables + INTEGER :: DATE(2) + + !================================================================= + ! ITS_TIME_FOR_IMPRV_OBS_STOP begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + DURING_IMPRV_OBS = .FALSE. + + ! Get time in midwest + DATE = GET_TIME_AHEAD( - 7 * 60 ) + + ! Check if it's midnight + IF ( DATE(2) == 00 ) THEN + + ! Check if its a day where we have observations + ! for 200201 + IF ( MOD( DATE(1) - 20060701+2, 3 ) == 0 ) THEN + ! for 200104 + !IF ( MOD( DATE(1) - 20010400 + 1, 3 ) == 0 ) THEN + ! for 200107 + !IF ( MOD( DATE(1) - 20010700 + 2, 3 ) == 0 .and. +! & DATE(1) .ne. 20010701 ) THEN + ! for 200507 + !IF ( MOD( DATE(1) - 20050700 + 2, 3 ) == 0 .and. + & ! DATE(1) .ne. 20050701 ) THEN + + FLAG = .TRUE. + + WRITE(6,*) ' ITS_TIME_FOR_IMPRV_OBS_STOP at ', + & DATE(1), DATE(2) + + ! Forward calculation + IF ( DIRECTION > 0 ) THEN + + ! leaving measument period + DURING_IMPRV_OBS = .FALSE. + + ! Adjoint calculation + ELSEIF ( DIRECTION < 0 ) THEN + + ! entereing new measurement period + DURING_IMPRV_OBS = .TRUE. + + ENDIF + + ENDIF + + ENDIF + + print*, 'TIME_FOR_IMPRV_OBS_STOP: DATE = ', DATE, + & DURING_IMPRV_OBS + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_IMPRV_OBS_STOP + +!------------------------------------------------------------------------------ + + SUBROUTINE RESET_AEROAVE( ) +! +!****************************************************************************** +! Subroutine RESET_AEROAVE +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! Arguments as Output: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! NOTES: +! - called to calculate the 24-hour average model concentrations, +! AVE_BC and AVE_OC. You will need to modify to reference BCPI +! and BCPO instead of BC / OC / NH4 +! +!****************************************************************************** +! + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J + + !================================================================= + ! RESET_AEROAVE begins here! + !================================================================= + + WRITE(6,*) ' RESET_AEROSAVE ' + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + AVE_BCPI(I,J) = 0d0 + !AVE_OCPI(I,J) = 0d0 + AVE_BCPO(I,J) = 0d0 + !AVE_OCPO(I,J) = 0d0 + + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE RESET_AEROAVE + +!------------------------------------------------------------------------------ + + SUBROUTINE UPDATE_AEROAVE( BCPI, BCPO) +! +!****************************************************************************** +! Subroutine UPDATE_AEROAVE +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! Arguments as Output: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE DAO_MOD, ONLY : AIRVOL + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! IIPAR, JJPAR + + ! Arguments + REAL*8, INTENT(IN) :: BCPI(IIPAR,JJPAR) + !REAL*8, INTENT(IN) :: OCPI(IIPAR,JJPAR) + REAL*8, INTENT(IN) :: BCPO(IIPAR,JJPAR) + !REAL*8, INTENT(IN) :: OCPO(IIPAR,JJPAR) + + + ! Local variables + REAL*8 :: FACTOR + INTEGER :: I, J + + !================================================================= + ! UPDATE_AEROAVE begins here! + !================================================================= + + WRITE(6,*) ' UPDATE_AEROSAVE ' + + ! Percent of a day for a given chemistry timestep multiplied by + ! uBC conversion factor (kg --> ug) + FACTOR = GET_TS_CHEM() / ( 1440d0 ) * 1d9 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + ! Update average, and convert from ug/box to ug/m3 + AVE_BCPI(I,J) = AVE_BCPI(I,J) + BCPI(I,J) + &* FACTOR / AIRVOL(I,J,1) + ! AVE_OCPI(I,J) = AVE_OCPI(I,J) + OCPI(I,J) + !&* FACTOR / AIRVOL(I,J,1) + AVE_BCPO(I,J) = AVE_BCPO(I,J) + BCPO(I,J) + &* FACTOR / AIRVOL(I,J,1) + ! AVE_OCPO(I,J) = AVE_OCPO(I,J) + OCPO(I,J) + !&* FACTOR / AIRVOL(I,J,1) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + + ! Return to calling program + END SUBROUTINE UPDATE_AEROAVE + +!------------------------------------------------------------------------------ + SUBROUTINE CALC_IMPRV_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_IMPRV_FORCE +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! Arguments as Output: +! ============================================================================ +! (1 ) ARG (TYPE) : Description [uBC] +! +! NOTES: +! - This is where the cost function actually gets calculated and the +! adjoint variables given values. The cost function is the sum of the +! error weighted squared residuals. +! - This routine should be called from within geos_chem_adj_mod +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_NYMD, GET_NYMDb + USE TIME_MOD, ONLY : GET_NHMS, GET_NHMSb + + +# include "CMN_SIZE" ! IIPAR, JJPAR + + ! Arguments + REAL*8 :: COST_FUNC + + ! Parameters + REAL*8, PARAMETER :: OBS_REP_UNC = 0.3d0 + + ! Local variables + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8, SAVE :: JSAVE(IIPAR,JJPAR,5) + INTEGER, SAVE :: NEXCD(IIPAR,JJPAR) + REAL*8 :: DIFF, OBS_ERRCOV + INTEGER :: I, J, DATE(2), YYYYMMDD + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: USA_MASK(IIPAR,JJPAR) + REAL*8, PARAMETER :: THRESH = 0d0 + !REAL*8 :: THRESH_2 + + !================================================================= + ! CALC_IMPRV_FORCE begins here! + !================================================================= + + ! IBC NEW_COST + NEW_COST(:,:) = 0d0 + + DATE = GET_TIME_AHEAD( -8 * 60 ) + + YYYYMMDD = DATE(1) + + ! Read BPCH file + CALL READ_IMPRV_BPCH( YYYYMMDD ) + + ! Read improve checkpt + CALL READ_AEROAVE_FILE( YYYYMMDD ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, DIFF, OBS_ERRCOV ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + + !------------------------------------------ + ! BC + !------------------------------------------ + ! Only include points above detection limit + !IF ( IMPRV_BC(I,J,1) > 1d-3 ) THEN + IF ( IMPRV_BC(I,J,1) > IMPRV_BC(I,J,2) ) THEN + + ! Difference between predicted and observed daily average + DIFF = AVE_BCPI(I,J) + AVE_BCPO(I,J) - IMPRV_BC(I,J,1) + + ! Calculate obs error (30% representation + reported err) +! OBS_ERRCOV = ( OBS_REP_UNC * IMPRV_BC(I,J,1) +! & + SQRT( IMPRV_BC(I,J,3) ) ) **2 + OBS_ERRCOV = OBS_REP_UNC * IMPRV_BC(I,J,1) + & + IMPRV_BC(I,J,3) +! ! Use representational error calculated with 4x5 vs 2x2.5 +! OBS_ERRCOV = IMPRV_BC(I,J,4) ** 2 + IMPRV_BC(I,J,3) ** 2 + + ! Calculate new cost + NEW_COST(I,J) = NEW_COST(I,J) + & + 0.5d0 * DIFF ** 2 / OBS_ERRCOV + + ! Calculate adjoint forcing + ADJ_AVE_BCPI(I,J) = DIFF / OBS_ERRCOV + ADJ_AVE_BCPO(I,J) = DIFF / OBS_ERRCOV + + ENDIF + + !------------------------------------------ + ! OC + !------------------------------------------ + ! Only include points above detection limit + !IF ( IMPRV_OC(I,J,1) > 1d-3 ) THEN + !IF ( IMPRV_OC(I,J,1) > IMPRV_OC(I,J,2) ) THEN + + ! Difference between predicted and observed daily average + ! DIFF = AVE_OCPI(I,J) + AVE_OCPO(I,J) - IMPRV_OC(I,J,1) + + ! Calculate obs error (30% representation + reported err) +! OBS_ERRCOV = ( OBS_REP_UNC * IMPRV_OC(I,J,1) +! & + SQRT( IMPRV_OC(I,J,3) ) ) **2 + ! OBS_ERRCOV = OBS_REP_UNC * IMPRV_OC(I,J,1) + !& + IMPRV_OC(I,J,3) + + ! Calculate new cost + ! NEW_COST(I,J) = NEW_COST(I,J) + !& + 0.5d0 * DIFF ** 2 / OBS_ERRCOV + + ! Calculate adjoint forcing + ! ADJ_AVE_OCPI(I,J) = DIFF / OBS_ERRCOV + ! ADJ_AVE_OCPO(I,J) = DIFF / OBS_ERRCOV + ! ENDIF + + !------------------------------------------ + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! dkh debug + print*, 'AVE_BCPI = ', AVE_BCPI(17:23,34) + print*, 'IMPRV_BC = ', IMPRV_BC(17:23,34,1) + print*, 'IMPRV_BC2 = ', IMPRV_BC(17:23,34,2) + print*, 'IMPRV_BC3 = ', IMPRV_BC(17:23,34,3) + print*, ' new cost = ', NEW_COST(17:23,34) + print*, 'ADJ_AVE_BCPI = ', ADJ_AVE_BCPI(17:23,34) + + ! Update cost function + WRITE(6,*) ' CALC_IMPRV_FORCE: NEW_COST = ', SUM( NEW_COST(:,:)) + + COST_FUNC = COST_FUNC + SUM(NEW_COST(:,:)) + + ! Error check + IF ( IT_IS_NAN( COST_FUNC ) ) THEN + CALL ERROR_STOP( 'COST_FUNC IS NaN', 'calc_imprv_force') + ENDIF + + IF ( GET_NYMD() == GET_NYMDb() ) THEN + CALL MAKE_JSAVE_FILE( GET_NYMD(), JSAVE, COST_FUNC, NEXCD ) + ENDIF + + + ! Return to calling program + END SUBROUTINE CALC_IMPRV_FORCE + +!------------------------------------------------------------------------------ + SUBROUTINE ADJ_UPDATE_AEROAVE( ADJ_BCPI, ADJ_BCPO ) +! +!****************************************************************************** +! Subroutine ADJ_UPDATE_AEROAVE applies the adjoint of the average +! concentrations corresponding to IMPROVE measurements to the adjoint tracer +! of BC and OC. (dkh, 11/19/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) ADJ_BC (REAL*8) : Adjoint of BC aerosol +! (2 ) ADJ_OC (REAL*8) : Adjoint of OC aerosol +! +! Arguments as Output: +! ============================================================================ +! (1 ) ADJ_BC (REAL*8) : Adjoint of BC aerosol +! (2 ) ADJ_OC (REAL*8) : Adjoint of OC aerosol +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE DAO_MOD, ONLY : AIRVOL + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! IIPAR, JJPAR + + ! Arguments + REAL*8, INTENT(INOUT) :: ADJ_BCPI(IIPAR,JJPAR) + !REAL*8, INTENT(INOUT) :: ADJ_OCPI(IIPAR,JJPAR) + REAL*8, INTENT(INOUT) :: ADJ_BCPO(IIPAR,JJPAR) + !REAL*8, INTENT(INOUT) :: ADJ_OCPO(IIPAR,JJPAR) + + ! Local variables + REAL*8 :: FACTOR + INTEGER :: I, J + + !================================================================= + ! ADJ_UPDATE_AEROAVE begins here! + !================================================================= + + WRITE(6,*) ' ADJ_UPDATE_AEROSAVE ' + ! dkh debug + print*, 'ADJ_BCPI before = ', ADJ_BCPI(17:23,34) + + ! Percent of a day for a given chemistry timestep multiplied by + ! uBC conversion factor (kg --> ug) + FACTOR = GET_TS_CHEM() / ( 1440d0 ) * 1d9 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + + ! fwd code: + !AVE_BC(I,J) = AVE_BC(I,J) + BC(I,J) * FACTOR / AIRVOL(I,J,1) + !AVE_OC(I,J) = AVE_OC(I,J) + OC(I,J) * FACTOR / AIRVOL(I,J,1) + ADJ_BCPI(I,J) = ADJ_BCPI(I,J) + & + ADJ_AVE_BCPI(I,J) * FACTOR / AIRVOL(I,J,1) + ADJ_BCPO(I,J) = ADJ_BCPO(I,J) + & + ADJ_AVE_BCPO(I,J) * FACTOR / AIRVOL(I,J,1) + ! ADJ_OCPI(I,J) = ADJ_OCPI(I,J) + !& + ADJ_AVE_OCPI(I,J) * FACTOR / AIRVOL(I,J,1) + ! ADJ_OCPO(I,J) = ADJ_OCPO(I,J) + !& + ADJ_AVE_OCPO(I,J) * FACTOR / AIRVOL(I,J,1) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE ADJ_UPDATE_AEROAVE +!------------------------------------------------------------------------------ + + SUBROUTINE ADJ_RESET_AEROAVE( ) +! +!****************************************************************************** +! Subroutine ADJ_RESET_AEROAVE resets the adjoint of the average aerosol +! concentrations that correspond to IMPROVE measurements. (dkh, 11/19/06) +! +! NOTES: +! +!****************************************************************************** +! + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J + + !================================================================= + ! ADJ_RESET_AEROAVE begins here! + !================================================================= + + WRITE(6,*) ' ADJ_RESET_AEROSAVE ' + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1, IIPAR + DO J = 1, JJPAR + + ADJ_AVE_BCPI(I,J) = 0d0 + ! ADJ_AVE_OCPI(I,J) = 0d0 + ADJ_AVE_BCPO(I,J) = 0d0 + ! ADJ_AVE_OCPO(I,J) = 0d0 + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE ADJ_RESET_AEROAVE + +!------------------------------------------------------------------------------ +! SUBROUTINE READ_USA_MASK( USA_MASK ) +! +!****************************************************************************** +! Subroutine READ_USA_MASK reads the USA mask from disk. The USA mask is +! the fraction of the grid box (I,J) which lies w/in the continental USA. +! (rch, bmy, 11/10/04, 10/3/05) +! - just for diagnostic; you don't need this +! +! NOTES: +! (1 ) Now can read data for GEOS and GCAP grids (bmy, 8/16/05) +! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! Reference to F90 modules + !USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + !USE DIRECTORY_MOD, ONLY : DATA_DIR + !USE TRANSFER_MOD, ONLY : TRANSFER_2D + +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_SETUP" ! DATA_DIR + + ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU +! REAL*8 :: USA_MASK(IGLOB,JGLOB) +! CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_USA_MASK begins here! + !================================================================= + + ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'EPA_NEI_200411/usa_mask.' // GET_NAME_EXT_2D() // +! & 'EPA_NEI_200411/usa_mask.geos' // +! & '.' // GET_RES_EXT() + + ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_USA_MASK: Reading ', a ) + + ! Get TAU0 for Jan 1985 +! XTAU = GET_TAU0( 1, 1, 1985 ) + + ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 + !CALL TRANSFER_2D( ARRAY(:,:,1), USA_MASK ) +! USA_MASK(:,:) = ARRAY(:,:,1) + + ! Return to calling program +! END SUBROUTINE READ_USA_MASK + +!------------------------------------------------------------------------------ + SUBROUTINE MAKE_JSAVE_FILE( YYYYMMDD, JSAVE, COST_FUNC, NEXCD ) +! +!****************************************************************************** +! Subroutine MAKE_JSAVE_FILE saves daily average concentrations of +! OC and BC aerosol. (dkh, 11/18/06) +! - another diagnostic. It saves the residuals to bpch file for plotting +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD (INTEGER) : Date of average [uBC] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : GET_TAU, EXPAND_DATE + +# include "CMN_SIZE" ! Size params +!# include "CMN_ADJ" ! ADJ_DIR + + ! Arguments + INTEGER :: YYYYMMDD + REAL*8 :: JSAVE(IIPAR,JJPAR,5) + REAL*8 :: COST_FUNC + INTEGER :: NEXCD(IIPAR,JJPAR) + + ! Local variables + INTEGER :: I, J, I0, J0, HHMMSS_dum, L + CHARACTER(LEN=120) :: FILENAME + REAL*4 :: DAT(IIPAR,JJPAR,5) + + ! For binary punch file, version 2.0 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UBC + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + !================================================================= + ! MAKE_JSAVE_FILE begins here! + !================================================================= + + FILENAME = TRIM( 'jsave.YYYYMMDD' ) + + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum) + + ! Append data directory prefix + FILENAME = '/qb6/yhmao/geos-chem/adjoint/new/gcadj_std/obsdata/'// + & TRIM( FILENAME ) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'Average Aerosol data file ' + CATEGORY = 'IJ-AVE-$' + LONRES = DISIZE + LATRES = DJSIZE + UBC = '%' + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_JSAVE_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_JSAVE, FILENAME, TITLE ) + + IF ( COST_FUNC > 0d0 ) THEN + ! Temporarily store data in DAT as REAL4 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, 5 + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( L < 5 ) THEN + + IF ( NEXCD(I,J) > 0 ) THEN + DAT(I,J,L) = JSAVE(I,J,L) / REAL(NEXCD(I,J)) + ELSE + DAT(I,J,L) = 0 + ENDIF + + ELSE + + DAT(I,J,L) = JSAVE(I,J,L) / COST_FUNC * 100d0 + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + + print*, 'COST FUNCTION IS ZERO' + print*, 'COST FUNCTION IS ZERO' + print*, 'COST FUNCTION IS ZERO' + DAT = 0d0 + + ENDIF + + CALL BPCH2( IU_JSAVE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UBC, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 5, I0+1, + & J0+1, 1, DAT ) + + ! Close file + CLOSE( IU_JSAVE ) + + ! Return to calling program + END SUBROUTINE MAKE_JSAVE_FILE + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_IMPROVE +! +!***************************************************************************** +! Subroutine INIT_IMPROVE deallocates all module arrays. (dkh, 11/16/06) +! +! NOTES: +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! IIPAR, JJPAR + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_IMPROVE begins here + !================================================================= + ALLOCATE( IMPRV_BC( IIPAR, JJPAR, 4 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IMPRV_BC' ) + IMPRV_BC = 0d0 + + !ALLOCATE( IMPRV_OC( IIPAR, JJPAR, 4 ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'IMPRV_OC' ) + !IMPRV_OC = 0d0 + + ALLOCATE( AVE_BCPI( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AVE_BCPI' ) + AVE_BCPI = 0d0 + + !ALLOCATE( AVE_OCPI( IIPAR, JJPAR ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'AVE_OCPI' ) + !AVE_OCPI = 0d0 + + ALLOCATE( AVE_BCPO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AVE_BCPO' ) + AVE_BCPO = 0d0 + + !ALLOCATE( AVE_OCPO( IIPAR, JJPAR ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'AVE_OCPO' ) + !AVE_OCPO = 0d0 + + ALLOCATE( ADJ_AVE_BCPI( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_AVE_BCPI' ) + ADJ_AVE_BCPI = 0d0 + + !ALLOCATE( ADJ_AVE_OCPI( IIPAR, JJPAR ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_AVE_OCPI' ) + !ADJ_AVE_OCPI = 0d0 + + ALLOCATE( ADJ_AVE_BCPO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_AVE_BCPO' ) + ADJ_AVE_BCPO = 0d0 + + !ALLOCATE( ADJ_AVE_OCPO( IIPAR, JJPAR ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_AVE_OCPO' ) + !ADJ_AVE_OCPO = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_IMPROVE +!------------------------------------------------------------------------------ + SUBROUTINE CLEANUP_IMPROVE +! +!***************************************************************************** +! Subroutine CLEANUP_IMPROVE deallocates all module arrays. (dkh, 11/16/06) +! +! NOTES: +! +!****************************************************************************** +! + IF ( ALLOCATED( IMPRV_BC ) ) DEALLOCATE( IMPRV_BC) + !IF ( ALLOCATED( IMPRV_OC ) ) DEALLOCATE( IMPRV_OC) + IF ( ALLOCATED( AVE_BCPI ) ) DEALLOCATE( AVE_BCPI) + !IF ( ALLOCATED( AVE_OCPI ) ) DEALLOCATE( AVE_OCPI) + IF ( ALLOCATED( AVE_BCPO ) ) DEALLOCATE( AVE_BCPO) + !IF ( ALLOCATED( AVE_OCPO ) ) DEALLOCATE( AVE_OCPO) + IF ( ALLOCATED( ADJ_AVE_BCPI ) ) DEALLOCATE( ADJ_AVE_BCPI) + !IF ( ALLOCATED( ADJ_AVE_OCPI ) ) DEALLOCATE( ADJ_AVE_OCPI) + IF ( ALLOCATED( ADJ_AVE_BCPO ) ) DEALLOCATE( ADJ_AVE_BCPO) + !IF ( ALLOCATED( ADJ_AVE_OCPO ) ) DEALLOCATE( ADJ_AVE_OCPO) + + ! Return to calling program + END SUBROUTINE CLEANUP_IMPROVE +!------------------------------------------------------------------------------ + END MODULE IMPROVE_BC_MOD + diff --git a/code/obs_operators/interp.f b/code/obs_operators/interp.f new file mode 100644 index 0000000..8a2f1e3 --- /dev/null +++ b/code/obs_operators/interp.f @@ -0,0 +1,29 @@ + SUBROUTINE INTERP_AP( ya, na, xa, yb, nb, xb ) + + ! Linear interpolation xa (ya, na) >> xb (yb, nb) + ! ya, yb == pressure levels + ! NOTE: yb:bottom->top ; ya: top->bottom + + integer :: na, nb + integer :: i, j + real*4, dimension(na) :: xa, ya + real*4, dimension(nb) :: xb, yb + real*4 :: slope, biais + + do j = 1, nb + do i = 1, na-1 + if (( yb(j) .ge. ya(i)) .and. ( yb(j) .lt. ya(i+1))) then + if ( (xa(i) -xa(i+1)) .ne. 0.) then + slope = ( ya(i) - ya (i+1) ) / (xa(i) -xa(i+1)) + biais = ya(i) - slope * xa(i) + xb(j) = ( yb(j) - biais) / slope + else + xb(j) = xa(i) + endif + endif + enddo + enddo + + + !Return to calling program + END SUBROUTINE INTERP_AP diff --git a/code/obs_operators/leo_ch4_mod.f b/code/obs_operators/leo_ch4_mod.f new file mode 100644 index 0000000..e68c70d --- /dev/null +++ b/code/obs_operators/leo_ch4_mod.f @@ -0,0 +1,1429 @@ +!$Id: leo_ch4_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE LEO_CH4_MOD +! +!****************************************************************************** +! Module LEO_CH4_MOD for CH4 observations. +! By kjw, added adj32_023 (dkh, 02/12/12) +! +!****************************************************************************** +! + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: LLLEO = 13 + INTEGER, PARAMETER :: MAXLEO = 639059 + + + ! Record to store information about the new instrument + REAL*8 :: AVGKERNEL( LLLEO, LLLEO ) + REAL*8 :: OBSERROR( LLLEO, LLLEO ) + REAL*8 :: OBSERROR_INV( LLLEO, LLLEO ) + REAL*8 :: TOTERROR_INV( LLLEO, LLLEO ) + REAL*8 :: PRESSURE( LLLEO ) + REAL*8 :: PRESSURE_EDGE( LLLEO ) + REAL*8 :: RANDNUM( MAXLEO ) + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_LEO_INFO +! +!****************************************************************************** +! Subroutine READ_LEO_INFO reads and stores information about the new +! instrument, specifically AK, pressure levels and error covariance matrices. +! (kjw, 07/24/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHAR) : LEO filename to read +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_NYMD + + ! Arguments + CHARACTER(LEN=255) :: FILENAME + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + + ! netCDF id's + INTEGER :: NCID, LG, LN + INTEGER :: nobs_id, yyyymmdd_id, hhmmss_id + INTEGER :: qflag_id, xch4_id, ch4ak_id + INTEGER :: ch4pres_id, ch4prior_id + INTEGER :: gcii_id, gcjj_id, gcfrac_id + + ! Loop indexes, and error handling. + INTEGER :: IOS, IU_IN + + + + !================================================================= + ! READ_LEO_CH4_OBS begins here! + !================================================================= + + ! Initialize module variabl + AVGKERNEL(:,:) = 0d0 + OBSERROR(:,:) = 0d0 + OBSERROR_INV(:,:) = 0d0 + TOTERROR_INV(:,:) = 0d0 + PRESSURE(:) = 0d0 + PRESSURE_EDGE(:) = 0d0 + RANDNUM(:) = 0d0 + + + ! Read and store one variable at a time + + ! ------ Averaging Kernel Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/leo/' ) // + & 'data/' // TRIM( 'leo_AK.txt' ) + WRITE(6,*) ' - READ_LEO_AK: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_avg_kernel:1' ) + + ! Read File and save info into module variable AVGKERNEL(:,:) + DO LN=1,LLLEO + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) AVGKERNEL(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_LEO_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_avg_kernel:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/leo/' ) // + & 'data/' // TRIM( 'leo_obs_error.txt' ) + WRITE(6,*) ' - READ_LEO_OBSERROR: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR(:,:) + DO LN=1,LLLEO + READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) OBSERROR(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_LEO_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Inverse of Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/leo/' ) // + & 'data/' // TRIM( 'leo_obs_error_inv.txt' ) + WRITE(6,*) ' - READ_LEO_OBSERROR_INV: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR_INV(:,:) + DO LN=1,LLLEO + READ( IU_IN, '(13F18.6)', IOSTAT=IOS ) OBSERROR_INV(LN,:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_LEO_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + +! ! ------ Total Error Covariance Matrix ------ +! ! Filename to read +! READ_FILENAME = TRIM( '/home/kjw/new_satellites/leo/' ) // +! & 'data/' // TRIM( 'leo_total_error_inv.txt' ) +! WRITE(6,*) ' - READ_LEO_TOTERROR: reading file: ', +! & TRIM(READ_FILENAME) +! +! +! ! Open file +! OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), +! & STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_tot_error:1' ) +! +! ! Read File and save info into module variable OBSERROR(:,:) +! DO LN=1,LLLEO +! READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) TOTERROR_INV(LN,:) +! +! ! IO status +! IF ( IOS < 0 ) THEN +! WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' +! WRITE( 6, '(a)' ) 'STOP in READ_LEO_CH4' +! ENDIF +! IF ( IOS > 0 ) THEN +! CALL IOERROR(IOS, IU_IN, 'read_tot_error:2') +! ENDIF +! ENDDO +! +! ! Close file +! CLOSE( IU_IN ) + + + ! ------ Pressure Levels ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/leo/' ) // + & 'data/' // TRIM( 'leo_pressure.txt' ) + WRITE(6,*) ' - READ_LEO_PRESSURE: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_pressure:1' ) + + ! Read File and save info into module variable PRESSURE(:) + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) PRESSURE(:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_LEO_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_pressure:2') + ENDIF + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Pressure Edges ------ + ! By finite difference on log(pressure) grid + PRESSURE_EDGE(1) = PRESSURE(1) + PRESSURE_EDGE(LLLEO) = 0. + DO LN=2,LLLEO-1 + PRESSURE_EDGE(LN) = exp( log(pressure(LN+1)) + + & ( log(PRESSURE(LN)) - log(PRESSURE(LN+1)) ) / 2. ) + ENDDO + + + ! Return to calling program + END SUBROUTINE READ_LEO_INFO +!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_LEO_CH4_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_LEO_CH4_FORCE calculates the adjoint forcing from the LEO +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER, SAVE :: NT ! # observations processed this day + INTEGER :: LG, LN, LLN, II, JJ, NB, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP, NTh + INTEGER, SAVE :: NTT + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: CH4_PRIOR(IIPAR,JJPAR,LLLEO) + REAL*4 :: DUMMY_PRIOR(IIPAR,JJPAR,LLLEO) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GC_CH4_onLEO(LLLEO) + REAL*8 :: GC_CH4_onLEO_OB(LLLEO) + REAL*8 :: GRIDMAP(LLPAR,LLLEO) + REAL*8 :: CH4_HAT(LLLEO) + REAL*8 :: CH4_HAT_OB(LLLEO) + REAL*8 :: CH4_HAT_ADJ(LLLEO) + REAL*8 :: CH4_HAT_werr(LLLEO) + REAL*8 :: CH4_HAT_werr_ADJ(LLLEO) + REAL*8 :: CH4_PERT(LLLEO) + REAL*8 :: CH4_PERT_OB(LLLEO) + REAL*8 :: CH4_PERT_ADJ(LLLEO) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: DIFF(LLLEO) + REAL*8 :: FORCE(LLLEO) + REAL*8 :: DIFF_ADJ(LLLEO) + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_CH4_onLEO_ADJ(LLLEO) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXLEO) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + ! Variables for FD testing + REAL*8 :: cost_func_pos, cost_func_neg + REAL*8 :: cost_func_0 + REAL*8 :: PERT(LLPAR) + REAL*8 :: ADJ_SAVE(LLPAR) + REAL*8 :: ADJ(LLPAR) + REAL*8 :: FD_CEN(LLPAR) + REAL*8 :: FD_POS(LLPAR) + REAL*8 :: FD_NEG(LLPAR) + REAL*8 :: DOFS + + + !================================================================= + ! CALC_LEO_CH4_FORCE begins here! + !================================================================= + + NEW_COST(:) = 0d0 + + + ! Open files for output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_nh3_pert.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat_dbl.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + !kjw for testing adjoint of obs operator + FILENAME = 'test_adjoint_obs.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 116, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! Read CH4 data + CALL READ_LEO_INFO + + ! Initialize counter for total number of observations processed + NTT = 0 + + + FIRST = .FALSE. ! only open files on first call to + ENDIF + + +! ! Open file for this hour's satellite diagnostics +! FILENAME = 'diag_sat.YYYYMMDD.hhmm.NN' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Read "TRUE" state for this time step [kg/box] + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 + FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // + & 'ch4/leo/' // GET_RES_EXT() // '/adjtmp/' // + & 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + !FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE , QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + ! Read a priori vertical profiles from file + FILENAME = '/home/kjw/new_satellites/leo/data/' // + & 'leo_prior.' // GET_RES_EXT() // '.bpch' + XTAU = GET_TAU0( 1, 1, 1985 ) + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IIPAR, JJPAR, + & LLLEO, DUMMY_PRIOR, QUIET=.TRUE. ) + CH4_PRIOR(:,:,:) = DUMMY_PRIOR(:,:,:) + + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LLNT, IIJJ, I, J, L, LL ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CH4, DIFF ) +!!$OMP+PRIVATE( GC_CH4_NATIVE, CH4_PERT, CH4_HAT, FORCE ) +!!$OMP+PRIVATE( ADJ_GC_CH4_NATIVE, ADJ_GC_CH4 ) +!!$OMP+PRIVATE( ADJ_CH4_PERT, ADJ_CH4_HAT ) +!!$OMP+PRIVATE( ADJ_DIFF ) + + ! If new day of observations initialize count + IF ( GET_NHMS() .EQ. 230000 ) THEN + NT = 0 + + ! ------ Random Numbers ------ + ! Open and read random number file. mean = 0, stddev = 1 + FILENAME = '/home/kjw/new_satellites/leo/data/' // + & 'randnums/random.YYYYMMDD.txt' + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 0 ) + OPEN( IU_IN, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + DO LG=1,MAXLEO + READ(IU_IN,'(F13.6)') RANDNUM(LG) + ENDDO + CLOSE(IU_IN) + + ENDIF + + ! Begin counter for number of observations processed this hour + NTh = 0 + + ! Information for spatial criteria for observations + latmin = 40.0 + + ! Determine minimum JJ index over which to look for observations + DO JJ=1, JJPAR-1 + IF ( ( GET_YEDGE(JJ) .LE. latmin ) .AND. + & ( GET_YEDGE(JJ+1) .GT. latmin ) ) THEN + JMIN = JJ + Jfrac_min = ( GET_YEDGE(JJ+1) - latmin ) / + & ( GET_YEDGE(JJ+1) - GET_YEDGE(JJ) ) + ENDIF + ENDDO + + print*, ' - CALC_LEO_CH4_FORCE ', GET_NYMD(), GET_NHMS() + + + ! Loop over each grid box north of the minimum latitude + ! 1. Determine number of observations in the current grid box + ! 2. Make obseravations + DO II = 1, IIPAR + + ! If not 1400 <= local time < 1500, cycle to next II value + IF ( ( GET_LOCALTIME( II ) .LT. 14.00 ) .OR. + & ( GET_LOCALTIME( II ) .GE. 15.00 ) ) CYCLE + + ! It is 1400-1500 local time, so let's make observations! + DO JJ = JMIN, JJPAR + + ! For safety, initilize these variables + nobs = 0 + cloud_frac = 0. + box_area = 0. + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onLEO(:) = 0d0 + GC_CH4_onLEO_OB(:) = 0d0 + + + ! Fraction of grid box above minimum latitude + Jfrac = 1. + IF ( JJ .EQ. JMIN ) Jfrac = Jfrac_min + + ! Determine number of observations in this grid box + ! # obs = box_area * (1-cloud_fraction) * Jfrac / 100 + ! divide by 100 because each observation takes up 100 km2 + box_area = GET_AREA_M2( JJ ) * 1d-6 ! [m2] --> [km2] + cloud_frac = CLDFRC( II, JJ ) + nobs = NINT( ( (1-cloud_frac) * box_area * Jfrac ) / 100. ) + + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1 ) + & * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < LEO pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLLEO + 1 - nlev ! minimum vertical index on LEO grid + + + ! Get interpolation matrix that maps GEOS-Chem to LEO grid + GRIDMAP(1:LLPAR, 1:LLLEO) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + ! Interpolate GEOS-Chem CH4 column and observation to LEO grid + ! Column in [v/v] + DO LN = lind, LLLEO + GC_CH4_onLEO(LN) = 0d0 + GC_CH4_onLEO_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onLEO(LN) = GC_CH4_onLEO(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onLEO_OB(LN) = GC_CH4_onLEO_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + + !-------------------------------------------------------------- + ! Apply LEO observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by LEO [molec/cm2] + ! x_a = LEO apriori column [molec/cm2] + ! x_m = GC modeled column on LEO grid [molec/cm2] + ! A = LEO averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLLEO + GC_CH4_onLEO(LN) =MAX(GC_CH4_onLEO(LN), 1d-10) + GC_CH4_onLEO_OB(LN)=MAX(GC_CH4_onLEO_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onLEO(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onLEO_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + DO LN = lind, LLLEO + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLLEO + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) +LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN)= CH4_HAT_OB(LN)+LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + + ! Loop over number of observations in this grid box + DO OB=1,NOBS + + ! Increment number of observations + NTh = NTh + 1 ! processed this hour + NT = NT + 1 ! processed today + NTT = NTT + 1 ! processed total + + !print*, ' - CALC_LEO_CH4_FORCE ', OB, ' of ',NOBS + + + ! For safety, initialize these up to LLLEO + CH4_HAT_werr(:) = 0d0 + DIFF(:) = 0d0 + FORCE(:) = 0d0 + NEW_COST(:) = 0d0 + + ! Add random error to this observation + DO LN = lind, LLLEO + + CH4_HAT_werr(LN) = CH4_HAT(LN) + + DO LLN = lind, LLLEO + CH4_HAT_werr(LN) = CH4_HAT_werr(LN) + + & CH4_HAT(LN) * RANDNUM(NT) * OBSERROR(LN,LLN) + ENDDO + ENDDO + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO LN = lind, LLLEO + DIFF(LN) = CH4_HAT_werr(LN) - CH4_HAT_OB(LN) + ENDDO + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + DO LN = lind, LLLEO + DO LLN = lind, LLLEO + FORCE(LN) = FORCE(LN) + + & 2d0 * OBSERROR_INV(LN,LLN) * DIFF(LLN) + ENDDO + NEW_COST(LN) = NEW_COST(LN) + 0.5*DIFF(LN)*FORCE(LN) + ENDDO + + + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug +! print*, 'DIFF , FORCE, Sobs ' +! WRITE(6,102) (DIFF, FORCE, Sobs) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = 2. * FORCE(:) + + ! Adjoint of GEOS-Chem - Observation difference + CH4_HAT_werr_ADJ(:) = DIFF_ADJ(:) + + ! Adjoint of adding random error to observation + DO LN=lind,LLLEO + CH4_HAT_ADJ(LN) = 0d0 + + DO LLN=lind,LLLEO + CH4_HAT_ADJ(LN) = CH4_HAT_ADJ(LN) + + & CH4_HAT_ADJ(LLN) * RANDNUM(NT) * OBSERROR(LLN,LN) + ENDDO + ENDDO + + ! Adjoint of LEO observation operator + DO LN=lind,LLLEO + CH4_PERT_ADJ(LN) = 0D0 + + DO LLN=lind,LLLEO + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLLEO + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onLEO(LN) > 1d-10 ) THEN + GC_CH4_onLEO_ADJ(LN) = 1d0 / GC_CH4_onLEO(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onLEO_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + + ! Adjoint of interpolation + DO LN=lind,LLLEO + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onLEO_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + STT_ADJ(II,JJ,LG,1) = STT_ADJ(II,JJ,LG,1) + + & GC_CH4_NATIVE_ADJ(LG) + ENDDO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(:)) + + ENDDO ! End looping over each observation in this grid box + ENDDO ! End looping over each grid box JJ + ENDDO ! End looping over each grid box II + +!!$OMP END PARALLEL DO + + +! ----------------------------------------------------------------------- +! Use this section to test the adjoint of the LEO_CH4 operator by +! slightly perturbing model [CH4] and recording resultant change +! in calculated contribution to the cost function. +! +! This routine will write the following information for each observation +! to rundir/diagadj/test_adjoint_obs.NN.m +! +! The adjoint of the observation operator has been tested and validated +! as of 7/20/10, kjw. +! + IF ( DO_FDTEST ) THEN + WRITE(116,210) ' LG' , ' TROP', ' GC_PRES', + & ' FD_POS', ' FD_NEG', ' FD_CEN', + & ' ADJ', ' COST_POS', ' COST_NEG', + & ' FD_POS/ADJ', ' FD_NEG/ADJ', ' FD_CEN/ADJ' + PERT(:) = 0D0 + + COST_FUNC_0 = 0d0 + CALL CALC_LEO_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ ) + ADJ_SAVE(:) = ADJ(:) + + DO LN=lind,LLLEO + DOFS = DOFS + AVGKERNEL(LN,LN) + ENDDO + + ! Write identifying information to top of satellite diagnostic file + WRITE(116,212) 'COST_FUNC_0:',( COST_FUNC_0 ) + WRITE(116,212) 'RANDOM ERROR',RANDNUM(NT) + WRITE(116,212) 'DOFS ',DOFS + !WRITE(116,*) (AVGKERNEL(1,LN),LN=1,13) + !WRITE(116,*) (OBSERROR(1,LN),LN=1,13) + + + ! Perform finite difference testing at each vertical level + DO LG = 1, 47 + + ! Positive perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = 0.001 + COST_FUNC_pos = 0D0 + CALL CALC_LEO_CH4_FORCE_FD( COST_FUNC_pos, PERT, ADJ ) + + ! Negative perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = -0.001 + COST_FUNC_neg = 0D0 + CALL CALC_LEO_CH4_FORCE_FD( COST_FUNC_neg, PERT, ADJ ) + + ! Calculate dJ/dCH4 from perturbations + FD_CEN(LG) = ( COST_FUNC_pos - COST_FUNC_neg ) / 0.2d0 + FD_POS(LG) = ( COST_FUNC_pos - COST_FUNC_0 ) / 0.1d0 + FD_NEG(LG) = ( COST_FUNC_0 - COST_FUNC_neg ) / 0.1d0 + + ! Write information to satellite diagnostic file + WRITE(116, 211) LG, GC_PCENTER(LG), + & FD_POS(LG), FD_NEG(LG), + & FD_CEN(LG), ADJ_SAVE(LG), + & COST_FUNC_pos, COST_FUNC_neg, + & FD_POS(LG)/ADJ_SAVE(LG), + & FD_NEG(LG)/ADJ_SAVE(LG), + & FD_CEN(LG)/ADJ_SAVE(LG) + ENDDO + + + WRITE(116,'(a)') '----------------------------------------------' + + 210 FORMAT(A4,2x,A6,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x, + & A12,2x,A12,2x,A12,2x,A12,2x) + 211 FORMAT(I4,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6, + & 2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6) + 212 FORMAT(A12,F22.6) + 213 FORMAT(A12,I4) + 214 FORMAT(I4,2x,F18.6,2x,F18.6) +! ----------------------------------------------------------------------- + DO_FDTEST = .FALSE. + ENDIF ! IF ( DO_FDTEST ) + + + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(:)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' LEO contribution this hour = ', COST_FUNC - OLD_COST + print*, ' # Obs analyzed this hour = ', NTh + print*, ' # Obs analyzed today = ', NT + print*, ' # Obs analyzed total = ', NTT + + + + ! Return to calling program + END SUBROUTINE CALC_LEO_CH4_FORCE + +!------------------------------------------------------------------------------ + + + + SUBROUTINE CALC_LEO_CH4_FORCE_FD( COST_FUNC_A, PERT, ADJ ) +! +!****************************************************************************** +! Subroutine CALC_LEO_CH4_FORCE calculates the adjoint forcing from the LEO +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC_A (REAL*8) : Cost funciton (INOUT) [unitless] +! (2 ) PERT (Real*8) : Array of perturbations to CH4 column (+/- 0.1, for ex.) +! (5 ) ADJ (REAL*8) : Array of adjoint forcings (OUT) +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC_A + REAL*8, INTENT(OUT) :: ADJ(LLPAR) + REAL*8, INTENT(IN) :: PERT(LLPAR) + + + ! Local variables + INTEGER :: NT + INTEGER :: LG, LN, LLN, II, JJ, NB, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: CH4_PRIOR(IIPAR,JJPAR,LLLEO) + REAL*4 :: DUMMY_PRIOR(IIPAR,JJPAR,LLLEO) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GC_CH4_onLEO(LLLEO) + REAL*8 :: GC_CH4_onLEO_OB(LLLEO) + REAL*8 :: GRIDMAP(LLPAR,LLLEO) + REAL*8 :: CH4_HAT(LLLEO) + REAL*8 :: CH4_HAT_OB(LLLEO) + REAL*8 :: CH4_HAT_ADJ(LLLEO) + REAL*8 :: CH4_HAT_werr(LLLEO) + REAL*8 :: CH4_HAT_werr_ADJ(LLLEO) + REAL*8 :: CH4_PERT(LLLEO) + REAL*8 :: CH4_PERT_OB(LLLEO) + REAL*8 :: CH4_PERT_ADJ(LLLEO) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: DIFF(LLLEO) + REAL*8 :: FORCE(LLLEO) + REAL*8 :: DIFF_ADJ(LLLEO) + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_CH4_onLEO_ADJ(LLLEO) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXLEO) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + + + !================================================================= + ! CALC_LEO_CH4_FORCE_FD begins here! + !================================================================= + + print*, ' - CALC_LEO_CH4_FORCE_FD ' + + NEW_COST(:) = 0d0 + + + ! Read "TRUE" state for this time step + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 +! FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // +! & 'ch4/leo/' // GET_RES_EXT() // '/adjtmp/' // +! & 'gctm.obs.YYYYMMDD.hhmm' + FILENAME_OBS = 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE, QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + ! Read a priori vertical profiles from file + FILENAME = '/home/kjw/new_satellites/leo/data/' // + & 'leo_prior.' // GET_RES_EXT() // '.bpch' + XTAU = GET_TAU0( 1, 1, 1985 ) + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IGLOB, JGLOB, + & LLLEO, DUMMY_PRIOR, QUIET=.TRUE. ) + CH4_PRIOR(:,:,:) = DUMMY_PRIOR(:,:,:) + + + + ! Select arbitrary II, JJ and NT value + II=40 + JJ=JJPAR-10 + NT=100 + + ! Initialize variables + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onLEO(:) = 0d0 + GC_CH4_onLEO_OB(:) = 0d0 + CH4_HAT_werr(:) = 0d0 + DIFF(:) = 0d0 + FORCE(:) = 0d0 + + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1) + & * (1+PERT(LG)) * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < LEO pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLLEO + 1 - nlev ! minimum vertical index on LEO grid + + ! Get interpolation matrix that maps GEOS-Chem to LEO grid + GRIDMAP(1:LLPAR, 1:LLLEO) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + + ! Interpolate GEOS-Chem CH4 column and observation to LEO grid + ! Column in [v/v] + DO LN = lind, LLLEO + GC_CH4_onLEO(LN) = 0d0 + GC_CH4_onLEO_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onLEO(LN) = GC_CH4_onLEO(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onLEO_OB(LN) = GC_CH4_onLEO_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + + + !-------------------------------------------------------------- + ! Apply LEO observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by LEO [molec/cm2] + ! x_a = LEO apriori column [molec/cm2] + ! x_m = GC modeled column on LEO grid [molec/cm2] + ! A = LEO averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLLEO + GC_CH4_onLEO(LN) =MAX(GC_CH4_onLEO(LN), 1d-10) + GC_CH4_onLEO_OB(LN)=MAX(GC_CH4_onLEO_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onLEO(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onLEO_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + CH4_HAT(:)=CH4_PERT(:) + DO LN = lind, LLLEO + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLLEO + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + + ! For safety, initialize these up to LLLEO + + ! Add random error to this observation + CH4_HAT_werr(:) = CH4_HAT(:) + DO LN = lind, LLLEO + + CH4_HAT_werr(LN) = CH4_HAT(LN) + DO LLN = lind, LLLEO + CH4_HAT_werr(LN) = CH4_HAT_werr(LN) + + & CH4_HAT(LN) * RANDNUM(NT) * OBSERROR(LN,LLN) + ENDDO + ENDDO + + + !------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO LN = lind, LLLEO + DIFF(LN) = CH4_HAT_werr(LN) - CH4_HAT_OB(LN) + ENDDO + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + DO LN = lind, LLLEO + DO LLN = lind, LLLEO + FORCE(LN) = FORCE(LN) + + & 2d0 * OBSERROR_INV(LN,LLN) * DIFF(LLN) + ENDDO + NEW_COST(LN) = NEW_COST(LN) + 0.5*DIFF(LN)*FORCE(LN) + ENDDO + + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + ! Adjoint of GEOS-Chem - Observation difference + CH4_HAT_werr_ADJ(:) = DIFF_ADJ(:) + + ! Adjoint of adding random error to observation + DO LN=lind,LLLEO + CH4_HAT_ADJ(LN) = 0d0 + + DO LLN=lind,LLLEO + CH4_HAT_ADJ(LN) = CH4_HAT_ADJ(LN) + + & CH4_HAT_werr_ADJ(LLN) * RANDNUM(NT) * OBSERROR(LLN,LN) + ENDDO + ENDDO + CH4_HAT_ADJ(:) = CH4_HAT_werr_ADJ(:) + + ! Adjoint of LEO observation operator + CH4_PERT_ADJ(:) = CH4_HAT_ADJ(:) + DO LN=lind,LLLEO + CH4_PERT_ADJ(LN) = 0D0 + + DO LLN=lind,LLLEO + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLLEO + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onLEO(LN) > 1d-10 ) THEN + GC_CH4_onLEO_ADJ(LN) = 1d0 / GC_CH4_onLEO(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onLEO_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + + ! Adjoint of interpolation + DO LN=lind,LLLEO + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onLEO_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) * CHK_STT(II,JJ,LG,1) + ENDDO + + ! Update cost function + COST_FUNC_A = COST_FUNC_A + SUM(NEW_COST(:)) + + + ! Return to calling program + END SUBROUTINE CALC_LEO_CH4_FORCE_FD + + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( GC_PEDGE, LEO_PEDGE, nlev ) + & RESULT ( M ) +! +!****************************************************************************** +! Function GET_INTMAP creates the matrix that places GEOS-Chem column methane +! [molec/cm2] onto the 13-level pressure grid used by theoretical instrument, M. +! GC[1x47] * M[47x13] = LEO[1x13] (kjw, 7/21/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) GC_PEDGE (REAL*8) : LLPAR bottom pressure edges of GEOS-Chem column +! (2 ) SCIA_PEDGE (REAL*8) : LLLEO pressure edges of LEO column +! (3 ) nlev (REAL*8) : Number of LEO pressure levels to use +! +! Arguments as Output: +! ============================================================================ +! (1 ) M (REAL*8) : Interpolation matrix that maps GEOS-Chem to LEO grid +! +! NOTES: +! (1 ) Based on GET_INTMAP in scia_ch4_mod.f +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: LEO_PEDGE(LLLEO) + INTEGER :: nlev + + ! Return value + REAL*8 :: M(LLPAR,LLLEO) + + ! Local variables + INTEGER :: LGC, LTM, LS, LG, LN, LIND + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: GUP, GLO, NUP, NLO + REAL*8 :: column_total(LLLEO) + + !================================================================= + ! GET_INTMAP begins here! + !================================================================= + + ! Initialize output + M(:,:) = 0D0 + + ! Minimum LEO vertical level to use + lind = LLLEO + 1 - nlev + + ! Loop over each pressure level of GEOS-Chem and LEO grids + DO LG=1,LLPAR-1 + + ! Get upper and lower pressure edges of GEOS-Chem box + GUP = GC_PEDGE( LG+1 ) + GLO = GC_PEDGE( LG ) + + DO LN=lind,LLLEO-1 + + ! Get top and bottom pressures of LEO box + NUP = LEO_PEDGE( LN+1 ) + NLO = LEO_PEDGE( LN ) + + ! If both GEOS-Chem edges are within the LEO box, map value = 1 + IF ( ( GUP .gt. NUP ) .AND. ( GLO .lt. NLO ) ) THEN + M(LG,LN) = 1 + ENDIF + + ! If both GEOS-Chem stradles a LEO pressure level, interpolate + IF ( ( GUP .lt. NUP ) .AND. ( GLO .gt. NUP ) ) THEN + DIFF = GLO - GUP + M(LG,LN+1) = ( NUP - GUP ) / DIFF + M(LG,LN ) = ( GLO - NUP ) / DIFF + ENDIF + + ENDDO + ENDDO + + ! Add value for uppermost GEOS-Chem grid box + M(LLPAR,LLLEO) = 1 + + + ! Correct for case in which GEOS-Chem pressure is higher than LEO + IF ( GC_PEDGE(1) .GT. LEO_PEDGE(1) ) THEN + + + ! If any part of GEOS-Chem box are under LEO_PEDGE(1), let + ! this GEOS-Chem grid box contribute to the observation because + ! LEO and GEOS-Chem should have same surface pressure. map value = 1 + DO LG=1,LLPAR-1 + + ! If GEOS-Chem box entirely below LEO surface pressure + IF ( ( GC_PEDGE(LG) .GT. LEO_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .GT. LEO_PEDGE(1) ) ) THEN + M(LG,1) = 1 + ENDIF + + ! If GEOS-Chem box straddles LEO surface pressure + IF ( ( GC_PEDGE(LG) .GT. LEO_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .LT. LEO_PEDGE(1) ) ) THEN + DIFF = GC_PEDGE(LG) - GC_PEDGE( LG+1 ) + M(LG,1) = ( LEO_PEDGE(1) - GC_PEDGE(LG+1) ) / DIFF + ENDIF + + ENDDO + ENDIF + + + ! Correct for case in which GEOS-Chem surface pressure is within 2nd LEO + ! pressure level. + IF ( GC_PEDGE(1) .LT. LEO_PEDGE(2) ) THEN + M(1,1) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 3rd LEO + ! pressure level. + IF ( GC_PEDGE(1) .LT. LEO_PEDGE(3) ) THEN + M(1,2) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 4th LEO + ! pressure level. + IF ( GC_PEDGE(1) .LT. LEO_PEDGE(4) ) THEN + M(1,3) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 5th LEO + ! pressure level. + IF ( GC_PEDGE(1) .LT. LEO_PEDGE(5) ) THEN + M(1,4) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 6th LEO + ! pressure level. + IF ( GC_PEDGE(1) .LT. LEO_PEDGE(6) ) THEN + M(1,5) = 0. + ENDIF + + ! Normalize each column of M to 1 so that we are not creating any molecules + ! when mapping from GEOS-Chem to LEO grids. + + ! DO NOT do this since we are mapping molc/cm2, not + ! Initialize to be safe and calculate column total + column_total(:) = 0d0 + column_total(:) = SUM( M, DIM=1 ) + + ! Normalize columns to column_total + DO LN=1,LLLEO + IF ( column_total(LN) .EQ. 0. ) CYCLE + M(:,LN) = M(:,LN) / column_total(LN) + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + + +!----------------------------------------------------------------------------- + + + + END MODULE LEO_CH4_MOD diff --git a/code/obs_operators/mem_ch4_mod.f b/code/obs_operators/mem_ch4_mod.f new file mode 100644 index 0000000..3b158ef --- /dev/null +++ b/code/obs_operators/mem_ch4_mod.f @@ -0,0 +1,1923 @@ +!$Id: mem_ch4_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE MEM_CH4_MOD +! +!****************************************************************************** +! Module MEM_CH4_MOD for CH4 observations. +! By kjw, added adj32_023 (dkh, 02/12/12) +! +!****************************************************************************** +! + IMPLICIT NONE + + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: LLMEM = 13 + INTEGER, PARAMETER :: MAXMEM = 639059 + + + ! Record to store information about the new instrument + REAL*8 :: AVGKERNEL( LLMEM, LLMEM ) + REAL*8 :: OBSERROR( LLMEM, LLMEM ) + REAL*8 :: OBSERROR_INV( LLMEM, LLMEM ) + REAL*8 :: TOTERROR_INV( LLMEM, LLMEM ) + REAL*8 :: PRESSURE( LLMEM ) + REAL*8 :: PRESSURE_EDGE( LLMEM ) + REAL*8 :: RANDNUM( MAXMEM ) + REAL*8, ALLOCATABLE :: CH4_PRIOR(:,:,:) + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_MEM_INFO +! +!****************************************************************************** +! Subroutine READ_MEM_INFO reads and stores information about the new +! instrument, specifically AK, pressure levels and error covariance matrices. +! (kjw, 07/24/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHAR) : MEM filename to read +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_NYMD + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size params + + ! Arguments + CHARACTER(LEN=255) :: FILENAME + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + + ! netCDF id's + INTEGER :: NCID, LG, LN + INTEGER :: nobs_id, yyyymmdd_id, hhmmss_id + INTEGER :: qflag_id, xch4_id, ch4ak_id + INTEGER :: ch4pres_id, ch4prior_id + INTEGER :: gcii_id, gcjj_id, gcfrac_id + LOGICAL, SAVE :: LDEBUG = .TRUE. + REAL*8 :: XTAU + REAL*4 :: DUMMY_PRIOR(IGLOB,JGLOB,LLMEM) + + ! Loop indexes, and error handling. + INTEGER :: IOS, IU_IN, AS + + + + !================================================================= + ! READ_MEM_CH4_OBS begins here! + !================================================================= + + ! Initialize module variabl + AVGKERNEL(:,:) = 0d0 + OBSERROR(:,:) = 0d0 + OBSERROR_INV(:,:) = 0d0 + TOTERROR_INV(:,:) = 0d0 + PRESSURE(:) = 0d0 + PRESSURE_EDGE(:) = 0d0 + RANDNUM(:) = 0d0 + + + ! Read and store one variable at a time + + ! ------ Averaging Kernel Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/mem/' ) // + & 'data/' // TRIM( 'mem_AK.txt' ) + WRITE(6,*) ' - READ_MEM_AK: reading file: ', + & TRIM(READ_FILENAME) + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_avg_kernel:1' ) + + ! Read File and save info into module variable AVGKERNEL(:,:) + DO LN=1,LLMEM + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) AVGKERNEL(LN,:) + + IF ( LDEBUG ) THEN + WRITE(6,*) 'Avg Kernel, row ',LN + WRITE(6,'(13F12.6)') AVGKERNEL(LN,:) + ENDIF + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_MEM_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_avg_kernel:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/mem/' ) // + & 'data/' // TRIM( 'mem_obs_error.txt' ) + WRITE(6,*) ' - READ_MEM_OBSERROR: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR(:,:) + DO LN=1,LLMEM + READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) OBSERROR(LN,:) + + IF ( LDEBUG ) THEN + WRITE(6,*) 'Obs Error covar, row ',LN + WRITE(6,'(13F18.12)') OBSERROR(LN,:) + ENDIF + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_MEM_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Inverse of Observation Error Covariance Matrix ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/mem/' ) // + & 'data/' // TRIM( 'mem_obs_error_inv.txt' ) + WRITE(6,*) ' - READ_MEM_OBSERROR_INV: reading file: ', + & TRIM(READ_FILENAME) + + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_obs_error:1' ) + + ! Read File and save info into module variable OBSERROR_INV(:,:) + DO LN=1,LLMEM + READ( IU_IN, '(13F18.6)', IOSTAT=IOS ) OBSERROR_INV(LN,:) + + IF ( LDEBUG ) THEN + WRITE(6,*) 'Inv Obs Error covar, row ',LN + WRITE(6,'(13F18.6)') OBSERROR_INV(LN,:) + ENDIF + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_MEM_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_obs_error:2') + ENDIF + ENDDO + + ! Close file + CLOSE( IU_IN ) + + +! ! ------ Total Error Covariance Matrix ------ +! ! Filename to read +! READ_FILENAME = TRIM( '/home/kjw/new_satellites/mem/' ) // +! & 'data/' // TRIM( 'mem_total_error_inv.txt' ) +! WRITE(6,*) ' - READ_MEM_TOTERROR: reading file: ', +! & TRIM(READ_FILENAME) +! +! +! ! Open file +! OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), +! & STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_tot_error:1' ) +! +! ! Read File and save info into module variable OBSERROR(:,:) +! DO LN=1,LLMEM +! READ( IU_IN, '(13F18.12)', IOSTAT=IOS ) TOTERROR_INV(LN,:) +! +! ! IO status +! IF ( IOS < 0 ) THEN +! WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' +! WRITE( 6, '(a)' ) 'STOP in READ_MEM_CH4' +! ENDIF +! IF ( IOS > 0 ) THEN +! CALL IOERROR(IOS, IU_IN, 'read_tot_error:2') +! ENDIF +! ENDDO +! +! ! Close file +! CLOSE( IU_IN ) + + + ! ------ Pressure Levels ------ + ! Filename to read + READ_FILENAME = TRIM( '/home/kjw/new_satellites/mem/' ) // + & 'data/' // TRIM( 'mem_pressure.txt' ) + WRITE(6,*) ' - READ_MEM_PRESSURE: reading file: ', + & TRIM(READ_FILENAME) + + ! Open file + OPEN( IU_IN, FILE=TRIM( READ_FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_IN, 'read_pressure:1' ) + + ! Read File and save info into module variable PRESSURE(:) + READ( IU_IN, '(13F12.6)', IOSTAT=IOS ) PRESSURE(:) + + ! IO status + IF ( IOS < 0 ) THEN + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_MEM_CH4' + ENDIF + IF ( IOS > 0 ) THEN + CALL IOERROR(IOS, IU_IN, 'read_pressure:2') + ENDIF + + ! Close file + CLOSE( IU_IN ) + + + ! ------ Pressure Edges ------ + ! By finite difference on log(pressure) grid + PRESSURE_EDGE(1) = PRESSURE(1) + PRESSURE_EDGE(LLMEM) = 0. + DO LN=2,LLMEM-1 + PRESSURE_EDGE(LN) = exp( log(pressure(LN+1)) + + & ( log(PRESSURE(LN)) - log(PRESSURE(LN+1)) ) / 2. ) + ENDDO + + + ! ------ A priori vertical profiles ------ + ALLOCATE( CH4_PRIOR(IGLOB,JGLOB,LLMEM), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH4_PRIOR' ) + CH4_PRIOR(:,:,:) = 0d0 + + FILENAME = '/home/kjw/new_satellites/mem/data/' // + & 'mem_prior.' // GET_RES_EXT() // '.bpch' + XTAU = GET_TAU0( 1, 1, 1985 ) + + WRITE(6,*) ' - READ_CH4_PRIOR: reading file: ', + & TRIM(FILENAME) + + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IGLOB, JGLOB, + & LLMEM, DUMMY_PRIOR, QUIET=.TRUE. ) + CH4_PRIOR(:,:,:) = DUMMY_PRIOR(:,:,:) + + + ! LDEBUG = FALSE. Only print values first time reading + LDEBUG = .FALSE. + + + ! Return to calling program + END SUBROUTINE READ_MEM_INFO +!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_MEM_CH4_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_MEM_CH4_FORCE calculates the adjoint forcing from the MEM +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2, GET_MODELNAME + USE BPCH2_MOD, ONLY : BPCH2, OPEN_BPCH2_FOR_WRITE + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, CHECK_STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_DAY, GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP, IT_IS_NAN + USE LOGICAL_ADJ_MOD, ONLY : LDCOSAT + USE FILE_MOD, ONLY : IU_RST + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER, SAVE :: NT ! # observations processed this day + INTEGER :: LG, LN, LLN, II, JJ, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP, NTh, NB + INTEGER, SAVE :: NTT + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*4 :: DUMMY_RAND(IGLOB,JGLOB,1) + REAL*4, SAVE :: RANDOM_GRID(IGLOB,JGLOB) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: GC_CH4_onMEM(LLMEM) + REAL*8 :: GC_CH4_onMEM_OB(LLMEM) + REAL*8 :: GRIDMAP(LLPAR,LLMEM) + REAL*8 :: OBSERROR_INV_SUPER(LLMEM,LLMEM) + REAL*8 :: SIGN(LLMEM,LLMEM) + REAL*8 :: OBSERROR_SQRT(LLMEM,LLMEM) + REAL*8 :: CH4_HAT(LLMEM) + REAL*8 :: CH4_HAT_EXP(LLMEM) + REAL*8 :: CH4_HAT_OB(LLMEM) + REAL*8 :: CH4_HAT_OB_EXP(LLMEM) + REAL*8 :: CH4_HAT_ADJ(LLMEM) + REAL*8 :: CH4_HAT_EXP_ADJ(LLMEM) + REAL*8 :: CH4_PERT(LLMEM) + REAL*8 :: CH4_PERT_OB(LLMEM) + REAL*8 :: CH4_PERT_ADJ(LLMEM) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: PUP, PLO + REAL*8 :: XCH4_HAT, XCH4_HAT_OB + REAL*8 :: XCH4_HAT_ADJ, XCH4_HAT_OB_ADJ + REAL*8 :: SUPER_ERR, S_obs_inv + REAL*8 :: SUPER_ERR_EXPECTED + REAL*8 :: XWEIGHT(LLMEM) + REAL*8 :: DIFF, FORCE + REAL*8 :: sumxweight + REAL*8 :: DIFF_ADJ + REAL*8 :: GC_CH4_onMEM_ADJ(LLMEM) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(IIPAR*JJPAR*LLPAR) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + ! Arrays for saving with satellite diagnostic turned on + REAL*8 :: hourly_nobs(IIPAR,JJPAR) + REAL*8 :: hourly_xch4_sat(IIPAR,JJPAR) + REAL*8 :: hourly_xch4_model(IIPAR,JJPAR) + REAL*4 :: DATA_FIELD(IIPAR,JJPAR) + REAL*4 :: LONRES, LATRES + INTEGER :: TRACER, I0, J0 + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Parameters + REAL*8, PARAMETER :: XCH4_ERR = 8d0 + + ! Variables for FD testing + REAL*8 :: cost_func_pos, cost_func_neg + REAL*8 :: cost_func_0 + REAL*8 :: PERT(LLPAR) + REAL*8 :: ADJ_SAVE(LLPAR) + REAL*8 :: ADJ(LLPAR) + REAL*8 :: FD_CEN(LLPAR) + REAL*8 :: FD_POS(LLPAR) + REAL*8 :: FD_NEG(LLPAR) + REAL*8 :: DOFS + + + !================================================================= + ! CALC_MEM_CH4_FORCE begins here! + !================================================================= + + NEW_COST(:) = 0d0 + + + ! Open files for output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_nh3_pert.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat_dbl.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + !kjw for testing adjoint of obs operator + FILENAME = 'test_adjoint_obs.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 116, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! Read CH4 data + CALL READ_MEM_INFO + + ! Initialize counter for total number of observations processed + NTT = 0 + + + FIRST = .FALSE. ! only open files on first call to + ENDIF + + +! ! Open file for this hour's satellite diagnostics +! FILENAME = 'diag_sat.YYYYMMDD.hhmm.NN' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! Check that we haven't added any NaN to the STT_ADJ array + CALL CHECK_STT_ADJ( 'Start of CALC_MEM_CH4_FORCE' ) + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Read "TRUE" state for this time step [kg/box] + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 +! FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // +! & 'ch4/mem/' // GET_RES_EXT() // '/adjtmp/' // +! & 'gctm.obs.YYYYMMDD.hhmm' + FILENAME_OBS = 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE , QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LLNT, IIJJ, I, J, L, LL ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CH4, DIFF ) +!!$OMP+PRIVATE( GC_CH4_NATIVE, CH4_PERT, CH4_HAT, FORCE ) +!!$OMP+PRIVATE( ADJ_GC_CH4_NATIVE, ADJ_GC_CH4 ) +!!$OMP+PRIVATE( ADJ_CH4_PERT, ADJ_CH4_HAT ) +!!$OMP+PRIVATE( ADJ_DIFF ) + + ! If new day of observations initialize count + IF ( GET_NHMS() .EQ. 230000 ) THEN + NT = 0 ! initialize counter of total observations processed today + NB = 0 ! initialize counter of total boxes processed today + + ! ------ Random Numbers ------ + ! Read error values for this day + XTAU = GET_TAU0( GET_MONTH(), GET_DAY(), GET_YEAR() ) + FILENAME = '/home/kjw/new_satellites/mem/data/randnums/' + & // 'random.YYYYMMDD.' // GET_RES_EXT() // '.bpch' + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 0 ) + CALL READ_BPCH2( TRIM(FILENAME), 'IJ-AVG-$', 1, + & XTAU, IGLOB, JGLOB, + & 1, DUMMY_RAND , QUIET=.TRUE.) + RANDOM_GRID(:,:) = DUMMY_RAND(:,:,1) + + ENDIF + + ! Get grid offsets for use with nested grid + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + + ! Begin counter for + NTh = 0 ! number of observations processed this hour + NB = 0 ! number of grid boxes processed this hour + + ! Clear satellite diagnostic information to be safe + IF ( LDCOSAT .EQ. .TRUE. ) THEN + hourly_nobs(:,:) = 0d0 + hourly_xch4_sat(:,:) = 0d0 + hourly_xch4_model(:,:) = 0d0 + ENDIF + + ! Information for spatial criteria for observations + latmin = 40.0 + + ! Determine minimum JJ index over which to look for observations + DO JJ=1, JJPAR-1 + IF ( ( GET_YEDGE(JJ) .LE. latmin ) .AND. + & ( GET_YEDGE(JJ+1) .GT. latmin ) ) THEN + JMIN = JJ + Jfrac_min = ( GET_YEDGE(JJ+1) - latmin ) / + & ( GET_YEDGE(JJ+1) - GET_YEDGE(JJ) ) + ENDIF + ENDDO + + print*, ' - CALC_MEM_CH4_FORCE ', GET_NYMD(), GET_NHMS() + + + ! Loop over each grid box north of the minimum latitude + ! 1. Determine number of observations in the current grid box + ! 2. Make "super-observation" in current grid box + ! "super-observation" is one observation with error and + ! associated error covariance matrix scaled to sqrt(N) + ! where N is the number of regular observations in box + DO II = 1, IIPAR + + ! If not 1400 <= local time < 1500, cycle to next II value + IF ( ( GET_LOCALTIME( II ) .LT. 14.00 ) .OR. + & ( GET_LOCALTIME( II ) .GE. 15.00 ) ) CYCLE + + ! It is 1400-1500 local time, so let's make observations! + DO JJ = JMIN, JJPAR + + ! For safety, initilize these variables + nobs = 0 + cloud_frac = 0. + box_area = 0. + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onMEM(:) = 0d0 + GC_CH4_onMEM_OB(:) = 0d0 + + + ! Fraction of grid box above minimum latitude + Jfrac = 1. + IF ( JJ .EQ. JMIN ) Jfrac = Jfrac_min + + ! Determine number of observations in this grid box + ! # obs = box_area * (1-cloud_fraction) * Jfrac / 100 + ! divide by 100 because each observation takes up 100 km2 + box_area = GET_AREA_M2( JJ ) * 1d-6 ! [m2] --> [km2] + cloud_frac = CLDFRC( II, JJ ) + nobs = NINT( ( (1-cloud_frac) * box_area * Jfrac ) / 100. ) + nobs = 10 + IF ( nobs .LT. 1 ) CYCLE + + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1 ) + & * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < MEM pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + !IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLMEM + 1 - nlev ! minimum vertical index on MEM grid + + ! Get interpolation matrix that maps GEOS-Chem to MEM grid + GRIDMAP(1:LLPAR, 1:LLMEM) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + ! Interpolate GEOS-Chem CH4 column and observation to MEM grid + ! Column in [v/v] + DO LN = lind, LLMEM + GC_CH4_onMEM(LN) = 0d0 + GC_CH4_onMEM_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onMEM(LN) = GC_CH4_onMEM(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onMEM_OB(LN) = GC_CH4_onMEM_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + !-------------------------------------------------------------- + ! Apply MEM observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by MEM [ln(vmr)] + ! x_a = MEM apriori column [ln(vmr)] + ! x_m = GC modeled column on MEM grid [ln(vmr)] + ! A = MEM averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLMEM + GC_CH4_onMEM(LN) =MAX(GC_CH4_onMEM(LN), 1d-10) + GC_CH4_onMEM_OB(LN)=MAX(GC_CH4_onMEM_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onMEM(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onMEM_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + DO LN = lind, LLMEM + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLMEM + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) +LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN)= CH4_HAT_OB(LN)+LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + + ! Convert vertical profiles from [ln(vmr)] --> [vmr] before + ! calculating XCH4 + CH4_HAT_EXP = EXP(CH4_HAT) + CH4_HAT_OB_EXP = EXP(CH4_HAT_OB) + + + ! ---- Calculate XCH4 [v/v] from CH4_HAT [v/v] and CH4_HAT_OB [v/v] + XCH4_HAT = 0d0 + XCH4_HAT_OB = 0d0 + + ! Calculate weight of each vertical level on MEM grid for averaging + ! levels to get XCH4. Weight by # molecules / verical level, which is + ! proportional to pressure difference between upper and lower bounds + ! of each box. + DO LN=lind, LLMEM + + ! If ground level, average with same weight as if it were 1st atm level + IF ( LN .EQ. lind ) THEN + PUP = PRESSURE_EDGE(LN+1) + PLO = PRESSURE_EDGE(LN ) + ELSE + PUP = PRESSURE_EDGE(LN ) + PLO = PRESSURE_EDGE(LN-1) + ENDIF + + Xweight(LN) = PLO - PUP + ENDDO + + !Normalize so that SUM(Xweight) = 1 + sumxweight = SUM( Xweight(:) ) + DO LN=lind,LLMEM + Xweight(LN) = Xweight(LN) / sumxweight + ENDDO + + ! Calculate weighted average of CH4_HAT and CH4_HAT_OB + DO LN=lind, LLMEM + XCH4_HAT = XCH4_HAT + Xweight(LN) * CH4_HAT_EXP(LN) + XCH4_HAT_OB = XCH4_HAT_OB + + & Xweight(LN) * CH4_HAT_OB_EXP(LN) + ENDDO + +! if (( II .eq. 11 ) .AND. (JJ .eq. 39)) then +! print*,'lind = ',lind +! DO LN=lind,LLMEM +! print*, LN, xweight(LN), +! & GC_CH4_onMEM(LN), ch4_hat_exp(LN) +! ENDDO +! print*,'---------------------------------------' +! WRITE(6,'(14F16.8)') 0d0, PRESSURE_EDGE(:) +! DO LG=1,LLPAR +! WRITE(6,'(14F16.8)') GC_PEDGE(LG), GRIDMAP(LG,:) +! ENDDO +! print*,'---------------------------------------' +! endif + + ! Create super observation by adding random error + ! to XCH4_HAT_OB + ! SUPER_ERR is 1d-9 * XCH4_ERR[ppb] * N(0,1) / sqrt(nobs) [v/v] + ! where 8ppb is expected error on a single XCH4 measurement + ! N(0,1) is a random number of mean 0, standard deviation 1 + ! nobs is the number of observations merged to form super obs + ! Expected error of super-observation XCH4 + SUPER_ERR_EXPECTED = 1d-9 * XCH4_ERR / SQRT( REAL(nobs) ) + + ! Multiply expected error of super-observation by + ! prescribed random number with mean 0, standard deviation 1 + SUPER_ERR = SUPER_ERR_EXPECTED * RANDOM_GRID( II+I0, JJ+J0 ) + + ! Add random error to super-observation + XCH4_HAT_OB = XCH4_HAT_OB + SUPER_ERR ! add error [v/v] + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is observation error + ! covariance matrix. + ! Sobs = 1x1 array [ ln(vmr)^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Initialize values to be safe + DIFF = 0d0 + FORCE = 0d0 + + ! Calculate difference between modeled and observed profile + DIFF = XCH4_HAT - XCH4_HAT_OB + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + ! Inverse observation error covariance matrix of super-obs + S_obs_inv = 1d0 / (SUPER_ERR_EXPECTED**2) + FORCE = 2 * DIFF * S_obs_inv + NEW_COST(NB) = 0.5d0 * DIFF * FORCE + +! print*,'DIFF, XCH4_HAT, XCH4_HAT_OB', +! & DIFF, XCH4_HAT, XCH4_HAT_OB +! print*,'DIFF, FORCE, S_obs_inv', +! & DIFF, FORCE, S_obs_inv +! print*,'NB, NEW_COST(NB) = ',NB, NEW_COST(NB) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! Initialize to be safe + DIFF_ADJ = 0d0 + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + ! Adjoint of GEOS-Chem - Observation difference + XCH4_HAT_ADJ = DIFF_ADJ + + + ! Adjoint of CH4_HAT_EXP --> XCH4_HAT + DO LN=lind, LLMEM + CH4_HAT_EXP_ADJ(LN) = XCH4_HAT_ADJ * Xweight(LN) + ENDDO + + ! Adjoint of CH4_HAT --> CH4_HAT_EXP + DO LN=lind, LLMEM + CH4_HAT_ADJ(LN) = CH4_HAT_EXP_ADJ(LN) * CH4_HAT_EXP(LN) + ENDDO + + ! Adjoint of MEM observation operator + CH4_PERT_ADJ(:) = 0D0 + DO LN=lind,LLMEM + DO LLN=lind,LLMEM + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLMEM + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onMEM(LN) > 1d-10 ) THEN + GC_CH4_onMEM_ADJ(LN) = 1d0 / GC_CH4_onMEM(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onMEM_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + + ! Adjoint of interpolation + DO LN=lind,LLMEM + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onMEM_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion [kg/box] --> [v/v] + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + STT_ADJ(II,JJ,LG,1) = STT_ADJ(II,JJ,LG,1) + + & GC_CH4_NATIVE_ADJ(LG) + ENDDO + + + ! Update cost function + COST_FUNC = COST_FUNC + NEW_COST(NB) + print*,'--------------------------------' + print*,'I,J = ',II,JJ + CALL CHECK_STT_ADJ( 'Inside CALC_MEM_CH4_FORCE' ) + print*,' COST_FUNC, NEW_COST(NB) = ',COST_FUNC, NEW_COST(NB) + + + ! Record information for satellite diagnostics + IF ( LDCOSAT .EQ. .TRUE. ) THEN + hourly_nobs(II,JJ) = hourly_nobs(II,JJ) + nobs + hourly_xch4_sat(II,JJ) =hourly_xch4_sat(II,JJ) + XCH4_HAT_OB + hourly_xch4_model(II,JJ)=hourly_xch4_model(II,JJ) + XCH4_HAT + ENDIF + + + ! Increment counters + NTh = NTh + nobs ! # obs processed this hour4 + NT = NT + nobs ! # obs processed today + NTT = NTT + nobs ! # obs processed total + NB = NB + 1 ! # boxes processed this hour + + ENDDO ! End looping over each grid box JJ + ENDDO ! End looping over each grid box II + + ! Save satellite diagnostic information to file + IF ( LDCOSAT .EQ. .TRUE. ) THEN + FILENAME = TRIM( DIAGADJ_DIR ) // 'sat.diagnostic.mem.' // + & 'YYYYMMDD.hhmm.NN' + TITLE = 'Satellite Observation Diagnostic File' + UNIT = '[v/v]' + CATEGORY = 'IJ-AVG-$' + MODELNAME = GET_MODELNAME() + LONRES = DISIZE + LATRES = DJSIZE + + CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Open BPCH file for writing + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + ! Write values to bpch + TRACER = 1 + DATA_FIELD(:,:) = hourly_nobs + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, TRACER, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, DATA_FIELD ) + TRACER = 2 + DATA_FIELD(:,:) = hourly_xch4_sat + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, TRACER, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, DATA_FIELD ) + TRACER = 3 + DATA_FIELD(:,:) = hourly_xch4_model + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, TRACER, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, DATA_FIELD ) + + ! Close file + CLOSE( IU_RST ) + + ENDIF + + + ! Check that we haven't added any NaN to the STT_ADJ array + CALL CHECK_STT_ADJ( 'End of CALC_MEM_CH4_FORCE' ) + + +!!$OMP END PARALLEL DO + + +! ----------------------------------------------------------------------- +! Use this section to test the adjoint of the MEM_CH4 operator by +! slightly perturbing model [CH4] and recording resultant change +! in calculated contribution to the cost function. +! +! This routine will write the following information for each observation +! to rundir/diagadj/test_adjoint_obs.NN.m +! +! The adjoint of the observation operator has been tested and validated +! as of 7/20/10, kjw. +! + IF ( DO_FDTEST ) THEN + WRITE(116,210) ' LG' , ' TROP', ' GC_PRES', + & ' FD_POS', ' FD_NEG', ' FD_CEN', + & ' ADJ', ' COST_POS', ' COST_NEG', + & ' FD_POS/ADJ', ' FD_NEG/ADJ', ' FD_CEN/ADJ' + PERT(:) = 0D0 + + COST_FUNC_0 = 0d0 + CALL CALC_MEM_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ ) + ADJ_SAVE(:) = ADJ(:) + + !DO LN=lind,LLMEM + ! DOFS = DOFS + AVGKERNEL(LN,LN) + !ENDDO + + ! Write identifying information to top of satellite diagnostic file + WRITE(116,212) 'COST_FUNC_0: ',( COST_FUNC_0 ) + + + ! Perform finite difference testing at each vertical level + DO LG = 1, 47 + + ! Positive perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = 0.001 + COST_FUNC_pos = 0D0 + CALL CALC_MEM_CH4_FORCE_FD( COST_FUNC_pos, PERT, ADJ ) + + ! Negative perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = -0.001 + COST_FUNC_neg = 0D0 + CALL CALC_MEM_CH4_FORCE_FD( COST_FUNC_neg, PERT, ADJ ) + + ! Calculate dJ/dCH4 from perturbations + FD_CEN(LG) =(COST_FUNC_pos - COST_FUNC_neg) / (2*abs(PERT(LG))) + FD_POS(LG) = ( COST_FUNC_pos - COST_FUNC_0 ) / abs(PERT(LG)) + FD_NEG(LG) = ( COST_FUNC_0 - COST_FUNC_neg ) / abs(PERT(LG)) + + ! Write information to satellite diagnostic file + WRITE(116, 211) LG, GC_PCENTER(LG), + & FD_POS(LG), FD_NEG(LG), + & FD_CEN(LG), ADJ_SAVE(LG), + & COST_FUNC_pos, COST_FUNC_neg, + & FD_POS(LG)/ADJ_SAVE(LG), + & FD_NEG(LG)/ADJ_SAVE(LG), + & FD_CEN(LG)/ADJ_SAVE(LG) + ENDDO + + + WRITE(116,'(a)') '----------------------------------------------' + + 210 FORMAT(A4,2x,A6,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x, + & A12,2x,A12,2x,A12,2x,A12,2x) + 211 FORMAT(I4,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6, + & 2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6) + 212 FORMAT(A12,F22.6) + 213 FORMAT(A12,I4) + 214 FORMAT(I4,2x,F18.6,2x,F18.6) +! ----------------------------------------------------------------------- + DO_FDTEST = .FALSE. + ENDIF ! IF ( DO_FDTEST ) + + + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(:)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' MEM contribution this hour = ', COST_FUNC - OLD_COST + print*, ' # Obs analyzed this hour = ', NTh + print*, ' # Obs analyzed today = ', NT + print*, ' # Obs analyzed total = ', NTT + + + + ! Return to calling program + END SUBROUTINE CALC_MEM_CH4_FORCE + +!------------------------------------------------------------------------------ + + + + SUBROUTINE CALC_MEM_CH4_FORCE_FD( COST_FUNC_A, PERT, ADJ ) +! +!****************************************************************************** +! Subroutine CALC_MEM_CH4_FORCE calculates the adjoint forcing from the MEM +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC_A (REAL*8) : Cost funciton (INOUT) [unitless] +! (2 ) PERT (Real*8) : Array of perturbations to CH4 column (+/- 0.1, for ex.) +! (5 ) ADJ (REAL*8) : Array of adjoint forcings (OUT) +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, CLDFRC + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR, ADJTMP_DIR + USE GRID_MOD, ONLY : GET_YEDGE, GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_LOCALTIME, EXPAND_DATE + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC_A + REAL*8, INTENT(OUT) :: ADJ(LLPAR) + REAL*8, INTENT(IN) :: PERT(LLPAR) + + + ! Local variables + INTEGER, SAVE :: NT ! # observations processed this day + INTEGER :: LG, LN, LLN, II, JJ, JMIN, OB + INTEGER :: nlev, lind, IU_IN + INTEGER :: nboxes, nobs + INTEGER :: NTSTART, NTSTOP, NTh, NB + INTEGER, SAVE :: NTT + REAL*8 :: GC_CH4_TRUE_ARRAY(IIPAR,JJPAR,LLPAR) + REAL*4 :: DUMMY_PRIOR(IIPAR,JJPAR,LLMEM) + REAL*4 :: DUMMY_TRUE(IIPAR,JJPAR,LLPAR) + REAL*4 :: RANDOM_GRID(IGLOB,JGLOB) + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_AD(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4_NATIVE_OB(LLPAR) + REAL*8 :: GC_CH4_onMEM(LLMEM) + REAL*8 :: GC_CH4_onMEM_OB(LLMEM) + REAL*8 :: GRIDMAP(LLPAR,LLMEM) + REAL*8 :: OBSERROR_INV_SUPER(LLMEM,LLMEM) + REAL*8 :: SIGN(LLMEM,LLMEM) + REAL*8 :: OBSERROR_SQRT(LLMEM,LLMEM) + REAL*8 :: CH4_HAT(LLMEM) + REAL*8 :: CH4_HAT_EXP(LLMEM) + REAL*8 :: CH4_HAT_OB(LLMEM) + REAL*8 :: CH4_HAT_OB_EXP(LLMEM) + REAL*8 :: CH4_HAT_ADJ(LLMEM) + REAL*8 :: CH4_HAT_EXP_ADJ(LLMEM) + REAL*8 :: CH4_PERT(LLMEM) + REAL*8 :: CH4_PERT_OB(LLMEM) + REAL*8 :: CH4_PERT_ADJ(LLMEM) + REAL*8 :: frac, frac_total + REAL*8 :: latmin, Jfrac_min, Jfrac + REAL*8 :: box_area, cloud_frac + REAL*8 :: mass_air, mole_air, mole_ch4 + REAL*8 :: LHS, RHS, GC_XCH4, XTAU + REAL*8 :: PUP, PLO + REAL*8 :: XCH4_HAT, XCH4_HAT_OB + REAL*8 :: XCH4_HAT_ADJ, XCH4_HAT_OB_ADJ + REAL*8 :: SUPER_ERR, S_obs_inv + REAL*8 :: SUPER_ERR_EXPECTED + REAL*8 :: XWEIGHT(LLMEM) + REAL*8 :: DIFF, FORCE + REAL*8 :: sumxweight + REAL*8 :: DIFF_ADJ + REAL*8 :: GC_CH4_onMEM_ADJ(LLMEM) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(IIPAR*JJPAR*LLPAR) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + LOGICAL, SAVE :: LDEBUG = .FALSE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_OBS + + ! Parameters + REAL*8, PARAMETER :: XCH4_ERR = 8d0 + + + !================================================================= + ! CALC_MEM_CH4_FORCE_FD begins here! + !================================================================= + + print*, ' - CALC_MEM_CH4_FORCE_FD ' + + NEW_COST(:) = 0d0 + + + ! ---- Read "TRUE" state for this time step ---- + GC_CH4_TRUE_ARRAY(:,:,:) = 0d0 +! FILENAME_OBS = '/home/kjw/GEOS-Chem/gcadj_std/runs/v8-02-01/' // +! & 'ch4/mem/' // GET_RES_EXT() // '/adjtmp/' // +! & 'gctm.obs.YYYYMMDD.hhmm' + FILENAME_OBS = 'gctm.obs.YYYYMMDD.hhmm' + CALL EXPAND_DATE( FILENAME_OBS, GET_NYMD(), GET_NHMS() ) + FILENAME_OBS = TRIM( ADJTMP_DIR ) // TRIM( FILENAME_OBS ) + XTAU = GET_TAU() + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, DUMMY_TRUE, QUIET=.TRUE.) + GC_CH4_TRUE_ARRAY(:,:,:) = DUMMY_TRUE(:,:,:) + + ! Convert from [kg] --> [v/v] + DO II=1,IIPAR + DO JJ=1,JJPAR + DO LG=1,LLPAR + GC_CH4_TRUE_ARRAY(II,JJ,LG) = GC_CH4_TRUE_ARRAY(II,JJ,LG) + & * ( 1d3 / 16d0 ) / ( AD(II,JJ,LG) * 1d3 / 28.96 ) + ENDDO + ENDDO + ENDDO + + + ! Select arbitrary II, JJ and NT value + II=40 + JJ=JJPAR-10 + NB=100 + RANDOM_GRID(:,:) = 0d0 + RANDOM_GRID(II,JJ) = 1.00 + + ! Initialize variables + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_AD(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GC_CH4_onMEM(:) = 0d0 + GC_CH4_onMEM_OB(:) = 0d0 + DIFF = 0d0 + FORCE = 0d0 + + + ! Fraction of grid box above minimum latitude + Jfrac = 1. + IF ( JJ .EQ. JMIN ) Jfrac = Jfrac_min + + ! Determine number of observations in this grid box + ! # obs = box_area * (1-cloud_fraction) * Jfrac / 100 + ! divide by 100 because each observation takes up 100 km2 + box_area = GET_AREA_M2( JJ ) * 1d-6 ! [m2] --> [km2] + cloud_frac = CLDFRC( II, JJ ) + nobs = NINT( ( (1-cloud_frac) * box_area * Jfrac ) / 100. ) + + ! Get GEOS-Chem pressure and CH4 column corresponding to this grid box. + ! CH4 in [kg/box] and pressure in [hPa] + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + GC_PCENTER(LG) = GET_PCENTER(II,JJ,LG) + + ! Pressure edges [hPa] + GC_PEDGE(LG) = GET_PEDGE(II,JJ,LG) + + ! mass per box [kg] + GC_AD(LG) = AD(II,JJ,LG) + + ! CH4 values [kg/box] --> [v/v] + GC_CH4_NATIVE(LG) = ( CHK_STT(II,JJ,LG,1) + & * (1+PERT(LG)) * XNUMOL(1) ) / ( GC_AD(LG) * XNUMOLAIR ) + + ENDDO + + + ! Number of vertical levels to use in these observations + ! Chop off lowermost levels if + ! GEOS-Chem surface pressure < MEM pressure levels + nlev = count( PRESSURE_EDGE .LT. GC_PEDGE(1) ) + IF ( nlev .LT. 13 ) nlev = nlev + 1 + lind = LLMEM + 1 - nlev ! minimum vertical index on MEM grid + + ! Get interpolation matrix that maps GEOS-Chem to MEM grid + GRIDMAP(1:LLPAR, 1:LLMEM) = + & GET_INTMAP( GC_PEDGE, PRESSURE_EDGE, nlev ) + + if ( LDEBUG ) THEN + print*,'kjw MAP_GC2MEM, debug' + print*,'---------------------------------------' + WRITE(6,'(14F16.8)') 0d0, PRESSURE_EDGE(:) + DO LG=1,LLPAR + WRITE(6,'(14F16.8)') GC_PEDGE(LG), GRIDMAP(LG,:) + ENDDO + print*,'---------------------------------------' + endif + + ! Get GEOS-Chem column from "truth" run to make pseudo-observations + GC_CH4_NATIVE_OB(:) = 0d0 + GC_CH4_NATIVE_OB(:) = GC_CH4_TRUE_ARRAY(II,JJ,:) + + + IF ( LDEBUG ) THEN + DO LG = 1, LLPAR + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'L, GC_PCENTER, GC_CH4_NATIVE,' // + & 'GC_CH4_NATIVE_OB', + & LG, GC_PCENTER(LG), GC_CH4_NATIVE(LG), + & GC_CH4_NATIVE_OB(LG) + ENDDO + ENDIF + 299 FORMAT(A50,I3,3F30.12) + + + ! Interpolate GEOS-Chem CH4 column and observation to MEM grid + ! Column in [v/v] + DO LN = lind, LLMEM + GC_CH4_onMEM(LN) = 0d0 + GC_CH4_onMEM_OB(LN) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onMEM(LN) = GC_CH4_onMEM(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE(LG) + GC_CH4_onMEM_OB(LN) = GC_CH4_onMEM_OB(LN) + & + GRIDMAP(LG,LN) * GC_CH4_NATIVE_OB(LG) + ENDDO + ENDDO + + IF ( LDEBUG ) THEN + DO LN = lind, LLMEM + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'LN, PRESSURE, GC_CH4,GC_CH4_OB', + & LN, PRESSURE(LN), GC_CH4_onMEM(LN), + & GC_CH4_onMEM_OB(LN) + ENDDO + ENDIF + + !-------------------------------------------------------------- + ! Apply MEM observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by MEM [molec/cm2] + ! x_a = MEM apriori column [molec/cm2] + ! x_m = GC modeled column on MEM grid [molec/cm2] + ! A = MEM averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a for model and "observation" + ! [v/v] --> ln( v/v ) happens here + DO LN = lind, LLMEM + GC_CH4_onMEM(LN) =MAX(GC_CH4_onMEM(LN), 1d-10) + GC_CH4_onMEM_OB(LN)=MAX(GC_CH4_onMEM_OB(LN),1d-10) + CH4_PERT(LN) =LOG( GC_CH4_onMEM(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_PERT_OB(LN) =LOG( GC_CH4_onMEM_OB(LN) ) - + & LOG( CH4_PRIOR(II,JJ,LN) ) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) for model and "observation" + CH4_HAT(:)=CH4_PERT(:) + DO LN = lind, LLMEM + CH4_HAT(LN) = 0d0 + CH4_HAT_OB(LN) = 0d0 + + DO LLN = lind, LLMEM + CH4_HAT(LN) = CH4_HAT(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT(LLN) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + & + AVGKERNEL(LN,LLN) * CH4_PERT_OB(LLN) + ENDDO + CH4_HAT(LN) = CH4_HAT(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + CH4_HAT_OB(LN) = CH4_HAT_OB(LN) + LOG( CH4_PRIOR(II,JJ,LN) ) + + ENDDO + + IF ( LDEBUG ) THEN + DO LN = lind, LLMEM + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'LN, PRESSURE, CH4_HAT,CH4_HAT_OB', + & LN, PRESSURE(LN), exp(CH4_HAT(LN)), + & exp(CH4_HAT_OB(LN)) + WRITE(6,299) 'LN, CH4_HAT,GC_CH4_onMEM,CH4_PRIOR', + & LN, exp(CH4_HAT(LN)), + & GC_CH4_onMEM(LN), CH4_PRIOR(II,JJ,LN) + ENDDO + ENDIF + + + ! Convert vertical profiles from [ln(vmr)] --> [vmr] before + ! calculating XCH4 + CH4_HAT_EXP = EXP(CH4_HAT) + CH4_HAT_OB_EXP = EXP(CH4_HAT_OB) + + IF ( LDEBUG ) THEN + DO LN = lind, LLMEM + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'CH4_HAT_EXP, CH4_HAT_EXP, CH4_HAT_OB_EXP', + & LN, CH4_HAT_EXP(LN), CH4_HAT_EXP(LN), CH4_HAT_OB_EXP(LN) + ENDDO + ENDIF + + ! ---- Calculate XCH4 [v/v] from CH4_HAT [v/v] and CH4_HAT_OB [v/v] + XCH4_HAT = 0d0 + XCH4_HAT_OB = 0d0 + + ! Calculate weight of each vertical level on MEM grid for averaging + ! levels to get XCH4. Weight by # molecules / verical level, which is + ! proportional to pressure difference between upper and lower bounds + ! of each box. + DO LN=lind, LLMEM + + ! If ground level, average with same weight as if it were 1st atm level + IF ( LN .EQ. lind ) THEN + PUP = PRESSURE_EDGE(LN+1) + PLO = PRESSURE_EDGE(LN ) + ELSE + PUP = PRESSURE_EDGE(LN ) + PLO = PRESSURE_EDGE(LN-1) + ENDIF + + Xweight(LN) = PLO - PUP + ENDDO + + !Normalize so that SUM(Xweight) = 1 + sumxweight = SUM( Xweight(:) ) + DO LN=lind,LLMEM + Xweight(LN) = Xweight(LN) / sumxweight + ENDDO + + + IF ( LDEBUG ) THEN + DO LN=lind,LLMEM + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'Xweight', + & LN, Xweight(LN), Xweight(LN), Xweight(LN) + ENDDO + ENDIF + + + ! Calculate weighted average of CH4_HAT and CH4_HAT_OB + DO LN=lind, LLMEM + XCH4_HAT = XCH4_HAT + Xweight(LN) * CH4_HAT_EXP(LN) + XCH4_HAT_OB = XCH4_HAT_OB + Xweight(LN) * CH4_HAT_OB_EXP(LN) + ENDDO + + IF ( LDEBUG ) THEN + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'XCH4_HAT, XCH4_HAT, XCH4_HAT_OB', + & 1, XCH4_HAT, XCH4_HAT, XCH4_HAT_OB + ENDIF + + + ! Create super observation by adding random error + ! to XCH4_HAT_OB + ! SUPER_ERR is 1d-9 * 8ppb * N(0,1) / sqrt(nobs) [v/v] + ! where 8ppb is expected error on a single XCH4 measurement + ! N(0,1) is a random number of mean 0, standard deviation 1 + ! nobs is the number of observations merged to form super obs + ! Add error of each observation that makes up super-obs. Do this to + ! preserve error structure across different resolutions. + SUPER_ERR_EXPECTED = 1d-9 * XCH4_ERR / SQRT( REAL(nobs) ) + + ! Multiply expected error of super-observation by + ! prescribed random number with mean 0, standard deviation 1 + SUPER_ERR = SUPER_ERR_EXPECTED * RANDOM_GRID( II, JJ ) + + ! Add random error to super-observation + XCH4_HAT_OB = XCH4_HAT_OB + SUPER_ERR ! add error [v/v] + + + IF ( LDEBUG ) THEN + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'XCH4_ERR, SUPER_ERR, nobs', + & 1, XCH4_ERR, SUPER_ERR, REAL(nobs) + ENDIF + IF ( LDEBUG ) THEN + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'XCH4_HAT_OB, XCH4_HAT_OB, XCH4_HAT_OB', + & 1, XCH4_HAT_OB, XCH4_HAT_OB, XCH4_HAT_OB + ENDIF + + +! ! Add error to create super-observation +! ! nobs - number observations in this grid box +! ! boxno - box number processed during this day +! ! Magnitude of error in super observation +! SUPER_ERR = 1d0 / SQRT( REAL(nobs) ) * RANDNUM( NB ) +! +! ! Print information about this grid box to file +! IF ( SUM(PERT(:)) .EQ. 0. ) THEN +! WRITE(116,212) 'II = ', REAL(40) +! WRITE(116,212) 'JJ = ', REAL(JJPAR-10) +! WRITE(116,212) 'nobs = ', REAL(nobs) +! WRITE(116,212) 'RANDOM(NB) = ', RANDNUM( NB ) +! WRITE(116,212) 'SUPER_ERR = ', SUPER_ERR +! ENDIF +! 212 FORMAT(A12,F22.6) +! +! ! Calculate sqrt( obserror ) <-- magnitude of error in 1 observation +! DO LN = lind, LLMEM +! DO LLN = lind, LLMEM +! SIGN(LN,LLN) = OBSERROR(LN,LLN) / ABS( OBSERROR(LN,LLN) ) +! OBSERROR_SQRT(LN,LLN) = SIGN( LN, LLN ) * +! & SQRT( ABS( OBSERROR(LN,LLN) ) ) +! ENDDO +! ENDDO +! print*,'maxval/minval( SIGN ) ', maxval(sign),minval(sign) +! +! ! Create super observation +! CH4_HAT_OB_werr(:) = 0d0 +! DO LN = lind, LLMEM +! CH4_HAT_OB_werr(LN) = CH4_HAT_OB(LN) +! DO LLN = lind, LLMEM +! CH4_HAT_OB_werr(LN) = CH4_HAT_OB_werr(LN) + +! & CH4_HAT_OB(LN) * SUPER_ERR * OBSERROR_SQRT(LN,LLN) +! ENDDO +! ENDDO +! +! IF ( LDEBUG ) THEN +! DO LN = lind, LLMEM +! DO LLN = lind, LLMEM +! dummyerr(LN) = CH4_HAT_OB(LN) * OBSERROR_SQRT(LN,LN) +! ENDDO +! ENDDO +! WRITE(6,'(A16,13F18.9)') ,'dummyerr = ', dummyerr(:) +! WRITE(6,'(A16,13F18.9)') ,'CH4_HAT_OB = ',exp(CH4_HAT_OB(:)) +! WRITE(6,'(A16,13F18.9)') ,'PERT = ', +! & exp(CH4_HAT_OB(:)+dummyerr(:)) +! ENDIF +! +! +! +! ! Scale observation error covariance matrix to nobs +! DO LN = lind, LLMEM +! DO LLN = lind, LLMEM +! OBSERROR_INV_SUPER(LN,LLN) = +! & OBSERROR_INV(LN,LLN) * REAL(nobs) +! ENDDO +! ENDDO +! +! IF ( LDEBUG ) THEN +! DO LN = lind, LLMEM +! WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' +! WRITE(6,299) 'LN, PRESSURE, CH4_HAT_OB, CH4_HAT_OB_werr', +! & LN, PRESSURE(LN), +! & exp(CH4_HAT_OB(LN)), exp(CH4_HAT_OB_werr(LN)) +! ENDDO +! ENDIF +! + !------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ ln(vmr)^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! Initialize values to be safe + DIFF = 0d0 + FORCE = 0d0 + + ! Calculate difference between modeled and observed profile + DIFF = XCH4_HAT - XCH4_HAT_OB + + ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} + ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF + S_obs_inv = 1d0 / (SUPER_ERR**2) + FORCE = 2 * DIFF * S_obs_inv + NEW_COST(NB) = 0.5d0 * DIFF * FORCE + + + IF ( LDEBUG ) THEN + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'DIFF, FORCE, NEW_COST(NB)', + & 1, 1d9*DIFF, 1d9*FORCE, NEW_COST(NB) + ENDIF + +! ! Initialize values to be safe +! DIFF(:) = 0d0 +! FORCE(:) = 0d0 +! +! ! Calculate difference between modeled and observed profile +! DO LN = lind, LLMEM +! DIFF(LN) = CH4_HAT(LN) - CH4_HAT_OB_werr(LN) +! ENDDO +! +! ! Print information about this grid box to file +! DO LN=lind,LLMEM +! IF ( LDEBUG ) THEN +! WRITE(116,213) 'PRESSURE(LN),CH4_HAT(LN),' // +! & 'CH4_HAT_OB(LN),CH4_PRIOR(LN)', +! & PRESSURE( LN ), 1d9 * exp(CH4_HAT(LN)), +! & 1d9 * exp(CH4_HAT_OB_werr(LN)), 1d9 * CH4_PRIOR(II,JJ,LN) +! ENDIF +! ENDDO +! 213 FORMAT(A60,4F22.6) +! +! +! ! Calculate adjoint forcing: 2 * DIFF^T * S_{obs}^{-1} +! ! and cost function: DIFF^T * S_{obs}^{-1} * DIFF +! DO LN = lind, LLMEM +! DO LLN = lind, LLMEM +! FORCE(LN) = FORCE(LN) + +! & 2d0 * OBSERROR_INV_SUPER(LN,LLN) * DIFF(LLN) +! ENDDO +! NEW_COST(NB) = NEW_COST(NB) + 0.5*DIFF(LN)*FORCE(LN) +! ENDDO +! +! + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + +! ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! ! Adjoint of GEOS-Chem - Observation difference +! CH4_HAT_ADJ(:) = DIFF_ADJ(:) +! +! ! Adjoint of adding random error to observation +! DO LN=lind,LLMEM +! CH4_HAT_ADJ(LN) = 0d0 +! +! DO LLN=lind,LLMEM +! CH4_HAT_ADJ(LN) = CH4_HAT_ADJ(LN) + +! & CH4_HAT_ADJ(LLN) * SUPER_ERR * OBSERROR(LLN,LN) +! ENDDO +! ENDDO + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + ! Adjoint of GEOS-Chem - Observation difference + XCH4_HAT_ADJ = DIFF_ADJ + + ! Adjoint of CH4_HAT_EXP --> XCH4_HAT + DO LN=lind, LLMEM + CH4_HAT_EXP_ADJ(LN) = XCH4_HAT_ADJ * Xweight(LN) + ENDDO + + ! Adjoint of CH4_HAT --> CH4_HAT_EXP + DO LN=lind, LLMEM + CH4_HAT_ADJ(LN) = CH4_HAT_EXP_ADJ(LN) * CH4_HAT_EXP(LN) + ENDDO + + + ! Adjoint of MEM observation operator + CH4_PERT_ADJ(:) = 0D0 + DO LN=lind,LLMEM + DO LLN=lind,LLMEM + CH4_PERT_ADJ(LN) = CH4_PERT_ADJ(LN) + + & AVGKERNEL(LLN,LN) * CH4_HAT_ADJ(LLN) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO LN = lind, LLMEM + ! fwd code: + !GC_CH4(LN) = MAX(GC_CH4(LN), 1d-10) + !CH4_PERT(LN) = LOG(GC_CH4(LN)) - LOG(PRIOR(LN)) + ! adj code: + IF ( GC_CH4_onMEM(LN) > 1d-10 ) THEN + GC_CH4_onMEM_ADJ(LN) = 1d0 / GC_CH4_onMEM(LN) * + & CH4_PERT_ADJ(LN) + ELSE + GC_CH4_onMEM_ADJ(LN) = 1d0 / 1d-10 * CH4_PERT_ADJ(LN) + ENDIF + ENDDO + + IF ( LDEBUG ) THEN + DO LN=lind,LLMEM + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'GC_CH4_onMEM_ADJ, CH4_PERT_ADJ, CH4_HAT_ADJ', + & LN, GC_CH4_onMEM_ADJ(LN), CH4_PERT_ADJ(LN), + & CH4_HAT_ADJ(LN) + ENDDO + ENDIF + + + ! Adjoint of interpolation + DO LN=lind,LLMEM + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LN) * GC_CH4_onMEM_ADJ(LN) + ENDDO + ENDDO + + + ! Adjoint of unit conversion + DO LG=1,LLPAR + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + & * XNUMOL(1) / ( XNUMOLAIR * GC_AD(LG) ) + ENDDO + + + ! Pass adjoing forcing back to adjoint tracer array + DO LG=1,LLPAR + ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) * CHK_STT(II,JJ,LG,1) + ENDDO + + IF ( LDEBUG ) THEN + DO LG=1,LLPAR + WRITE(6,*) 'kjw DEBUG IN CALC_MEM_FORCE' + WRITE(6,299) 'GC_CH4_NATIVE_ADJ, ADJ(LG)', + & LN, GC_CH4_NATIVE_ADJ(LG), ADJ(LG),1 + ENDDO + ENDIF + + ! Update cost function + COST_FUNC_A = COST_FUNC_A + NEW_COST(NB) + + ! Only debug on first pass through routine + LDEBUG = .FALSE. + + + + ! Return to calling program + END SUBROUTINE CALC_MEM_CH4_FORCE_FD + + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( GC_PEDGE, MEM_PEDGE, nlev ) + & RESULT ( M ) +! +!****************************************************************************** +! Function GET_INTMAP creates the matrix that places GEOS-Chem column methane +! [molec/cm2] onto the 13-level pressure grid used by theoretical instrument, M. +! GC[1x47] * M[47x13] = MEM[1x13] (kjw, 7/21/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) GC_PEDGE (REAL*8) : LLPAR bottom pressure edges of GEOS-Chem column +! (2 ) SCIA_PEDGE (REAL*8) : LLMEM upper pressure edges of MEM column (except +! first entry, which is surface pressure) +! (3 ) nlev (REAL*8) : Number of MEM pressure levels to use +! +! Arguments as Output: +! ============================================================================ +! (1 ) M (REAL*8) : Interpolation matrix that maps GEOS-Chem to MEM grid +! +! NOTES: +! (1 ) Based on GET_INTMAP in scia_ch4_mod.f +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: MEM_PEDGE(LLMEM) + INTEGER :: nlev + + ! Return value + REAL*8 :: M(LLPAR,LLMEM) + + ! Local variables + INTEGER :: LGC, LTM, LS, LG, LN, LIND + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: GUP, GLO, NUP, NLO + REAL*8 :: column_total(LLMEM) + LOGICAL, SAVE :: LDEBUG = .TRUE. + + !================================================================= + ! GET_INTMAP begins here! + !================================================================= + + ! Initialize output + M(:,:) = 0D0 + + ! Minimum MEM vertical level to use + lind = LLMEM + 1 - nlev + + ! Loop over each pressure level of GEOS-Chem and MEM grids + DO LG=1,LLPAR + + ! Get upper and lower pressure edges of GEOS-Chem box + IF ( LG .EQ. LLPAR ) THEN + GUP = 0d0 + GLO = GC_PEDGE( LG ) + ELSE + GUP = GC_PEDGE( LG+1 ) + GLO = GC_PEDGE( LG ) + ENDIF + + DO LN=lind,LLMEM + + ! Get top and bottom pressures of MEM box + ! If processing first MEM level, this is surface level, so + ! bottom and top of box are same level. Set "bottom" of + ! MEM box to GEOS-Chem surface pressure so that MEM surface + ! box avgs GEOS-Chem values between GEOS-Chem surface and + ! MEM surface pressures. + ! GC surface pressure is always > MEM surface pressure because + ! we chop off lowermost MEM levels if it is not + IF ( LN .EQ. lind ) THEN + NUP = MEM_PEDGE( LN ) + NLO = GC_PEDGE( LG ) + ELSE + NUP = MEM_PEDGE( LN ) + NLO = MEM_PEDGE( LN-1 ) + ENDIF + + ! If both GEOS-Chem edges are within the MEM box, map value = 1 + IF ( ( GUP .gt. NUP ) .AND. ( GLO .lt. NLO ) ) THEN + M(LG,LN) = 1 + ENDIF + + ! If both GEOS-Chem stradles a MEM pressure level, interpolate + IF ( ( GUP .lt. NUP ) .AND. ( GLO .gt. NUP ) ) THEN + DIFF = GLO - GUP + M(LG,LN+1) = ( NUP - GUP ) / DIFF + M(LG,LN ) = ( GLO - NUP ) / DIFF + ENDIF + + ENDDO + ENDDO + + ! Add value for uppermost GEOS-Chem grid box + M(LLPAR,LLMEM) = 1 + + + ! Correct for case in which GEOS-Chem pressure is higher than MEM + IF ( GC_PEDGE(1) .GT. MEM_PEDGE(1) ) THEN + + ! If any part of GEOS-Chem box are under MEM_PEDGE(1), let + ! this GEOS-Chem grid box contribute to the observation because + ! MEM and GEOS-Chem should have same surface pressure. map value = 1 + DO LG=1,LLPAR-1 + + ! If GEOS-Chem box entirely below MEM surface pressure + IF ( ( GC_PEDGE(LG) .GT. MEM_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .GT. MEM_PEDGE(1) ) ) THEN + M(LG,1) = 1 + ENDIF + + ! If GEOS-Chem box straddles MEM surface pressure + IF ( ( GC_PEDGE(LG) .GT. MEM_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .LT. MEM_PEDGE(1) ) ) THEN + DIFF = GC_PEDGE(LG) - GC_PEDGE( LG+1 ) + M(LG,1) = ( MEM_PEDGE(1) - GC_PEDGE(LG+1) ) / DIFF + ENDIF + + ENDDO + ENDIF + + + ! Correct for case in which GEOS-Chem surface pressure is within 2nd MEM + ! pressure level. + IF ( GC_PEDGE(1) .LT. MEM_PEDGE(2) ) THEN + M(1,1) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 3rd MEM + ! pressure level. + IF ( GC_PEDGE(1) .LT. MEM_PEDGE(3) ) THEN + M(1,2) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 4th MEM + ! pressure level. + IF ( GC_PEDGE(1) .LT. MEM_PEDGE(4) ) THEN + M(1,3) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 5th MEM + ! pressure level. + IF ( GC_PEDGE(1) .LT. MEM_PEDGE(5) ) THEN + M(1,4) = 0. + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 6th MEM + ! pressure level. + IF ( GC_PEDGE(1) .LT. MEM_PEDGE(6) ) THEN + M(1,5) = 0. + ENDIF + + ! Normalize each column of M to 1 so that we are not creating any molecules + ! when mapping from GEOS-Chem to MEM grids. + + ! DO NOT do this since we are mapping molc/cm2, not + ! Initialize to be safe and calculate column total + column_total(:) = 0d0 + column_total(:) = SUM( M, DIM=1 ) + + ! Normalize columns to column_total + DO LN=1,LLMEM + IF ( column_total(LN) .EQ. 0. ) CYCLE + M(:,LN) = M(:,LN) / column_total(LN) + ENDDO + + + !if ( LDEBUG ) THEN + ! print*,'kjw GET_INTMAP, debug' + ! print*,'---------------------------------------' + ! WRITE(6,'(14F16.8)') 0d0, MEM_PEDGE(:) + ! DO LG=1,LLPAR + ! WRITE(6,'(14F16.8)') GC_PEDGE(LG), M(LG,:) + ! ENDDO + ! print*,'---------------------------------------' + ! LDEBUG = .FALSE. + !endif + + ! Return to calling program + END FUNCTION GET_INTMAP + + +!----------------------------------------------------------------------------- + + + + END MODULE MEM_CH4_MOD diff --git a/code/obs_operators/mls_hno3_obs_mod.f90 b/code/obs_operators/mls_hno3_obs_mod.f90 new file mode 100644 index 0000000..d19eda2 --- /dev/null +++ b/code/obs_operators/mls_hno3_obs_mod.f90 @@ -0,0 +1,595 @@ +MODULE MLS_HNO3_OBS_MOD + +! +! +! Module MLS_HNO3_OBS contains all subroutines and variables needed for MLS HNO3 column data +! +! +! Module Routines: +! +! (1) READ_MLS_HNO3_FILE : Read MLS hdf file + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + !PUBLIC READ_OMI_HNO3_FILE + PUBLIC READ_MLS_HNO3_FILE + PUBLIC CALC_MLS_HNO3_FORCE + + ! Module variables + + ! MLS data + REAL*8, ALLOCATABLE :: MLS_LON(:) + REAL*8, ALLOCATABLE :: MLS_LAT(:) + REAL*8, ALLOCATABLE :: MLS_TIME(:) + REAL*8, ALLOCATABLE :: MLS_HNO3(:,:) + REAL*8, ALLOCATABLE :: MLS_HNO3_STD(:,:) + REAL*8, ALLOCATABLE :: MLS_CN(:) + REAL*8, ALLOCATABLE :: MLS_CON_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_STA_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_MAIN_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_VIEW_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_PRESSURE(:) + + ! MLS grid specification + INTEGER :: N_MLS_OBS + INTEGER :: N_MLS_ALT + +CONTAINS + +!-----------------------------------------------------------------------------! + SUBROUTINE READ_MLS_HNO3_FILE ( YYYYMMDD, HHMMSS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + CHARACTER(LEN=255) :: DIR_MLS + CHARACTER(LEN=255) :: DIR_MONTH_MLS + CHARACTER(LEN=255) :: FILENAME_MLS + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + + INTEGER(HID_T) :: file_id, dset_id, dspace_id + INTEGER(HSIZE_T) :: dims(2), maxdims(2), data_dims(2) + INTEGER :: error + + CALL CLEANUP_MLS + + DIR_MLS = '/users/jk/15/xzhang/MLS_HNO3/' + DIR_MONTH_MLS = '/YYYY/MM/' + FILENAME_MLS = 'MLS-Aura_L2GP-HNO3_v04-22-c01_YYYYdMMDD.he5' + + CALL EXPAND_DATE(DIR_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(DIR_MONTH_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(FILENAME_MLS, YYYYMMDD, 0) + + FILENAME_FULL = TRIM(DIR_MLS) // TRIM(DIR_MONTH_MLS) // TRIM(FILENAME_MLS) + + PRINT *,"READING MLS File: ", FILENAME_FULL + + ! Initialize HDF5 Interface + + PRINT *,"INITIALIZE INTERFACE" + + CALL h5open_f(error) + + ! Open HDF5 file + + PRINT *,"OPEN FILE" + + CALL h5fopen_f (FILENAME_FULL, H5F_ACC_RDONLY_F, file_id, error) + + ! Read Time array + + PRINT *,"READING TIME ARRAY" + + DSET_NAME = '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + PRINT *,"OPENING DATA SET" + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + ! open dataspace + + CALL h5dget_space_f(dset_id, dspace_id, error) + + ! read in length of data arrays + + CALL h5sget_simple_extent_dims_f(dspace_id, dims, maxdims, error) + + ! close dataspace + + CALL h5sclose_f(dspace_id, error) + + N_MLS_ALT = dims(1) + N_MLS_OBS = dims(2) + + ALLOCATE(MLS_TIME(N_MLS_OBS)) + ALLOCATE(MLS_LON(N_MLS_OBS)) + ALLOCATE(MLS_LAT(N_MLS_OBS)) + ALLOCATE(MLS_HNO3(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_CON_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_HNO3_STD(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_MAIN_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_STA_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_CN(N_MLS_OBS)) + ALLOCATE(MLS_VIEW_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_SOLAR_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_PRESSURE(N_MLS_ALT)) + + PRINT *,"ALLOCATING TIME ARRAY WITH LENGTH: ", N_MLS_OBS + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + !PRINT *, "L2gpValue", MLS_HNO3(:,N_MLS_OBS) + + ! Read Time array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Time' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_TIME, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Longitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LON, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Latitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LAT, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 Precision array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpPrecision' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3_STD, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Quality' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_MAIN_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Status array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Status' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_STA_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read ChunkNumber array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/ChunkNumber' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CN, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read LineofSightAngle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/LineOfSightAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_VIEW_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Solar zenith Angle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_SOLAR_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Convergence' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CON_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Pressure' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_PRESSURE, (/data_dims(1),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! close HDF5 file + + CALL h5fclose_f(file_id,error) + + ! close HDF5 interface + + CALL h5close_f(error) + + + END SUBROUTINE READ_MLS_HNO3_FILE +!-----------------------------------------------------------------------------! + SUBROUTINE CALC_MLS_HNO3_FORCE + +!! +!! Subroutine CALC_OMI_HNO3_FORCE computes the HNO3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_HOUR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDHNO3, IDTHNO3 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,K,L + INTEGER :: I_MLS, J_MLS, JLOOP + INTEGER :: IIJJ(2) + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_HNO3(LLPAR) + REAL*8 :: GC_HNO3_COL + REAL*8 :: GC_HNO3_ADJ(IIPAR,JJPAR,LLPAR) + REAL*8 :: CM22DU + REAL*8 :: DIFF + REAL*8 :: OBS_ERROR + + LOGICAL :: MLS_MATCH + REAL*8 :: OMI_MLS_DIST + REAl*8 :: OMI_MLS_DIST_LON + REAl*8 :: OMI_MLS_DIST_LAT + REAL*8 :: MLS_HNO3_GC(LLPAR) + REAL*8 :: MLS_HNO3_GC_STD(LLPAR) + REAL*8 :: NCP(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(LLPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMI(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + ! Loop through data to find observations + + CM22DU = 2.69E16 ! conversion factor for DU -> #/cm2 + + GC_HOUR = GET_HOUR() + + ! initialize needed arrays and variables + + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_HNO3 = 0d0 + GC_HNO3_ADJ = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + GC_ADJ_COUNT = 0d0 + + OMI_MLS_DIST = 10000d0 + + DO I_MLS = 1, N_MLS_OBS + IF(MLS_TIME(I_MLS)>0) THEN + ! There is an observation in the MLS grid box. + ! Check if it was made within the current hour. + tai93 = MLS_TIME(I_MLS) + + ! Convert TAI93 to UTC + CALL TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + ( MLS_MAIN_QUAL(I_MLS) > 0.5 ) .AND. & + ( MLS_STA_QUAL(I_MLS) < 250 ) .AND. & + ( MLS_CON_QUAL(I_MLS) < 1.4 ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(MLS_LON(I_MLS),4),REAL(MLS_LAT(I_MLS),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM HNO3 values + + GC_HNO3 = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + COST_CONTRIB = 0d0 + DO L = 1, LLPAR + + JLOOP = JLOP(I,J,L) + + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + + !IF ( JLOOP > 0 ) THEN + + !GC_HNO3(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDHNO3)) * 1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + + !GC_HNO3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + ! CHK_STT is in units of [kg/box] here. Convert to ppb + GC_HNO3(L) = CHK_STT(I,J,L,IDTHNO3) * TCVV(IDTHNO3) / AD(I,J,L) + + DO J_MLS = 1, N_MLS_ALT + + IF( ( MLS_PRESSURE(J_MLS) >= GET_PEDGE(I,J,L+1) ) .AND. & + ( MLS_PRESSURE(J_MLS) < GET_PEDGE(I,J,L) ) .AND. & + ( MLS_PRESSURE(J_MLS) < 151 ) .AND. & + ( MLS_PRESSURE(J_MLS) > 15 ) .AND. & + ( MLS_HNO3(J_MLS,I_MLS) > 0 ) ) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L) + MLS_HNO3(J_MLS,I_MLS) + + MLS_HNO3_GC_STD(L) = MLS_HNO3_GC_STD(L) + MLS_HNO3_STD(J_MLS,I_MLS)**2 + + NCP(L) = NCP(L) + 1 + ENDIF + ENDDO + + IF (NCP(L)>0) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L)/NCP(L) + MLS_HNO3_GC_STD(L) = (MLS_HNO3_GC_STD(L)**(0.5))/NCP(L) + OBS_ERROR = MLS_HNO3_GC_STD(L) + DIFF = GC_HNO3(L) - MLS_HNO3_GC(L) + COST_CONTRIB(L) = 0.5 * (DIFF/OBS_ERROR)**2 + IF ( ( COST_CONTRIB(L) > 0d0) .AND. & + ( GET_PCENTER(I,J,L) < 151 ) .AND. & + ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + IF (SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1 + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * TCVV(IDTHNO3) / AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDIF + ENDIF + ENDIF + + ENDDO + !PRINT *, "MODELLED HNO3", GC_HNO3 + !PRINT *, "OBSERVED HNO3", MLS_HNO3_GC + + ! Compute stratospheric HNO3 column value [v/v*cm] + + !GC_HNO3_COL = SUM(GC_HNO3(:) * BXHEIGHT(I,J,:) * 100d0) + + !PRINT *, "GC_HNO3_COL", GC_HNO3_COL + + !PRINT *, "MLS_HNO3_COL", MLS_HNO3_COL(I_MLS) + + !DIFF = GC_HNO3_COL - MLS_HNO3_COL(I_MLS) + + !OBS_ERROR = (MLS_HNO3_COL_STD(I_MLS))**0.5 + + !DO L = 1, LLPAR + !IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + !IF (SUPER_OBS) THEN + + !SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + !ELSE + !STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + + !ENDIF + !ENDIF + !ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + ENDIF + + ENDIF + ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L = 1,LLPAR + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. & + ( GET_PCENTER(I,J,L) > 15 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ENDIF + + PRINT *, "COST FUNCTION OF MLS HNO3", COST_FUNC + + END SUBROUTINE CALC_MLS_HNO3_FORCE + +!----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_MLS + + IF (ALLOCATED( MLS_LON )) DEALLOCATE( MLS_LON ) + IF (ALLOCATED( MLS_LAT )) DEALLOCATE( MLS_LAT ) + IF (ALLOCATED( MLS_TIME )) DEALLOCATE( MLS_TIME ) + IF (ALLOCATED( MLS_HNO3 )) DEALLOCATE( MLS_HNO3 ) + IF (ALLOCATED( MLS_HNO3_STD )) DEALLOCATE( MLS_HNO3_STD ) + IF (ALLOCATED( MLS_CON_QUAL )) DEALLOCATE( MLS_CON_QUAL ) + IF (ALLOCATED( MLS_MAIN_QUAL )) DEALLOCATE( MLS_MAIN_QUAL ) + IF (ALLOCATED( MLS_STA_QUAL )) DEALLOCATE( MLS_STA_QUAL ) + IF (ALLOCATED( MLS_CN )) DEALLOCATE( MLS_CN ) + IF (ALLOCATED( MLS_SOLAR_ZENITH )) DEALLOCATE( MLS_SOLAR_ZENITH ) + IF (ALLOCATED( MLS_VIEW_ZENITH )) DEALLOCATE( MLS_VIEW_ZENITH ) + IF (ALLOCATED( MLS_PRESSURE )) DEALLOCATE( MLS_PRESSURE ) + + END SUBROUTINE CLEANUP_MLS + +!-----------------------------------------------------------------------------! + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=7 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + +END MODULE MLS_HNO3_OBS_MOD + diff --git a/code/obs_operators/mls_hno3_obs_mod.f90~ b/code/obs_operators/mls_hno3_obs_mod.f90~ new file mode 100644 index 0000000..c1fc89c --- /dev/null +++ b/code/obs_operators/mls_hno3_obs_mod.f90~ @@ -0,0 +1,592 @@ +MODULE MLS_HNO3_OBS_MOD + +! +! +! Module MLS_HNO3_OBS contains all subroutines and variables needed for MLS HNO3 column data +! +! +! Module Routines: +! +! (1) READ_MLS_HNO3_FILE : Read MLS hdf file + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + !PUBLIC READ_OMI_HNO3_FILE + PUBLIC READ_MLS_HNO3_FILE + PUBLIC CALC_MLS_HNO3_FORCE + + ! Module variables + + ! MLS data + REAL*8, ALLOCATABLE :: MLS_LON(:) + REAL*8, ALLOCATABLE :: MLS_LAT(:) + REAL*8, ALLOCATABLE :: MLS_TIME(:) + REAL*8, ALLOCATABLE :: MLS_HNO3(:,:) + REAL*8, ALLOCATABLE :: MLS_HNO3_STD(:,:) + REAL*8, ALLOCATABLE :: MLS_CN(:) + REAL*8, ALLOCATABLE :: MLS_CON_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_STA_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_MAIN_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_VIEW_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_PRESSURE(:) + + ! MLS grid specification + INTEGER :: N_MLS_OBS + INTEGER :: N_MLS_ALT + +CONTAINS + +!-----------------------------------------------------------------------------! + SUBROUTINE READ_MLS_HNO3_FILE ( YYYYMMDD, HHMMSS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + CHARACTER(LEN=255) :: DIR_MLS + CHARACTER(LEN=255) :: FILENAME_MLS + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + + INTEGER(HID_T) :: file_id, dset_id, dspace_id + INTEGER(HSIZE_T) :: dims(2), maxdims(2), data_dims(2) + INTEGER :: error + + CALL CLEANUP_MLS + + DIR_MLS = '/users/jk/15/xzhang/MLS_HNO3/' + FILENAME_MLS = 'MLS-Aura_L2GP-HNO3_v04-22-c01_YYYYdMMDD.he5' + + CALL EXPAND_DATE(DIR_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(FILENAME_MLS, YYYYMMDD, 0) + + FILENAME_FULL = TRIM(DIR_MLS) // TRIM(FILENAME_MLS) + + PRINT *,"READING MLS File: ", FILENAME_FULL + + ! Initialize HDF5 Interface + + PRINT *,"INITIALIZE INTERFACE" + + CALL h5open_f(error) + + ! Open HDF5 file + + PRINT *,"OPEN FILE" + + CALL h5fopen_f (FILENAME_FULL, H5F_ACC_RDONLY_F, file_id, error) + + ! Read Time array + + PRINT *,"READING TIME ARRAY" + + DSET_NAME = '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + PRINT *,"OPENING DATA SET" + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + ! open dataspace + + CALL h5dget_space_f(dset_id, dspace_id, error) + + ! read in length of data arrays + + CALL h5sget_simple_extent_dims_f(dspace_id, dims, maxdims, error) + + ! close dataspace + + CALL h5sclose_f(dspace_id, error) + + N_MLS_ALT = dims(1) + N_MLS_OBS = dims(2) + + ALLOCATE(MLS_TIME(N_MLS_OBS)) + ALLOCATE(MLS_LON(N_MLS_OBS)) + ALLOCATE(MLS_LAT(N_MLS_OBS)) + ALLOCATE(MLS_HNO3(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_CON_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_HNO3_STD(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_MAIN_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_STA_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_CN(N_MLS_OBS)) + ALLOCATE(MLS_VIEW_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_SOLAR_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_PRESSURE(N_MLS_ALT)) + + PRINT *,"ALLOCATING TIME ARRAY WITH LENGTH: ", N_MLS_OBS + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpValue' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + !PRINT *, "L2gpValue", MLS_HNO3(:,N_MLS_OBS) + + ! Read Time array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Time' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_TIME, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Longitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LON, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Latitude array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LAT, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS HNO3 Precision array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/L2gpPrecision' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_HNO3_STD, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Quality' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_MAIN_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Status array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Status' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_STA_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read ChunkNumber array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/ChunkNumber' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CN, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read LineofSightAngle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/LineOfSightAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_VIEW_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Solar zenith Angle array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_SOLAR_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Data Fields/Convergence' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CON_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/HNO3/Geolocation Fields/Pressure' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_PRESSURE, (/data_dims(1),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! close HDF5 file + + CALL h5fclose_f(file_id,error) + + ! close HDF5 interface + + CALL h5close_f(error) + + + END SUBROUTINE READ_MLS_HNO3_FILE +!-----------------------------------------------------------------------------! + SUBROUTINE CALC_MLS_HNO3_FORCE + +!! +!! Subroutine CALC_OMI_HNO3_FORCE computes the HNO3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_HOUR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDHNO3, IDTHNO3 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,K,L + INTEGER :: I_MLS, J_MLS, JLOOP + INTEGER :: IIJJ(2) + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_HNO3(LLPAR) + REAL*8 :: GC_HNO3_COL + REAL*8 :: GC_HNO3_ADJ(IIPAR,JJPAR,LLPAR) + REAL*8 :: CM22DU + REAL*8 :: DIFF + REAL*8 :: OBS_ERROR + + LOGICAL :: MLS_MATCH + REAL*8 :: OMI_MLS_DIST + REAl*8 :: OMI_MLS_DIST_LON + REAl*8 :: OMI_MLS_DIST_LAT + REAL*8 :: MLS_HNO3_GC(LLPAR) + REAL*8 :: MLS_HNO3_GC_STD(LLPAR) + REAL*8 :: NCP(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(LLPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMI(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + ! Loop through data to find observations + + CM22DU = 2.69E16 ! conversion factor for DU -> #/cm2 + + GC_HOUR = GET_HOUR() + + ! initialize needed arrays and variables + + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_HNO3 = 0d0 + GC_HNO3_ADJ = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + GC_ADJ_COUNT = 0d0 + + OMI_MLS_DIST = 10000d0 + + DO I_MLS = 1, N_MLS_OBS + IF(MLS_TIME(I_MLS)>0) THEN + ! There is an observation in the MLS grid box. + ! Check if it was made within the current hour. + tai93 = MLS_TIME(I_MLS) + + ! Convert TAI93 to UTC + CALL TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + ( MLS_MAIN_QUAL(I_MLS) > 0.5 ) .AND. & + ( MLS_STA_QUAL(I_MLS) < 250 ) .AND. & + ( MLS_CON_QUAL(I_MLS) < 1.4 ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(MLS_LON(I_MLS),4),REAL(MLS_LAT(I_MLS),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM HNO3 values + + GC_HNO3 = 0d0 + GC_HNO3_COL = 0d0 + MLS_HNO3_GC = 0d0 + MLS_HNO3_GC_STD = 0d0 + NCP = 0d0 + COST_CONTRIB = 0d0 + DO L = 1, LLPAR + + JLOOP = JLOP(I,J,L) + + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + + !IF ( JLOOP > 0 ) THEN + + !GC_HNO3(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDHNO3)) * 1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + + !GC_HNO3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + ! CHK_STT is in units of [kg/box] here. Convert to ppb + GC_HNO3(L) = CHK_STT(I,J,L,IDTHNO3) * TCVV(IDTHNO3) / AD(I,J,L) + + DO J_MLS = 1, N_MLS_ALT + + IF( ( MLS_PRESSURE(J_MLS) >= GET_PEDGE(I,J,L+1) ) .AND. & + ( MLS_PRESSURE(J_MLS) < GET_PEDGE(I,J,L) ) .AND. & + ( MLS_PRESSURE(J_MLS) < 151 ) .AND. & + ( MLS_PRESSURE(J_MLS) > 15 ) .AND. & + ( MLS_HNO3(J_MLS,I_MLS) > 0 ) ) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L) + MLS_HNO3(J_MLS,I_MLS) + + MLS_HNO3_GC_STD(L) = MLS_HNO3_GC_STD(L) + MLS_HNO3_STD(J_MLS,I_MLS)**2 + + NCP(L) = NCP(L) + 1 + ENDIF + ENDDO + + IF (NCP(L)>0) THEN + + MLS_HNO3_GC(L) = MLS_HNO3_GC(L)/NCP(L) + MLS_HNO3_GC_STD(L) = (MLS_HNO3_GC_STD(L)**(0.5))/NCP(L) + OBS_ERROR = 0.5*MLS_HNO3_GC_STD(L) + DIFF = GC_HNO3(L) - MLS_HNO3_GC(L) + COST_CONTRIB(L) = 0.5 * (DIFF/OBS_ERROR)**2 + IF ( ( COST_CONTRIB(L) > 0d0) .AND. & + ( GET_PCENTER(I,J,L) < 151 ) .AND. & + ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + IF (SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1 + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * TCVV(IDTHNO3) / AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDIF + ENDIF + ENDIF + + ENDDO + !PRINT *, "MODELLED HNO3", GC_HNO3 + !PRINT *, "OBSERVED HNO3", MLS_HNO3_GC + + ! Compute stratospheric HNO3 column value [v/v*cm] + + !GC_HNO3_COL = SUM(GC_HNO3(:) * BXHEIGHT(I,J,:) * 100d0) + + !PRINT *, "GC_HNO3_COL", GC_HNO3_COL + + !PRINT *, "MLS_HNO3_COL", MLS_HNO3_COL(I_MLS) + + !DIFF = GC_HNO3_COL - MLS_HNO3_COL(I_MLS) + + !OBS_ERROR = (MLS_HNO3_COL_STD(I_MLS))**0.5 + + !DO L = 1, LLPAR + !IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. ( GET_PCENTER(I,J,L) > 15 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + !IF (SUPER_OBS) THEN + + !SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + !ELSE + !STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + DIFF/(OBS_ERROR**2) * BXHEIGHT(I,J,L) * 100d0 & + !* TCVV(IDTHNO3) / (AD(I,J,L) * 1d6) + + !ENDIF + !ENDIF + !ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + ENDIF + + ENDIF + ENDDO + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L = 1,LLPAR + IF( ( GET_PCENTER(I,J,L) < 151 ) .AND. & + ( GET_PCENTER(I,J,L) > 15 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) ) THEN + + !JLOOP = JLOP(I,J,L) + + STT_ADJ(I,J,L,IDTHNO3) = STT_ADJ(I,J,L,IDTHNO3) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ENDIF + + PRINT *, "COST FUNCTION OF MLS HNO3", COST_FUNC + + END SUBROUTINE CALC_MLS_HNO3_FORCE + +!----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_MLS + + IF (ALLOCATED( MLS_LON )) DEALLOCATE( MLS_LON ) + IF (ALLOCATED( MLS_LAT )) DEALLOCATE( MLS_LAT ) + IF (ALLOCATED( MLS_TIME )) DEALLOCATE( MLS_TIME ) + IF (ALLOCATED( MLS_HNO3 )) DEALLOCATE( MLS_HNO3 ) + IF (ALLOCATED( MLS_HNO3_STD )) DEALLOCATE( MLS_HNO3_STD ) + IF (ALLOCATED( MLS_CON_QUAL )) DEALLOCATE( MLS_CON_QUAL ) + IF (ALLOCATED( MLS_MAIN_QUAL )) DEALLOCATE( MLS_MAIN_QUAL ) + IF (ALLOCATED( MLS_STA_QUAL )) DEALLOCATE( MLS_STA_QUAL ) + IF (ALLOCATED( MLS_CN )) DEALLOCATE( MLS_CN ) + IF (ALLOCATED( MLS_SOLAR_ZENITH )) DEALLOCATE( MLS_SOLAR_ZENITH ) + IF (ALLOCATED( MLS_VIEW_ZENITH )) DEALLOCATE( MLS_VIEW_ZENITH ) + IF (ALLOCATED( MLS_PRESSURE )) DEALLOCATE( MLS_PRESSURE ) + + END SUBROUTINE CLEANUP_MLS + +!-----------------------------------------------------------------------------! + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=7 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + +END MODULE MLS_HNO3_OBS_MOD + diff --git a/code/obs_operators/mls_o3_obs_mod.f90 b/code/obs_operators/mls_o3_obs_mod.f90 new file mode 100644 index 0000000..59cc358 --- /dev/null +++ b/code/obs_operators/mls_o3_obs_mod.f90 @@ -0,0 +1,594 @@ +MODULE MLS_O3_OBS_MOD + +! +! +! Module MLS_O3_OBS contains all subroutines and variables needed for OMI O3 column data +! +! +! Module Routines: + +! (1) READ_MLS_O3_FILE : Read MLS hdf file + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + !PUBLIC READ_OMI_O3_FILE + PUBLIC READ_MLS_O3_FILE + PUBLIC CALC_MLS_O3_FORCE + + ! MLS data + REAL*8, ALLOCATABLE :: MLS_LON(:) + REAL*8, ALLOCATABLE :: MLS_LAT(:) + REAL*8, ALLOCATABLE :: MLS_TIME(:) + REAL*8, ALLOCATABLE :: MLS_O3(:,:) + REAL*8, ALLOCATABLE :: MLS_O3_STD(:,:) + REAL*8, ALLOCATABLE :: MLS_CN(:) + REAL*8, ALLOCATABLE :: MLS_CON_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_STA_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_MAIN_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_VIEW_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_PRESSURE(:) + + ! MLS grid specification + INTEGER :: N_MLS_OBS + INTEGER :: N_MLS_ALT + +CONTAINS + +!--------------------------------------------------------------------------! + SUBROUTINE READ_MLS_O3_FILE ( YYYYMMDD, HHMMSS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + CHARACTER(LEN=255) :: DIR_MLS + CHARACTER(LEN=255) :: DIR_MONTH_MLS + CHARACTER(LEN=255) :: FILENAME_MLS + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + + INTEGER(HID_T) :: file_id, dset_id, dspace_id + INTEGER(HSIZE_T) :: dims(2), maxdims(2), data_dims(2) + INTEGER :: error + + CALL CLEANUP_MLS + + DIR_MLS = '/users/jk/16/xzhang/MLS_O3/' + DIR_MONTH_MLS = 'YYYY/MM/' + FILENAME_MLS = 'MLS-Aura_L2GP-O3_v04-20-c01_YYYYdMMDD.he5' + + CALL EXPAND_DATE(DIR_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(DIR_MONTH_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(FILENAME_MLS, YYYYMMDD, 0) + + FILENAME_FULL = TRIM(DIR_MLS) // TRIM(DIR_MONTH_MLS) // TRIM(FILENAME_MLS) + + PRINT *,"READING MLS File: ", FILENAME_FULL + + ! Initialize HDF5 Interface + + PRINT *,"INITIALIZE INTERFACE" + + CALL h5open_f(error) + + ! Open HDF5 file + + PRINT *,"OPEN FILE" + + CALL h5fopen_f (FILENAME_FULL, H5F_ACC_RDONLY_F, file_id, error) + + ! Read Time array + + PRINT *,"READING TIME ARRAY" + + DSET_NAME = '/HDFEOS/SWATHS/O3/Data Fields/L2gpValue' + + PRINT *,"OPENING DATA SET" + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + ! open dataspace + + CALL h5dget_space_f(dset_id, dspace_id, error) + + ! read in length of data arrays + + CALL h5sget_simple_extent_dims_f(dspace_id, dims, maxdims, error) + + ! close dataspace + + CALL h5sclose_f(dspace_id, error) + + N_MLS_ALT = dims(1) + N_MLS_OBS = dims(2) + + ALLOCATE(MLS_TIME(N_MLS_OBS)) + ALLOCATE(MLS_LON(N_MLS_OBS)) + ALLOCATE(MLS_LAT(N_MLS_OBS)) + !ALLOCATE(MLS_O3_COL(N_MLS_OBS)) + ALLOCATE(MLS_O3(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_CON_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_O3_STD(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_MAIN_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_STA_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_CN(N_MLS_OBS)) + ALLOCATE(MLS_VIEW_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_SOLAR_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_PRESSURE(N_MLS_ALT)) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Time array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Time' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_TIME, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Longitude array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LON, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Latitude array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LAT, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS O3 array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/L2gpValue' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + !PRINT *, "L2gpValue", MLS_O3(:,N_MLS_OBS) + ! Read MLS O3 Precision array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/L2gpPrecision' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3_STD, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Quality array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Quality' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_MAIN_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Status array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Status' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_STA_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read ChunkNumber array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/ChunkNumber' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CN, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read LineofSightAngle array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/LineOfSightAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_VIEW_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Solar zenith Angle array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_SOLAR_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Convergence' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CON_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Pressure' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_PRESSURE, (/data_dims(1),0/), error) + + CALL h5dclose_f(dset_id,error) + ! close HDF5 file + + CALL h5fclose_f(file_id,error) + + ! close HDF5 interface + + CALL h5close_f(error) + + + END SUBROUTINE READ_MLS_O3_FILE +!-----------------------------------------------------------------------------! + SUBROUTINE CALC_MLS_O3_FORCE + +!! +!! Subroutine CALC_OMI_O3_FORCE computes the O3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_HOUR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,K,L + INTEGER :: I_MLS, J_MLS, JLOOP + INTEGER :: IIJJ(2) + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_O3(LLPAR) + REAL*8 :: GC_O3_ADJ(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_O3_COL + REAL*8 :: CM22DU + REAL*8 :: DIFF + REAL*8 :: OBS_ERROR + REAL*8 :: GC_PRES(LLPAR) + + REAL*8 :: MLS_O3_GC(LLPAR) + REAL*8 :: MLS_O3_GC_STD(LLPAR) + REAL*8 :: NCP(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(LLPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_DIFF(IIPAR,JJPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'gc_press_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 761, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 762, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 763, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_adj_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 764, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 765, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 766, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'obs_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 769, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'err_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 762, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ENDIF + + ! Loop through data to find observations + + CM22DU = 2.69E16 ! conversion factor for DU -> #/cm2 + + GC_HOUR = GET_HOUR() + + ! initialize needed arrays and variables + + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_O3 = 0d0 + GC_O3_ADJ = 0d0 + GC_O3_COL = 0d0 + MLS_O3_GC = 0d0 + MLS_O3_GC_STD = 0d0 + NCP = 0d0 + SOBS_COUNT = 0d0 + SOBS_DIFF = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + GC_ADJ_COUNT = 0d0 + + DO I_MLS=1, N_MLS_OBS + IF(MLS_TIME(I_MLS)>0) THEN + ! There is an observation in the MLS grid box. + ! Check if it was made within the current hour. + tai93 = MLS_TIME(I_MLS) + + ! Convert TAI93 to UTC + CALL TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + ( MLS_STA_QUAL(I_MLS) < 250 ) .AND. & + ( ABS(MLS_LAT(I_MLS)) < 75d0 ) .AND. & + !( MLS_SOLAR_ZENITH(I_MLS) < 75d0 ) .AND. & + ( MLS_MAIN_QUAL(I_MLS) > 1.0 ) .AND. & + ( MLS_CON_QUAL(I_MLS) < 1.03 ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(MLS_LON(I_MLS),4),REAL(MLS_LAT(I_MLS),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM O3 values + + GC_O3 = 0d0 + GC_O3_COL = 0d0 + MLS_O3_GC = 0d0 + MLS_O3_GC_STD = 0d0 + NCP = 0d0 + COST_CONTRIB = 0d0 + + DO L = 1, LLPAR + + GC_PRES(L) = GET_PCENTER(I,J,L) + + ! CHK_STT is in units of [kg/box] here, convert to ppb + IF( ( GET_PCENTER(I,J,L) < 215 ) .AND. ( GET_PCENTER(I,J,L) > 10 ) ) THEN + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) + + DO J_MLS = 1, N_MLS_ALT + IF( ( MLS_PRESSURE(J_MLS) >= GET_PEDGE(I,J,L+1) ) .AND. & + ( MLS_PRESSURE(J_MLS) < GET_PEDGE(I,J,L) ) .AND. & + ( MLS_PRESSURE(J_MLS) < 215 ) .AND. & + ( MLS_PRESSURE(J_MLS) > 10 ) .AND. & + ( MLS_O3(J_MLS,I_MLS) > 0 ) ) THEN + + MLS_O3_GC(L) = MLS_O3_GC(L) + MLS_O3(J_MLS,I_MLS) + + MLS_O3_GC_STD(L) = MLS_O3_GC_STD(L) + MLS_O3_STD(J_MLS,I_MLS)**2 + + NCP(L) = NCP(L) + 1 + ENDIF + ENDDO + IF (NCP(L)>0) THEN + + MLS_O3_GC(L) = MLS_O3_GC(L)/NCP(L) + !PRINT *, "MLS_O3_GC", MLS_O3_GC(L) + MLS_O3_GC_STD(L) = (MLS_O3_GC_STD(L)**(0.5))/NCP(L) + OBS_ERROR = MLS_O3_GC_STD(L) + !OBS_ERROR(L) = 0.2 * MLS_O3_GC(L) + DIFF = GC_O3(L) - MLS_O3_GC(L) + !PRINT *, "DIFF(L)", DIFF(L) + !PRINT *, "OBS_ERROR(L)", OBS_ERROR(L) + COST_CONTRIB(L) = 0.5 * (DIFF/OBS_ERROR)**2 + IF ( ( COST_CONTRIB(L) > 0d0) .AND. & + ( COST_CONTRIB(L) < 200d0) .AND. & + ( GET_PCENTER(I,J,L) < 215 ) .AND. & + ( GET_PCENTER(I,J,L) > 10 ) ) THEN + + IF (SUPER_OBS) THEN + SOBS_DIFF(I,J) = SOBS_DIFF(I,J) + DIFF + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1 + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * TCVV(IDTOX) / AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + +110 FORMAT(F18.6,1X) + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L = 1,LLPAR + IF( ( GET_PCENTER(I,J,L) < 215 ) .AND. & + ( GET_PCENTER(I,J,L) > 10 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ENDIF + + !PRINT *, "STT_ADJ AFTER MLS O3", SOBS_ADJ_FORCE + PRINT *, "COST FUNCTION OF MLS O3", COST_FUNC + + END SUBROUTINE CALC_MLS_O3_FORCE + +!----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_MLS + + IF (ALLOCATED( MLS_LON )) DEALLOCATE( MLS_LON ) + IF (ALLOCATED( MLS_LAT )) DEALLOCATE( MLS_LAT ) + IF (ALLOCATED( MLS_TIME )) DEALLOCATE( MLS_TIME ) + IF (ALLOCATED( MLS_O3 )) DEALLOCATE( MLS_O3 ) + IF (ALLOCATED( MLS_O3_STD )) DEALLOCATE( MLS_O3_STD ) + IF (ALLOCATED( MLS_CON_QUAL )) DEALLOCATE( MLS_CON_QUAL ) + IF (ALLOCATED( MLS_MAIN_QUAL )) DEALLOCATE( MLS_MAIN_QUAL ) + IF (ALLOCATED( MLS_STA_QUAL )) DEALLOCATE( MLS_STA_QUAL ) + IF (ALLOCATED( MLS_CN )) DEALLOCATE( MLS_CN ) + IF (ALLOCATED( MLS_SOLAR_ZENITH )) DEALLOCATE( MLS_SOLAR_ZENITH ) + IF (ALLOCATED( MLS_VIEW_ZENITH )) DEALLOCATE( MLS_VIEW_ZENITH ) + IF (ALLOCATED( MLS_PRESSURE )) DEALLOCATE( MLS_PRESSURE ) + + END SUBROUTINE CLEANUP_MLS + +!-----------------------------------------------------------------------------! + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=7 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + +END MODULE MLS_O3_OBS_MOD + diff --git a/code/obs_operators/mls_o3_obs_mod.f90~ b/code/obs_operators/mls_o3_obs_mod.f90~ new file mode 100644 index 0000000..964f8f0 --- /dev/null +++ b/code/obs_operators/mls_o3_obs_mod.f90~ @@ -0,0 +1,596 @@ +MODULE MLS_O3_OBS_MOD + +! +! +! Module MLS_O3_OBS contains all subroutines and variables needed for OMI O3 column data +! +! +! Module Routines: + +! (1) READ_MLS_O3_FILE : Read MLS hdf file + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + !PUBLIC READ_OMI_O3_FILE + PUBLIC READ_MLS_O3_FILE + PUBLIC CALC_MLS_O3_FORCE + + ! MLS data + REAL*8, ALLOCATABLE :: MLS_LON(:) + REAL*8, ALLOCATABLE :: MLS_LAT(:) + REAL*8, ALLOCATABLE :: MLS_TIME(:) + REAL*8, ALLOCATABLE :: MLS_O3(:,:) + REAL*8, ALLOCATABLE :: MLS_O3_STD(:,:) + REAL*8, ALLOCATABLE :: MLS_CN(:) + REAL*8, ALLOCATABLE :: MLS_CON_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_STA_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_MAIN_QUAL(:) + REAL*8, ALLOCATABLE :: MLS_VIEW_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_SOLAR_ZENITH(:) + REAL*8, ALLOCATABLE :: MLS_PRESSURE(:) + + ! MLS grid specification + INTEGER :: N_MLS_OBS + INTEGER :: N_MLS_ALT + +CONTAINS + +!--------------------------------------------------------------------------! + SUBROUTINE READ_MLS_O3_FILE ( YYYYMMDD, HHMMSS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + CHARACTER(LEN=255) :: DIR_MLS + CHARACTER(LEN=255) :: DIR_MONTH_MLS + CHARACTER(LEN=255) :: FILENAME_MLS + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + + INTEGER(HID_T) :: file_id, dset_id, dspace_id + INTEGER(HSIZE_T) :: dims(2), maxdims(2), data_dims(2) + INTEGER :: error + + CALL CLEANUP_MLS + + DIR_MLS = '/users/jk/16/xzhang/MLS_O3/' + DIR_MONTH_MLS = 'YYYY/MM/' + FILENAME_MLS = 'MLS-Aura_L2GP-O3_v04-20-c01_YYYYdMMDD.he5' + + CALL EXPAND_DATE(DIR_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(DIR_MONTH_MLS, YYYYMMDD, 0) + CALL EXPAND_DATE(FILENAME_MLS, YYYYMMDD, 0) + + FILENAME_FULL = TRIM(DIR_MLS) // TRIM(DIR_MONTH_MLS) // TRIM(FILENAME_MLS) + + PRINT *,"READING MLS File: ", FILENAME_FULL + + ! Initialize HDF5 Interface + + PRINT *,"INITIALIZE INTERFACE" + + CALL h5open_f(error) + + ! Open HDF5 file + + PRINT *,"OPEN FILE" + + CALL h5fopen_f (FILENAME_FULL, H5F_ACC_RDONLY_F, file_id, error) + + ! Read Time array + + PRINT *,"READING TIME ARRAY" + + DSET_NAME = '/HDFEOS/SWATHS/O3/Data Fields/L2gpValue' + + PRINT *,"OPENING DATA SET" + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + ! open dataspace + + CALL h5dget_space_f(dset_id, dspace_id, error) + + ! read in length of data arrays + + CALL h5sget_simple_extent_dims_f(dspace_id, dims, maxdims, error) + + ! close dataspace + + CALL h5sclose_f(dspace_id, error) + + N_MLS_ALT = dims(1) + N_MLS_OBS = dims(2) + + ALLOCATE(MLS_TIME(N_MLS_OBS)) + ALLOCATE(MLS_LON(N_MLS_OBS)) + ALLOCATE(MLS_LAT(N_MLS_OBS)) + !ALLOCATE(MLS_O3_COL(N_MLS_OBS)) + ALLOCATE(MLS_O3(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_CON_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_O3_STD(N_MLS_ALT,N_MLS_OBS)) + ALLOCATE(MLS_MAIN_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_STA_QUAL(N_MLS_OBS)) + ALLOCATE(MLS_CN(N_MLS_OBS)) + ALLOCATE(MLS_VIEW_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_SOLAR_ZENITH(N_MLS_OBS)) + ALLOCATE(MLS_PRESSURE(N_MLS_ALT)) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Time array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Time' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_TIME, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Longitude array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LON, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Latitude array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_LAT, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read MLS O3 array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/L2gpValue' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3, data_dims, error) + + CALL h5dclose_f(dset_id,error) + !PRINT *, "L2gpValue", MLS_O3(:,N_MLS_OBS) + ! Read MLS O3 Precision array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/L2gpPrecision' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_O3_STD, data_dims, error) + + CALL h5dclose_f(dset_id,error) + + ! Read Quality array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Quality' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_MAIN_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Status array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Status' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_STA_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read ChunkNumber array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/ChunkNumber' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CN, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read LineofSightAngle array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/LineOfSightAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_VIEW_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + ! Read Solar zenith Angle array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_SOLAR_ZENITH, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + ! Read Convergence quality array + + DSET_NAME= '/HDFEOS/SWATHS/O3/Data Fields/Convergence' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_CON_QUAL, (/data_dims(2),0/), error) + + CALL h5dclose_f(dset_id,error) + + DSET_NAME= '/HDFEOS/SWATHS/O3/Geolocation Fields/Pressure' + + CALL h5dopen_f(file_id, DSET_NAME, dset_id, error) + + CALL h5dread_f(dset_id, H5T_NATIVE_DOUBLE, MLS_PRESSURE, (/data_dims(1),0/), error) + + CALL h5dclose_f(dset_id,error) + ! close HDF5 file + + CALL h5fclose_f(file_id,error) + + ! close HDF5 interface + + CALL h5close_f(error) + + + END SUBROUTINE READ_MLS_O3_FILE +!-----------------------------------------------------------------------------! + SUBROUTINE CALC_MLS_O3_FORCE + +!! +!! Subroutine CALC_OMI_O3_FORCE computes the O3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_HOUR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,K,L + INTEGER :: I_MLS, J_MLS, JLOOP + INTEGER :: IIJJ(2) + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_O3(LLPAR) + REAL*8 :: GC_O3_ADJ(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_O3_COL + REAL*8 :: CM22DU + REAL*8 :: DIFF + REAL*8 :: OBS_ERROR + REAL*8 :: GC_PRES(LLPAR) + + REAL*8 :: MLS_O3_GC(LLPAR) + REAL*8 :: MLS_O3_GC_STD(LLPAR) + REAL*8 :: NCP(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(LLPAR) + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_DIFF(IIPAR,JJPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'gc_press_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 761, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 762, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 763, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_adj_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 764, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 765, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 766, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'obs_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 769, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'err_mls.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 762, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ENDIF + + ! Loop through data to find observations + + CM22DU = 2.69E16 ! conversion factor for DU -> #/cm2 + + GC_HOUR = GET_HOUR() + + ! initialize needed arrays and variables + + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_O3 = 0d0 + GC_O3_ADJ = 0d0 + GC_O3_COL = 0d0 + MLS_O3_GC = 0d0 + MLS_O3_GC_STD = 0d0 + NCP = 0d0 + SOBS_COUNT = 0d0 + SOBS_DIFF = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + GC_ADJ_COUNT = 0d0 + + DO I_MLS=1, N_MLS_OBS + IF(MLS_TIME(I_MLS)>0) THEN + ! There is an observation in the MLS grid box. + ! Check if it was made within the current hour. + tai93 = MLS_TIME(I_MLS) + + ! Convert TAI93 to UTC + CALL TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + ( MLS_STA_QUAL(I_MLS) < 250 ) .AND. & + ( ABS(MLS_LAT(I_MLS)) < 75d0 ) .AND. & + !( MLS_SOLAR_ZENITH(I_MLS) < 75d0 ) .AND. & + ( MLS_MAIN_QUAL(I_MLS) > 1.0 ) .AND. & + ( MLS_CON_QUAL(I_MLS) < 1.03 ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(MLS_LON(I_MLS),4),REAL(MLS_LAT(I_MLS),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM O3 values + + GC_O3 = 0d0 + GC_O3_COL = 0d0 + MLS_O3_GC = 0d0 + MLS_O3_GC_STD = 0d0 + NCP = 0d0 + COST_CONTRIB = 0d0 + + DO L = 1, LLPAR + + GC_PRES(L) = GET_PCENTER(I,J,L) + + ! CHK_STT is in units of [kg/box] here, convert to ppb + IF( ( GET_PCENTER(I,J,L) < 215 ) .AND. ( GET_PCENTER(I,J,L) > 10 ) ) THEN + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) + + DO J_MLS = 1, N_MLS_ALT + IF( ( MLS_PRESSURE(J_MLS) >= GET_PEDGE(I,J,L+1) ) .AND. & + ( MLS_PRESSURE(J_MLS) < GET_PEDGE(I,J,L) ) .AND. & + ( MLS_PRESSURE(J_MLS) < 215 ) .AND. & + ( MLS_PRESSURE(J_MLS) > 10 ) .AND. & + ( MLS_O3(J_MLS,I_MLS) > 0 ) ) THEN + + MLS_O3_GC(L) = MLS_O3_GC(L) + MLS_O3(J_MLS,I_MLS) + + MLS_O3_GC_STD(L) = MLS_O3_GC_STD(L) + MLS_O3_STD(J_MLS,I_MLS)**2 + + NCP(L) = NCP(L) + 1 + ENDIF + ENDDO + IF (NCP(L)>0) THEN + + MLS_O3_GC(L) = MLS_O3_GC(L)/NCP(L) + !PRINT *, "MLS_O3_GC", MLS_O3_GC(L) + MLS_O3_GC_STD(L) = (MLS_O3_GC_STD(L)**(0.5))/NCP(L) + OBS_ERROR = MLS_O3_GC_STD(L) + !OBS_ERROR(L) = 0.2 * MLS_O3_GC(L) + DIFF = GC_O3(L) - MLS_O3_GC(L) + PRINT *, "GC_O3", GC_O3(L) + PRINT *, "MLS_O3_GC", MLS_O3_GC(L) + !PRINT *, "DIFF(L)", DIFF(L) + !PRINT *, "OBS_ERROR(L)", OBS_ERROR(L) + COST_CONTRIB(L) = 0.5 * (DIFF/OBS_ERROR)**2 + IF ( ( COST_CONTRIB(L) > 0d0) .AND. & + ( COST_CONTRIB(L) < 200d0) .AND. & + ( GET_PCENTER(I,J,L) < 215 ) .AND. & + ( GET_PCENTER(I,J,L) > 10 ) ) THEN + + IF (SUPER_OBS) THEN + SOBS_DIFF(I,J) = SOBS_DIFF(I,J) + DIFF + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1 + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF/(OBS_ERROR**2) * TCVV(IDTOX) / AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + +110 FORMAT(F18.6,1X) + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L = 1,LLPAR + IF( ( GET_PCENTER(I,J,L) < 215 ) .AND. & + ( GET_PCENTER(I,J,L) > 10 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ENDIF + + !PRINT *, "STT_ADJ AFTER MLS O3", SOBS_ADJ_FORCE + PRINT *, "COST FUNCTION OF MLS O3", COST_FUNC + + END SUBROUTINE CALC_MLS_O3_FORCE + +!----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_MLS + + IF (ALLOCATED( MLS_LON )) DEALLOCATE( MLS_LON ) + IF (ALLOCATED( MLS_LAT )) DEALLOCATE( MLS_LAT ) + IF (ALLOCATED( MLS_TIME )) DEALLOCATE( MLS_TIME ) + IF (ALLOCATED( MLS_O3 )) DEALLOCATE( MLS_O3 ) + IF (ALLOCATED( MLS_O3_STD )) DEALLOCATE( MLS_O3_STD ) + IF (ALLOCATED( MLS_CON_QUAL )) DEALLOCATE( MLS_CON_QUAL ) + IF (ALLOCATED( MLS_MAIN_QUAL )) DEALLOCATE( MLS_MAIN_QUAL ) + IF (ALLOCATED( MLS_STA_QUAL )) DEALLOCATE( MLS_STA_QUAL ) + IF (ALLOCATED( MLS_CN )) DEALLOCATE( MLS_CN ) + IF (ALLOCATED( MLS_SOLAR_ZENITH )) DEALLOCATE( MLS_SOLAR_ZENITH ) + IF (ALLOCATED( MLS_VIEW_ZENITH )) DEALLOCATE( MLS_VIEW_ZENITH ) + IF (ALLOCATED( MLS_PRESSURE )) DEALLOCATE( MLS_PRESSURE ) + + END SUBROUTINE CLEANUP_MLS + +!-----------------------------------------------------------------------------! + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=7 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + +END MODULE MLS_O3_OBS_MOD + diff --git a/code/obs_operators/modis_aod_obs_mod.f b/code/obs_operators/modis_aod_obs_mod.f new file mode 100644 index 0000000..cb9b5bf --- /dev/null +++ b/code/obs_operators/modis_aod_obs_mod.f @@ -0,0 +1,822 @@ +!$Id: modis_aod_obs_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE MODIS_AOD_OBS_MOD +! +!****************************************************************************** +! Mdoule MODIS_AOD_OBS_MOD contains subroutines necessary to +! 1. READ modis aot observations (Wang et al., 2010), and apriori +! 2. COMPUTE MOIDS-CEOS-Chem difference, cost function, and adj forcing +! +! (xxu, 7/20/10, 5/17/11) +! Added to standard code (xxu, dkh, 01/12/12, adj32_011) +! +! Module Variables: +! ============================================================================ +! ( 1) NSPECI (INTEGER) : # of aerosol species included for adjoint +! ( 2) NLEV (INTEGER) : # of obs layers +! ( 3) MAXMODIS (INTEGER) : Max # of obs per day, used for array defining +! ( 4) MODIS (TYPE ) : Record data from each MODIS obs +! ( ) IDT_MODIS (INTEGER) : Available modis obs tracers' id +! +! Module Routines: +! ============================================================================ +! (1) READ_MODIS_AOD_OBS : Read modis obs from netCDF file +! (2) CALC_MODIS_AOD_FORCE : Calculates cost function, obs forcing +! (3) CHECK : Check status for calling netCDF +! (4) GET_NT_RANGE : Return the obs range for current hour +! (5) PCENTL() : Function calculating percentiles +! (6) HPSORT : Sort an array by Heapsort method +! +! ============================================================================ +! NOTES: +! (1) This module is copied and adapted from Daven Henze's 'tes_o3_mod.f', +! which is the operator calculating the adjoint forcing from the TES O3 +! observations. (xxu, 7/20/10) +! (2) Initial code was designed for pixel-based MODIS observations. Here is +! modified for those observation aggregated to each grid-box, to aviod +! wired single observation values. (xxu,9/9/10) +! (3) Now only consider the troposhere by using ITS_IN_THE_TROP from +! tropopause_mod.f. (xxu, 6/14/11) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "aerosol_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CALC_MODIS_AOD_FORCE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: MAX_MODIS_TRC = 11 + INTEGER, PARAMETER :: MAX_MODIS_OBS = 500 + INTEGER, PARAMETER :: NSPECI = 11 + INTEGER, PARAMETER :: NLEV = 47 + INTEGER, PARAMETER :: MAXMODIS = 500 + REAL*8, PARAMETER :: OBS_CUTOFF = 1d-3 + + ! Variables + INTEGER :: IDT_MODIS(MAX_MODIS_TRC) + + ! Record to store data from each MODIS obs + TYPE MODIS_AOD_OBS + REAL :: LAT(1) + REAL :: LON(1) + REAL :: TIME(1) + REAL*8 :: SFactor(1) ! Ratio of obs to model + REAL*8 :: AP_MODIS (NLEV,MAX_MODIS_TRC) ! a priori + REAL*8 :: OBS_MODIS(NLEV,MAX_MODIS_TRC) ! Observations + REAL*8 :: OER_INV (NLEV,MAX_MODIS_TRC) ! diagnal elements + ENDTYPE MODIS_AOD_OBS + + TYPE(MODIS_AOD_OBS) :: MODIS(MAX_MODIS_OBS) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_MODIS_AOD_OBS +! +!****************************************************************************** +! Subourtine INIT_MODIS_AOD_OBS initialize the MODIS aerosol operator: +! (1) Assign available modis obs tracers to array IDT_MODIS +! (2) Check if the used obs are exactly same to those specified by the +! adjoint input files +! (xxu, 6/28/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE TRACER_MOD, ONLY : TRACER_NAME + USE TRACERID_MOD, ONLY : IDTSO4, IDTNH4, IDTNIT + USE TRACERID_MOD, ONLY : IDTBCPI, IDTOCPI, IDTBCPO, IDTOCPO + USE TRACERID_MOD, ONLY : IDTDST1, IDTDST2, IDTDST3, IDTDST4 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER, NOBS + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Local variables + INTEGER :: T, TT, COUNTER_TRC + + !================================================================ + ! INIT_MODIS_AOD_OBS begins here! + !================================================================ + + ! Assign tracers id to IDT_MODIS + IDT_MODIS( 1) = IDTSO4 + IDT_MODIS( 2) = IDTNH4 + IDT_MODIS( 3) = IDTNIT + IDT_MODIS( 4) = IDTBCPI + IDT_MODIS( 5) = IDTOCPI + IDT_MODIS( 6) = IDTBCPO + IDT_MODIS( 7) = IDTOCPO + IDT_MODIS( 8) = IDTDST1 + IDT_MODIS( 9) = IDTDST2 + IDT_MODIS(10) = IDTDST3 + IDT_MODIS(11) = IDTDST4 + + ! Initialize the obs counter + COUNTER_TRC = 0 + + ! Start modis tracer loop + DO T = 1, MAX_MODIS_TRC + + ! Global tracer ID + TT = IDT_MODIS(T) + + ! Selected tracers to be obs? + IF ( OBS_THIS_TRACER ( TT ) ) THEN + + WRITE( 6, 100 ) TT, TRACER_NAME( TT ) + COUNTER_TRC = COUNTER_TRC + 1 + + ENDIF + + ! Finish modis tracer loop: T + ENDDO + + ! Check if the counted obs equals to that specified + WRITE( 6, 110 ) COUNTER_TRC + IF ( COUNTER_TRC /= NOBS ) + & CALL ERROR_STOP( 'Error: selected modis obs tracer =/ NOBS', + & 'init_modis_aer_obs (modis_aer_obs_mod.f)' ) + + + 100 FORMAT( 3x, 'Used MODIS obs tracers: ', I4, 3x, A6) + 110 FORMAT( 3x, '# of selected MODIS obs: ', I4 ) + + ! Return to the calling routine + END SUBROUTINE INIT_MODIS_AOD_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_MODIS_AOD_OBS( YYYYMMDD, NMODIS ) +! +!****************************************************************************** +! Subroutine READ_MODIS_AOD_OBS reads the file and passes back info contained +! therein. (xxu, 02/19/09) +! +! Based on READ_TES_O3_OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD (INTEGER) : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NMODIS (INTEGER) : Number of MODIS retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) MODIS (MODIS_AOD_OBS) : TES retrieval for current day +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + ! Arguments + INTEGER, INTENT( IN) :: YYYYMMDD + INTEGER, INTENT(OUT) :: NMODIS + + ! Local variables + INTEGER :: FID, NM_ID + INTEGER :: TIME_ID, LON_ID, LAT_ID + INTEGER :: AOD1_ID, AOD2_ID, AOD3_ID, EOR_ID + INTEGER :: SO4_ID, NH4_ID, NIT_ID + INTEGER :: BCPI_ID, OCPI_ID, BCPO_ID, OCPO_ID + INTEGER :: DST1_ID, DST2_ID, DST3_ID, DST4_ID +! INTEGER :: START0(1), COUNT0(1) +! INTEGER :: START1(2), COUNT1(2) +! INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, L, T + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + + REAL :: EOR_FRAC, EFR_IN + REAL, ALLOCATABLE :: TMP1(:) + REAL, ALLOCATABLE :: TMP2(:,:) + REAL*8 :: TMP_OER_INV + + !================================================================= + ! READ_MODIS_AOD_OBS begins here! + !================================================================= + + ! filename root + READ_FILENAME = TRIM( 'modis_aod_obs_2x25_YYYYMMDD.nc' ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + READ_FILENAME = TRIM( DATA_DIR ) // 'MODIS_AOD_OBS_201009/' // + & TRIM( READ_FILENAME ) + + ! Print to screen + WRITE(6,100) TRIM(READ_FILENAME) + 100 FORMAT(' - READ_MODIS_AOD_OBS: reading file: ', A ) + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "hhmm", NM_ID), 101 ) + CALL CHECK( NF90_INQ_VARID( FID, "obserrorfrac", EOR_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "dayfrc", TIME_ID), 103 ) + CALL CHECK( NF90_INQ_VARID( FID, "lon", LON_ID), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "lat", LAT_ID), 105 ) + CALL CHECK( NF90_INQ_VARID( FID, "gc_aod", AOD1_ID), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "ret_aod", AOD2_ID), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "modis_aod", AOD3_ID), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "SO4_GC", SO4_ID), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "NH4_GC", NH4_ID), 110 ) + CALL CHECK( NF90_INQ_VARID( FID, "NIT_GC", NIT_ID), 111 ) + CALL CHECK( NF90_INQ_VARID( FID, "BCPI_GC", BCPI_ID), 112 ) + CALL CHECK( NF90_INQ_VARID( FID, "OCPI_GC", OCPI_ID), 113 ) + CALL CHECK( NF90_INQ_VARID( FID, "BCPO_GC", BCPO_ID), 114 ) + CALL CHECK( NF90_INQ_VARID( FID, "OCPO_GC", OCPO_ID), 115 ) + CALL CHECK( NF90_INQ_VARID( FID, "DST1_GC", DST1_ID), 116 ) + CALL CHECK( NF90_INQ_VARID( FID, "DST2_GC", DST2_ID), 117 ) + CALL CHECK( NF90_INQ_VARID( FID, "DST3_GC", DST3_ID), 118 ) + CALL CHECK( NF90_INQ_VARID( FID, "DST4_GC", DST4_ID), 119 ) + + !-------------------------------- + ! Read dimensions + !-------------------------------- + + ! READ number of retrievals, NMODIS + CALL CHECK( NF90_INQUIRE_DIMENSION(FID, NM_ID, TMP, NMODIS), 201) + + ! Print to screen + WRITE(6,110) NMODIS + 110 FORMAT(' NMODIS = ', I6) + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! READ observation error fraction + CALL CHECK( NF90_GET_VAR ( FID, EOR_ID, EOR_FRAC ), 300) + + ! Print to screen + WRITE(6,120) EOR_FRAC + 120 FORMAT(' OBS ERROR FRACTION = ', F10.4) + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! allocate temporal arrays for 1D data + ALLOCATE ( TMP1 (NMODIS) ) + TMP1 = 0 + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LAT_ID, TMP1 ), 301) + MODIS(1:NMODIS)%LAT(1) = TMP1(1:NMODIS) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LON_ID, TMP1 ), 302) + MODIS(1:NMODIS)%LON(1) = TMP1(1:NMODIS) + + ! READ time + CALL CHECK( NF90_GET_VAR ( FID, TIME_ID, TMP1 ), 303) + MODIS(1:NMODIS)%TIME(1) = TMP1(1:NMODIS) + + ! READ AODs and calculate the ratio of obs to model + CALL CHECK( NF90_GET_VAR ( FID, AOD1_ID, TMP1 ), 304) + MODIS(1:NMODIS)%SFACTOR(1) = TMP1(1:NMODIS) + CALL CHECK( NF90_GET_VAR ( FID, AOD2_ID, TMP1 ), 305) + MODIS(1:NMODIS)%SFACTOR(1) = TMP1(1:NMODIS) + & / MODIS(1:NMODIS)%SFACTOR(1) + + ! To avoid wired ratios + DO N = 1, NMODIS + IF ( MODIS(N)%SFACTOR(1) < 0.5 ) MODIS(N)%SFACTOR(1) = 0.5 + IF ( MODIS(N)%SFACTOR(1) > 10.0 ) MODIS(N)%SFACTOR(1) = 10.0 + ENDDO + + !-------------------------------- + ! Read 2D Data + !-------------------------------- + + ! allocate temporal arrays for 2D data + ALLOCATE ( TMP2 (NMODIS,NLEV) ) + TMP2 = 0 + + ! READ SO4 A Priori + CALL CHECK( NF90_GET_VAR ( FID, SO4_ID, TMP2 ), 401) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,1) = TMP2(1:NMODIS,L) + ENDDO + + ! READ NH4 A Priori + CALL CHECK( NF90_GET_VAR ( FID, NH4_ID, TMP2 ), 402) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,2) = TMP2(1:NMODIS,L) + ENDDO + + ! READ NIT A Priori + CALL CHECK( NF90_GET_VAR ( FID, NIT_ID, TMP2 ), 403) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,3) = TMP2(1:NMODIS,L) + ENDDO + + ! READ BCPI A Priori + CALL CHECK( NF90_GET_VAR ( FID, BCPI_ID, TMP2 ), 404) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,4) = TMP2(1:NMODIS,L) + ENDDO + + ! READ OCPI A Priori + CALL CHECK( NF90_GET_VAR ( FID, OCPI_ID, TMP2 ), 405) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,5) = TMP2(1:NMODIS,L) + ENDDO + + ! READ BCPO A Priori + CALL CHECK( NF90_GET_VAR ( FID, BCPO_ID, TMP2 ), 406) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,6) = TMP2(1:NMODIS,L) + ENDDO + + ! READ OCPO A Priori + CALL CHECK( NF90_GET_VAR ( FID, OCPO_ID, TMP2 ), 407) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,7) = TMP2(1:NMODIS,L) + ENDDO + + ! READ DST1 A Priori + CALL CHECK( NF90_GET_VAR ( FID, DST1_ID, TMP2 ), 408) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,8) = TMP2(1:NMODIS,L) + ENDDO + + ! READ DST2 A Priori + CALL CHECK( NF90_GET_VAR ( FID, DST2_ID, TMP2 ), 409) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,9) = TMP2(1:NMODIS,L) + ENDDO + + ! READ DST3 A Priori + CALL CHECK( NF90_GET_VAR ( FID, DST3_ID, TMP2 ), 410) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,10) = TMP2(1:NMODIS,L) + ENDDO + + ! READ DST4 A Priori + CALL CHECK( NF90_GET_VAR ( FID, DST4_ID, TMP2 ), 411) + DO L = 1, NLEV + MODIS(1:NMODIS)%AP_MODIS(L,11) = TMP2(1:NMODIS,L) + ENDDO + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + ! deallocate arrays + IF ( ALLOCATED(TMP1) ) DEALLOCATE( TMP1 ) + IF ( ALLOCATED(TMP2) ) DEALLOCATE( TMP2 ) + + !================================================================ + ! Calculate MODIS obs: obs = apriori * sfactor + !================================================================ + DO L = 1, NLEV + DO T = 1, MAX_MODIS_TRC + MODIS(1:NMODIS)%OBS_MODIS(L,T) = MODIS(1:NMODIS)%AP_MODIS(L,T) + & * MODIS(1:NMODIS)%SFACTOR(1) + ENDDO + ENDDO + + !================================================================ + ! obs error covriance maxtrices and their inverse + !================================================================ + + !---------------------------------------------------------------- + ! NOTE: + ! (1) from inverse error fraction to absolute error + ! OER_INV = err^(-2) = ( obs * err_frac )^(-2) + ! (2) put a cap on the error + ! if (obs <= 0.001) OER_INV = 1d0 + ! if (obs > 0.001) OER_INV = MIN(25d0, OER_INV) + !---------------------------------------------------------------- + + ! Inverse of error fraction square + EFR_IN = 1.d0 / EOR_FRAC / EOR_FRAC + + ! Calculate the obs error inverse matrix + DO N = 1, NMODIS + DO L = 1, NLEV + DO T = 1, MAX_MODIS_TRC + + ! Only consider + IF ( MODIS(N)%OBS_MODIS(L,T) >= OBS_CUTOFF ) THEN + TMP_OER_INV = EFR_IN / MODIS(N)%OBS_MODIS(L,T) + MODIS(N)%OER_INV(L,T) = MIN( 25d0, TMP_OER_INV ) + ELSE + MODIS(N)%OER_INV(L,T) = 1d0 + ENDIF + + ENDDO + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE READ_MODIS_AOD_OBS +! +!------------------------------------------------------------------------------ +! + SUBROUTINE CALC_MODIS_AOD_FORCE( COST_FUNC ) + +!****************************************************************************** +! Subroutine CALC_MODIS_AOD_FORCE calculates the adjoint frocing from the MODIS +! retrieval (Wang et al., 2010) and the cost function. (xxu, 7/20/10) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! NOTES: +! (1 ) This subroutine is adopted from Daven's "CALC_TES_O3_FORCE", which is +! for TES O3. (xxu, 7/20/10) +! +!****************************************************************************** + + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, STT_ADJ, EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : CSPEC, JLOP + USE DAO_MOD, ONLY : AD, AIRDEN + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TS_CHEM + USE TRACER_MOD, ONLY : TCVV, TRACER_NAME + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER,SAVE :: N_MODIS_OBS + INTEGER,SAVE :: MODIS_TIME(MAX_MODIS_OBS) + LOGICAL,SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: MODIS_DAYFRC(MAX_MODIS_OBS) + + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J, L, N + INTEGER :: T, TT, NSP + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + REAL*8 :: NEW_COST(MAX_MODIS_OBS) + REAL*8 :: OLD_COST + REAL*8 :: H_GC(NLEV, MAX_MODIS_TRC) + REAL*8 :: DIFF(NLEV, MAX_MODIS_TRC) + REAL*8 :: FORCE(NLEV, MAX_MODIS_TRC) + REAL*8 :: DIFF_ADJ(NLEV, MAX_MODIS_TRC) + + !================================================================= + ! CALC_MODIS_AOD_FORCE begins here! + !================================================================= + + print*, ' - CALC_MODIS_AOD_FORCE: MODIS AOD forcing ' + + ! Initialize + CALL INIT_MODIS_AOD_OBS + + ! Reset + NEW_COST = 0D0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + + ! Start modis tracer loop + DO T = 1, MAX_MODIS_TRC + + TT = IDT_MODIS(T) + IF ( OBS_THIS_TRACER( TT ) ) THEN + FILENAME = 'debug_'//TRIM(TRACER_NAME(TT))//'_ITRNN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM(DIAGADJ_DIR) // TRIM(FILENAME) + OPEN( 100+T, FILE=TRIM(FILENAME), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Finish modis tracer loop: T + ENDDO + + ENDIF ! FIRST + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the MODIS obs file for this day + CALL READ_MODIS_AOD_OBS( GET_NYMD(), N_MODIS_OBS ) + + ! Day fraction. + DO N = 1, N_MODIS_OBS + MODIS_DAYFRC(1:N) = MODIS(1:N)%TIME(1) + ENDDO + + ENDIF + + ! Get the range of MODIS retrievals for the current hour + CALL GET_NT_RANGE( N_MODIS_OBS, GET_NHMS(), + & MODIS_DAYFRC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + PRINT*, ' No matching MODIS obs for this hour: ', GET_NHMS() + RETURN + ENDIF + + PRINT*, ' For hour range: ', GET_NHMS(), MODIS_DAYFRC(NTSTART), + & MODIS_DAYFRC(NTSTOP) + PRINT*, ' found record range: ', NTSTART, NTSTOP + + ! loop for this GC hour + DO NT = NTSTART, NTSTOP, -1 + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(MODIS(NT)%LON(1),4), + & REAL(MODIS(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + H_GC(:,:) = 0d0 + DIFF(:,:) = 0d0 + + ! modeled profile (convert units from kg/box to ppbv) + DO L = 1, NLEV + DO T = 1, MAX_MODIS_TRC + + ! Tracer id + TT = IDT_MODIS(T) + + ! Check if this is an obs tracer + IF ( OBS_THIS_TRACER( TT ) ) THEN + + ! GC simulation on the Observation space + H_GC(L,T) = CHK_STT(I,J,L,TT) * TCVV(TT) + & * 1d9 / AD(I,J,L) + + ! Difference of observations from model simulation + DIFF(L,T) = H_GC(L,T) - MODIS(NT)%OBS_MODIS(L,T) + + ! Adjoint forcing: S_{obs}^{-1} * DIFF + FORCE(L,T) = MODIS(NT)%OER_INV(L,T) * DIFF(L,T) + + ! Contribution to the cost function: + ! 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + NEW_COST(NT) = NEW_COST(NT) + .5d0*DIFF(L,T)*FORCE(L,T) + + ! Now pass the adjoint back to the adjoint tracer array + DIFF_ADJ(L,T) = FORCE(L,T) + STT_ADJ(I,J,L,TT) = STT_ADJ(I,J,L,TT) + DIFF_ADJ(L,T) + & * TCVV(TT) * 1d9 / AD(I,J,L) + + ! Debug -xxu + WRITE(100+T, 110) NT, I, J, L, + & H_GC(L,T), + & MODIS(NT)%AP_MODIS(L,T), + & MODIS(NT)%OBS_MODIS(L,T), + & MODIS(NT)%SFACTOR(1), + & MODIS(NT)%OER_INV(L,T), + & FORCE(L,T), + & NEW_COST(NT), + & STT_ADJ(I,J,L,TT) + + ENDIF + + ENDDO + ENDDO + +110 FORMAT(4I6,1P8d10.2) + + ! finish NT loop + ENDDO ! NT + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' MODIS AOD contribution = ', COST_FUNC - OLD_COST + + ! Reset + IF ( FIRST ) FIRST = .FALSE. + + ! debug + print*, ' MAX STT_ADJ = ', MAXVAL(STT_ADJ(:,:,:,:)) + print*, ' MAX in = ', MAXLOC(STT_ADJ(:,:,:,:)) + print*, ' MAX NEW_COST = ', MAXVAL(NEW_COST) + print*, ' MAX cost in = ', MAXLOC(NEW_COST) + + ! Return to calling program + END SUBROUTINE CALC_MODIS_AOD_FORCE +! +!------------------------------------------------------------------------------ +! + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'modis_aod_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK +! +!------------------------------------------------------------------------------ +! + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + ! for debug only, need to change back to above line when oneline + !IF ( HHMMSS == 230000 ) NTSAVE = NTES + + print*, ' GET_NT_RANGE for ', HHMMSS + print*, ' NTSAVE ', NTSAVE + print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE +! +!------------------------------------------------------------------------------ +! + END MODULE MODIS_AOD_OBS_MOD diff --git a/code/obs_operators/mopitt_obs_mod.f b/code/obs_operators/mopitt_obs_mod.f new file mode 100644 index 0000000..adc9f40 --- /dev/null +++ b/code/obs_operators/mopitt_obs_mod.f @@ -0,0 +1,1671 @@ + MODULE MOPITT_OBS_MOD +!***************************************************************************** +! Module MOPITT_OBS_MOD contains all the subroutines for the using of MOPITT +! observation (version 3 and version 4).(zhe 1/19/11) +! Remove the support to MOPITT v3 and v4. Now support v5 and v6. (Zhe 1/20/14) +! Module Routines: +! ============================================================================ +! (1 ) READ_MOPITT_FILE : Read MOPITT hdf file +! (2 ) CALC_MOPITT_FORCE : Calculates cost function and STT_ADJ increments +! (3 ) CALC_AVGKER : Construct the averging kernel matrix +! (4 ) BIN_DATA : Interpolation between different vertical resolutions +! (5 ) INIT_DOMAIN : Define the observation window +! (6 ) CALC_OBS_HOUR : Calculated hour of morning obs +! (7 ) ITS_TIME_FOR_MOPITT_OBS: FUNCTION that checks time vs. OBS_HOUR array +! (8 ) READ_MOP02 : Reads MOPITT data fields from the HDF-EOS file +! (9) INFO_MOP02 : Prints name, dims, type, etc. of MOPITT data fields +! (10) CLEANUP_MOP02 : Deallocates all module arrays +! ============================================================================= + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "../adjoint/define_adj.h" + + PRIVATE + + PUBLIC OBS_HOUR_MOPITT + PUBLIC COUNT_TOTAL + PUBLIC ITS_TIME_FOR_MOPITT_OBS + PUBLIC READ_MOPITT_FILE + PUBLIC CALC_MOPITT_FORCE + + !============================================================================= + ! MODULE VARIABLES + !============================================================================= + + INTEGER :: OBS_HOUR_MOPITT(IIPAR,JJPAR) + INTEGER :: DOMAIN_OBS(IIPAR,JJPAR) + REAL*8 :: COUNT_TOTAL + + REAL*4 :: ERR_PERCENT(IIPAR,JJPAR) + REAL*4, ALLOCATABLE :: A(:,:) + REAL*4, ALLOCATABLE :: T(:) + REAL*4, ALLOCATABLE :: XA(:) + REAL*8, ALLOCATABLE :: AC(:) + + ! MOPITT dimension fields + INTEGER :: T_DIM, Z_DIM + REAL*4, ALLOCATABLE :: LATITUDE(:) + REAL*4, ALLOCATABLE :: LONGITUDE(:) + REAL*4, ALLOCATABLE :: PRESSURE(:) + REAL*4, ALLOCATABLE :: SECONDS_IN_DAY(:) + REAL*4, ALLOCATABLE :: MOPITT_GMT(:) + REAL*8, ALLOCATABLE :: TAU(:) + + ! MOPITT data quantities + REAL*4, ALLOCATABLE :: BOTTOM_PRESSURE(:) + REAL*4, ALLOCATABLE :: CO_MIXING_RATIO(:,:,:) + REAL*4, ALLOCATABLE :: CO_RET_BOT_MIXING_RATIO(:,:) + REAL*4, ALLOCATABLE :: CO_TOTAL_COLUMN(:,:) + REAL*4, ALLOCATABLE :: AVGKER(:,:,:) + REAL*4, ALLOCATABLE :: RET_ERR_COV(:,:,:) + INTEGER, ALLOCATABLE :: CLOUD_DES(:) + INTEGER, ALLOCATABLE :: SURFACE_INDEX(:) + + ! MOPITT a priori + INTEGER :: NLEV_AP + REAL*4, ALLOCATABLE :: PLEV_AP(:) + REAL*4, ALLOCATABLE :: CO_MR_AP(:,:,:) + REAL*4, ALLOCATABLE :: CO_MR_AP_BOTTOM(:,:) + + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_MOPITT_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_MOPITT_FILE reads the MOPITT hdf file. +! (mak, 7/12/07, zhe 1/19/11) +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +!****************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, AS + CHARACTER(LEN=255) :: DIR_MOPITT + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: FILENAMEM + CHARACTER(LEN=255) :: FILENAME2 + LOGICAL :: IT_EXISTS + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! READ_MOPITT_FILE begins here! + !================================================================= +#if defined( MOPITT_V5_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v5/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V10.1.3.beta.hdf' +#endif +#if defined( MOPITT_V6_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v6/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V16.2.3.he5' +#endif +#if defined( MOPITT_V7_CO_OBS ) + DIR_MOPITT = '/users/jk/15/xzhang/MOPITT/' + DIR_MONTH = 'YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V17.9.3.he5' +#endif + + IF ( FIRST ) THEN + ERR_PERCENT(:,:) = 0.0 + COUNT_TOTAL = 0 + FIRST = .FALSE. + ENDIF + + OBS_HOUR_MOPITT(:,:) = -99 + + CALL EXPAND_DATE( FILENAMEM, YYYYMMDD, 0 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 0 ) + + FILENAME2 = TRIM( DIR_MOPITT ) // TRIM( DIR_MONTH ) // FILENAMEM + PRINT*, '=== Reading ===:', TRIM( FILENAME2 ) + + INQUIRE( FILE = FILENAME2, EXIST = IT_EXISTS ) + IF (IT_EXISTS) THEN + + !CALL INFO_MOP02(FILENAME2) + + CALL READ_MOP02( FILENAME2 ) + + CALL INIT_DOMAIN + + ! Calculate hour of day when obs should be compared to model + CALL CALC_OBS_HOUR + + ENDIF + + !CALL READ_ERROR_VARIANCE + !We assume 20% uniform observation error + ERR_PERCENT(:,:) = 0.1/LOG(10d0) + + END SUBROUTINE READ_MOPITT_FILE +!------------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_MOPITT_FORCE + +!****************************************************************************** +! CALC_MOPITT_FORCE calculate cost function and STT_ADJ increments +! (zhe 1/19/11) +!****************************************************************************** + + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_AP, GET_BP + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, GET_YEAR + USE TIME_MOD, ONLY : GET_HOUR + USE CHECKPT_MOD, ONLY : CHK_STT + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDTCO + USE DAO_MOD, ONLY : AD, IS_LAND + USE ADJ_ARRAYS_MOD, ONLY : SET_FORCING, SET_MOP_MOD_DIFF, + & SET_MODEL_BIAS, SET_MODEL, SET_OBS, + & COST_ARRAY, DAY_OF_SIM, IFD, JFD, LFD, NFD, + & COST_FUNC, ADJ_FORCE, STT_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD, LDCOSAT + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY: DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY: N_CALC, EXPAND_NAME + USE TROPOPAUSE_MOD, ONLY: ITS_IN_THE_TROP + + LOGICAL, SAVE :: SECOND = .TRUE. + CHARACTER(LEN=255) :: FILENAME + + ! Local Variables + INTEGER :: W, I, J, Z, ZZ, L,LL + INTEGER :: LON15, IIJJ(2) + INTEGER :: NLEV_RET + + REAL*4 :: RETLEV(Z_DIM+1) + REAL*8 :: P_EDGE(Z_DIM+2), MODEL_COL, MOPITT_COL + REAL*8 :: UTC, TAU0 + REAL*8 :: MODEL_P(LLPAR), MODEL_CO_MR(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: COUNT(IIPAR,JJPAR) + REAL*8 :: MOP_COL_GRID(IIPAR,JJPAR) + REAL*8 :: MODEL_COL_GRID(IIPAR,JJPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: ADJ_F(LLPAR) + REAL*8 :: SY + REAL*8 :: MODEL_P_EDGE(LLPAR+1) + INTEGER :: IOS + REAL*8 :: DIFF_COST_COL + REAL*4 :: MOP_CO_BIAS(IIPAR,JJPAR,11) + REAL*4 :: MOP_BIAS_COUNT(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_BIAS_SOBS(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ_SOBS(IIPAR,JJPAR,11) + + REAL*8, ALLOCATABLE :: GEOS_RAW(:) + REAL*8, ALLOCATABLE :: MOP_CO(:) + REAL*8, ALLOCATABLE :: DIFF_ADJ(:) + REAL*8, ALLOCATABLE :: GEOS_CO(:) + REAL*8, ALLOCATABLE :: DIFF_COST(:) + REAL*8, ALLOCATABLE :: COST_CONTRIB(:) + + IF ( SECOND ) THEN + FILENAME = 'co_bias_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 201, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'co_chi_square_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 202, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lat_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 203, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lon_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 204, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_MOPITT_FORCE begins here! + !================================================================= + + TAU0 = GET_TAU0( GET_MONTH(), GET_DAY(), GET_YEAR() ) + + COUNT_GRID(:,:) = 0d0 + COUNT(:,:) = 0d0 + MOP_COL_GRID(:,:) = -999.0 + MODEL_COL_GRID(:,:) = -999.0 + ADJ_FORCE(:,:,:,:) = 0d0 + NEW_COST(:,:) = 0d0 + MOP_CO_BIAS(:,:,:) = 0d0 + MOP_BIAS_COUNT(:,:,:) = 0d0 + MOP_CO_CHI_SQ(:,:,:) = 0d0 + MOP_CO_BIAS_SOBS(:,:,:) = 0d0 + MOP_CO_CHI_SQ_SOBS(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + + !================================================================= + ! Loop over MOPITT data + !================================================================= + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + LON15 = LONGITUDE(W) / 15. + UTC = TAU(W) - TAU0 + LON15 + IF (UTC < 0. ) UTC = UTC + 24 + IF (UTC > 24.) UTC = UTC - 24 + + !Only consider day time MOPITT measurements + ! am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + ! Get grid box + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + !================================================================= + ! Data selection + !================================================================= + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & CLOUD_DES(W) == 2.0 .and. + & CO_TOTAL_COLUMN(1,W) > 5E17 .and. + & DOMAIN_OBS(I,J) == 1 ) THEN + +! IF ( (IS_LAND(I,J) .AND. +! & LATITUDE(W) .GE. -52 .AND. LATITUDE(W) .LE. 52 ) .OR. !52S-52N +! & (LATITUDE(W) .GE. -40 .AND. LATITUDE(W) .LE. 40) ) THEN !40S-40N + + RETLEV(:) = -999.0 + MODEL_COL = 0D0 + MOPITT_COL = 0D0 + + ! Create pressure profile + RETLEV(1) = BOTTOM_PRESSURE(W) + + ZZ = 0 + ! Loop over Mopitt levels + DO Z = 1, Z_DIM + ! Always start from the bottom pressure, + ! even if it means skipping a MOPITT pressure level + IF ( PRESSURE(Z) >= RETLEV(1) ) THEN + ZZ = ZZ + 1 + CYCLE + ENDIF + ! Save into profile + RETLEV(Z+1-ZZ) = PRESSURE(Z) + ENDDO + NLEV_RET = Z_DIM+1 - ZZ + + DO L = 1, NLEV_RET + P_EDGE(L) = RETLEV(L) + ENDDO + P_EDGE(NLEV_RET+1) = 36 + + ALLOCATE( XA( NLEV_RET ) ) + ALLOCATE( T( NLEV_RET ) ) + ALLOCATE( A( NLEV_RET,NLEV_RET ) ) + ALLOCATE( AC( NLEV_RET ) ) + ALLOCATE( MOP_CO( NLEV_RET ) ) + ALLOCATE( GEOS_RAW( NLEV_RET ) ) + ALLOCATE( DIFF_ADJ( NLEV_RET ) ) + ALLOCATE( GEOS_CO( NLEV_RET ) ) + ALLOCATE( DIFF_COST( NLEV_RET ) ) + ALLOCATE( COST_CONTRIB( NLEV_RET ) ) + + ! MOPITT CO vertical profile + MOP_CO(1) = CO_RET_BOT_MIXING_RATIO(1,W) + MOP_CO(2:NLEV_RET) = CO_MIXING_RATIO(1,11-NLEV_RET:9,W) + MOP_CO = MOP_CO * 1E-9 + + ! COMPUTE AVERAGING KERNEL + CALL CALC_AVGKER(NLEV_RET, W, RETLEV, MOP_CO) + + !USE MOPITT SURFACE PRESSURE + !DO L=1, LLPAR + 1 + ! MODEL_P_EDGE(L) = GET_AP(L) + GET_BP(L) * RETLEV(1) + !ENDDO + + DO L = 1, LLPAR + !MOPITT PRESSURE LEVEL + !MODEL_P(L) = (MODEL_P_EDGE(L) + MODEL_P_EDGE(L+1)) / 2 + + ! Get GC pressure levels (mbar) + MODEL_P(L) = GET_PCENTER(I,J,L) + + ! Obtain archieved forward model results + ! kg -> v/v + MODEL_CO_MR(L) = CHK_STT(I,J,L,IDTCO) * + & TCVV(IDTCO) / AD(I,J,L) + ENDDO + + ! Interplote the model to MOPITT vertical grids + CALL BIN_DATA(MODEL_P, P_EDGE, MODEL_CO_MR(:), + & GEOS_RAW, NLEV_RET, 1) + + !================================================================= + ! Apply MOPITT observation operator + !================================================================= + + ! Total Column: C = T * XA + AC * ( Xm - XA ) + ! Stratosphere Levels are removed + !DO L = 1, NLEV_RET + DO L = 1, NLEV_RET - 1 + MODEL_COL = MODEL_COL + & + T(L) * XA(L) + & + AC(L) * (LOG10(GEOS_RAW(L)) + & - LOG10(XA(L))) + !MOPITT_COL = MOPITT_COL + T(L) * MOP_CO(L) + ENDDO + + MOPITT_COL = CO_TOTAL_COLUMN(1,W) + + GEOS_CO(:) = 0d0 + ! Smoothed Profile: X_hat = XA + A * ( Xm - XA ) + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + GEOS_CO(L) = GEOS_CO(L) + & + A(L,LL) + & * (LOG10( GEOS_RAW(LL) ) - LOG10( XA(LL) )) + ENDDO + GEOS_CO(L) = LOG10( XA(L) ) + GEOS_CO(L) + ENDDO + + !================================================================= + ! COST FUNCTION + !================================================================= + DIFF_COST_COL = 0d0 + !SY = ( ERR_PERCENT(I,J) * MOPITT_COL )**2 + !DIFF_COST_COL = MODEL_COL - MOPITT_COL + !NEW_COST(I,J) = NEW_COST(I,J) + 0.5 * (DIFF_COST_COL ** 2) / SY + !COUNT(I,J) = COUNT(I,J) +1 + DIFF_COST(:) = 0D0 + COST_CONTRIB(:) = 0D0 + SY = ERR_PERCENT(I,J) **2 + DO L = 1, NLEV_RET - 1 + DIFF_COST(L) = GEOS_CO(L) - LOG10( MOP_CO(L) ) + COST_CONTRIB(L) = 0.5d0*(DIFF_COST(L)**2) / SY + IF (COST_CONTRIB(L) > 0d0) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + COUNT(I,J) = COUNT(I,J) + 1 + ENDIF + MOP_CO_BIAS(I,J,L) = MOP_CO_BIAS(I,J,L) + + & 10**(GEOS_CO(L)) - MOP_CO(L) + MOP_CO_CHI_SQ(I,J,L) = MOP_CO_CHI_SQ(I,J,L) + + & (DIFF_COST(L))**2/ SY + MOP_BIAS_COUNT(I,J,L) = MOP_BIAS_COUNT(I,J,L) + 1d0 + + ENDDO + !================================================================= + ! adjoint operator + !================================================================= + DIFF_ADJ(:) = 0D0 + !DO L = 1, NLEV_RET + !DIFF_ADJ(L) = DIFF_COST_COL * AC(L) / SY + !DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10.0)) + !ENDDO + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + DIFF_ADJ(L) = DIFF_ADJ(L) + & + A(LL,L) * DIFF_COST(LL) / SY + ENDDO + ! fwd code: LOG(GEOS_RAW) - LOG(XA) + ! mkeller: this is just plain wrong! + ! the forward code is LOG10(GEOS_RAW) - LOG10(XA) + ! a factor of 1/LOG(10) is missing + !DIFF_ADJ(L) = DIFF_ADJ(L) / GEOS_RAW(L) + DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10d0)) + ENDDO + + + CALL BIN_DATA( MODEL_P, P_EDGE, ADJ_F, + & DIFF_ADJ, NLEV_RET, -1 ) + + ! adjoint FORCE + DO L = 1, LLPAR + IF (ADJ_F(L) .NE. 0d0) THEN + !v/v->kg + ADJ_FORCE(I,J,L,IDTCO) = ADJ_FORCE(I,J,L,IDTCO) + & + ADJ_F(L) * TCVV(IDTCO)/ AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDDO + IF (NEW_COST(I,J) > 0d0) THEN + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1.d0 + ENDIF + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + MOPITT_COL + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + MODEL_COL + + IF ( ALLOCATED( GEOS_RAW ) ) DEALLOCATE( GEOS_RAW ) + IF ( ALLOCATED( MOP_CO ) ) DEALLOCATE( MOP_CO ) + IF ( ALLOCATED( DIFF_ADJ ) ) DEALLOCATE( DIFF_ADJ ) + IF ( ALLOCATED( A ) ) DEALLOCATE( A ) + IF ( ALLOCATED( AC ) ) DEALLOCATE( AC ) + IF ( ALLOCATED( T ) ) DEALLOCATE( T ) + IF ( ALLOCATED( XA ) ) DEALLOCATE( XA ) + IF ( ALLOCATED( GEOS_CO ) ) DEALLOCATE( GEOS_CO ) + IF ( ALLOCATED( DIFF_COST ) ) DEALLOCATE( DIFF_COST) + IF ( ALLOCATED(COST_CONTRIB) ) DEALLOCATE( COST_CONTRIB ) + + !ENDIF !IS_LAND + + ENDIF !OBS_HOUR + + ENDIF !local time + + ENDDO !loop over MOPITT data + + !================================================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !================================================================= + DO I = 1, IIPAR + DO J = 1, JJPAR + + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + !The mean value in the grid + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + & / COUNT_GRID(I,J) + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + & / COUNT_GRID(I,J) + DO L = 1, LLPAR + IF (GC_ADJ_COUNT(I,J,L) > 0) THEN + ADJ_FORCE(I,J,L,IDTCO) = ADJ_FORCE(I,J,L,IDTCO) + & / GC_ADJ_COUNT(I,J,L) + ENDIF + ENDDO + NEW_COST(I,J) = NEW_COST(I,J) / COUNT(I,J) + COUNT(I,J) = COUNT(I,J) / COUNT_GRID(I,J) + + !Update adjoint tracer + STT_ADJ(I,J,:,IDTCO) = STT_ADJ(I,J,:,IDTCO) + + & ADJ_FORCE(I,J,:,IDTCO) + + ! Diagnostic stuff: FORCING, MOP_MOD_DIFF, MODEL_BIAS + IF( LDCOSAT )THEN + + CALL SET_FORCING( I, J, DAY_OF_SIM, + & ADJ_FORCE(I,J,1,IDTCO) ) + CALL SET_MOP_MOD_DIFF( I, J, DAY_OF_SIM, + & MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) + + CALL SET_MODEL_BIAS( I, J, DAY_OF_SIM, 1, + & ( MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) / + & MOP_COL_GRID(I,J) ) + CALL SET_MODEL ( I, J, DAY_OF_SIM, 1, + & MODEL_COL_GRID(I,J) ) + CALL SET_OBS ( I, J, DAY_OF_SIM, 1, + & MOP_COL_GRID(I,J) ) + + COST_ARRAY(I,J,DAY_OF_SIM) = + & COST_ARRAY(I,J,DAY_OF_SIM) + NEW_COST(I,J) + + ENDIF + + IF ( IT_IS_NAN( NEW_COST(I,J) ) ) THEN + PRINT*, 'I=', I, 'J=', J + CALL ERROR_STOP( 'NEW_COST is NaN', + & 'CALC_MOPITT_FORCE') + ENDIF + + ENDIF !COUNT_GRID + !DO L=1,NLEV_RET + IF (MOP_BIAS_COUNT(I,J,6) > 0d0) THEN + MOP_CO_BIAS_SOBS(I,J,6) = + & MOP_CO_BIAS(I,J,6)/MOP_BIAS_COUNT(I,J,6) + !PRINT *, "MOP_CO_BIAS", MOP_CO_BIAS_SOBS(I,J,6) + MOP_CO_CHI_SQ_SOBS(I,J,6) = + & MOP_CO_CHI_SQ(I,J,6)/MOP_BIAS_COUNT(I,J,6) + ENDIF + WRITE(201,110) (1e12*MOP_CO_BIAS_SOBS(I,J,6)) + WRITE(202,110) (MOP_CO_CHI_SQ_SOBS(I,J,6)) + WRITE(203,110) (GET_YMID(J)) + WRITE(204,110) (GET_XMID(I)) + !ENDDO + 110 FORMAT(F18.6,1X) + ENDDO + ENDDO + + IF (LPRINTFD) THEN + PRINT*, 'IFD, JFD= ', IFD, JFD + PRINT*, 'MODEL_STT:', MODEL_COL_GRID(IFD,JFD) + PRINT*, 'OBS_STT:', MOP_COL_GRID(IFD,JFD) + PRINT*, 'NEW_COST', NEW_COST(IFD,JFD) + PRINT*, 'ADJ_FORCE:', ADJ_FORCE(IFD,JFD,:,IDTCO) + PRINT*, 'STT_ADJ:', STT_ADJ(IFD,JFD,:,IDTCO) + ENDIF + + ! Update cost function + PRINT*, 'TOTAL NEW_COST = ', SUM(NEW_COST) + PRINT*, 'COST_FUNC BEFORE ADDING NEW_COST=', COST_FUNC + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + COUNT_TOTAL = COUNT_TOTAL + SUM ( COUNT ) + PRINT*, 'Total observation number:', COUNT_TOTAL + + ! Return to calling program + END SUBROUTINE CALC_MOPITT_FORCE +!-------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_AVGKER( NLEV_RET, W, RETLEV, MOP_CO ) + +!****************************************************************************** +! SUBROUTINE CALC_AVGKER construct the averging kernel matrix +! (zhe 1/19/11) +!****************************************************************************** + + INTEGER :: ILEV, JLEV, ILEV2, JLEV2, Z, W + INTEGER :: NLEV_RET + REAL*4 :: DELP(NLEV_RET) + REAL*4 :: RETLEV(NLEV_RET) + REAL*8 :: MOP_CO(NLEV_RET) + REAL*8, PARAMETER :: log10e = LOG10(2.71828183) + + !================================================================= + ! CALC_AVGKER begins here! + !================================================================= + + A(:,:) = 0d0 + AC(:) = 0d0 + + XA(1) = CO_MR_AP_BOTTOM(1, W) + XA(2:NLEV_RET) = CO_MR_AP(1,11-NLEV_RET:9,W) + XA = XA * 1E-9 + + !Remove bad levels from averging kernel matrix + IF ( NLEV_RET < 10 ) THEN + DO ILEV = 1, NLEV_RET + ILEV2 = ILEV + ( 10 - NLEV_RET ) + DO JLEV =1, NLEV_RET + JLEV2 = JLEV + ( 10 - NLEV_RET) + A(ILEV,JLEV) = + & AVGKER(ILEV2,JLEV2,W) + ENDDO + ENDDO + ELSE + A(:,:) = AVGKER(:,:,W) + ENDIF + + DELP(1) = RETLEV(1) - RETLEV(2) + DELP(2:NLEV_RET-1) = 100D0 + DELP(NLEV_RET) = 74D0 + + ! transfer function [v/v -> molec/cm2] + T = 2.12E+22 * DELP + + ! Convert to column averaging kernel + DO JLEV = 1, NLEV_RET + DO ILEV = 1, NLEV_RET + AC(JLEV) = AC(JLEV) + DELP(ILEV) * MOP_CO(ILEV) + & * A(ILEV,JLEV) + ENDDO + AC(JLEV) = (2.12E+22 / log10e ) * AC(JLEV) + ENDDO + + + END SUBROUTINE CALC_AVGKER +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_DATA( P_MODEL, P_EDGE, DATA_MODEL, DATA_MOP, + & NLEV_RET, FB ) + +!****************************************************************************** +!Based on the code from Monika. (zhe 1/19/11) +!FB = 1 for forward +!FB = -1 for adjoint +!****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: NLEV_RET, NB + REAL*8 :: P_MODEL(LLPAR) + REAL*8 :: DATA_MODEL(LLPAR), DATA_MOP(NLEV_RET), DATA_TEM + REAL*8 :: P_EDGE(NLEV_RET+1) + + !================================================================= + ! BIN_DATA begins here! + !================================================================= + + IF (FB > 0) THEN + + DO L = 1, NLEV_RET + DO LL = 1, LLPAR + IF ( P_MODEL(LL) <= P_EDGE(L) ) THEN + DATA_MOP(L) = DATA_MODEL(LL) + EXIT + ENDIF + ENDDO + ENDDO + + DO L = 1, NLEV_RET + NB = 0 + DATA_TEM = 0 + DO LL = 1, LLPAR + IF ( ( P_MODEL(LL) <= P_EDGE(L)) .and. + & ( P_MODEL(LL) > P_EDGE(L+1)) ) THEN + DATA_TEM = DATA_TEM + DATA_MODEL(LL) + NB = NB + 1 + ENDIF + ENDDO + IF (NB > 0) DATA_MOP(L) = DATA_TEM / NB + ENDDO + + ELSE + + DATA_MODEL(:) = 0. + DO L = 1, LLPAR + DO LL = 1, NLEV_RET + IF ( ( P_MODEL(L) <= P_EDGE(LL)) .and. + & ( P_MODEL(L) > P_EDGE(LL+1)) ) THEN + DATA_MODEL(L) = DATA_MOP(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_DATA +!----------------------------------------------------------------------------------- + + SUBROUTINE INIT_DOMAIN + +!****************************************************************************** +!Define the observatio region +!****************************************************************************** +# include "CMN_SIZE" ! Size parameters + + !local variables + INTEGER :: I, J + + !================================================================= + ! INIT_DOMAIN begins here! + !================================================================= + + DOMAIN_OBS(:,:) = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined( GRID05x0666 ) +! The surrounding region is used as cushion +! (zhe 11/28/10) + IF ( J >= 8 .and. J <= JJPAR-7 .and. + & I >= 7 .and. I <= IIPAR-6 +#elif defined( GRID2x25 ) + IF ( J >= 16 .and. J <= 76 !60S-60N +#elif defined( GRID4x5 ) + IF ( J >= 9 .and. J <= 39 !60S-60N +#endif + & ) DOMAIN_OBS(I,J) = 1d0 + + ENDDO + ENDDO + + PRINT*, sum(DOMAIN_obs), 'MAX observations today' + + END SUBROUTINE INIT_DOMAIN + +!----------------------------------------------------------------------------- + + SUBROUTINE CALC_OBS_HOUR + +!*************************************************************************** +! Subroutine CALC_OBS_HOUR computes an array of hours for each day of obs. +! If there is an obs in a particular gridbox on that day, it assigns the +! hour (0..23). If there isn't, OBS_HOUR stays initialized to -1. +! (mak, 12/14/05) +!*************************************************************************** + + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, + & GET_YEAR, GET_HOUR + USE GRID_MOD, ONLY : GET_IJ + +# include "CMN_SIZE" + + REAL*4 :: OBS_HOUR(IIPAR,JJPAR) + REAL*8 :: TAU0, UTC + INTEGER :: W, I, J + INTEGER :: LON15, IIJJ(2) + INTEGER :: COUNT_GRID(IIPAR,JJPAR) + + !================================================================= + ! CALC_OBS_HOUR begins here! + !================================================================= + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0(GET_MONTH(), GET_DAY(), GET_YEAR()) + + OBS_HOUR_MOPITT(:,:) = -1 + OBS_HOUR(:,:) = 0 + COUNT_GRID(:,:) = 0 + + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + !============================================================ + LON15 = LONGITUDE(W) / 15d0 + UTC = TAU(W) - TAU0 + LON15 + IF ( UTC < 0d0 ) UTC = UTC + 24 + IF ( UTC > 24d0 ) UTC = UTC - 24 + + !Only consider day time MOPITT measurements + !am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + + ! Get grid box of current record + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + ! If there's an obs, calculate the time + IF ( CO_TOTAL_COLUMN(1,W) > 0d0 ) THEN + + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1d0 + !Add the time of obs, to be averaged and floored later + OBS_HOUR(I,J) = OBS_HOUR(I,J) + MOPITT_GMT(W) + + ENDIF + ENDIF + ENDDO + + ! average obs_hour on the grid + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + OBS_HOUR_MOPITT(I,J) = + & FLOOR( OBS_HOUR(I,J) / COUNT_GRID(I,J) ) + + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CALC_OBS_HOUR + +!---------------------------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_MOPITT_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_MOPITT_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day) based on +! the OBS_HOUR_MOPITT array which holds the hour of obs in each gridbox +! (computed when file read in mop02_mod.f) (mak, 7/12/07) +!****************************************************************************** + + USE TIME_MOD, ONLY : GET_HOUR, GET_MINUTE + +# include "CMN_SIZE" ! Size params + + ! Function value + LOGICAL :: FLAG + + INTEGER :: I,J + + !================================================================= + ! ITS_TIME_FOR_MOPITT_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO J = 1,JJPAR + DO I = 1,IIPAR + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & GET_MINUTE() == 0 ) THEN + + PRINT*, 'obs_hour was', get_hour(), 'in box', I, J + FLAG = .TRUE. + + !GOTO 11 + RETURN + + ENDIF + ENDDO + ENDDO + + END FUNCTION ITS_TIME_FOR_MOPITT_OBS + +!---------------------------------------------------------------------------- + + SUBROUTINE READ_MOP02( FILENAME ) + +!****************************************************************************** +! Subroutine READ_MOP02 allocates all module arrays and reads data into +! them from the HDF file. (bmy, 7/2/03, zhe 1/19/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** + + ! References to F90 modules +#if defined( MOPITT_V5_CO_OBS ) + USE HdfSdModule + USE HdfVdModule +#endif + USE BPCH2_MOD, ONLY : GET_TAU0 + USE ERROR_MOD, ONLY : ALLOC_ERR + + ! Local variables + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + INTEGER :: as, i, year, month, day + REAL*8 :: TAU0 + +#if defined( MOPITT_V5_CO_OBS ) + INTEGER :: sId, vId, vSize, nDims, dims(4) +#endif +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + INTEGER :: he5_swopen, he5_swattach, he5_swfldinfo, + & he5_swrdfld, he5_swdetach, he5_swclose + + INTEGER :: N, fId, swathid, rank + INTEGER :: ntype(4) + INTEGER*8 :: dims8(4) + INTEGER*8 :: START1(1), STRIDE1(1), EDGE1(1) + INTEGER*8 :: START2(2), STRIDE2(2), EDGE2(2) + INTEGER*8 :: START3(3), STRIDE3(3), EDGE3(3) + INTEGER, PARAMETER :: HE5F_ACC_RDONLY=101 + character*72 dimlist, maxdimlist + +#endif + + !================================================================= + ! Mop02Read begins here! + !================================================================= + + ! Deallocate arrays + CALL CLEANUP_MOP02 + + ! Get date from filename (next to the '-' character) + i = INDEX( FILENAME, '-' ) + READ( FILENAME(i+1:i+4), '(i4)' ) year + READ( FILENAME(i+5:i+6), '(i2)' ) month + READ( FILENAME(i+7:i+8), '(i2)' ) day + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0( month, day, year ) + +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + ! Opening an HDF-EOS5 swath file + fId = he5_swopen(FILENAME, HE5F_ACC_RDONLY) + + ! Attaching to a swath object + swathid = he5_swattach(fId, 'MOP02' ) + + !================================================================= + ! Seconds in day (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SecondsinDay", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SecondsinDay', + & START1, STRIDE1, EDGE1, SECONDS_IN_DAY) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = dims8(1) + + !================================================================= + ! LONGITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Longitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LONGITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Longitude', + & START1, STRIDE1, EDGE1, LONGITUDE) + + !================================================================= + ! LATITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Latitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LATITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Latitude', + & START1, STRIDE1, EDGE1, LATITUDE) + + !================================================================= + ! PRESSURE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Pressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Pressure', + & START1, STRIDE1, EDGE1, PRESSURE) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = dims8(1) + + !================================================================= + ! Cloud Description (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "CloudDescription", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CLOUD_DES( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'CloudDescription', + & START1, STRIDE1, EDGE1, CLOUD_DES) + + !================================================================= + ! Surface Index (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfaceIndex", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(SURFACE_INDEX( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfaceIndex', + & START1, STRIDE1, EDGE1, SURFACE_INDEX) + + !================================================================= + ! Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfacePressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(BOTTOM_PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfacePressure', + & START1, STRIDE1, EDGE1, BOTTOM_PRESSURE) + + !================================================================= + ! CO Mixing Ratio (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims8(1), dims8(2), dims8(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MIXING_RATIO) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_RET_BOT_MIXING_RATIO) + + !================================================================= + ! CO Total Column (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOTotalColumn", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOTotalColumn', + & START2, STRIDE2, EDGE2, CO_TOTAL_COLUMN) + + !================================================================= + ! Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievalAveragingKernelMatrix", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( AVGKER( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievalAveragingKernelMatrix', + & START3, STRIDE3, EDGE3, AVGKER) + + !================================================================= + ! A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MR_AP) + + !================================================================= + ! A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims8(1), dims8(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_MR_AP_BOTTOM) + + ! Detaching from the swath object + as = he5_swdetach(swathid) + + ! Closing the file + as = he5_swclose(fId) + + +#endif !MOPITT v6 + +#if defined( MOPITT_V5_CO_OBS ) + + ! Open file for HDF-VDATA interface + CALL vdOpen( FILENAME ) + + !================================================================= + ! VDATA field: Time (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Seconds in Day', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + ! Read data + CALL vdGetData( vId, vSize, SECONDS_IN_DAY ) + + ! Close field + CALL vdCloseField( vId ) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = vSize + + !================================================================= + ! VDATA field: LONGITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Longitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LONGITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LONGITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: LATITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Latitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LATITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LATITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Cloud Description (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Cloud Description', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( CLOUD_DES( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + ! Read data + CALL vdGetData( vId, vSize, CLOUD_DES ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Surface Index (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Index', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( SURFACE_INDEX( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + ! Read data + CALL vdGetData( vId, vSize, SURFACE_INDEX ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: PRESSURE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Pressure Grid', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = vSize + + !================================================================= + ! VDATA field: Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Pressure', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( BOTTOM_PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, BOTTOM_PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Close HDF-VDATA interface + CALL vdClose( FILENAME ) + + + + ! Open file for HDF-SDATA interface + CALL sdOpen( FILENAME ) + + !================================================================= + ! SDATA field: CO Mixing Ratio (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims(1), dims(2), dims(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), + & CO_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_RET_BOT_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Total Column (2-D) + !================================================================= + + ! Open field + + CALL sdOpenFieldByName( 'Retrieved CO Total Column', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_TOTAL_COLUMN ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieval Averaging Kernel Matrix', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( AVGKER( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), AVGKER ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), CO_MR_AP ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims(1), dims(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_MR_AP_BOTTOM ) + + ! Close field + CALL sdCloseField( sId ) + + ! Close file and quit + CALL sdClose( FILENAME ) + +#endif !MOPITT v5 + + ! Return to calling program + END SUBROUTINE READ_MOP02 + +!------------------------------------------------------------------------------------ + + SUBROUTINE READ_ERROR_VARIANCE +! +!****************************************************************************** +! Subroutine READ_ERROR_VARIANCE reads observation error from binary punch files +! (zhe 4/20/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE TIME_MOD, ONLY : GET_TAUb + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_ERROR_VARIANCE begins here! + !================================================================= + + ! Filename + FILENAME = TRIM( 'OBS_ERR_' ) // GET_RES_EXT() + + ! Echo some information to the standard output + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_ERROR_VARIANCE: Reading ERR_PERCENT + & from: ', a ) + + ! Read data from the binary punch file + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & GET_TAUb(), IGLOB, JGLOB, + & 1, ERR_PERCENT, QUIET=.TRUE. ) + + ! Return to calling program + END SUBROUTINE READ_ERROR_VARIANCE + +!------------------------------------------------------------------------------ + + SUBROUTINE INFO_MOP02( FILENAME ) +! +!****************************************************************************** +! Subroutine INFO_MOP02 Info prints info about all VDATA and SDATA fields +! contained within the MOPITT HDF file. (bmy, 7/3/03, 4/27/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE HdfSdModule + USE HdfVdModule + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + + !================================================================= + ! INFO_MOP02 begins here! + !================================================================= + + ! Print HDF-VDATA variables + CALL vdOpen( FILENAME ) + CALL vdPrintInfo + CALL vdClose( FILENAME ) + + ! Print HDF-SDATA variables + CALL sdOpen( FILENAME ) + CALL sdPrintInfo + CALL sdClose( FILENAME ) + + ! Return to calling program + END SUBROUTINE INFO_MOP02 + +!----------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_MOP02 +! +!****************************************************************************** +! Subroutine CLEANUP_MOP02 deallocates all module arrays (bmy, 4/27/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_MOP02 begins here! + !================================================================= + IF ( ALLOCATED( LATITUDE ) ) DEALLOCATE( LATITUDE ) + IF ( ALLOCATED( LONGITUDE ) ) DEALLOCATE( LONGITUDE ) + IF ( ALLOCATED( PRESSURE ) ) DEALLOCATE( PRESSURE ) + IF ( ALLOCATED( CLOUD_DES ) ) DEALLOCATE( CLOUD_DES ) + IF ( ALLOCATED( SURFACE_INDEX ) ) DEALLOCATE( SURFACE_INDEX ) + IF ( ALLOCATED( TAU ) ) DEALLOCATE( TAU ) + IF ( ALLOCATED( SECONDS_IN_DAY ) ) DEALLOCATE( SECONDS_IN_DAY ) + IF ( ALLOCATED( MOPITT_GMT ) ) DEALLOCATE( MOPITT_GMT ) + IF ( ALLOCATED( BOTTOM_PRESSURE ) ) DEALLOCATE( BOTTOM_PRESSURE ) + IF ( ALLOCATED( CO_MIXING_RATIO ) ) DEALLOCATE( CO_MIXING_RATIO ) + + IF ( ALLOCATED( CO_RET_BOT_MIXING_RATIO)) THEN + DEALLOCATE( CO_RET_BOT_MIXING_RATIO ) + ENDIF + + IF ( ALLOCATED( CO_TOTAL_COLUMN ) ) DEALLOCATE( CO_TOTAL_COLUMN ) + IF ( ALLOCATED( AVGKER ) ) DEALLOCATE( AVGKER ) + IF ( ALLOCATED( PLEV_AP ) ) DEALLOCATE( PLEV_AP ) + IF ( ALLOCATED( CO_MR_AP ) ) DEALLOCATE( CO_MR_AP ) + IF ( ALLOCATED( CO_MR_AP_BOTTOM ) ) DEALLOCATE( CO_MR_AP_BOTTOM ) + + ! Return to calling program + END SUBROUTINE CLEANUP_MOP02 + +!--------------------------------------------------------------------------------------------------- + + + END MODULE MOPITT_OBS_MOD diff --git a/code/obs_operators/mopitt_obs_mod.f~ b/code/obs_operators/mopitt_obs_mod.f~ new file mode 100644 index 0000000..ffcc2fc --- /dev/null +++ b/code/obs_operators/mopitt_obs_mod.f~ @@ -0,0 +1,1671 @@ + MODULE MOPITT_OBS_MOD +!***************************************************************************** +! Module MOPITT_OBS_MOD contains all the subroutines for the using of MOPITT +! observation (version 3 and version 4).(zhe 1/19/11) +! Remove the support to MOPITT v3 and v4. Now support v5 and v6. (Zhe 1/20/14) +! Module Routines: +! ============================================================================ +! (1 ) READ_MOPITT_FILE : Read MOPITT hdf file +! (2 ) CALC_MOPITT_FORCE : Calculates cost function and STT_ADJ increments +! (3 ) CALC_AVGKER : Construct the averging kernel matrix +! (4 ) BIN_DATA : Interpolation between different vertical resolutions +! (5 ) INIT_DOMAIN : Define the observation window +! (6 ) CALC_OBS_HOUR : Calculated hour of morning obs +! (7 ) ITS_TIME_FOR_MOPITT_OBS: FUNCTION that checks time vs. OBS_HOUR array +! (8 ) READ_MOP02 : Reads MOPITT data fields from the HDF-EOS file +! (9) INFO_MOP02 : Prints name, dims, type, etc. of MOPITT data fields +! (10) CLEANUP_MOP02 : Deallocates all module arrays +! ============================================================================= + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "../adjoint/define_adj.h" + + PRIVATE + + PUBLIC OBS_HOUR_MOPITT + PUBLIC COUNT_TOTAL + PUBLIC ITS_TIME_FOR_MOPITT_OBS + PUBLIC READ_MOPITT_FILE + PUBLIC CALC_MOPITT_FORCE + + !============================================================================= + ! MODULE VARIABLES + !============================================================================= + + INTEGER :: OBS_HOUR_MOPITT(IIPAR,JJPAR) + INTEGER :: DOMAIN_OBS(IIPAR,JJPAR) + REAL*8 :: COUNT_TOTAL + + REAL*4 :: ERR_PERCENT(IIPAR,JJPAR) + REAL*4, ALLOCATABLE :: A(:,:) + REAL*4, ALLOCATABLE :: T(:) + REAL*4, ALLOCATABLE :: XA(:) + REAL*8, ALLOCATABLE :: AC(:) + + ! MOPITT dimension fields + INTEGER :: T_DIM, Z_DIM + REAL*4, ALLOCATABLE :: LATITUDE(:) + REAL*4, ALLOCATABLE :: LONGITUDE(:) + REAL*4, ALLOCATABLE :: PRESSURE(:) + REAL*4, ALLOCATABLE :: SECONDS_IN_DAY(:) + REAL*4, ALLOCATABLE :: MOPITT_GMT(:) + REAL*8, ALLOCATABLE :: TAU(:) + + ! MOPITT data quantities + REAL*4, ALLOCATABLE :: BOTTOM_PRESSURE(:) + REAL*4, ALLOCATABLE :: CO_MIXING_RATIO(:,:,:) + REAL*4, ALLOCATABLE :: CO_RET_BOT_MIXING_RATIO(:,:) + REAL*4, ALLOCATABLE :: CO_TOTAL_COLUMN(:,:) + REAL*4, ALLOCATABLE :: AVGKER(:,:,:) + REAL*4, ALLOCATABLE :: RET_ERR_COV(:,:,:) + INTEGER, ALLOCATABLE :: CLOUD_DES(:) + INTEGER, ALLOCATABLE :: SURFACE_INDEX(:) + + ! MOPITT a priori + INTEGER :: NLEV_AP + REAL*4, ALLOCATABLE :: PLEV_AP(:) + REAL*4, ALLOCATABLE :: CO_MR_AP(:,:,:) + REAL*4, ALLOCATABLE :: CO_MR_AP_BOTTOM(:,:) + + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_MOPITT_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_MOPITT_FILE reads the MOPITT hdf file. +! (mak, 7/12/07, zhe 1/19/11) +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +!****************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, AS + CHARACTER(LEN=255) :: DIR_MOPITT + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: FILENAMEM + CHARACTER(LEN=255) :: FILENAME2 + LOGICAL :: IT_EXISTS + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! READ_MOPITT_FILE begins here! + !================================================================= +#if defined( MOPITT_V5_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v5/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V10.1.3.beta.hdf' +#endif +#if defined( MOPITT_V6_CO_OBS ) + DIR_MOPITT = '/nobackupp8/zjiang2/mopitt/' + DIR_MONTH = 'v6/YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V16.2.3.he5' +#endif +#if defined( MOPITT_V7_CO_OBS ) + DIR_MOPITT = '/users/jk/15/xzhang/MOPITT/' + DIR_MONTH = 'YYYY/MM/' + FILENAMEM = 'MOP02J-YYYYMMDD-L2V17.9.3.he5' +#endif + + IF ( FIRST ) THEN + ERR_PERCENT(:,:) = 0.0 + COUNT_TOTAL = 0 + FIRST = .FALSE. + ENDIF + + OBS_HOUR_MOPITT(:,:) = -99 + + CALL EXPAND_DATE( FILENAMEM, YYYYMMDD, 0 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 0 ) + + FILENAME2 = TRIM( DIR_MOPITT ) // TRIM( DIR_MONTH ) // FILENAMEM + PRINT*, '=== Reading ===:', TRIM( FILENAME2 ) + + INQUIRE( FILE = FILENAME2, EXIST = IT_EXISTS ) + IF (IT_EXISTS) THEN + + !CALL INFO_MOP02(FILENAME2) + + CALL READ_MOP02( FILENAME2 ) + + CALL INIT_DOMAIN + + ! Calculate hour of day when obs should be compared to model + CALL CALC_OBS_HOUR + + ENDIF + + !CALL READ_ERROR_VARIANCE + !We assume 20% uniform observation error + ERR_PERCENT(:,:) = 0.2/LOG(10d0) + + END SUBROUTINE READ_MOPITT_FILE +!------------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_MOPITT_FORCE + +!****************************************************************************** +! CALC_MOPITT_FORCE calculate cost function and STT_ADJ increments +! (zhe 1/19/11) +!****************************************************************************** + + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_AP, GET_BP + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, GET_YEAR + USE TIME_MOD, ONLY : GET_HOUR + USE CHECKPT_MOD, ONLY : CHK_STT + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDTCO + USE DAO_MOD, ONLY : AD, IS_LAND + USE ADJ_ARRAYS_MOD, ONLY : SET_FORCING, SET_MOP_MOD_DIFF, + & SET_MODEL_BIAS, SET_MODEL, SET_OBS, + & COST_ARRAY, DAY_OF_SIM, IFD, JFD, LFD, NFD, + & COST_FUNC, ADJ_FORCE, STT_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD, LDCOSAT + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE GRID_MOD, ONLY : GET_IJ, GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY: DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY: N_CALC, EXPAND_NAME + USE TROPOPAUSE_MOD, ONLY: ITS_IN_THE_TROP + + LOGICAL, SAVE :: SECOND = .TRUE. + CHARACTER(LEN=255) :: FILENAME + + ! Local Variables + INTEGER :: W, I, J, Z, ZZ, L,LL + INTEGER :: LON15, IIJJ(2) + INTEGER :: NLEV_RET + + REAL*4 :: RETLEV(Z_DIM+1) + REAL*8 :: P_EDGE(Z_DIM+2), MODEL_COL, MOPITT_COL + REAL*8 :: UTC, TAU0 + REAL*8 :: MODEL_P(LLPAR), MODEL_CO_MR(LLPAR) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: COUNT(IIPAR,JJPAR) + REAL*8 :: MOP_COL_GRID(IIPAR,JJPAR) + REAL*8 :: MODEL_COL_GRID(IIPAR,JJPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: ADJ_F(LLPAR) + REAL*8 :: SY + REAL*8 :: MODEL_P_EDGE(LLPAR+1) + INTEGER :: IOS + REAL*8 :: DIFF_COST_COL + REAL*4 :: MOP_CO_BIAS(IIPAR,JJPAR,11) + REAL*4 :: MOP_BIAS_COUNT(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_BIAS_SOBS(IIPAR,JJPAR,11) + REAL*4 :: MOP_CO_CHI_SQ_SOBS(IIPAR,JJPAR,11) + + REAL*8, ALLOCATABLE :: GEOS_RAW(:) + REAL*8, ALLOCATABLE :: MOP_CO(:) + REAL*8, ALLOCATABLE :: DIFF_ADJ(:) + REAL*8, ALLOCATABLE :: GEOS_CO(:) + REAL*8, ALLOCATABLE :: DIFF_COST(:) + REAL*8, ALLOCATABLE :: COST_CONTRIB(:) + + IF ( SECOND ) THEN + FILENAME = 'co_bias_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 201, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'co_chi_square_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 202, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lat_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 203, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + FILENAME = 'lon_orb_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 204, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_MOPITT_FORCE begins here! + !================================================================= + + TAU0 = GET_TAU0( GET_MONTH(), GET_DAY(), GET_YEAR() ) + + COUNT_GRID(:,:) = 0d0 + COUNT(:,:) = 0d0 + MOP_COL_GRID(:,:) = -999.0 + MODEL_COL_GRID(:,:) = -999.0 + ADJ_FORCE(:,:,:,:) = 0d0 + NEW_COST(:,:) = 0d0 + MOP_CO_BIAS(:,:,:) = 0d0 + MOP_BIAS_COUNT(:,:,:) = 0d0 + MOP_CO_CHI_SQ(:,:,:) = 0d0 + MOP_CO_BIAS_SOBS(:,:,:) = 0d0 + MOP_CO_CHI_SQ_SOBS(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + + !================================================================= + ! Loop over MOPITT data + !================================================================= + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + LON15 = LONGITUDE(W) / 15. + UTC = TAU(W) - TAU0 + LON15 + IF (UTC < 0. ) UTC = UTC + 24 + IF (UTC > 24.) UTC = UTC - 24 + + !Only consider day time MOPITT measurements + ! am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + ! Get grid box + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + !================================================================= + ! Data selection + !================================================================= + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & CLOUD_DES(W) == 2.0 .and. + & CO_TOTAL_COLUMN(1,W) > 5E17 .and. + & DOMAIN_OBS(I,J) == 1 ) THEN + +! IF ( (IS_LAND(I,J) .AND. +! & LATITUDE(W) .GE. -52 .AND. LATITUDE(W) .LE. 52 ) .OR. !52S-52N +! & (LATITUDE(W) .GE. -40 .AND. LATITUDE(W) .LE. 40) ) THEN !40S-40N + + RETLEV(:) = -999.0 + MODEL_COL = 0D0 + MOPITT_COL = 0D0 + + ! Create pressure profile + RETLEV(1) = BOTTOM_PRESSURE(W) + + ZZ = 0 + ! Loop over Mopitt levels + DO Z = 1, Z_DIM + ! Always start from the bottom pressure, + ! even if it means skipping a MOPITT pressure level + IF ( PRESSURE(Z) >= RETLEV(1) ) THEN + ZZ = ZZ + 1 + CYCLE + ENDIF + ! Save into profile + RETLEV(Z+1-ZZ) = PRESSURE(Z) + ENDDO + NLEV_RET = Z_DIM+1 - ZZ + + DO L = 1, NLEV_RET + P_EDGE(L) = RETLEV(L) + ENDDO + P_EDGE(NLEV_RET+1) = 36 + + ALLOCATE( XA( NLEV_RET ) ) + ALLOCATE( T( NLEV_RET ) ) + ALLOCATE( A( NLEV_RET,NLEV_RET ) ) + ALLOCATE( AC( NLEV_RET ) ) + ALLOCATE( MOP_CO( NLEV_RET ) ) + ALLOCATE( GEOS_RAW( NLEV_RET ) ) + ALLOCATE( DIFF_ADJ( NLEV_RET ) ) + ALLOCATE( GEOS_CO( NLEV_RET ) ) + ALLOCATE( DIFF_COST( NLEV_RET ) ) + ALLOCATE( COST_CONTRIB( NLEV_RET ) ) + + ! MOPITT CO vertical profile + MOP_CO(1) = CO_RET_BOT_MIXING_RATIO(1,W) + MOP_CO(2:NLEV_RET) = CO_MIXING_RATIO(1,11-NLEV_RET:9,W) + MOP_CO = MOP_CO * 1E-9 + + ! COMPUTE AVERAGING KERNEL + CALL CALC_AVGKER(NLEV_RET, W, RETLEV, MOP_CO) + + !USE MOPITT SURFACE PRESSURE + !DO L=1, LLPAR + 1 + ! MODEL_P_EDGE(L) = GET_AP(L) + GET_BP(L) * RETLEV(1) + !ENDDO + + DO L = 1, LLPAR + !MOPITT PRESSURE LEVEL + !MODEL_P(L) = (MODEL_P_EDGE(L) + MODEL_P_EDGE(L+1)) / 2 + + ! Get GC pressure levels (mbar) + MODEL_P(L) = GET_PCENTER(I,J,L) + + ! Obtain archieved forward model results + ! kg -> v/v + MODEL_CO_MR(L) = CHK_STT(I,J,L,IDTCO) * + & TCVV(IDTCO) / AD(I,J,L) + ENDDO + + ! Interplote the model to MOPITT vertical grids + CALL BIN_DATA(MODEL_P, P_EDGE, MODEL_CO_MR(:), + & GEOS_RAW, NLEV_RET, 1) + + !================================================================= + ! Apply MOPITT observation operator + !================================================================= + + ! Total Column: C = T * XA + AC * ( Xm - XA ) + ! Stratosphere Levels are removed + !DO L = 1, NLEV_RET + DO L = 1, NLEV_RET - 1 + MODEL_COL = MODEL_COL + & + T(L) * XA(L) + & + AC(L) * (LOG10(GEOS_RAW(L)) + & - LOG10(XA(L))) + !MOPITT_COL = MOPITT_COL + T(L) * MOP_CO(L) + ENDDO + + MOPITT_COL = CO_TOTAL_COLUMN(1,W) + + GEOS_CO(:) = 0d0 + ! Smoothed Profile: X_hat = XA + A * ( Xm - XA ) + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + GEOS_CO(L) = GEOS_CO(L) + & + A(L,LL) + & * (LOG10( GEOS_RAW(LL) ) - LOG10( XA(LL) )) + ENDDO + GEOS_CO(L) = LOG10( XA(L) ) + GEOS_CO(L) + ENDDO + + !================================================================= + ! COST FUNCTION + !================================================================= + DIFF_COST_COL = 0d0 + !SY = ( ERR_PERCENT(I,J) * MOPITT_COL )**2 + !DIFF_COST_COL = MODEL_COL - MOPITT_COL + !NEW_COST(I,J) = NEW_COST(I,J) + 0.5 * (DIFF_COST_COL ** 2) / SY + !COUNT(I,J) = COUNT(I,J) +1 + DIFF_COST(:) = 0D0 + COST_CONTRIB(:) = 0D0 + SY = ERR_PERCENT(I,J) **2 + DO L = 1, NLEV_RET - 1 + DIFF_COST(L) = GEOS_CO(L) - LOG10( MOP_CO(L) ) + COST_CONTRIB(L) = 0.5d0*(DIFF_COST(L)**2) / SY + IF (COST_CONTRIB(L) > 0d0) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB(L) + COUNT(I,J) = COUNT(I,J) + 1 + ENDIF + MOP_CO_BIAS(I,J,L) = MOP_CO_BIAS(I,J,L) + + & 10**(GEOS_CO(L)) - MOP_CO(L) + MOP_CO_CHI_SQ(I,J,L) = MOP_CO_CHI_SQ(I,J,L) + + & (DIFF_COST(L))**2/ SY + MOP_BIAS_COUNT(I,J,L) = MOP_BIAS_COUNT(I,J,L) + 1d0 + + ENDDO + !================================================================= + ! adjoint operator + !================================================================= + DIFF_ADJ(:) = 0D0 + !DO L = 1, NLEV_RET + !DIFF_ADJ(L) = DIFF_COST_COL * AC(L) / SY + !DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10.0)) + !ENDDO + DO L = 1, NLEV_RET + DO LL = 1, NLEV_RET + DIFF_ADJ(L) = DIFF_ADJ(L) + & + A(LL,L) * DIFF_COST(LL) / SY + ENDDO + ! fwd code: LOG(GEOS_RAW) - LOG(XA) + ! mkeller: this is just plain wrong! + ! the forward code is LOG10(GEOS_RAW) - LOG10(XA) + ! a factor of 1/LOG(10) is missing + !DIFF_ADJ(L) = DIFF_ADJ(L) / GEOS_RAW(L) + DIFF_ADJ(L) = DIFF_ADJ(L) / (GEOS_RAW(L) * LOG(10d0)) + ENDDO + + + CALL BIN_DATA( MODEL_P, P_EDGE, ADJ_F, + & DIFF_ADJ, NLEV_RET, -1 ) + + ! adjoint FORCE + DO L = 1, LLPAR + IF (ADJ_F(L) .NE. 0d0) THEN + !v/v->kg + ADJ_FORCE(I,J,L,IDTCO) = ADJ_FORCE(I,J,L,IDTCO) + & + ADJ_F(L) * TCVV(IDTCO)/ AD(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ENDIF + ENDDO + IF (NEW_COST(I,J) > 0d0) THEN + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1.d0 + ENDIF + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + MOPITT_COL + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + MODEL_COL + + IF ( ALLOCATED( GEOS_RAW ) ) DEALLOCATE( GEOS_RAW ) + IF ( ALLOCATED( MOP_CO ) ) DEALLOCATE( MOP_CO ) + IF ( ALLOCATED( DIFF_ADJ ) ) DEALLOCATE( DIFF_ADJ ) + IF ( ALLOCATED( A ) ) DEALLOCATE( A ) + IF ( ALLOCATED( AC ) ) DEALLOCATE( AC ) + IF ( ALLOCATED( T ) ) DEALLOCATE( T ) + IF ( ALLOCATED( XA ) ) DEALLOCATE( XA ) + IF ( ALLOCATED( GEOS_CO ) ) DEALLOCATE( GEOS_CO ) + IF ( ALLOCATED( DIFF_COST ) ) DEALLOCATE( DIFF_COST) + IF ( ALLOCATED(COST_CONTRIB) ) DEALLOCATE( COST_CONTRIB ) + + !ENDIF !IS_LAND + + ENDIF !OBS_HOUR + + ENDIF !local time + + ENDDO !loop over MOPITT data + + !================================================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !================================================================= + DO I = 1, IIPAR + DO J = 1, JJPAR + + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + !The mean value in the grid + MOP_COL_GRID(I,J) = MOP_COL_GRID(I,J) + & / COUNT_GRID(I,J) + MODEL_COL_GRID(I,J) = MODEL_COL_GRID(I,J) + & / COUNT_GRID(I,J) + DO L = 1, LLPAR + IF (GC_ADJ_COUNT(I,J,L) > 0) THEN + ADJ_FORCE(I,J,L,IDTCO) = ADJ_FORCE(I,J,L,IDTCO) + & / GC_ADJ_COUNT(I,J,L) + ENDIF + ENDDO + NEW_COST(I,J) = NEW_COST(I,J) / COUNT(I,J) + COUNT(I,J) = COUNT(I,J) / COUNT_GRID(I,J) + + !Update adjoint tracer + STT_ADJ(I,J,:,IDTCO) = STT_ADJ(I,J,:,IDTCO) + + & ADJ_FORCE(I,J,:,IDTCO) + + ! Diagnostic stuff: FORCING, MOP_MOD_DIFF, MODEL_BIAS + IF( LDCOSAT )THEN + + CALL SET_FORCING( I, J, DAY_OF_SIM, + & ADJ_FORCE(I,J,1,IDTCO) ) + CALL SET_MOP_MOD_DIFF( I, J, DAY_OF_SIM, + & MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) + + CALL SET_MODEL_BIAS( I, J, DAY_OF_SIM, 1, + & ( MODEL_COL_GRID(I,J) - MOP_COL_GRID(I,J) ) / + & MOP_COL_GRID(I,J) ) + CALL SET_MODEL ( I, J, DAY_OF_SIM, 1, + & MODEL_COL_GRID(I,J) ) + CALL SET_OBS ( I, J, DAY_OF_SIM, 1, + & MOP_COL_GRID(I,J) ) + + COST_ARRAY(I,J,DAY_OF_SIM) = + & COST_ARRAY(I,J,DAY_OF_SIM) + NEW_COST(I,J) + + ENDIF + + IF ( IT_IS_NAN( NEW_COST(I,J) ) ) THEN + PRINT*, 'I=', I, 'J=', J + CALL ERROR_STOP( 'NEW_COST is NaN', + & 'CALC_MOPITT_FORCE') + ENDIF + + ENDIF !COUNT_GRID + !DO L=1,NLEV_RET + IF (MOP_BIAS_COUNT(I,J,6) > 0d0) THEN + MOP_CO_BIAS_SOBS(I,J,6) = + & MOP_CO_BIAS(I,J,6)/MOP_BIAS_COUNT(I,J,6) + !PRINT *, "MOP_CO_BIAS", MOP_CO_BIAS_SOBS(I,J,6) + MOP_CO_CHI_SQ_SOBS(I,J,6) = + & MOP_CO_CHI_SQ(I,J,6)/MOP_BIAS_COUNT(I,J,6) + ENDIF + WRITE(201,110) (1e12*MOP_CO_BIAS_SOBS(I,J,6)) + WRITE(202,110) (MOP_CO_CHI_SQ_SOBS(I,J,6)) + WRITE(203,110) (GET_YMID(J)) + WRITE(204,110) (GET_XMID(I)) + !ENDDO + 110 FORMAT(F18.6,1X) + ENDDO + ENDDO + + IF (LPRINTFD) THEN + PRINT*, 'IFD, JFD= ', IFD, JFD + PRINT*, 'MODEL_STT:', MODEL_COL_GRID(IFD,JFD) + PRINT*, 'OBS_STT:', MOP_COL_GRID(IFD,JFD) + PRINT*, 'NEW_COST', NEW_COST(IFD,JFD) + PRINT*, 'ADJ_FORCE:', ADJ_FORCE(IFD,JFD,:,IDTCO) + PRINT*, 'STT_ADJ:', STT_ADJ(IFD,JFD,:,IDTCO) + ENDIF + + ! Update cost function + PRINT*, 'TOTAL NEW_COST = ', SUM(NEW_COST) + PRINT*, 'COST_FUNC BEFORE ADDING NEW_COST=', COST_FUNC + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + COUNT_TOTAL = COUNT_TOTAL + SUM ( COUNT ) + PRINT*, 'Total observation number:', COUNT_TOTAL + + ! Return to calling program + END SUBROUTINE CALC_MOPITT_FORCE +!-------------------------------------------------------------------------------------------- + + SUBROUTINE CALC_AVGKER( NLEV_RET, W, RETLEV, MOP_CO ) + +!****************************************************************************** +! SUBROUTINE CALC_AVGKER construct the averging kernel matrix +! (zhe 1/19/11) +!****************************************************************************** + + INTEGER :: ILEV, JLEV, ILEV2, JLEV2, Z, W + INTEGER :: NLEV_RET + REAL*4 :: DELP(NLEV_RET) + REAL*4 :: RETLEV(NLEV_RET) + REAL*8 :: MOP_CO(NLEV_RET) + REAL*8, PARAMETER :: log10e = LOG10(2.71828183) + + !================================================================= + ! CALC_AVGKER begins here! + !================================================================= + + A(:,:) = 0d0 + AC(:) = 0d0 + + XA(1) = CO_MR_AP_BOTTOM(1, W) + XA(2:NLEV_RET) = CO_MR_AP(1,11-NLEV_RET:9,W) + XA = XA * 1E-9 + + !Remove bad levels from averging kernel matrix + IF ( NLEV_RET < 10 ) THEN + DO ILEV = 1, NLEV_RET + ILEV2 = ILEV + ( 10 - NLEV_RET ) + DO JLEV =1, NLEV_RET + JLEV2 = JLEV + ( 10 - NLEV_RET) + A(ILEV,JLEV) = + & AVGKER(ILEV2,JLEV2,W) + ENDDO + ENDDO + ELSE + A(:,:) = AVGKER(:,:,W) + ENDIF + + DELP(1) = RETLEV(1) - RETLEV(2) + DELP(2:NLEV_RET-1) = 100D0 + DELP(NLEV_RET) = 74D0 + + ! transfer function [v/v -> molec/cm2] + T = 2.12E+22 * DELP + + ! Convert to column averaging kernel + DO JLEV = 1, NLEV_RET + DO ILEV = 1, NLEV_RET + AC(JLEV) = AC(JLEV) + DELP(ILEV) * MOP_CO(ILEV) + & * A(ILEV,JLEV) + ENDDO + AC(JLEV) = (2.12E+22 / log10e ) * AC(JLEV) + ENDDO + + + END SUBROUTINE CALC_AVGKER +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_DATA( P_MODEL, P_EDGE, DATA_MODEL, DATA_MOP, + & NLEV_RET, FB ) + +!****************************************************************************** +!Based on the code from Monika. (zhe 1/19/11) +!FB = 1 for forward +!FB = -1 for adjoint +!****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: NLEV_RET, NB + REAL*8 :: P_MODEL(LLPAR) + REAL*8 :: DATA_MODEL(LLPAR), DATA_MOP(NLEV_RET), DATA_TEM + REAL*8 :: P_EDGE(NLEV_RET+1) + + !================================================================= + ! BIN_DATA begins here! + !================================================================= + + IF (FB > 0) THEN + + DO L = 1, NLEV_RET + DO LL = 1, LLPAR + IF ( P_MODEL(LL) <= P_EDGE(L) ) THEN + DATA_MOP(L) = DATA_MODEL(LL) + EXIT + ENDIF + ENDDO + ENDDO + + DO L = 1, NLEV_RET + NB = 0 + DATA_TEM = 0 + DO LL = 1, LLPAR + IF ( ( P_MODEL(LL) <= P_EDGE(L)) .and. + & ( P_MODEL(LL) > P_EDGE(L+1)) ) THEN + DATA_TEM = DATA_TEM + DATA_MODEL(LL) + NB = NB + 1 + ENDIF + ENDDO + IF (NB > 0) DATA_MOP(L) = DATA_TEM / NB + ENDDO + + ELSE + + DATA_MODEL(:) = 0. + DO L = 1, LLPAR + DO LL = 1, NLEV_RET + IF ( ( P_MODEL(L) <= P_EDGE(LL)) .and. + & ( P_MODEL(L) > P_EDGE(LL+1)) ) THEN + DATA_MODEL(L) = DATA_MOP(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_DATA +!----------------------------------------------------------------------------------- + + SUBROUTINE INIT_DOMAIN + +!****************************************************************************** +!Define the observatio region +!****************************************************************************** +# include "CMN_SIZE" ! Size parameters + + !local variables + INTEGER :: I, J + + !================================================================= + ! INIT_DOMAIN begins here! + !================================================================= + + DOMAIN_OBS(:,:) = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined( GRID05x0666 ) +! The surrounding region is used as cushion +! (zhe 11/28/10) + IF ( J >= 8 .and. J <= JJPAR-7 .and. + & I >= 7 .and. I <= IIPAR-6 +#elif defined( GRID2x25 ) + IF ( J >= 16 .and. J <= 76 !60S-60N +#elif defined( GRID4x5 ) + IF ( J >= 9 .and. J <= 39 !60S-60N +#endif + & ) DOMAIN_OBS(I,J) = 1d0 + + ENDDO + ENDDO + + PRINT*, sum(DOMAIN_obs), 'MAX observations today' + + END SUBROUTINE INIT_DOMAIN + +!----------------------------------------------------------------------------- + + SUBROUTINE CALC_OBS_HOUR + +!*************************************************************************** +! Subroutine CALC_OBS_HOUR computes an array of hours for each day of obs. +! If there is an obs in a particular gridbox on that day, it assigns the +! hour (0..23). If there isn't, OBS_HOUR stays initialized to -1. +! (mak, 12/14/05) +!*************************************************************************** + + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, + & GET_YEAR, GET_HOUR + USE GRID_MOD, ONLY : GET_IJ + +# include "CMN_SIZE" + + REAL*4 :: OBS_HOUR(IIPAR,JJPAR) + REAL*8 :: TAU0, UTC + INTEGER :: W, I, J + INTEGER :: LON15, IIJJ(2) + INTEGER :: COUNT_GRID(IIPAR,JJPAR) + + !================================================================= + ! CALC_OBS_HOUR begins here! + !================================================================= + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0(GET_MONTH(), GET_DAY(), GET_YEAR()) + + OBS_HOUR_MOPITT(:,:) = -1 + OBS_HOUR(:,:) = 0 + COUNT_GRID(:,:) = 0 + + DO W = 1, T_DIM + + ! Compute local time: + ! Local TIME = GMT + ( LONGITUDE / 15 ) since each hour of time + ! corresponds to 15 degrees of LONGITUDE on the globe + !============================================================ + LON15 = LONGITUDE(W) / 15d0 + UTC = TAU(W) - TAU0 + LON15 + IF ( UTC < 0d0 ) UTC = UTC + 24 + IF ( UTC > 24d0 ) UTC = UTC - 24 + + !Only consider day time MOPITT measurements + !am = 12 hrs centered on 10:30am local time (so 4:30am-4:30pm) + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > 70 + & .and. LONGITUDE(W) < 150 + & .and. LATITUDE(W) > -11 + & .and. LATITUDE(W) < 55 ) THEN +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -140 + & .and. LONGITUDE(W) < -40 + & .and. LATITUDE(W) > 10 + & .and. LATITUDE(W) < 70 ) THEN +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + IF ( UTC >= 4.5 .and. UTC <= 16.5 + & .and. LONGITUDE(W) > -126 + & .and. LONGITUDE(W) < -66 + & .and. LATITUDE(W) > 13 + & .and. LATITUDE(W) < 57 ) THEN +#else + IF ( UTC >= 4.5 .and. UTC <= 16.5 ) THEN +#endif + + ! Get grid box of current record + IIJJ = GET_IJ( LONGITUDE(W), LATITUDE(W)) + I = IIJJ(1) + J = IIJJ(2) + + ! If there's an obs, calculate the time + IF ( CO_TOTAL_COLUMN(1,W) > 0d0 ) THEN + + COUNT_GRID(I,J) = COUNT_GRID(I,J) + 1d0 + !Add the time of obs, to be averaged and floored later + OBS_HOUR(I,J) = OBS_HOUR(I,J) + MOPITT_GMT(W) + + ENDIF + ENDIF + ENDDO + + ! average obs_hour on the grid + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( COUNT_GRID(I,J) > 0d0 ) THEN + + OBS_HOUR_MOPITT(I,J) = + & FLOOR( OBS_HOUR(I,J) / COUNT_GRID(I,J) ) + + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CALC_OBS_HOUR + +!---------------------------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_MOPITT_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_MOPITT_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day) based on +! the OBS_HOUR_MOPITT array which holds the hour of obs in each gridbox +! (computed when file read in mop02_mod.f) (mak, 7/12/07) +!****************************************************************************** + + USE TIME_MOD, ONLY : GET_HOUR, GET_MINUTE + +# include "CMN_SIZE" ! Size params + + ! Function value + LOGICAL :: FLAG + + INTEGER :: I,J + + !================================================================= + ! ITS_TIME_FOR_MOPITT_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO J = 1,JJPAR + DO I = 1,IIPAR + IF( GET_HOUR() == OBS_HOUR_MOPITT(I,J) .and. + & GET_MINUTE() == 0 ) THEN + + PRINT*, 'obs_hour was', get_hour(), 'in box', I, J + FLAG = .TRUE. + + !GOTO 11 + RETURN + + ENDIF + ENDDO + ENDDO + + END FUNCTION ITS_TIME_FOR_MOPITT_OBS + +!---------------------------------------------------------------------------- + + SUBROUTINE READ_MOP02( FILENAME ) + +!****************************************************************************** +! Subroutine READ_MOP02 allocates all module arrays and reads data into +! them from the HDF file. (bmy, 7/2/03, zhe 1/19/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** + + ! References to F90 modules +#if defined( MOPITT_V5_CO_OBS ) + USE HdfSdModule + USE HdfVdModule +#endif + USE BPCH2_MOD, ONLY : GET_TAU0 + USE ERROR_MOD, ONLY : ALLOC_ERR + + ! Local variables + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + INTEGER :: as, i, year, month, day + REAL*8 :: TAU0 + +#if defined( MOPITT_V5_CO_OBS ) + INTEGER :: sId, vId, vSize, nDims, dims(4) +#endif +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + INTEGER :: he5_swopen, he5_swattach, he5_swfldinfo, + & he5_swrdfld, he5_swdetach, he5_swclose + + INTEGER :: N, fId, swathid, rank + INTEGER :: ntype(4) + INTEGER*8 :: dims8(4) + INTEGER*8 :: START1(1), STRIDE1(1), EDGE1(1) + INTEGER*8 :: START2(2), STRIDE2(2), EDGE2(2) + INTEGER*8 :: START3(3), STRIDE3(3), EDGE3(3) + INTEGER, PARAMETER :: HE5F_ACC_RDONLY=101 + character*72 dimlist, maxdimlist + +#endif + + !================================================================= + ! Mop02Read begins here! + !================================================================= + + ! Deallocate arrays + CALL CLEANUP_MOP02 + + ! Get date from filename (next to the '-' character) + i = INDEX( FILENAME, '-' ) + READ( FILENAME(i+1:i+4), '(i4)' ) year + READ( FILENAME(i+5:i+6), '(i2)' ) month + READ( FILENAME(i+7:i+8), '(i2)' ) day + + ! Get TAU0 from the date (at 0GMT) + TAU0 = GET_TAU0( month, day, year ) + +#if defined( MOPITT_V6_CO_OBS ) .or. defined( MOPITT_V7_CO_OBS ) + + ! Opening an HDF-EOS5 swath file + fId = he5_swopen(FILENAME, HE5F_ACC_RDONLY) + + ! Attaching to a swath object + swathid = he5_swattach(fId, 'MOP02' ) + + !================================================================= + ! Seconds in day (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SecondsinDay", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SecondsinDay', + & START1, STRIDE1, EDGE1, SECONDS_IN_DAY) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = dims8(1) + + !================================================================= + ! LONGITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Longitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LONGITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Longitude', + & START1, STRIDE1, EDGE1, LONGITUDE) + + !================================================================= + ! LATITUDE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Latitude", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( LATITUDE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Latitude', + & START1, STRIDE1, EDGE1, LATITUDE) + + !================================================================= + ! PRESSURE (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "Pressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'Pressure', + & START1, STRIDE1, EDGE1, PRESSURE) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = dims8(1) + + !================================================================= + ! Cloud Description (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "CloudDescription", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CLOUD_DES( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'CloudDescription', + & START1, STRIDE1, EDGE1, CLOUD_DES) + + !================================================================= + ! Surface Index (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfaceIndex", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(SURFACE_INDEX( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfaceIndex', + & START1, STRIDE1, EDGE1, SURFACE_INDEX) + + !================================================================= + ! Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "SurfacePressure", rank, dims8, + & ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE(BOTTOM_PRESSURE( dims8(1) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + START1 = (/0/) + STRIDE1 = (/1/) + EDGE1 = (/dims8(1)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'SurfacePressure', + & START1, STRIDE1, EDGE1, BOTTOM_PRESSURE) + + !================================================================= + ! CO Mixing Ratio (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims8(1), dims8(2), dims8(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MIXING_RATIO) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_RET_BOT_MIXING_RATIO) + + !================================================================= + ! CO Total Column (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievedCOTotalColumn", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims8(1), dims8(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievedCOTotalColumn', + & START2, STRIDE2, EDGE2, CO_TOTAL_COLUMN) + + !================================================================= + ! Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "RetrievalAveragingKernelMatrix", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( AVGKER( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'RetrievalAveragingKernelMatrix', + & START3, STRIDE3, EDGE3, AVGKER) + + !================================================================= + ! A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOMixingRatioProfile", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims8(1), dims8(2), dims8(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + START3 = (/0, 0, 0/) + STRIDE3 = (/1, 1, 1/) + EDGE3 = (/dims8(1), dims8(2), dims8(3)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOMixingRatioProfile', + & START3, STRIDE3, EDGE3, CO_MR_AP) + + !================================================================= + ! A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Retrieve information about a specific geolocation or data field in the swath. + as = he5_swfldinfo(swathid, "APrioriCOSurfaceMixingRatio", + & rank, dims8, ntype, dimlist, maxdimlist) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims8(1), dims8(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + START2 = (/0, 0/) + STRIDE2 = (/1, 1/) + EDGE2 = (/dims8(1), dims8(2)/) + + ! Reading data from a data field + as = he5_swrdfld(swathid, 'APrioriCOSurfaceMixingRatio', + & START2, STRIDE2, EDGE2, CO_MR_AP_BOTTOM) + + ! Detaching from the swath object + as = he5_swdetach(swathid) + + ! Closing the file + as = he5_swclose(fId) + + +#endif !MOPITT v6 + +#if defined( MOPITT_V5_CO_OBS ) + + ! Open file for HDF-VDATA interface + CALL vdOpen( FILENAME ) + + !================================================================= + ! VDATA field: Time (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Seconds in Day', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate arrays + ALLOCATE( SECONDS_IN_DAY( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SECONDS_IN_DAY' ) + + ALLOCATE( TAU( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'TAU' ) + + ALLOCATE( MOPITT_GMT( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'MOPITT_GMT' ) + + ! Read data + CALL vdGetData( vId, vSize, SECONDS_IN_DAY ) + + ! Close field + CALL vdCloseField( vId ) + + ! Compute GMT of MOPITT observations + MOPITT_GMT = ( DBLE( SECONDS_IN_DAY ) / 3600d0 ) + + ! Compute TAU values for GAMAP from SECONDS_IN_DAY + TAU = MOPITT_GMT + TAU0 + + ! Save time dimension in T_DIM + T_DIM = vSize + + !================================================================= + ! VDATA field: LONGITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Longitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LONGITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LONGITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LONGITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: LATITUDE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Latitude', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( LATITUDE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'LATITUDE' ) + + ! Read data + CALL vdGetData( vId, vSize, LATITUDE ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Cloud Description (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Cloud Description', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( CLOUD_DES( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CLOUD_DES' ) + + ! Read data + CALL vdGetData( vId, vSize, CLOUD_DES ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: Surface Index (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Index', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( SURFACE_INDEX( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'SURFACE_INDEX' ) + + ! Read data + CALL vdGetData( vId, vSize, SURFACE_INDEX ) + + ! Close field + CALL vdCloseField( vId ) + + !================================================================= + ! VDATA field: PRESSURE (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Pressure Grid', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Save PRESSURE dimension in Z_DIM + Z_DIM = vSize + + !================================================================= + ! VDATA field: Retrieval Bottom Pressure (1-D) + !================================================================= + + ! Open field for reading + CALL vdOpenField( 'Surface Pressure', vId ) + + ! Get size of field + CALL vdGetFieldDim( vId, vSize ) + + ! Allocate array + ALLOCATE( BOTTOM_PRESSURE( vSize ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'BOTTOM_PRESSURE' ) + + ! Read data + CALL vdGetData( vId, vSize, BOTTOM_PRESSURE ) + + ! Close field + CALL vdCloseField( vId ) + + ! Close HDF-VDATA interface + CALL vdClose( FILENAME ) + + + + ! Open file for HDF-SDATA interface + CALL sdOpen( FILENAME ) + + !================================================================= + ! SDATA field: CO Mixing Ratio (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MIXING_RATIO( dims(1), dims(2), dims(3) ), + & stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), + & CO_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Retrieval Bottom Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieved CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_RET_BOT_MIXING_RATIO( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_RET_BOT_MIXING_RATIO' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_RET_BOT_MIXING_RATIO ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: CO Total Column (2-D) + !================================================================= + + ! Open field + + CALL sdOpenFieldByName( 'Retrieved CO Total Column', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_TOTAL_COLUMN( dims(1), dims(2) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_TOTAL_COLUMN' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_TOTAL_COLUMN ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: Retrieval Averaging Kernel Matrix (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'Retrieval Averaging Kernel Matrix', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( AVGKER( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'AVGKER' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), AVGKER ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Mixing Ratio Profile (3-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Mixing Ratio Profile', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP( dims(1), dims(2), dims(3) ), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), dims(3), CO_MR_AP ) + + ! Close field + CALL sdCloseField( sId ) + + !================================================================= + ! SDATA field: A Priori CO Surface Mixing Ratio (2-D) + !================================================================= + + ! Open field + CALL sdOpenFieldByName( 'A Priori CO Surface Mixing Ratio', sId ) + + ! Get # of dimensions + CALL sdGetFieldDims( sId, nDims, dims ) + + ! Allocate array + ALLOCATE( CO_MR_AP_BOTTOM( dims(1), dims(2)), stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'CO_MR_AP_BOTTOM' ) + + ! Read data + CALL sdGetData( sId, dims(1), dims(2), CO_MR_AP_BOTTOM ) + + ! Close field + CALL sdCloseField( sId ) + + ! Close file and quit + CALL sdClose( FILENAME ) + +#endif !MOPITT v5 + + ! Return to calling program + END SUBROUTINE READ_MOP02 + +!------------------------------------------------------------------------------------ + + SUBROUTINE READ_ERROR_VARIANCE +! +!****************************************************************************** +! Subroutine READ_ERROR_VARIANCE reads observation error from binary punch files +! (zhe 4/20/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE TIME_MOD, ONLY : GET_TAUb + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_ERROR_VARIANCE begins here! + !================================================================= + + ! Filename + FILENAME = TRIM( 'OBS_ERR_' ) // GET_RES_EXT() + + ! Echo some information to the standard output + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_ERROR_VARIANCE: Reading ERR_PERCENT + & from: ', a ) + + ! Read data from the binary punch file + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & GET_TAUb(), IGLOB, JGLOB, + & 1, ERR_PERCENT, QUIET=.TRUE. ) + + ! Return to calling program + END SUBROUTINE READ_ERROR_VARIANCE + +!------------------------------------------------------------------------------ + + SUBROUTINE INFO_MOP02( FILENAME ) +! +!****************************************************************************** +! Subroutine INFO_MOP02 Info prints info about all VDATA and SDATA fields +! contained within the MOPITT HDF file. (bmy, 7/3/03, 4/27/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of MOPITT file to read +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE HdfSdModule + USE HdfVdModule + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + + !================================================================= + ! INFO_MOP02 begins here! + !================================================================= + + ! Print HDF-VDATA variables + CALL vdOpen( FILENAME ) + CALL vdPrintInfo + CALL vdClose( FILENAME ) + + ! Print HDF-SDATA variables + CALL sdOpen( FILENAME ) + CALL sdPrintInfo + CALL sdClose( FILENAME ) + + ! Return to calling program + END SUBROUTINE INFO_MOP02 + +!----------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_MOP02 +! +!****************************************************************************** +! Subroutine CLEANUP_MOP02 deallocates all module arrays (bmy, 4/27/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_MOP02 begins here! + !================================================================= + IF ( ALLOCATED( LATITUDE ) ) DEALLOCATE( LATITUDE ) + IF ( ALLOCATED( LONGITUDE ) ) DEALLOCATE( LONGITUDE ) + IF ( ALLOCATED( PRESSURE ) ) DEALLOCATE( PRESSURE ) + IF ( ALLOCATED( CLOUD_DES ) ) DEALLOCATE( CLOUD_DES ) + IF ( ALLOCATED( SURFACE_INDEX ) ) DEALLOCATE( SURFACE_INDEX ) + IF ( ALLOCATED( TAU ) ) DEALLOCATE( TAU ) + IF ( ALLOCATED( SECONDS_IN_DAY ) ) DEALLOCATE( SECONDS_IN_DAY ) + IF ( ALLOCATED( MOPITT_GMT ) ) DEALLOCATE( MOPITT_GMT ) + IF ( ALLOCATED( BOTTOM_PRESSURE ) ) DEALLOCATE( BOTTOM_PRESSURE ) + IF ( ALLOCATED( CO_MIXING_RATIO ) ) DEALLOCATE( CO_MIXING_RATIO ) + + IF ( ALLOCATED( CO_RET_BOT_MIXING_RATIO)) THEN + DEALLOCATE( CO_RET_BOT_MIXING_RATIO ) + ENDIF + + IF ( ALLOCATED( CO_TOTAL_COLUMN ) ) DEALLOCATE( CO_TOTAL_COLUMN ) + IF ( ALLOCATED( AVGKER ) ) DEALLOCATE( AVGKER ) + IF ( ALLOCATED( PLEV_AP ) ) DEALLOCATE( PLEV_AP ) + IF ( ALLOCATED( CO_MR_AP ) ) DEALLOCATE( CO_MR_AP ) + IF ( ALLOCATED( CO_MR_AP_BOTTOM ) ) DEALLOCATE( CO_MR_AP_BOTTOM ) + + ! Return to calling program + END SUBROUTINE CLEANUP_MOP02 + +!--------------------------------------------------------------------------------------------------- + + + END MODULE MOPITT_OBS_MOD diff --git a/code/obs_operators/omi_ch2o_obs_mod.f90 b/code/obs_operators/omi_ch2o_obs_mod.f90 new file mode 100644 index 0000000..ba67b0d --- /dev/null +++ b/code/obs_operators/omi_ch2o_obs_mod.f90 @@ -0,0 +1,948 @@ +MODULE OMI_CH2O_OBS_MOD + +! +! +! Module OMI_CH2O_OBS contains all subroutines and variables needed for OMH CH2O column data +! +! +! Module Routines: +! +! (1) READ_OMI_CH2O_FILE : Read OMI hdf file + + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC READ_OMI_CH2O_FILE + PUBLIC CALC_OMI_CH2O_FORCE + + !Arrays for diagnostic outpit + ! Module variables + + ! Diagnostic arrays for output in netCDF file + REAL*8, ALLOCATABLE :: OMH_LON(:,:), OMH_LAT(:,:) + REAL*8, ALLOCATABLE :: OMH_TIME(:), OMH_AMF_TROP(:,:) + REAL*8, ALLOCATABLE :: OMH_CH2O_TROP(:,:), OMH_CH2O_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: OMH_VIEW_ZEN(:,:), OMH_SOLAR_ZEN(:,:) + REAL*8, ALLOCATABLE :: OMH_CFR(:,:), OMH_SCW_PRE(:,:,:) + REAL*8, ALLOCATABLE :: OMH_SCW(:,:,:) + REAL*8, ALLOCATABLE :: OMH_X_Q_FLAG(:,:), OMH_M_Q_FLAG(:,:) + REAL*8, ALLOCATABLE :: LON_ORB(:,:), LAT_ORB(:,:) + REAL*8, ALLOCATABLE :: TIME_ORB(:), AMF_TROP_ORB(:,:) + REAL*8, ALLOCATABLE :: CH2O_TROP(:,:), CH2O_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: VIEW_ZEN(:,:), SOLAR_ZEN(:,:) + REAL*8, ALLOCATABLE :: CFR(:,:), SCW_PRE(:,:,:) + REAL*8, ALLOCATABLE :: SCW(:,:,:) + REAL*8, ALLOCATABLE :: X_Q_FLAG(:,:), M_Q_FLAG(:,:) + + INTEGER :: N_OMH_ORB + INTEGER, PARAMETER :: MAX_ORB = 50000 + INTEGER, PARAMETER :: N_OMH_SWATHS = 60 + INTEGER, PARAMETER :: N_OMH_LEVELS = 47 + + REAL*4:: OMH_CH2O_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI column + REAL*4:: OMH_GEOS_CH2O_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem column + REAL*4:: OMH_CH2O_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI observation error + + REAL*4:: OMH_BIAS(IIPAR,JJPAR)=0d0 ! Model bias + REAL*4:: OMH_VAR(IIPAR,JJPAR)=0d0 ! Model variance + REAL*4:: OMH_DELTA=0d0 ! temporary storage variable + REAL*4:: OMH_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations + REAL*4:: OMH_CHI_SQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + +CONTAINS + +!-----------------------------------------------------------------------------! + + SUBROUTINE READ_OMI_CH2O_FILE ( YYYYMMDD, N_OMH_ORB ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD!, HHMMSS + + CHARACTER(LEN=255) :: DIR_OMH + CHARACTER(LEN=255) :: FILENAME_OMH + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + CHARACTER(255) :: ORB_PATH,FILE_ORB,FILE_OMH + CHARACTER(2) :: I_CHAR + INTEGER :: IO_ORB_STATUS, IO_STATUS + INTEGER :: DAY + INTEGER(HID_T) :: file_id, dset_id, dspace_id + !INTEGER(HSIZE_T) :: data_dims + INTEGER :: error, DIMS_COUNTER, DIMS_INDEX + INTEGER :: N_OMH_ORB + INTEGER(HID_T) :: file_id_orb + INTEGER(HID_T) :: dset_id_orb + INTEGER(HID_T) :: dspace_id_orb + INTEGER :: error_orb + CHARACTER(LEN=255) :: filename_orb, dsetname + + INTEGER :: rank_orb, rank_omh + INTEGER(HSIZE_T) :: dims_orb(3), maxdims_orb(3) + INTEGER(HSIZE_T) :: dims_omh(3), maxdims_omh(3) + INTEGER(HSIZE_T) :: DATA_DIMS_ORB(3) + INTEGER :: GC_HOUR + LOGICAL :: DATA_VALID + + CALL CLEANUP_OMH + + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + DIR_OMH = '/users/jk/15/xzhang/OMI_HCHO/' + ORB_PATH = '/YYYY/MM/' + FILENAME_OMH = 'OMI-Aura_L2-OMHCHO_YYYYmMMDD' + + CALL EXPAND_DATE( ORB_PATH, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OMH, YYYYMMDD, 9999 ) + WRITE(I_CHAR,'(I2.2)') DAY + + !CALL SYSTEM("ls "//TRIM(ORB_PATH)//"OMH-Aura_L2-OMNO2_2016m08"//I_CHAR//"* > OMH_file_list"//I_CHAR//".txt") + CALL SYSTEM("ls "//TRIM(DIR_OMH)//TRIM(ORB_PATH)//TRIM(FILENAME_OMH)//"* > omi_hcho_file_list"//I_CHAR//".txt") + CLOSE(66) ! ugly... + + OPEN(66,FILE="omi_hcho_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + + N_OMH_ORB = 0 + DIMS_COUNTER = 1 + DIMS_INDEX = 0 + DO ! loop over all available OMH NO2 files for the current day + + READ(66,'(A)',IOSTAT=IO_STATUS) FILE_OMH + + IF(IO_STATUS < 0) EXIT + !FILE_ORB = TRIM(ORB_PATH) // FILE_ORB + + PRINT *,"Reading OMI HCHO file "//TRIM(FILE_OMH) + !! open OMH ORB file + + CALL H5OPEN_F(error) + + CALL H5FOPEN_f (FILE_OMH, H5F_ACC_RDWR_F,file_id,error) + + !PRINT *,"OMH file status: ",error_orb + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL H5DOPEN_F(FILE_ID, DSETNAME, DSET_ID, ERROR) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID, DSPACE_ID, ERROR) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID, RANK_OMH,ERROR) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID, DIMS_OMH, MAXDIMS_OMH, ERROR) + + CALL H5DCLOSE_F(DSET_ID,ERROR) + IF (ERROR < 0) DIMS_OMH(2) = 0 + + N_OMH_ORB = N_OMH_ORB + DIMS_OMH(2) + + CALL H5FCLOSE_F(FILE_ID,ERROR) + CALL H5CLOSE_F(ERROR) + !PRINT *, "DIMS3", DIMS_ORB(3) + ENDDO + + CLOSE(66) + ALLOCATE(TIME_ORB(N_OMH_ORB)) + ALLOCATE(LON_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(LAT_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(AMF_TROP_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CH2O_TROP(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CH2O_TROP_STD(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(VIEW_ZEN(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(SOLAR_ZEN(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CFR(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(X_Q_FLAG(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(M_Q_FLAG(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(SCW_PRE(N_OMH_SWATHS,N_OMH_ORB,N_OMH_LEVELS)) + ALLOCATE(SCW(N_OMH_SWATHS,N_OMH_ORB,N_OMH_LEVELS)) + CLOSE(76) + OPEN(76,FILE="omi_hcho_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + DO + READ(76,'(A)',IOSTAT=IO_ORB_STATUS) FILE_ORB + + IF(IO_ORB_STATUS < 0) EXIT + DATA_VALID = .TRUE. + !FILE_ORB = TRIM(ORB_PATH) // FILE_ORB + + !PRINT *,"Reading OMH file "//TRIM(FILE_ORB) + + !! open OMH ORB file + + CALL H5OPEN_F(error_orb) + + CALL H5FOPEN_f (FILE_ORB, H5F_ACC_RDWR_F,file_id_orb,error_orb) + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL H5DOPEN_F(FILE_ID_ORB, DSETNAME, DSET_ID_ORB, ERROR_ORB) + ! open dataspace + + CALL h5dget_space_f(dset_id_orb, dspace_id_orb, error_orb) + + CALL h5sget_simple_extent_ndims_f(dspace_id_orb, rank_orb, error_orb) + + CALL h5sget_simple_extent_dims_f(dspace_id_orb, dims_orb, maxdims_orb, error_orb) + + CALL h5dclose_f(dset_id_orb,error_orb) + + IF ( REAL(DIMS_ORB(2)) == 0d0 ) THEN + DATA_VALID = .FALSE. + ELSEIF (REAL(DIMS_ORB(3)) .NE. REAL(N_OMH_LEVELS)) THEN + DATA_VALID = .FALSE. + ELSEIF (REAL(DIMS_ORB(1)) .NE. REAL(N_OMH_SWATHS)) THEN + DATA_VALID = .FALSE. + ELSEIF (ERROR_ORB < 0) THEN + DATA_VALID = .FALSE. + ENDIF + + IF (DATA_VALID == .FALSE.) THEN + CALL H5FCLOSE_F(FILE_ID_ORB,ERROR_ORB) + CALL H5CLOSE_F(ERROR_ORB) + CYCLE + ENDIF + + ALLOCATE(OMH_TIME(dims_orb(2))) + ALLOCATE(OMH_LON(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_LAT(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_AMF_TROP(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CH2O_TROP(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CH2O_TROP_STD(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_VIEW_ZEN(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_SOLAR_ZEN(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CFR(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_SCW_PRE(dims_orb(1),dims_orb(2),dims_orb(3))) + ALLOCATE(OMH_SCW(dims_orb(1),dims_orb(2), dims_orb(3)) ) + ALLOCATE(OMH_M_Q_FLAG(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_X_Q_FLAG(dims_orb(1),dims_orb(2))) + + DIMS_INDEX = DIMS_COUNTER+DIMS_ORB(2)-1 + !! read times + !! open OMH ORB file + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Time' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_TIME,(/data_dims_orb(2),0/), error_orb) + TIME_ORB(DIMS_COUNTER:DIMS_INDEX) = OMH_TIME + CALL h5dclose_f(dset_id_orb,error_orb) + + !PRINT *,"Found matching OMH file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORB) + !! read tropospheric air mass factors + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/AirMassFactor' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_AMF_TROP, data_dims_orb, error_orb) + AMF_TROP_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_AMF_TROP + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read tropospheric CH2O column + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ReferenceSectorCorrectedVerticalColumn' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CH2O_TROP, data_dims_orb(1:2), error_orb) + CH2O_TROP(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CH2O_TROP + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read tropospheric CH2O column + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ColumnUncertainty' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CH2O_TROP_STD, data_dims_orb(1:2), error_orb) + CH2O_TROP_STD(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CH2O_TROP_STD + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read quality flag array + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/MainDataQualityFlag' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_INTEGER, OMH_M_Q_FLAG, data_dims_orb(2:3), error_orb) + M_Q_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMH_M_Q_FLAG + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read longitudes + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_LON, data_dims_orb(1:2), error_orb) + LON_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_LON + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read latitudes + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_LAT, data_dims_orb(1:2), error_orb) + LAT_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_LAT + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read viewing zenith angles + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/ViewingZenithAngle' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_VIEW_ZEN, data_dims_orb(1:2), error_orb) + VIEW_ZEN(:,DIMS_COUNTER:DIMS_INDEX) = OMH_VIEW_ZEN + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read solar zenith angles + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SOLAR_ZEN, data_dims_orb(1:2), error_orb) + SOLAR_ZEN(:,DIMS_COUNTER:DIMS_INDEX) = OMH_SOLAR_ZEN + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read cloud fraction + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/AMFCloudFraction' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CFR, data_dims_orb(1:2), error_orb) + CFR(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CFR + CALL h5dclose_f(dset_id_orb,error_orb) + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/XtrackQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORB, DSETNAME, DSET_ID_ORB, ERROR_ORB) + + CALL H5DREAD_F(DSET_ID_ORB, H5T_NATIVE_DOUBLE, OMH_X_Q_FLAG, DATA_DIMS_ORB(1:2), ERROR_ORB) + X_Q_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMH_X_Q_FLAG + CALL H5DCLOSE_F(DSET_ID_ORB,ERROR_ORB) + + !! read scattering weight pressures + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ClimatologyLevels' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SCW_PRE, data_dims_orb, error_orb) + SCW_PRE(:,DIMS_COUNTER:DIMS_INDEX,:) = OMH_SCW_PRE + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read scattering weights + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SCW, data_dims_orb, error_orb) + SCW(:,DIMS_COUNTER:DIMS_INDEX,:) = OMH_SCW + CALL h5dclose_f(dset_id_orb,error_orb) + + !! close file + + CALL H5FCLOSE_F(file_id_orb,error_orb) + + DIMS_COUNTER = DIMS_COUNTER+DIMS_ORB(2) + ! deallocate OMH arrays + CALL H5CLOSE_F(ERROR_ORB) + + IF(ALLOCATED(OMH_LON)) DEALLOCATE(OMH_LON) + IF(ALLOCATED(OMH_LAT)) DEALLOCATE(OMH_LAT) + IF(ALLOCATED(OMH_TIME)) DEALLOCATE(OMH_TIME) + IF(ALLOCATED(OMH_AMF_TROP)) DEALLOCATE(OMH_AMF_TROP) + IF(ALLOCATED(OMH_CH2O_TROP)) DEALLOCATE(OMH_CH2O_TROP) + IF(ALLOCATED(OMH_CH2O_TROP_STD)) DEALLOCATE(OMH_CH2O_TROP_STD) + IF(ALLOCATED(OMH_VIEW_ZEN)) DEALLOCATE(OMH_VIEW_ZEN) + IF(ALLOCATED(OMH_SOLAR_ZEN)) DEALLOCATE(OMH_SOLAR_ZEN) + IF(ALLOCATED(OMH_CFR)) DEALLOCATE(OMH_CFR) + IF(ALLOCATED(OMH_SCW_PRE)) DEALLOCATE(OMH_SCW_PRE) + IF(ALLOCATED(OMH_X_Q_FLAG)) DEALLOCATE(OMH_X_Q_FLAG) + IF(ALLOCATED(OMH_M_Q_FLAG)) DEALLOCATE(OMH_M_Q_FLAG) + IF(ALLOCATED(OMH_SCW)) DEALLOCATE(OMH_SCW) + + ENDDO + CLOSE(76) + + END SUBROUTINE READ_OMI_CH2O_FILE + +!================================================================================================================= + SUBROUTINE CALC_OMI_CH2O_FORCE + + USE HDF5 + + !! + !! Subroutine CALC_OMI_CH2O_FORCE computes the O3 adjoint forcing from OMH column data + !! + + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TS_CHEM + USE DAO_MOD, ONLY : BXHEIGHT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDCH2O + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,L + INTEGER :: I_OMH, J_OMH, K_OMH, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: NTSTART_OMH, NTSTOP_OMH + + !Arguments + !INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + INTEGER :: DAY + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: OMI_CH2O_GC(IIPAR,JJPAR) + REAL*8 :: SCW_GC(LLPAR), DP(LLPAR) + REAL*8 :: AMF_GC + REAL*8 :: GC_CH2O(LLPAR) + REAL*8 :: GC_CH2O_COL + REAL*8 :: DIFF, FORCE_COL, COST_CONTRIB_COL + REAL*8 :: OBS_ERROR + REAL*8 :: MEAN_DIFF(IIPAR,JJPAR) + REAL*8, SAVE :: OMH_HOUR(MAX_ORB) + REAL*8 :: OLD_COST_OMH + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMH(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + !============================================================= + ! CALC_OMI_HCHO_FORCE begins here! + !============================================================= + + PRINT *,"ID2C:",ID2C(IDCH2O) + + GC_HOUR = GET_HOUR() + + ! initialize arrays + + GC_CH2O = 0d0 + GC_CH2O_COL = 0d0 + MEAN_DIFF = 0d0 + OLD_COST_OMH = COST_FUNC + OMI_CH2O_GC = 0d0 + GC_ADJ_COUNT = 0d0 + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + SOBS_GC = 0d0 + SOBS_OMH = 0d0 + SOBS_BIAS = 0d0 + SOBS_CHISQUARED = 0d0 + + DAY = GET_DAY() + GC_HOUR = GET_HOUR() + + IF ( GET_NHMS() == 236000 - GET_TS_CHEM()* 100 ) THEN + CALL READ_OMI_CH2O_FILE(GET_NYMD(), N_OMH_ORB)!GET_NHMS()) + DO I_OMH = 1, N_OMH_ORB + IF (TIME_ORB(I_OMH) > 0) THEN + CALL TAI2UTC(TIME_ORB(I_OMH),IY,IM,ID,IH,IMIN,SEC) + IF (ID == DAY) THEN + OMH_HOUR(I_OMH) = IH + ELSE + OMH_HOUR(I_OMH) = -999 + ENDIF + ENDIF + ENDDO + ENDIF + + !! loop over data + CALL GET_NT_RANGE_OMH(N_OMH_ORB, GET_NHMS(), OMH_HOUR(1:N_OMH_ORB), NTSTART_OMH, NTSTOP_OMH) + IF ( NTSTART_OMH == 0 .and. NTSTOP_OMH == 0 ) THEN + + print*, ' No matching OMI HCHO obs for this hour' + RETURN + ENDIF + PRINT *, 'found record range:', NTSTART_OMH, NTSTOP_OMH + !PRINT *, "TIME_FRAC", TIME_FRAC(1:N_OMH_ORB) + DO I_OMH=NTSTART_OMH,NTSTOP_OMH,-1 + DO J_OMH=1,N_OMH_SWATHS + + ! A number of conditions have to be met for OMH CH2O data to actually be assimilated + IF ( ( TIME_ORB(I_OMH) > 0 ) .AND. & + ( REAL(M_Q_FLAG(J_OMH,I_OMH)) < 1d0 ) .AND. & + ( REAL(X_Q_FLAG(J_OMH,I_OMH)) < 1d0 ) .AND. & + ( ABS(LAT_ORB(J_OMH,I_OMH)) < 60d0 ) .AND. & + ( CH2O_TROP(J_OMH,I_OMH) > 0d0 ) .AND. & + ( ABS(SOLAR_ZEN(J_OMH, I_OMH)) < 75d0 ) .AND. & + ( ABS(VIEW_ZEN(J_OMH,I_OMH)) < 65d0 ) .AND. & + ( AMF_TROP_ORB(J_OMH,I_OMH) > 0d0 ) .AND. & + ( CFR(J_OMH,I_OMH) < 0.4 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + + IIJJ = GET_IJ(REAL(LON_ORB(J_OMH,I_OMH),4), REAL(LAT_ORB(J_OMH,I_OMH),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM CH2O values [#/cm3] + + GC_CH2O = 0d0 + GC_CH2O_COL = 0d0 + SCW_GC = 0d0 + DP = 0d0 + COST_CONTRIB_COL = 0d0 + FORCE_COL = 0d0 + + DO L = 1, LLPAR + + IF( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + GC_CH2O(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDCH2O)) + ENDIF + + ENDDO + + ! Compute tropospheric CH2O column value [#/cm2] + + GC_CH2O_COL = SUM(GC_CH2O(:) * BXHEIGHT(I,J,:) * 100d0) + + ! interpolate scattering weights to GEOS-Chem grid + + DO L=1,LLPAR + DO K_OMH = 2,N_OMH_LEVELS + + IF( GET_PCENTER(I,J,L) < SCW_PRE(J_OMH,I_OMH,K_OMH-1) .AND. GET_PCENTER(I,J,L) > SCW_PRE(J_OMH,I_OMH,K_OMH) ) THEN + + ! linearly interpolate scattering weights to GEOS-Chem center pressures + + SCW_GC(L) = SCW(J_OMH,I_OMH,K_OMH) + & + ( SCW(J_OMH,I_OMH,K_OMH-1) - SCW(J_OMH,I_OMH,K_OMH) ) * & + ( GET_PCENTER(I,J,L) - SCW_PRE(J_OMH,I_OMH,K_OMH) )/( SCW_PRE(J_OMH,I_OMH,K_OMH-1) - SCW_PRE(J_OMH,I_OMH,K_OMH) ) + + ! save pressure differences + + DP(L) = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + !! convert CH2O concentrations from number density to mixing ratio + + GC_CH2O(L) = GC_CH2O(L) *1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + !EXIT + + ENDIF + + ENDDO + ENDDO + + ! Use tropospheric air mass factors to convert vertical column to slant column + !PRINT *, "SUM1", SUM(GC_CH2O * DP) + !PRINT *, "SUM2", SUM(DP) + + AMF_GC = SUM(GC_CH2O * DP * SCW_GC)/SUM(GC_CH2O * DP) + !PRINT *, "AMF_GC", AMF_GC + GC_CH2O_COL = AMF_GC*GC_CH2O_COL + + ! The computation above is a little awkward, since the slant column can be computed directly from equation (2) in Bucsela2013 without + ! computing the airmass factors and CH2O column first. + ! I chose to compute the slant column from the computed air mass factors (which already included the computation of the slant column) + ! since the air mass factors might be of diagnostic interest (i.e. some reviewer might want to see them) and should be computed and saved + ! alongside other observation operator diagnostics. Furthermore, this formulation makes the adjoint of the observation operator somewhat simpler to handle. + + DIFF = GC_CH2O_COL - CH2O_TROP(J_OMH,I_OMH) * AMF_TROP_ORB(J_OMH, I_OMH) + + !MEAN_DIFF(I,J) = MEAN_DIFF(I,J) + DIFF + !PRINT *, "CHECK" + OBS_ERROR = CH2O_TROP_STD(J_OMH,I_OMH) * AMF_TROP_ORB(J_OMH,I_OMH) + IF (OBS_ERROR > 0d0) THEN + FORCE_COL = DIFF/(OBS_ERROR**2) + COST_CONTRIB_COL = 0.5d0 * DIFF * FORCE_COL + ELSE + FORCE_COL = 0d0 + COST_CONTRIB_COL = 0d0 + ENDIF + IF ( ( COST_CONTRIB_COL > 0d0 ) .AND. & + ( COST_CONTRIB_COL <= 200d0 ) ) THEN + DO L=1,LLPAR + + IF(ITS_IN_THE_TROP(I,J,L)) THEN + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) + & + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + ENDIF + ENDIF + + ENDDO + + ! update cost function + IF(SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONTRIB_COL + !PRINT *, "OBS_COST", COST_FUNC + ENDIF + ENDIF + ! update dignostic arrays + + IF(SUPER_OBS) THEN + SOBS_GC(I,J) = SOBS_GC(I,J) + GC_CH2O_COL + SOBS_OMH(I,J) = SOBS_OMH(I,J) + CH2O_TROP(J_OMH,I_OMH) + SOBS_BIAS(I,J) = SOBS_BIAS(I,J) + DIFF + SOBS_CHISQUARED(I,J) = SOBS_CHISQUARED(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + ELSE + ! calculate OMH bias and variance using Knuth's online algorithm + OMH_BIAS_COUNT(I,J) = OMH_BIAS_COUNT(I,J) + 1d0 + OMH_CH2O_MEAN(I,J) = OMH_CH2O_MEAN(I,J) + (AMF_TROP_ORB(J_OMH,I_OMH)*CH2O_TROP(J_OMH,I_OMH)) + OMH_GEOS_CH2O_MEAN(I,J) = OMH_GEOS_CH2O_MEAN(I,J) + GC_CH2O_COL + OMH_CH2O_ERR_MEAN(I,J) = OMH_CH2O_ERR_MEAN(I,J) + OBS_ERROR + OMH_DELTA = DIFF - OMH_BIAS(I,J) + OMH_BIAS(I,J) = OMH_BIAS(I,J) + OMH_DELTA/OMH_BIAS_COUNT(I,J) + OMH_VAR(I,J) = OMH_VAR(I,J) + OMH_DELTA*(DIFF-OMH_BIAS(I,J)) + OMH_CHI_SQUARED(I,J) = OMH_CHI_SQUARED(I,J) + ( DIFF/OBS_ERROR )**2 + ENDIF + ENDIF + ENDDO + ENDDO + !PRINT *, "SOBS_ADJ_FORCE", SOBS_ADJ_FORCE + !PRINT *, "CSPEC_AFTER_CHEM", CSPEC_AFTER_CHEM_ADJ + !PRINT *, "SOBS_COST_CONTRIBUTION", SOBS_COST_CONTRIBUTION + + IF(SUPER_OBS) THEN + + DO J=1,JJPAR + DO I=1,IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L=1,LLPAR + JLOOP = JLOP(I,J,L) + IF( ( ITS_IN_THE_TROP(I,J,L) ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) .AND. & + (JLOOP > 0) ) THEN + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + + OMH_BIAS_COUNT(I,J) = OMH_BIAS_COUNT(I,J) + 1d0 + + OMH_CH2O_MEAN(I,J) = OMH_CH2O_MEAN(I,J) + SOBS_OMH(I,J)/SOBS_COUNT(I,J) + + OMH_GEOS_CH2O_MEAN(I,J) = OMH_GEOS_CH2O_MEAN(I,J) + SOBS_GC(I,J)/SOBS_COUNT(I,J) + + OMH_CH2O_ERR_MEAN(I,J) = OMH_CH2O_ERR_MEAN(I,J) + OBS_ERROR + + ! calculate bias and variance of GC-OMH bias using numerically stable one-pass algorithm (Chan83) + + OMH_DELTA = SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMH_BIAS(I,J) + + OMH_BIAS(I,J) = OMH_BIAS(I,J) + OMH_DELTA/OMH_BIAS_COUNT(I,J) + + OMH_VAR(I,J) = OMH_VAR(I,J) + OMH_DELTA*(SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMH_BIAS(I,J)) + + OMH_CHI_SQUARED(I,J) = OMH_CHI_SQUARED(I,J) + SOBS_CHISQUARED(I,J)/SOBS_COUNT(I,J) + + ENDIF + + ENDDO + ENDDO + + ENDIF + + PRINT *, "COST FUNCTION OF OMI HCHO", COST_FUNC-OLD_COST_OMH + + END SUBROUTINE CALC_OMI_CH2O_FORCE + +!-----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_OMH + ! deallocate OMH arrays + + IF(ALLOCATED(LON_ORB)) DEALLOCATE(LON_ORB) + IF(ALLOCATED(LAT_ORB)) DEALLOCATE(LAT_ORB) + IF(ALLOCATED(TIME_ORB)) DEALLOCATE(TIME_ORB) + IF(ALLOCATED(AMF_TROP_ORB)) DEALLOCATE(AMF_TROP_ORB) + IF(ALLOCATED(CH2O_TROP)) DEALLOCATE(CH2O_TROP) + IF(ALLOCATED(CH2O_TROP_STD)) DEALLOCATE(CH2O_TROP_STD) + IF(ALLOCATED(VIEW_ZEN)) DEALLOCATE(VIEW_ZEN) + IF(ALLOCATED(SOLAR_ZEN)) DEALLOCATE(SOLAR_ZEN) + IF(ALLOCATED(CFR)) DEALLOCATE(CFR) + IF(ALLOCATED(SCW_PRE)) DEALLOCATE(SCW_PRE) + IF(ALLOCATED(X_Q_FLAG)) DEALLOCATE(X_Q_FLAG) + IF(ALLOCATED(M_Q_FLAG)) DEALLOCATE(M_Q_FLAG) + IF(ALLOCATED(SCW)) DEALLOCATE(SCW) + + END SUBROUTINE CLEANUP_OMH +!---------------------------------------------------------------------------------- + SUBROUTINE GET_NT_RANGE_OMH( N_OMH_ORB, HHMMSS, OMH_HOUR, NTSTART_OMH, NTSTOP_OMH) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE_OMH retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +!===================================================================================== +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART_OMH (INTEGER) : TES record number at which to start +! (1 ) NTSTOP_OMH (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_OMH_ORB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: OMH_HOUR(N_OMH_ORB) + INTEGER, INTENT(OUT) :: NTSTART_OMH + INTEGER, INTENT(OUT) :: NTSTOP_OMH + + ! Local variables + INTEGER, SAVE :: NTSAVE_OMH + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST_OMH + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE_OMH begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART_OMH = 0 + NTSTOP_OMH = 0 + + ! set NTSAVE_OMH to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE_OMH = N_OMH_ORB + !print*, ' GET_NT_RANGE_OMH for ', HHMMSS + !print*, ' NTSAVE_OMH ', NTSAVE_OMH + !print*, ' N_IASI_NOB ', N_IASI_NOB + DO WHILE (OMH_HOUR(NTSAVE_OMH) < 0 ) + NTSAVE_OMH = NTSAVE_OMH - 1 + IF (NTSAVE_OMH == 0) EXIT + ENDDO + + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE_OMH-1000:NTSAVE_OMH) + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) + ! one hour as a fraction of day + H1_FRAC = 0d0 + + + ! All records have been read already + IF ( NTSAVE_OMH == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( OMH_HOUR(NTSAVE_OMH) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( OMH_HOUR(NTSAVE_OMH) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART_OMH = NTSAVE_OMH + + !print*, ' Starting : TIME_FRAC(NTSTART_OMH) ', TIME_FRAC(NTSTART_OMH), NTSTART_OMH + + ! Now search forward to find stopping record + NTEST_OMH = NTSTART_OMH + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST_OMH = NTEST_OMH - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST_OMH == 0 ) THEN + + NTSTOP_OMH = NTEST_OMH + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMH, NTSTOP_OMH = ', NTSTART_OMH, NTSTOP_OMH + ! Reset NTSAVE_OMH + NTSAVE_OMH = NTEST_OMH + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( OMH_HOUR(NTEST_OMH) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST_OMH), NTEST_OMH + + NTSTOP_OMH = NTEST_OMH + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMH, NTSTOP_OMH = ', NTSTART_OMH, NTSTOP_OMH + + ! Reset NTSAVE_OMH + NTSAVE_OMH = NTEST_OMH + !ELSE + !print*, ' still looking ', NTEST_OMH + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE_OMH' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE_OMH +!================================================================================================================================ + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=10 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605, 615254406, 709862407, 757382408/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + !------------------------------------------------------------------------------ + SUBROUTINE OMH_HANDLE_ERR( RETVAL ) + + INTEGER, INTENT(IN) :: RETVAL + + PRINT *,"AN ERROR OCCURED WHILE WRITING OUT OMH CH2O DIAGNOSTICS!" + PRINT *,"NETCDF ERROR MESSAGE:" + + END SUBROUTINE OMH_HANDLE_ERR + + !-------------------------------------------------------------------------------- + +END MODULE OMI_CH2O_OBS_MOD diff --git a/code/obs_operators/omi_ch2o_obs_mod.f90~ b/code/obs_operators/omi_ch2o_obs_mod.f90~ new file mode 100644 index 0000000..704ea4f --- /dev/null +++ b/code/obs_operators/omi_ch2o_obs_mod.f90~ @@ -0,0 +1,948 @@ +MODULE OMI_CH2O_OBS_MOD + +! +! +! Module OMI_CH2O_OBS contains all subroutines and variables needed for OMH CH2O column data +! +! +! Module Routines: +! +! (1) READ_OMI_CH2O_FILE : Read OMI hdf file + + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC READ_OMI_CH2O_FILE + PUBLIC CALC_OMI_CH2O_FORCE + + !Arrays for diagnostic outpit + ! Module variables + + ! Diagnostic arrays for output in netCDF file + REAL*8, ALLOCATABLE :: OMH_LON(:,:), OMH_LAT(:,:) + REAL*8, ALLOCATABLE :: OMH_TIME(:), OMH_AMF_TROP(:,:) + REAL*8, ALLOCATABLE :: OMH_CH2O_TROP(:,:), OMH_CH2O_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: OMH_VIEW_ZEN(:,:), OMH_SOLAR_ZEN(:,:) + REAL*8, ALLOCATABLE :: OMH_CFR(:,:), OMH_SCW_PRE(:,:,:) + REAL*8, ALLOCATABLE :: OMH_SCW(:,:,:) + REAL*8, ALLOCATABLE :: OMH_X_Q_FLAG(:,:), OMH_M_Q_FLAG(:,:) + REAL*8, ALLOCATABLE :: LON_ORB(:,:), LAT_ORB(:,:) + REAL*8, ALLOCATABLE :: TIME_ORB(:), AMF_TROP_ORB(:,:) + REAL*8, ALLOCATABLE :: CH2O_TROP(:,:), CH2O_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: VIEW_ZEN(:,:), SOLAR_ZEN(:,:) + REAL*8, ALLOCATABLE :: CFR(:,:), SCW_PRE(:,:,:) + REAL*8, ALLOCATABLE :: SCW(:,:,:) + REAL*8, ALLOCATABLE :: X_Q_FLAG(:,:), M_Q_FLAG(:,:) + + INTEGER :: N_OMH_ORB + INTEGER, PARAMETER :: MAX_ORB = 50000 + INTEGER, PARAMETER :: N_OMH_SWATHS = 60 + INTEGER, PARAMETER :: N_OMH_LEVELS = 47 + + REAL*4:: OMH_CH2O_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI column + REAL*4:: OMH_GEOS_CH2O_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem column + REAL*4:: OMH_CH2O_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI observation error + + REAL*4:: OMH_BIAS(IIPAR,JJPAR)=0d0 ! Model bias + REAL*4:: OMH_VAR(IIPAR,JJPAR)=0d0 ! Model variance + REAL*4:: OMH_DELTA=0d0 ! temporary storage variable + REAL*4:: OMH_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations + REAL*4:: OMH_CHI_SQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + +CONTAINS + +!-----------------------------------------------------------------------------! + + SUBROUTINE READ_OMI_CH2O_FILE ( YYYYMMDD, N_OMH_ORB ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD!, HHMMSS + + CHARACTER(LEN=255) :: DIR_OMH + CHARACTER(LEN=255) :: FILENAME_OMH + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + CHARACTER(255) :: ORB_PATH,FILE_ORB,FILE_OMH + CHARACTER(2) :: I_CHAR + INTEGER :: IO_ORB_STATUS, IO_STATUS + INTEGER :: DAY + INTEGER(HID_T) :: file_id, dset_id, dspace_id + !INTEGER(HSIZE_T) :: data_dims + INTEGER :: error, DIMS_COUNTER, DIMS_INDEX + INTEGER :: N_OMH_ORB + INTEGER(HID_T) :: file_id_orb + INTEGER(HID_T) :: dset_id_orb + INTEGER(HID_T) :: dspace_id_orb + INTEGER :: error_orb + CHARACTER(LEN=255) :: filename_orb, dsetname + + INTEGER :: rank_orb, rank_omh + INTEGER(HSIZE_T) :: dims_orb(3), maxdims_orb(3) + INTEGER(HSIZE_T) :: dims_omh(3), maxdims_omh(3) + INTEGER(HSIZE_T) :: DATA_DIMS_ORB(3) + INTEGER :: GC_HOUR + LOGICAL :: DATA_VALID + + CALL CLEANUP_OMH + + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + DIR_OMH = '/users/jk/15/xzhang/OMI_HCHO/' + ORB_PATH = '/YYYY/MM/' + FILENAME_OMH = 'OMI-Aura_L2-OMHCHO_YYYYmMMDD' + + CALL EXPAND_DATE( ORB_PATH, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OMH, YYYYMMDD, 9999 ) + WRITE(I_CHAR,'(I2.2)') DAY + + !CALL SYSTEM("ls "//TRIM(ORB_PATH)//"OMH-Aura_L2-OMNO2_2016m08"//I_CHAR//"* > OMH_file_list"//I_CHAR//".txt") + CALL SYSTEM("ls "//TRIM(DIR_OMH)//TRIM(ORB_PATH)//TRIM(FILENAME_OMH)//"* > omi_hcho_file_list"//I_CHAR//".txt") + CLOSE(66) ! ugly... + + OPEN(66,FILE="omi_hcho_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + + N_OMH_ORB = 0 + DIMS_COUNTER = 1 + DIMS_INDEX = 0 + DO ! loop over all available OMH NO2 files for the current day + + READ(66,'(A)',IOSTAT=IO_STATUS) FILE_OMH + + IF(IO_STATUS < 0) EXIT + !FILE_ORB = TRIM(ORB_PATH) // FILE_ORB + + PRINT *,"Reading OMI HCHO file "//TRIM(FILE_OMH) + !! open OMH ORB file + + CALL H5OPEN_F(error) + + CALL H5FOPEN_f (FILE_OMH, H5F_ACC_RDWR_F,file_id,error) + + !PRINT *,"OMH file status: ",error_orb + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL H5DOPEN_F(FILE_ID, DSETNAME, DSET_ID, ERROR) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID, DSPACE_ID, ERROR) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID, RANK_OMH,ERROR) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID, DIMS_OMH, MAXDIMS_OMH, ERROR) + + CALL H5DCLOSE_F(DSET_ID,ERROR) + IF (ERROR < 0) DIMS_OMH(2) = 0 + + N_OMH_ORB = N_OMH_ORB + DIMS_OMH(2) + + CALL H5FCLOSE_F(FILE_ID,ERROR) + CALL H5CLOSE_F(ERROR) + !PRINT *, "DIMS3", DIMS_ORB(3) + ENDDO + + CLOSE(66) + ALLOCATE(TIME_ORB(N_OMH_ORB)) + ALLOCATE(LON_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(LAT_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(AMF_TROP_ORB(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CH2O_TROP(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CH2O_TROP_STD(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(VIEW_ZEN(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(SOLAR_ZEN(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(CFR(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(X_Q_FLAG(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(M_Q_FLAG(N_OMH_SWATHS,N_OMH_ORB)) + ALLOCATE(SCW_PRE(N_OMH_SWATHS,N_OMH_ORB,N_OMH_LEVELS)) + ALLOCATE(SCW(N_OMH_SWATHS,N_OMH_ORB,N_OMH_LEVELS)) + CLOSE(76) + OPEN(76,FILE="omi_hcho_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + DO + READ(76,'(A)',IOSTAT=IO_ORB_STATUS) FILE_ORB + + IF(IO_ORB_STATUS < 0) EXIT + DATA_VALID = .TRUE. + !FILE_ORB = TRIM(ORB_PATH) // FILE_ORB + + !PRINT *,"Reading OMH file "//TRIM(FILE_ORB) + + !! open OMH ORB file + + CALL H5OPEN_F(error_orb) + + CALL H5FOPEN_f (FILE_ORB, H5F_ACC_RDWR_F,file_id_orb,error_orb) + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL H5DOPEN_F(FILE_ID_ORB, DSETNAME, DSET_ID_ORB, ERROR_ORB) + ! open dataspace + + CALL h5dget_space_f(dset_id_orb, dspace_id_orb, error_orb) + + CALL h5sget_simple_extent_ndims_f(dspace_id_orb, rank_orb, error_orb) + + CALL h5sget_simple_extent_dims_f(dspace_id_orb, dims_orb, maxdims_orb, error_orb) + + CALL h5dclose_f(dset_id_orb,error_orb) + + IF ( REAL(DIMS_ORB(2)) == 0d0 ) THEN + DATA_VALID = .FALSE. + ELSEIF (REAL(DIMS_ORB(3)) .NE. REAL(N_OMH_LEVELS)) THEN + DATA_VALID = .FALSE. + ELSEIF (REAL(DIMS_ORB(1)) .NE. REAL(N_OMH_SWATHS)) THEN + DATA_VALID = .FALSE. + ELSEIF (ERROR_ORB < 0) THEN + DATA_VALID = .FALSE. + ENDIF + + IF (DATA_VALID == .FALSE.) THEN + CALL H5FCLOSE_F(FILE_ID_ORB,ERROR_ORB) + CALL H5CLOSE_F(ERROR_ORB) + CYCLE + ENDIF + + ALLOCATE(OMH_TIME(dims_orb(2))) + ALLOCATE(OMH_LON(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_LAT(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_AMF_TROP(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CH2O_TROP(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CH2O_TROP_STD(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_VIEW_ZEN(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_SOLAR_ZEN(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_CFR(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_SCW_PRE(dims_orb(1),dims_orb(2),dims_orb(3))) + ALLOCATE(OMH_SCW(dims_orb(1),dims_orb(2), dims_orb(3)) ) + ALLOCATE(OMH_M_Q_FLAG(dims_orb(1),dims_orb(2))) + ALLOCATE(OMH_X_Q_FLAG(dims_orb(1),dims_orb(2))) + + DIMS_INDEX = DIMS_COUNTER+DIMS_ORB(2)-1 + !! read times + !! open OMH ORB file + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Time' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_TIME,(/data_dims_orb(2),0/), error_orb) + TIME_ORB(DIMS_COUNTER:DIMS_INDEX) = OMH_TIME + CALL h5dclose_f(dset_id_orb,error_orb) + + !PRINT *,"Found matching OMH file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORB) + !! read tropospheric air mass factors + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/AirMassFactor' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_AMF_TROP, data_dims_orb, error_orb) + AMF_TROP_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_AMF_TROP + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read tropospheric CH2O column + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ReferenceSectorCorrectedVerticalColumn' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CH2O_TROP, data_dims_orb(1:2), error_orb) + CH2O_TROP(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CH2O_TROP + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read tropospheric CH2O column + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ColumnUncertainty' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CH2O_TROP_STD, data_dims_orb(1:2), error_orb) + CH2O_TROP_STD(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CH2O_TROP_STD + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read quality flag array + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/MainDataQualityFlag' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_INTEGER, OMH_M_Q_FLAG, data_dims_orb(2:3), error_orb) + M_Q_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMH_M_Q_FLAG + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read longitudes + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Longitude' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_LON, data_dims_orb(1:2), error_orb) + LON_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_LON + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read latitudes + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/Latitude' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_LAT, data_dims_orb(1:2), error_orb) + LAT_ORB(:,DIMS_COUNTER:DIMS_INDEX) = OMH_LAT + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read viewing zenith angles + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/ViewingZenithAngle' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_VIEW_ZEN, data_dims_orb(1:2), error_orb) + VIEW_ZEN(:,DIMS_COUNTER:DIMS_INDEX) = OMH_VIEW_ZEN + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read solar zenith angles + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/SolarZenithAngle' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SOLAR_ZEN, data_dims_orb(1:2), error_orb) + SOLAR_ZEN(:,DIMS_COUNTER:DIMS_INDEX) = OMH_SOLAR_ZEN + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read cloud fraction + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/AMFCloudFraction' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_CFR, data_dims_orb(1:2), error_orb) + CFR(:,DIMS_COUNTER:DIMS_INDEX) = OMH_CFR + CALL h5dclose_f(dset_id_orb,error_orb) + + DSETNAME = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Geolocation Fields/XtrackQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORB, DSETNAME, DSET_ID_ORB, ERROR_ORB) + + CALL H5DREAD_F(DSET_ID_ORB, H5T_NATIVE_DOUBLE, OMH_X_Q_FLAG, DATA_DIMS_ORB(1:2), ERROR_ORB) + X_Q_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMH_X_Q_FLAG + CALL H5DCLOSE_F(DSET_ID_ORB,ERROR_ORB) + + !! read scattering weight pressures + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ClimatologyLevels' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SCW_PRE, data_dims_orb, error_orb) + SCW_PRE(:,DIMS_COUNTER:DIMS_INDEX,:) = OMH_SCW_PRE + CALL h5dclose_f(dset_id_orb,error_orb) + + !! read scattering weights + + dsetname = '/HDFEOS/SWATHS/OMI Total Column Amount HCHO/Data Fields/ScatteringWeights' + + CALL h5dopen_f(file_id_orb, dsetname, dset_id_orb, error_orb) + + CALL h5dread_f(dset_id_orb, H5T_NATIVE_DOUBLE, OMH_SCW, data_dims_orb, error_orb) + SCW(:,DIMS_COUNTER:DIMS_INDEX,:) = OMH_SCW + CALL h5dclose_f(dset_id_orb,error_orb) + + !! close file + + CALL H5FCLOSE_F(file_id_orb,error_orb) + + DIMS_COUNTER = DIMS_COUNTER+DIMS_ORB(2) + ! deallocate OMH arrays + CALL H5CLOSE_F(ERROR_ORB) + + IF(ALLOCATED(OMH_LON)) DEALLOCATE(OMH_LON) + IF(ALLOCATED(OMH_LAT)) DEALLOCATE(OMH_LAT) + IF(ALLOCATED(OMH_TIME)) DEALLOCATE(OMH_TIME) + IF(ALLOCATED(OMH_AMF_TROP)) DEALLOCATE(OMH_AMF_TROP) + IF(ALLOCATED(OMH_CH2O_TROP)) DEALLOCATE(OMH_CH2O_TROP) + IF(ALLOCATED(OMH_CH2O_TROP_STD)) DEALLOCATE(OMH_CH2O_TROP_STD) + IF(ALLOCATED(OMH_VIEW_ZEN)) DEALLOCATE(OMH_VIEW_ZEN) + IF(ALLOCATED(OMH_SOLAR_ZEN)) DEALLOCATE(OMH_SOLAR_ZEN) + IF(ALLOCATED(OMH_CFR)) DEALLOCATE(OMH_CFR) + IF(ALLOCATED(OMH_SCW_PRE)) DEALLOCATE(OMH_SCW_PRE) + IF(ALLOCATED(OMH_X_Q_FLAG)) DEALLOCATE(OMH_X_Q_FLAG) + IF(ALLOCATED(OMH_M_Q_FLAG)) DEALLOCATE(OMH_M_Q_FLAG) + IF(ALLOCATED(OMH_SCW)) DEALLOCATE(OMH_SCW) + + ENDDO + CLOSE(76) + + END SUBROUTINE READ_OMI_CH2O_FILE + +!================================================================================================================= + SUBROUTINE CALC_OMI_CH2O_FORCE + + USE HDF5 + + !! + !! Subroutine CALC_OMI_CH2O_FORCE computes the O3 adjoint forcing from OMH column data + !! + + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TS_CHEM + USE DAO_MOD, ONLY : BXHEIGHT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE TRACERID_MOD, ONLY : IDCH2O + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,L + INTEGER :: I_OMH, J_OMH, K_OMH, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: NTSTART_OMH, NTSTOP_OMH + + !Arguments + !INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + INTEGER :: DAY + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: OMI_CH2O_GC(IIPAR,JJPAR) + REAL*8 :: SCW_GC(LLPAR), DP(LLPAR) + REAL*8 :: AMF_GC + REAL*8 :: GC_CH2O(LLPAR) + REAL*8 :: GC_CH2O_COL + REAL*8 :: DIFF, FORCE_COL, COST_CONTRIB_COL + REAL*8 :: OBS_ERROR + REAL*8 :: MEAN_DIFF(IIPAR,JJPAR) + REAL*8, SAVE :: OMH_HOUR(MAX_ORB) + REAL*8 :: OLD_COST_OMH + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMH(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + !============================================================= + ! CALC_OMI_HCHO_FORCE begins here! + !============================================================= + + PRINT *,"ID2C:",ID2C(IDCH2O) + + GC_HOUR = GET_HOUR() + + ! initialize arrays + + GC_CH2O = 0d0 + GC_CH2O_COL = 0d0 + MEAN_DIFF = 0d0 + OLD_COST_OMH = COST_FUNC + OMI_CH2O_GC = 0d0 + GC_ADJ_COUNT = 0d0 + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + NEW_COST = 0d0 + SOBS_GC = 0d0 + SOBS_OMH = 0d0 + SOBS_BIAS = 0d0 + SOBS_CHISQUARED = 0d0 + + DAY = GET_DAY() + GC_HOUR = GET_HOUR() + + IF ( GET_NHMS() == 236000 - GET_TS_CHEM()* 100 ) THEN + CALL READ_OMI_CH2O_FILE(GET_NYMD(), N_OMH_ORB)!GET_NHMS()) + DO I_OMH = 1, N_OMH_ORB + IF (TIME_ORB(I_OMH) > 0) THEN + CALL TAI2UTC(TIME_ORB(I_OMH),IY,IM,ID,IH,IMIN,SEC) + IF (ID == DAY) THEN + OMH_HOUR(I_OMH) = IH + ELSE + OMH_HOUR(I_OMH) = -999 + ENDIF + ENDIF + ENDDO + ENDIF + + !! loop over data + CALL GET_NT_RANGE_OMH(N_OMH_ORB, GET_NHMS(), OMH_HOUR(1:N_OMH_ORB), NTSTART_OMH, NTSTOP_OMH) + IF ( NTSTART_OMH == 0 .and. NTSTOP_OMH == 0 ) THEN + + print*, ' No matching OMI HCHO obs for this hour' + RETURN + ENDIF + PRINT *, 'found record range:', NTSTART_OMH, NTSTOP_OMH + !PRINT *, "TIME_FRAC", TIME_FRAC(1:N_OMH_ORB) + DO I_OMH=NTSTART_OMH,NTSTOP_OMH,-1 + DO J_OMH=1,N_OMH_SWATHS + + ! A number of conditions have to be met for OMH CH2O data to actually be assimilated + IF ( ( TIME_ORB(I_OMH) > 0 ) .AND. & + ( REAL(M_Q_FLAG(J_OMH,I_OMH)) < 1d0 ) .AND. & + ( REAL(X_Q_FLAG(J_OMH,I_OMH)) < 1d0 ) .AND. & + ( ABS(LAT_ORB(J_OMH,I_OMH)) < 60d0 ) .AND. & + ( CH2O_TROP(J_OMH,I_OMH) > 0d0 ) .AND. & + ( ABS(SOLAR_ZEN(J_OMH, I_OMH)) < 75d0 ) .AND. & + ( ABS(VIEW_ZEN(J_OMH,I_OMH)) < 65d0 ) .AND. & + ( AMF_TROP_ORB(J_OMH,I_OMH) > 0d0 ) .AND. & + ( CFR(J_OMH,I_OMH) < 0.4 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + + IIJJ = GET_IJ(REAL(LON_ORB(J_OMH,I_OMH),4), REAL(LAT_ORB(J_OMH,I_OMH),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-CHEM CH2O values [#/cm3] + + GC_CH2O = 0d0 + GC_CH2O_COL = 0d0 + SCW_GC = 0d0 + DP = 0d0 + COST_CONTRIB_COL = 0d0 + FORCE_COL = 0d0 + + DO L = 1, LLPAR + + IF( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + GC_CH2O(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDCH2O)) + ENDIF + + ENDDO + + ! Compute tropospheric CH2O column value [#/cm2] + + GC_CH2O_COL = SUM(GC_CH2O(:) * BXHEIGHT(I,J,:) * 100d0) + + ! interpolate scattering weights to GEOS-Chem grid + + DO L=1,LLPAR + DO K_OMH = 2,N_OMH_LEVELS + + IF( GET_PCENTER(I,J,L) < SCW_PRE(J_OMH,I_OMH,K_OMH-1) .AND. GET_PCENTER(I,J,L) > SCW_PRE(J_OMH,I_OMH,K_OMH) ) THEN + + ! linearly interpolate scattering weights to GEOS-Chem center pressures + + SCW_GC(L) = SCW(J_OMH,I_OMH,K_OMH) + & + ( SCW(J_OMH,I_OMH,K_OMH-1) - SCW(J_OMH,I_OMH,K_OMH) ) * & + ( GET_PCENTER(I,J,L) - SCW_PRE(J_OMH,I_OMH,K_OMH) )/( SCW_PRE(J_OMH,I_OMH,K_OMH-1) - SCW_PRE(J_OMH,I_OMH,K_OMH) ) + + ! save pressure differences + + DP(L) = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + !! convert CH2O concentrations from number density to mixing ratio + + GC_CH2O(L) = GC_CH2O(L) *1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + !EXIT + + ENDIF + + ENDDO + ENDDO + + ! Use tropospheric air mass factors to convert vertical column to slant column + !PRINT *, "SUM1", SUM(GC_CH2O * DP) + !PRINT *, "SUM2", SUM(DP) + + AMF_GC = SUM(GC_CH2O * DP * SCW_GC)/SUM(GC_CH2O * DP) + !PRINT *, "AMF_GC", AMF_GC + GC_CH2O_COL = AMF_GC*GC_CH2O_COL + + ! The computation above is a little awkward, since the slant column can be computed directly from equation (2) in Bucsela2013 without + ! computing the airmass factors and CH2O column first. + ! I chose to compute the slant column from the computed air mass factors (which already included the computation of the slant column) + ! since the air mass factors might be of diagnostic interest (i.e. some reviewer might want to see them) and should be computed and saved + ! alongside other observation operator diagnostics. Furthermore, this formulation makes the adjoint of the observation operator somewhat simpler to handle. + + DIFF = GC_CH2O_COL - CH2O_TROP(J_OMH,I_OMH) * AMF_TROP_ORB(J_OMH, I_OMH) + + !MEAN_DIFF(I,J) = MEAN_DIFF(I,J) + DIFF + !PRINT *, "CHECK" + OBS_ERROR = 0.5*CH2O_TROP_STD(J_OMH,I_OMH) * AMF_TROP_ORB(J_OMH,I_OMH) + IF (OBS_ERROR > 0d0) THEN + FORCE_COL = DIFF/(OBS_ERROR**2) + COST_CONTRIB_COL = 0.5d0 * DIFF * FORCE_COL + ELSE + FORCE_COL = 0d0 + COST_CONTRIB_COL = 0d0 + ENDIF + IF ( ( COST_CONTRIB_COL > 0d0 ) .AND. & + ( COST_CONTRIB_COL <= 800d0 ) ) THEN + DO L=1,LLPAR + + IF(ITS_IN_THE_TROP(I,J,L)) THEN + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) + & + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + ENDIF + ENDIF + + ENDDO + + ! update cost function + IF(SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONTRIB_COL + !PRINT *, "OBS_COST", COST_FUNC + ENDIF + ENDIF + ! update dignostic arrays + + IF(SUPER_OBS) THEN + SOBS_GC(I,J) = SOBS_GC(I,J) + GC_CH2O_COL + SOBS_OMH(I,J) = SOBS_OMH(I,J) + CH2O_TROP(J_OMH,I_OMH) + SOBS_BIAS(I,J) = SOBS_BIAS(I,J) + DIFF + SOBS_CHISQUARED(I,J) = SOBS_CHISQUARED(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + ELSE + ! calculate OMH bias and variance using Knuth's online algorithm + OMH_BIAS_COUNT(I,J) = OMH_BIAS_COUNT(I,J) + 1d0 + OMH_CH2O_MEAN(I,J) = OMH_CH2O_MEAN(I,J) + (AMF_TROP_ORB(J_OMH,I_OMH)*CH2O_TROP(J_OMH,I_OMH)) + OMH_GEOS_CH2O_MEAN(I,J) = OMH_GEOS_CH2O_MEAN(I,J) + GC_CH2O_COL + OMH_CH2O_ERR_MEAN(I,J) = OMH_CH2O_ERR_MEAN(I,J) + OBS_ERROR + OMH_DELTA = DIFF - OMH_BIAS(I,J) + OMH_BIAS(I,J) = OMH_BIAS(I,J) + OMH_DELTA/OMH_BIAS_COUNT(I,J) + OMH_VAR(I,J) = OMH_VAR(I,J) + OMH_DELTA*(DIFF-OMH_BIAS(I,J)) + OMH_CHI_SQUARED(I,J) = OMH_CHI_SQUARED(I,J) + ( DIFF/OBS_ERROR )**2 + ENDIF + ENDIF + ENDDO + ENDDO + !PRINT *, "SOBS_ADJ_FORCE", SOBS_ADJ_FORCE + !PRINT *, "CSPEC_AFTER_CHEM", CSPEC_AFTER_CHEM_ADJ + !PRINT *, "SOBS_COST_CONTRIBUTION", SOBS_COST_CONTRIBUTION + + IF(SUPER_OBS) THEN + + DO J=1,JJPAR + DO I=1,IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L=1,LLPAR + JLOOP = JLOP(I,J,L) + IF( ( ITS_IN_THE_TROP(I,J,L) ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) .AND. & + (JLOOP > 0) ) THEN + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDCH2O)) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDDO + + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + + OMH_BIAS_COUNT(I,J) = OMH_BIAS_COUNT(I,J) + 1d0 + + OMH_CH2O_MEAN(I,J) = OMH_CH2O_MEAN(I,J) + SOBS_OMH(I,J)/SOBS_COUNT(I,J) + + OMH_GEOS_CH2O_MEAN(I,J) = OMH_GEOS_CH2O_MEAN(I,J) + SOBS_GC(I,J)/SOBS_COUNT(I,J) + + OMH_CH2O_ERR_MEAN(I,J) = OMH_CH2O_ERR_MEAN(I,J) + OBS_ERROR + + ! calculate bias and variance of GC-OMH bias using numerically stable one-pass algorithm (Chan83) + + OMH_DELTA = SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMH_BIAS(I,J) + + OMH_BIAS(I,J) = OMH_BIAS(I,J) + OMH_DELTA/OMH_BIAS_COUNT(I,J) + + OMH_VAR(I,J) = OMH_VAR(I,J) + OMH_DELTA*(SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMH_BIAS(I,J)) + + OMH_CHI_SQUARED(I,J) = OMH_CHI_SQUARED(I,J) + SOBS_CHISQUARED(I,J)/SOBS_COUNT(I,J) + + ENDIF + + ENDDO + ENDDO + + ENDIF + + PRINT *, "COST FUNCTION OF OMI HCHO", COST_FUNC-OLD_COST_OMH + + END SUBROUTINE CALC_OMI_CH2O_FORCE + +!-----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_OMH + ! deallocate OMH arrays + + IF(ALLOCATED(LON_ORB)) DEALLOCATE(LON_ORB) + IF(ALLOCATED(LAT_ORB)) DEALLOCATE(LAT_ORB) + IF(ALLOCATED(TIME_ORB)) DEALLOCATE(TIME_ORB) + IF(ALLOCATED(AMF_TROP_ORB)) DEALLOCATE(AMF_TROP_ORB) + IF(ALLOCATED(CH2O_TROP)) DEALLOCATE(CH2O_TROP) + IF(ALLOCATED(CH2O_TROP_STD)) DEALLOCATE(CH2O_TROP_STD) + IF(ALLOCATED(VIEW_ZEN)) DEALLOCATE(VIEW_ZEN) + IF(ALLOCATED(SOLAR_ZEN)) DEALLOCATE(SOLAR_ZEN) + IF(ALLOCATED(CFR)) DEALLOCATE(CFR) + IF(ALLOCATED(SCW_PRE)) DEALLOCATE(SCW_PRE) + IF(ALLOCATED(X_Q_FLAG)) DEALLOCATE(X_Q_FLAG) + IF(ALLOCATED(M_Q_FLAG)) DEALLOCATE(M_Q_FLAG) + IF(ALLOCATED(SCW)) DEALLOCATE(SCW) + + END SUBROUTINE CLEANUP_OMH +!---------------------------------------------------------------------------------- + SUBROUTINE GET_NT_RANGE_OMH( N_OMH_ORB, HHMMSS, OMH_HOUR, NTSTART_OMH, NTSTOP_OMH) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE_OMH retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +!===================================================================================== +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART_OMH (INTEGER) : TES record number at which to start +! (1 ) NTSTOP_OMH (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_OMH_ORB + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: OMH_HOUR(N_OMH_ORB) + INTEGER, INTENT(OUT) :: NTSTART_OMH + INTEGER, INTENT(OUT) :: NTSTOP_OMH + + ! Local variables + INTEGER, SAVE :: NTSAVE_OMH + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST_OMH + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE_OMH begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART_OMH = 0 + NTSTOP_OMH = 0 + + ! set NTSAVE_OMH to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE_OMH = N_OMH_ORB + !print*, ' GET_NT_RANGE_OMH for ', HHMMSS + !print*, ' NTSAVE_OMH ', NTSAVE_OMH + !print*, ' N_IASI_NOB ', N_IASI_NOB + DO WHILE (OMH_HOUR(NTSAVE_OMH) < 0 ) + NTSAVE_OMH = NTSAVE_OMH - 1 + IF (NTSAVE_OMH == 0) EXIT + ENDDO + + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE_OMH-1000:NTSAVE_OMH) + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) + ! one hour as a fraction of day + H1_FRAC = 0d0 + + + ! All records have been read already + IF ( NTSAVE_OMH == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( OMH_HOUR(NTSAVE_OMH) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( OMH_HOUR(NTSAVE_OMH) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART_OMH = NTSAVE_OMH + + !print*, ' Starting : TIME_FRAC(NTSTART_OMH) ', TIME_FRAC(NTSTART_OMH), NTSTART_OMH + + ! Now search forward to find stopping record + NTEST_OMH = NTSTART_OMH + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST_OMH = NTEST_OMH - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST_OMH == 0 ) THEN + + NTSTOP_OMH = NTEST_OMH + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMH, NTSTOP_OMH = ', NTSTART_OMH, NTSTOP_OMH + ! Reset NTSAVE_OMH + NTSAVE_OMH = NTEST_OMH + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( OMH_HOUR(NTEST_OMH) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST_OMH), NTEST_OMH + + NTSTOP_OMH = NTEST_OMH + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMH, NTSTOP_OMH = ', NTSTART_OMH, NTSTOP_OMH + + ! Reset NTSAVE_OMH + NTSAVE_OMH = NTEST_OMH + !ELSE + !print*, ' still looking ', NTEST_OMH + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE_OMH' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE_OMH +!================================================================================================================================ + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + + IMPLICIT NONE + + INTEGER,PARAMETER :: n=10 ! number of leap seconds after Jan. 1, 1993 + INTEGER,PARAMETER :: leapsec(n) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605, 615254406, 709862407, 757382408/) + REAL*8,INTENT(IN) :: tai93 + INTEGER,INTENT(OUT) :: iy,im,id,ih,imin + REAL*8,INTENT(OUT) :: sec + REAL*8,PARAMETER :: mins = 60.0d0 + REAL*8,PARAMETER :: hour = 60.0d0*mins + REAL*8,PARAMETER :: day = 24.0d0*hour + REAL*8,PARAMETER :: year = 365.0d0*day + INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: wk,tai + INTEGER :: days,i,leap + + tai = tai93 + sec = 0.0d0 + + DO i=1,n + + IF(FLOOR(tai93) == leapsec(i)+1) THEN + sec = 60.0d0 + tai93-FLOOR(tai93) + ENDIF + + IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0 + + END DO + + iy = 1993 + FLOOR(tai /year) + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + + IF(wk < 0.0d0) THEN + iy = iy -1 + wk = tai - REAL(iy-1993)*year - FLOOR(REAL(iy-1993)/4.0)*day + END IF + + days = FLOOR(wk/day) + wk = wk - REAL(days)*day + im = 1 + + DO i=1,12 + + leap = 0 + IF(im == 2 .AND. MOD(iy,4)==0) leap=1 + IF(im == i .AND. days >= mdays(i)+leap) THEN + im = im + 1 + days = days - mdays(i)-leap + END IF + + END DO + + id = days +1 + + ih = FLOOR(wk/hour) + wk = wk - REAL(ih)*hour + imin = FLOOR(wk/mins) + + IF(sec < 60.0d0) sec = wk - REAL(imin)*mins + + RETURN + + END SUBROUTINE TAI2UTC + !------------------------------------------------------------------------------ + SUBROUTINE OMH_HANDLE_ERR( RETVAL ) + + INTEGER, INTENT(IN) :: RETVAL + + PRINT *,"AN ERROR OCCURED WHILE WRITING OUT OMH CH2O DIAGNOSTICS!" + PRINT *,"NETCDF ERROR MESSAGE:" + + END SUBROUTINE OMH_HANDLE_ERR + + !-------------------------------------------------------------------------------- + +END MODULE OMI_CH2O_OBS_MOD diff --git a/code/obs_operators/omi_no2_obs_mod.f90 b/code/obs_operators/omi_no2_obs_mod.f90 new file mode 100644 index 0000000..b0b6a78 --- /dev/null +++ b/code/obs_operators/omi_no2_obs_mod.f90 @@ -0,0 +1,1046 @@ +MODULE OMI_NO2_OBS_MOD + + !! + ! Module OMI_NO2_OBS contains all subroutines and variables needed to assimilate OMI NO2 tropospheric column data + ! + ! Module Routines: + ! + ! (1) CALC_OMI_NO2_FORCE : calculates adjoint forcing and cost function contribution for OMI tropospheric NO2 columns + ! (2) TAI2UTC : converts TAI93 (seconds since 1.1.1993) to UTC + ! (3) MAKE_OMI_BIAS_FILE_HDF5 : writes OMI satellite diagnostics in satellite diagnostic HDF5 file + ! + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC READ_OMI_NO2_FILE + PUBLIC CALC_OMI_NO2_FORCE + + ! Module variables + + ! Arrays for diagnostic output + ! OMI data + ! Parameters + REAL*8, ALLOCATABLE :: OMI_LON(:,:), OMI_LAT(:,:) + REAL*8, ALLOCATABLE :: OMI_TIME(:), OMI_AMF_TROP(:,:) + REAL*8, ALLOCATABLE :: OMI_NO2_TROP(:,:), OMI_NO2_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: OMI_VIEW_ZENITH(:,:), OMI_SOLAR_ZENITH(:,:) + REAL*8, ALLOCATABLE :: OMI_CLOUDFR(:,:), OMI_SCW_P(:) + REAL*8, ALLOCATABLE :: OMI_SCATTERING_WEIGHTS(:,:,:) + REAL*8, ALLOCATABLE :: OMI_X_QUAL_FLAG(:,:), OMI_M_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: OMI_TROPO_PRESSURE(:,:) + REAL*8, ALLOCATABLE :: LON_ORBIT(:,:), LAT_ORBIT(:,:) + REAL*8, ALLOCATABLE :: TIME_ORBIT(:), AMF_TROP_ORBIT(:,:) + REAL*8, ALLOCATABLE :: NO2_TROP(:,:), NO2_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: VIEW_ZENITH(:,:), SOLAR_ZENITH(:,:) + REAL*8, ALLOCATABLE :: CLOUDFR(:,:), SCW_P(:) + REAL*8, ALLOCATABLE :: SCATTERING_WEIGHTS(:,:,:) + REAL*8, ALLOCATABLE :: X_QUAL_FLAG(:,:), M_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: TROPO_PRESSURE(:,:) + + INTEGER :: N_OMI_ORBITS + INTEGER, PARAMETER :: MAX_ORBITS = 50000 + INTEGER, PARAMETER :: N_OMI_SWATHS = 60 + INTEGER, PARAMETER :: N_OMI_LEVELS = 35 + + ! arrays to store diagnostic information + REAL*4:: OMI_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI columns + REAL*4:: OMI_GEOS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem columns + REAL*4:: OMI_NO2_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI observation errors + REAL*4:: OMI_BIAS(IIPAR,JJPAR)=0d0 ! Model biases + REAL*4:: OMI_VAR(IIPAR,JJPAR)=0d0 ! Model variances + REAL*4:: OMI_DELTA=0d0 ! temporary storage variable + REAL*4:: OMI_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations in grid box + REAL*4:: OMI_CHISQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + LOGICAL :: FIRST = .TRUE. + +CONTAINS + + !-----------------------------------------------------------------------------! + + SUBROUTINE READ_OMI_NO2_FILE ( YYYYMMDD, N_OMI_ORBITS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD!, HHMMSS + + CHARACTER(LEN=255) :: DIR_OMI + CHARACTER(LEN=255) :: FILENAME_OMI + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + CHARACTER(255) :: ORBIT_PATH,FILE_ORBIT, FILE_ORBIT2 + CHARACTER(2) :: I_CHAR + INTEGER :: IO_ORBIT_STATUS, IO_ORBIT_STATUS2 + INTEGER :: DAY + INTEGER(HID_T) :: file_id, dset_id, file_id2, dset_id2 + + !INTEGER(HSIZE_T) :: data_dims + INTEGER :: error, DIMS_COUNTER, DIMS_INDEX + INTEGER :: N_OMI_ORBITS + INTEGER(HID_T) :: file_id_orbit, file_id_orbit2 + INTEGER(HID_T) :: dset_id_orbit, dset_id_orbit2 + INTEGER(HID_T) :: dspace_id_orbit, dspace_id_orbit2 + INTEGER :: error_orbit, error_orbit2 + CHARACTER(LEN=255) :: filename_orbit, dsetname, filename_orbit2, dsetname2 + + INTEGER :: rank_orbit, rank_orbit2 + INTEGER(HSIZE_T) :: dims_orbit(3), maxdims_orbit(3), dims_count(3), maxdims_orbit2(3) + INTEGER(HSIZE_T) :: DATA_DIMS_ORBIT(3) + INTEGER :: GC_HOUR + LOGICAL :: DATA_VALID + + CALL CLEANUP_OMI + + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + DIR_OMI = '/users/jk/15/xzhang/OMI_NO2/' + ORBIT_PATH = '/YYYY/MM/' + FILENAME_OMI = 'OMI-Aura_L2-OMNO2_YYYYmMMDD' + + CALL EXPAND_DATE( ORBIT_PATH, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OMI, YYYYMMDD, 9999 ) + WRITE(I_CHAR,'(I2.2)') DAY + !WRITE(I_CHAR2, '(I4.4)') YEAR + !WRITE(I_CHAR3, '(I2.2)') + !PRINT *, "PATH TO FILE", TRIM(ORBIT_PATH)//TRIM(FILENAME_OMI) + !CALL SYSTEM("ls "//TRIM(ORBIT_PATH)//"OMI-Aura_L2-OMNO2_2016m08"//I_CHAR//"* > omi_file_list"//I_CHAR//".txt") + CALL SYSTEM("ls "//TRIM(DIR_OMI)//TRIM(ORBIT_PATH)//TRIM(FILENAME_OMI)//"* > omi_file_list"//I_CHAR//".txt") + CLOSE(65) ! ugly... + + OPEN(65,FILE="omi_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + + N_OMI_ORBITS = 0 + DIMS_COUNTER = 1 + DIMS_INDEX = 0 + DO ! loop over all available OMI NO2 files for the current day + + READ(65,'(A)',IOSTAT=IO_ORBIT_STATUS2) FILE_ORBIT2 + + IF(IO_ORBIT_STATUS2 < 0) EXIT + !FILE_ORBIT = TRIM(ORBIT_PATH) // FILE_ORBIT + + PRINT *,"Reading OMI file "//TRIM(FILE_ORBIT2) + + !! open OMI orbit file + + CALL H5OPEN_F(error_orbit2) + + CALL H5FOPEN_f (FILE_ORBIT2, H5F_ACC_RDWR_F,file_id_orbit2,error_orbit2) + + !PRINT *,"OMI file status: ",error_orbit + + ! Open an existing dataset. + + DSETNAME2 = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT2, DSETNAME2, DSET_ID_ORBIT2, ERROR_ORBIT2) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID_ORBIT2, DSPACE_ID_ORBIT2, ERROR_ORBIT2) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID_ORBIT2, RANK_ORBIT2,ERROR_ORBIT2) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID_ORBIT2, DIMS_COUNT, MAXDIMS_ORBIT2, ERROR_ORBIT2) + + CALL H5DCLOSE_F(DSET_ID_ORBIT2,ERROR_ORBIT2) + IF (ERROR_ORBIT2 < 0) THEN + DIMS_COUNT(3) = 0 + ENDIF + N_OMI_ORBITS = N_OMI_ORBITS + DIMS_COUNT(3) + CALL H5FCLOSE_F(FILE_ID_ORBIT2,ERROR_ORBIT2) + CALL H5CLOSE_F(ERROR_ORBIT2) + !PRINT *, "DIMS3", DIMS_ORBIT(3) + ENDDO + !PRINT *, "DATA_DIMS", N_OMI_ORBITS + CLOSE(65) + !PRINT *, "N_OMI_ORBITS TOTAL", N_OMI_ORBITS + ALLOCATE(TIME_ORBIT(N_OMI_ORBITS)) + ALLOCATE(LON_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(LAT_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(AMF_TROP_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(NO2_TROP(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(NO2_TROP_STD(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(VIEW_ZENITH(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(SOLAR_ZENITH(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(CLOUDFR(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(X_QUAL_FLAG(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(M_QUAL_FLAG(N_OMI_ORBITS)) + ALLOCATE(SCW_P(N_OMI_LEVELS)) + ALLOCATE(TROPO_PRESSURE(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(SCATTERING_WEIGHTS(N_OMI_LEVELS,N_OMI_SWATHS,N_OMI_ORBITS)) + CLOSE(75) + OPEN(75,FILE="omi_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + DO + READ(75,'(A)',IOSTAT=IO_ORBIT_STATUS) FILE_ORBIT + + IF(IO_ORBIT_STATUS < 0) EXIT + DATA_VALID = .TRUE. + !FILE_ORBIT = TRIM(ORBIT_PATH) // FILE_ORBIT + + !PRINT *,"Reading OMI file "//TRIM(FILE_ORBIT) + + !! open OMI orbit file + + CALL H5OPEN_F(error_orbit) + + CALL H5FOPEN_f (FILE_ORBIT, H5F_ACC_RDWR_F,file_id_orbit,error_orbit) + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID_ORBIT, DSPACE_ID_ORBIT, ERROR_ORBIT) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID_ORBIT, RANK_ORBIT,ERROR_ORBIT) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID_ORBIT, DIMS_ORBIT, MAXDIMS_ORBIT, ERROR_ORBIT) + + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + IF ( REAL(DIMS_ORBIT(3)) == 0d0 ) THEN + DATA_VALID = .FALSE. + ELSEIF ( REAL(DIMS_ORBIT(1)) .NE. REAL(N_OMI_LEVELS)) THEN + DATA_VALID = .FALSE. + ELSEIF ( REAL(DIMS_ORBIT(2)) .NE. REAL(N_OMI_SWATHS)) THEN + DATA_VALID = .FALSE. + ELSEIF ( ERROR_ORBIT < 0 ) THEN + DATA_VALID = .FALSE. + ENDIF + + IF (DATA_VALID == .FALSE.) THEN + CALL H5FCLOSE_F(FILE_ID_ORBIT,ERROR_ORBIT) + CALL H5CLOSE_F(ERROR_ORBIT) + CYCLE + ENDIF + !PRINT *,"Found matching OMI file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORBIT) + !PRINT *,"Found matching OMI file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORBIT) + + ALLOCATE(OMI_TIME(DIMS_ORBIT(3))) + ALLOCATE(OMI_LON(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_LAT(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_AMF_TROP(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_NO2_TROP(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_NO2_TROP_STD(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_VIEW_ZENITH(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_SOLAR_ZENITH(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_CLOUDFR(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_X_QUAL_FLAG(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_M_QUAL_FLAG(DIMS_ORBIT(3))) + ALLOCATE(OMI_SCW_P(DIMS_ORBIT(1))) + ALLOCATE(OMI_TROPO_PRESSURE(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_SCATTERING_WEIGHTS(DIMS_ORBIT(1),DIMS_ORBIT(2),DIMS_ORBIT(3)) ) + + DIMS_INDEX = DIMS_COUNTER+DIMS_ORBIT(3)-1 + + !! read in OMI data + !! read time + dsetname = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Time' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + !PRINT *, "DATA_DIMS_ORBIT", DATA_DIMS_ORBIT(3) + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_TIME, (/DATA_DIMS_ORBIT(3)/), ERROR_ORBIT) + !PRINT *, "DIMS_COUNTER", DIMS_COUNTER + !PRINT *, "DIMS_COUNTER2", DIMS_INDEX + !PRINT *, "SHAPE1", SHAPE(TIME_ORBIT(DIMS_COUNTER:DIMS_INDEX)) + !PRINT *, "SHAPE2", SHAPE(OMI_TIME) + TIME_ORBIT(DIMS_COUNTER:DIMS_INDEX) = OMI_TIME + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read tropospheric air mass factors + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/AmfTrop' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_AMF_TROP, DATA_DIMS_ORBIT, ERROR_ORBIT) + AMF_TROP_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_AMF_TROP + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "AMF_TROP_ORBIT", SHAPE(AMF_TROP_ORBIT) + + !! read tropospheric NO2 column + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ColumnAmountNO2Trop' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_NO2_TROP, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + NO2_TROP(:,DIMS_COUNTER:DIMS_INDEX) = OMI_NO2_TROP + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "NO2_TROP", NO2_TROP(:,DIMS_ORBIT(3)) + !! read tropospheric NO2 column + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/TropopausePressure' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_TROPO_PRESSURE, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + TROPO_PRESSURE(:,DIMS_COUNTER:DIMS_INDEX) = OMI_TROPO_PRESSURE + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !! read longitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ColumnAmountNO2TropStd' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_NO2_TROP_STD, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + NO2_TROP_STD(:,DIMS_COUNTER:DIMS_INDEX) = OMI_NO2_TROP_STD + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read longitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Longitude' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_LON, DATA_DIMS_ORBIT, ERROR_ORBIT) + LON_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_LON + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "LONG", LON_ORBIT(:,DIMS_ORBIT(3)) + + + !! read latitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Latitude' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_LAT, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + LAT_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_LAT + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "LON", LAT_ORBIT(:,DIMS_ORBIT(3)) + + !! read viewing zenith angles + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/ViewingZenithAngle' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_VIEW_ZENITH, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + VIEW_ZENITH(:,DIMS_COUNTER:DIMS_INDEX) = OMI_VIEW_ZENITH + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read solar zenith angles + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/SolarZenithAngle' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SOLAR_ZENITH, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + SOLAR_ZENITH(:,DIMS_COUNTER:DIMS_INDEX) = OMI_SOLAR_ZENITH + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read cloud fraction + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/CloudFraction' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_CLOUDFR, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + CLOUDFR(:,DIMS_COUNTER:DIMS_INDEX) = OMI_CLOUDFR + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read scattering weight pressures + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWtPressure' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SCW_P, (/DATA_DIMS_ORBIT(1),0/), ERROR_ORBIT) + SCW_P = OMI_SCW_P + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "data_dims_orbit", (/DATA_DIMS_ORBIT(1),0/) + !! read scattering weights + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SCATTERING_WEIGHTS, DATA_DIMS_ORBIT, ERROR_ORBIT) + SCATTERING_WEIGHTS(:,:,DIMS_COUNTER:DIMS_INDEX) = OMI_SCATTERING_WEIGHTS + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "SCATTERING WEIGHTS", SHAPE(SCATTERING_WEIGHTS) + !! close file + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/XTrackQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_X_QUAL_FLAG, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + X_QUAL_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMI_X_QUAL_FLAG + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "X QUAL FLAG", SHAPE(OMI_X_QUAL_FLAG) + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/MeasurementQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_M_QUAL_FLAG, (/DATA_DIMS_ORBIT(3)/), ERROR_ORBIT) + M_QUAL_FLAG(DIMS_COUNTER:DIMS_INDEX) = OMI_M_QUAL_FLAG + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "M_QUAL_FLAG", SHAPE(OMI_M_QUAL_FLAG) + + CALL H5FCLOSE_F(FILE_ID_ORBIT,ERROR_ORBIT) + DIMS_COUNTER = DIMS_COUNTER+DIMS_ORBIT(3) + CALL H5CLOSE_F(ERROR_ORBIT) + ! deallocate OMI arrays + IF(ALLOCATED(OMI_LON)) DEALLOCATE(OMI_LON) + IF(ALLOCATED(OMI_LAT)) DEALLOCATE(OMI_LAT) + IF(ALLOCATED(OMI_TIME)) DEALLOCATE(OMI_TIME) + IF(ALLOCATED(OMI_AMF_TROP)) DEALLOCATE(OMI_AMF_TROP) + IF(ALLOCATED(OMI_NO2_TROP)) DEALLOCATE(OMI_NO2_TROP) + IF(ALLOCATED(OMI_NO2_TROP_STD)) DEALLOCATE(OMI_NO2_TROP_STD) + IF(ALLOCATED(OMI_VIEW_ZENITH)) DEALLOCATE(OMI_VIEW_ZENITH) + IF(ALLOCATED(OMI_SOLAR_ZENITH)) DEALLOCATE(OMI_SOLAR_ZENITH) + IF(ALLOCATED(OMI_CLOUDFR)) DEALLOCATE(OMI_CLOUDFR) + IF(ALLOCATED(OMI_SCW_P)) DEALLOCATE(OMI_SCW_P) + IF(ALLOCATED(OMI_X_QUAL_FLAG)) DEALLOCATE(OMI_X_QUAL_FLAG) + IF(ALLOCATED(OMI_M_QUAL_FLAG)) DEALLOCATE(OMI_M_QUAL_FLAG) + IF(ALLOCATED(OMI_TROPO_PRESSURE)) DEALLOCATE(OMI_TROPO_PRESSURE) + IF(ALLOCATED(OMI_SCATTERING_WEIGHTS)) DEALLOCATE(OMI_SCATTERING_WEIGHTS) + ENDDO + CLOSE(75) + !N_OMI_ORBITS = DATA_DIMS + END SUBROUTINE READ_OMI_NO2_FILE +!================================================================================================================================ + SUBROUTINE CALC_OMI_NO2_FORCE + + USE HDF5 + + !! + !! Subroutine CALC_OMI_NO2_FORCE computes the NO2 adjoint forcing and cost function contribution from OMI column data + !! + !! References: + !! + !! Bucsela2013: + !! "A new stratospheric and tropospheric NO2 retrieval algorithm for nadir-viewing satellite instruments: applications to OMI" + !! E.J. Bucsela et.al + !! Atmos. Meas. Tech., 6, 2607-2626, 2013 + !! www.atmos-meas-tech.net/6/2607/2013/ + !! doi:10.5194/amt-6-2607-2013 + !! + !! Chan83 + !! "Algorithms for Computing the Sample Variance: Analysis and Recommendations" + !! Tony F. Chan, Gene H. Golub, Randall J. LeVeque + !! The American Statistician + !! Vol. 37, No. 3 (Aug. 1983), pp. 242-247 + !! + + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TS_CHEM + USE DAO_MOD, ONLY : BXHEIGHT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE TRACERID_MOD, ONLY : IDNO2 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + + + INTEGER :: I,J,L + INTEGER :: I_OMI, J_OMI, K_OMI, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: DAY + INTEGER :: NTSTART_OMI, NTSTOP_OMI + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: OMI_NO2_GC(IIPAR,JJPAR) + REAL*8 :: SCW_GC(LLPAR), DP(LLPAR) + REAL*8 :: AMF_GC + REAL*8 :: GC_NO2(LLPAR) + REAL*8 :: GC_NO2_COL + REAL*8 :: DIFF, FORCE_COL, COST_CONTRIB_COL + REAL*8 :: OBS_ERROR + REAL*8, SAVE :: OMI_HOUR(MAX_ORBITS) + REAL*8 :: OLD_COST_OMI + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMI(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( SECOND ) THEN + FILENAME = 'lat_orb_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 301, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 302, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_gc_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 303, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_obs_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 304, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 305, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 312, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_OMI_NO2_FORCE begins here! + !================================================================= + ! initialize arrays + + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + OMI_NO2_GC = 0d0 + OLD_COST_OMI = COST_FUNC + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + GC_ADJ_COUNT = 0d0 + NEW_COST = 0d0 + SOBS_GC = 0d0 + SOBS_OMI = 0d0 + SOBS_BIAS = 0d0 + SOBS_CHISQUARED = 0d0 + !DATA_DIMS_ORBIT(:) = 4565449537985793824 + ! Loop through data to find observations + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + IF ( GET_NHMS() == 236000 - GET_TS_CHEM()* 100 ) THEN + CALL READ_OMI_NO2_FILE(GET_NYMD(), N_OMI_ORBITS)!GET_NHMS()) + DO I_OMI = 1, N_OMI_ORBITS + IF (TIME_ORBIT(I_OMI) > 0) THEN + CALL TAI2UTC(TIME_ORBIT(I_OMI),IY,IM,ID,IH,IMIN,SEC) + IF (ID == DAY) THEN + OMI_HOUR(I_OMI) = IH + ELSE + OMI_HOUR(I_OMI) = -999 + ENDIF + ENDIF + ENDDO + ENDIF + !! loop over data + CALL GET_NT_RANGE_OMI(N_OMI_ORBITS, GET_NHMS(), OMI_HOUR(1:N_OMI_ORBITS), NTSTART_OMI, NTSTOP_OMI) + IF ( NTSTART_OMI == 0 .and. NTSTOP_OMI == 0 ) THEN + + print*, ' No matching OMI NO2 obs for this hour' + RETURN + ENDIF + PRINT *, 'found record range:', NTSTART_OMI, NTSTOP_OMI + !PRINT *, 'X_QUAL_FLAG',X_QUAL_FLAG(:,NTSTOP_OMI-1:NTSTART_OMI) + !PRINT *, 'M_QUAL_FLAG',M_QUAL_FLAG(NTSTOP_OMI-1:NTSTART_OMI) + !PRINT *, "TIME_FRAC", TIME_FRAC(1:N_OMI_ORBITS) + DO I_OMI=NTSTART_OMI,NTSTOP_OMI,-1 + DO J_OMI=1,N_OMI_SWATHS + !PRINT *, "QFLAG", M_QUAL_FLAG(I_OMI), X_QUAL_FLAG(J_OMI,I_OMI), NO2_TROP(J_OMI,I_OMI) + ! A number of conditions have to be met for OMI NO2 data to actually be assimilated + IF ( ( TIME_ORBIT(I_OMI) > 0 ) .AND. & +#if defined(NESTED_NA) || defined(NESTED_CH) + ( LON_ORBIT(J_OMI,I_OMI) >= GET_XMID(1) ) .AND. & + ( LON_ORBIT(J_OMI,I_OMI) <= GET_XMID(IIPAR)) .AND. & + ( LAT_ORBIT(J_OMI,I_OMI) >= GET_YMID(1) ) .AND. & + ( LAT_ORBIT(J_OMI,I_OMI) <= GET_YMID(JJPAR)) .AND. & +#endif + ( ABS(LAT_ORBIT(J_OMI,I_OMI)) < 60d0 ) .AND. & + ( NO2_TROP(J_OMI,I_OMI) > 0d0 ) .AND. & + ( NO2_TROP_STD(J_OMI,I_OMI) > 0d0 ) .AND. & + ( ABS(SOLAR_ZENITH(J_OMI,I_OMI)) < 75d0 ) .AND. & + ( ABS(VIEW_ZENITH(J_OMI,I_OMI)) < 65d0 ) .AND. & + ( AMF_TROP_ORBIT(J_OMI,I_OMI) > 0d0 ) .AND. & + ( REAL(X_QUAL_FLAG(J_OMI,I_OMI)) < 1d0 ) .AND. & + ( M_QUAL_FLAG(I_OMI) == 0d0 ) .AND. & + ( CLOUDFR(J_OMI,I_OMI) >= 0d0 ) .AND. & + ( CLOUDFR(J_OMI,I_OMI) < 200 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + + IIJJ = GET_IJ(REAL(LON_ORBIT(J_OMI,I_OMI),4), REAL(LAT_ORBIT(J_OMI,I_OMI),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! initialize variables & arrays + + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + SCW_GC = 0d0 + DP = 0d0 + COST_CONTRIB_COL = 0d0 + FORCE_COL = 0d0 + + ! Get GEOS-CHEM NO2 values [#/cm3] + + DO L = 1, LLPAR + + !IF( ITS_IN_THE_TROP(I,J,L) ) THEN + IF ( GET_PEDGE(I,J,L) >= TROPO_PRESSURE(J_OMI,I_OMI) ) THEN + JLOOP = JLOP(I,J,L) + IF (GET_PEDGE(I,J,L) >= 400d0) THEN + GC_NO2(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDNO2)) + ELSE + GC_NO2(L) = CSPEC(JLOOP,IDNO2) + ENDIF + !PRINT *, "GC_NO2", GC_NO2(2) + ENDIF + + ENDDO + + ! Compute tropospheric NO2 vertical column [#/cm2] + + GC_NO2_COL = SUM(GC_NO2(:) * BXHEIGHT(I,J,:)*100d0) + + ! interpolate scattering weights to GEOS-Chem grid to compute GEOS-Chem air mass factors + ! question: how do differences in surface pressures used in the retrieval and GEOS-Chem affect the computation below? + + DO L=1,LLPAR + DO K_OMI = 2,N_OMI_LEVELS + + IF( GET_PCENTER(I,J,L) < SCW_P(K_OMI-1) .AND. GET_PCENTER(I,J,L) > SCW_P(K_OMI) ) THEN + + ! linearly interpolate scattering weights to GEOS-Chem center pressures + + SCW_GC(L) = SCATTERING_WEIGHTS(K_OMI,J_OMI,I_OMI) + & + ( SCATTERING_WEIGHTS(K_OMI-1,J_OMI,I_OMI) - SCATTERING_WEIGHTS(K_OMI,J_OMI,I_OMI) ) * & + ( GET_PCENTER(I,J,L) - SCW_P(K_OMI) ) / ( SCW_P(K_OMI-1) - SCW_P(K_OMI) ) + + ! save pressure difference of edge pressures + + DP(L) = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! apply temperature correction, as in Bucsela2013, eq. (4) + + SCW_GC(L) = SCW_GC(L) * ( 1 - 0.003 * ( T(I,J,L) - 220 ) ) + + ! convert NO2 concentrations from number density to mixing ratio, as required for the calculation of the air mass factors from scattering weights + + GC_NO2(L) = GC_NO2(L) *1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + EXIT ! exit loop over K_OMI to go to next cycle in loop over L + + ENDIF + + ENDDO + ENDDO + + ! Use GEOS-Chem tropospheric air mass factors to convert vertical column to slant column + AMF_GC = SUM(GC_NO2 * DP * SCW_GC)/SUM(GC_NO2 * DP) + !PRINT *, "AMF_GC", AMF_GC + GC_NO2_COL = AMF_GC*GC_NO2_COL + + ! The computation above is a little awkward, since the slant column can be computed directly from equation (2) in Bucsela2013 without + ! computing the airmass factors and NO2 column first. + ! I chose to compute the slant column from the computed air mass factors (which already included the computation of the slant column) + ! since the air mass factors might be of diagnostic interest and can be computed and saved + ! alongside other observation operator diagnostics. Furthermore, this formulation makes the adjoint of the observation operator somewhat simpler to handle. + + ! compute slant column difference + + DIFF = GC_NO2_COL - (NO2_TROP(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI)) + !PRINT *, "GC_NO2_COL", GC_NO2_COL + !PRINT *, "NO2_TROP", GC_NO2_COL-DIFF + !PRINT *, "AMF_GC", AMF_GC + !PRINT *, "AMF_OBS", AMF_TROP_ORBIT(J_OMI,I_OMI) + ! compute slant column standard deviation + !PRINT *, "CHECK" + OBS_ERROR = 0.05*NO2_TROP_STD(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI) + IF (OBS_ERROR>0d0) THEN + FORCE_COL = DIFF/(OBS_ERROR**2) + COST_CONTRIB_COL = 0.5d0 * DIFF * FORCE_COL + ELSE + FORCE_COL = 0d0 + COST_CONTRIB_COL = 0d0 + ENDIF + ! update adjoint NO2 concentration + IF ( ( COST_CONTRIB_COL > 0d0 ) .AND. & + ( COST_CONTRIB_COL <= 80000d0) ) THEN + DO L = 1, LLPAR + IF (ITS_IN_THE_TROP(I,J,L)) THEN + ! question: how do errors in retrieved surface pressure impact the NO2 column values? + ! question: how do errors in simulated surface pressures impact the NO2 column values? + + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) & + + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + ENDIF + ENDIF + + ENDDO + ! update cost function + + IF(SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONTRIB_COL + ENDIF + + ENDIF + + WRITE(301,110) ( LAT_ORBIT(J_OMI,I_OMI) ) + WRITE(302,110) ( LON_ORBIT(J_OMI,I_OMI) ) + !WRITE(303,110) ( AMF_GC ) + !WRITE(304,110) ( AMF_TROP_ORBIT(J_OMI,I_OMI) ) + WRITE(312,110) ( DIFF/1e10 ) +110 FORMAT(F18.6,1X) + + ! update diagnostic arrays + + IF( SUPER_OBS) THEN + SOBS_GC(I,J) = SOBS_GC(I,J) + GC_NO2_COL + SOBS_OMI(I,J) = SOBS_OMI(I,J) + NO2_TROP(J_OMI,I_OMI) + SOBS_BIAS(I,J) = SOBS_BIAS(I,J) + DIFF + SOBS_CHISQUARED(I,J) = SOBS_CHISQUARED(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + ELSE + + OMI_BIAS_COUNT(I,J) = OMI_BIAS_COUNT(I,J) + 1d0 + + OMI_NO2_MEAN(I,J) = OMI_NO2_MEAN(I,J) + NO2_TROP(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI) + + OMI_GEOS_NO2_MEAN(I,J) = OMI_GEOS_NO2_MEAN(I,J) + GC_NO2_COL + + OMI_NO2_ERR_MEAN(I,J) = OMI_NO2_ERR_MEAN(I,J) + OBS_ERROR + + OMI_DELTA = DIFF - OMI_BIAS(I,J) + + OMI_BIAS(I,J) = OMI_BIAS(I,J) + OMI_DELTA/OMI_BIAS_COUNT(I,J) + + OMI_VAR(I,J) = OMI_VAR(I,J) + OMI_DELTA*(DIFF-OMI_BIAS(I,J)) + + OMI_CHISQUARED(I,J) = OMI_CHISQUARED(I,J) + ( DIFF/OBS_ERROR )**2 + + ENDIF + ENDIF ! data selection IF statement + + ENDDO ! J + ENDDO ! I + + IF(SUPER_OBS) THEN + + DO J=1,JJPAR + DO I=1,IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L=1,LLPAR + JLOOP = JLOP(I,J,L) + IF( ( ITS_IN_THE_TROP(I,J,L) ).AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) .AND. & + ( JLOOP > 0 ) ) THEN + + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) & + + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDDO + WRITE(305,110) (SOBS_COUNT(I,J)) + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + + OMI_BIAS_COUNT(I,J) = OMI_BIAS_COUNT(I,J) + 1d0 + + OMI_NO2_MEAN(I,J) = OMI_NO2_MEAN(I,J) + SOBS_OMI(I,J)/SOBS_COUNT(I,J) + + OMI_GEOS_NO2_MEAN(I,J) = OMI_GEOS_NO2_MEAN(I,J) + SOBS_GC(I,J)/SOBS_COUNT(I,J) + + OMI_NO2_ERR_MEAN(I,J) = OMI_NO2_ERR_MEAN(I,J) + OBS_ERROR ! mkeller: need to change this to reflect super observation error, but how? + + ! calculate bias and variance of GC-OMI bias using numerically stable one-pass algorithm (Chan83) + + OMI_DELTA = SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMI_BIAS(I,J) + + OMI_BIAS(I,J) = OMI_BIAS(I,J) + OMI_DELTA/OMI_BIAS_COUNT(I,J) + + OMI_VAR(I,J) = OMI_VAR(I,J) + OMI_DELTA*(SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMI_BIAS(I,J)) + + OMI_CHISQUARED(I,J) = OMI_CHISQUARED(I,J) + SOBS_CHISQUARED(I,J)/SOBS_COUNT(I,J) + + ENDIF + + ENDDO + ENDDO + + ENDIF + PRINT *, "OMI NO2 COST FUNCTION", COST_FUNC-OLD_COST_OMI + END SUBROUTINE CALC_OMI_NO2_FORCE + + !-----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_OMI + ! deallocate OMI arrays + + IF(ALLOCATED(LON_ORBIT)) DEALLOCATE(LON_ORBIT) + IF(ALLOCATED(LAT_ORBIT)) DEALLOCATE(LAT_ORBIT) + IF(ALLOCATED(TIME_ORBIT)) DEALLOCATE(TIME_ORBIT) + IF(ALLOCATED(AMF_TROP_ORBIT)) DEALLOCATE(AMF_TROP_ORBIT) + IF(ALLOCATED(NO2_TROP)) DEALLOCATE(NO2_TROP) + IF(ALLOCATED(NO2_TROP_STD)) DEALLOCATE(NO2_TROP_STD) + IF(ALLOCATED(VIEW_ZENITH)) DEALLOCATE(VIEW_ZENITH) + IF(ALLOCATED(SOLAR_ZENITH)) DEALLOCATE(SOLAR_ZENITH) + IF(ALLOCATED(CLOUDFR)) DEALLOCATE(CLOUDFR) + IF(ALLOCATED(SCW_P)) DEALLOCATE(SCW_P) + IF(ALLOCATED(X_QUAL_FLAG)) DEALLOCATE(X_QUAL_FLAG) + IF(ALLOCATED(M_QUAL_FLAG)) DEALLOCATE(M_QUAL_FLAG) + IF(ALLOCATED(TROPO_PRESSURE)) DEALLOCATE(TROPO_PRESSURE) + IF(ALLOCATED(SCATTERING_WEIGHTS)) DEALLOCATE(SCATTERING_WEIGHTS) + + END SUBROUTINE CLEANUP_OMI +!---------------------------------------------------------------------------------- + SUBROUTINE GET_NT_RANGE_OMI( N_OMI_ORBITS, HHMMSS, OMI_HOUR, NTSTART_OMI, NTSTOP_OMI) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE_OMI retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART_OMI (INTEGER) : TES record number at which to start +! (1 ) NTSTOP_OMI (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_OMI_ORBITS + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: OMI_HOUR(N_OMI_ORBITS) + INTEGER, INTENT(OUT) :: NTSTART_OMI + INTEGER, INTENT(OUT) :: NTSTOP_OMI + + ! Local variables + INTEGER, SAVE :: NTSAVE_OMI + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST_OMI + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE_OMI begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART_OMI = 0 + NTSTOP_OMI = 0 + + ! set NTSAVE_OMI to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE_OMI = N_OMI_ORBITS + !print*, ' GET_NT_RANGE_OMI for ', HHMMSS + !print*, ' NTSAVE_OMI ', NTSAVE_OMI + !print*, ' N_IASI_NOB ', N_IASI_NOB + DO WHILE (OMI_HOUR(NTSAVE_OMI) < 0 ) + NTSAVE_OMI = NTSAVE_OMI - 1 + IF (NTSAVE_OMI == 0) EXIT + ENDDO + + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE_OMI-1000:NTSAVE_OMI) + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) + ! one hour as a fraction of day + H1_FRAC = 0d0 + + + ! All records have been read already + IF ( NTSAVE_OMI == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( OMI_HOUR(NTSAVE_OMI) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( OMI_HOUR(NTSAVE_OMI) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART_OMI = NTSAVE_OMI + + !print*, ' Starting : TIME_FRAC(NTSTART_OMI) ', TIME_FRAC(NTSTART_OMI), NTSTART_OMI + + ! Now search forward to find stopping record + NTEST_OMI = NTSTART_OMI + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST_OMI = NTEST_OMI - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST_OMI == 0 ) THEN + + NTSTOP_OMI = NTEST_OMI + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMI, NTSTOP_OMI = ', NTSTART_OMI, NTSTOP_OMI + ! Reset NTSAVE_OMI + NTSAVE_OMI = NTEST_OMI + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( OMI_HOUR(NTEST_OMI) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST_OMI), NTEST_OMI + + NTSTOP_OMI = NTEST_OMI + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMI, NTSTOP_OMI = ', NTSTART_OMI, NTSTOP_OMI + + ! Reset NTSAVE_OMI + NTSAVE_OMI = NTEST_OMI + !ELSE + !print*, ' still looking ', NTEST_OMI + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE_OMI' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE_OMI +!================================================================================================================================ + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + !! + + IMPLICIT NONE + + INTEGER,PARAMETER :: N=10 ! number of leap seconds after Jan. 1, 1993 + !-----------------------------------93/06/30---94/06/30--95/12/31---97/06/30---98/12/31---05/12/31---08/12/31--12/06/30---15/06/30--16/12/31 + INTEGER,PARAMETER :: LEAPSEC(N) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605, 615254406, 709862407, 757382408/) + REAL*8,INTENT(IN) :: TAI93 + INTEGER,INTENT(OUT) :: IY,IM,ID,IH,IMIN + REAL*8,INTENT(OUT) :: SEC + REAL*8,PARAMETER :: MINS = 60.0D0 + REAL*8,PARAMETER :: HOUR = 60.0D0*MINS + REAL*8,PARAMETER :: DAY = 24.0D0*HOUR + REAL*8,PARAMETER :: YEAR = 365.0D0*DAY + INTEGER,PARAMETER :: MDAYS(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: WK,TAI + INTEGER :: DAYS,I,LEAP + + TAI = TAI93 + SEC = 0.0D0 + + DO I=1,N + + IF(FLOOR(TAI93) == LEAPSEC(I)+1) THEN + SEC = 60.0D0 + TAI93-FLOOR(TAI93) + ENDIF + + IF(FLOOR(TAI93) > LEAPSEC(I)) TAI = TAI -1.0D0 + + END DO + + IY = 1993 + FLOOR(TAI /YEAR) + WK = TAI - REAL(IY-1993)*YEAR - FLOOR(REAL(IY-1993)/4.0)*DAY + + IF(WK < 0.0D0) THEN + IY = IY -1 + WK = TAI - REAL(IY-1993)*YEAR - FLOOR(REAL(IY-1993)/4.0)*DAY + END IF + + DAYS = FLOOR(WK/DAY) + WK = WK - REAL(DAYS)*DAY + IM = 1 + + DO I=1,12 + + LEAP = 0 + IF(IM == 2 .AND. MOD(IY,4)==0) LEAP=1 + IF(IM == I .AND. DAYS >= MDAYS(I)+LEAP) THEN + IM = IM + 1 + DAYS = DAYS - MDAYS(I)-LEAP + END IF + + END DO + + ID = DAYS +1 + + IH = FLOOR(WK/HOUR) + WK = WK - REAL(IH)*HOUR + IMIN = FLOOR(WK/MINS) + + IF(SEC < 60.0D0) SEC = WK - REAL(IMIN)*MINS + + RETURN + + END SUBROUTINE TAI2UTC + + !---------------------------------------------------------- +END MODULE OMI_NO2_OBS_MOD diff --git a/code/obs_operators/omi_no2_obs_mod.f90~ b/code/obs_operators/omi_no2_obs_mod.f90~ new file mode 100644 index 0000000..61af012 --- /dev/null +++ b/code/obs_operators/omi_no2_obs_mod.f90~ @@ -0,0 +1,1046 @@ +MODULE OMI_NO2_OBS_MOD + + !! + ! Module OMI_NO2_OBS contains all subroutines and variables needed to assimilate OMI NO2 tropospheric column data + ! + ! Module Routines: + ! + ! (1) CALC_OMI_NO2_FORCE : calculates adjoint forcing and cost function contribution for OMI tropospheric NO2 columns + ! (2) TAI2UTC : converts TAI93 (seconds since 1.1.1993) to UTC + ! (3) MAKE_OMI_BIAS_FILE_HDF5 : writes OMI satellite diagnostics in satellite diagnostic HDF5 file + ! + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC READ_OMI_NO2_FILE + PUBLIC CALC_OMI_NO2_FORCE + + ! Module variables + + ! Arrays for diagnostic output + ! OMI data + ! Parameters + REAL*8, ALLOCATABLE :: OMI_LON(:,:), OMI_LAT(:,:) + REAL*8, ALLOCATABLE :: OMI_TIME(:), OMI_AMF_TROP(:,:) + REAL*8, ALLOCATABLE :: OMI_NO2_TROP(:,:), OMI_NO2_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: OMI_VIEW_ZENITH(:,:), OMI_SOLAR_ZENITH(:,:) + REAL*8, ALLOCATABLE :: OMI_CLOUDFR(:,:), OMI_SCW_P(:) + REAL*8, ALLOCATABLE :: OMI_SCATTERING_WEIGHTS(:,:,:) + REAL*8, ALLOCATABLE :: OMI_X_QUAL_FLAG(:,:), OMI_M_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: OMI_TROPO_PRESSURE(:,:) + REAL*8, ALLOCATABLE :: LON_ORBIT(:,:), LAT_ORBIT(:,:) + REAL*8, ALLOCATABLE :: TIME_ORBIT(:), AMF_TROP_ORBIT(:,:) + REAL*8, ALLOCATABLE :: NO2_TROP(:,:), NO2_TROP_STD(:,:) + REAL*8, ALLOCATABLE :: VIEW_ZENITH(:,:), SOLAR_ZENITH(:,:) + REAL*8, ALLOCATABLE :: CLOUDFR(:,:), SCW_P(:) + REAL*8, ALLOCATABLE :: SCATTERING_WEIGHTS(:,:,:) + REAL*8, ALLOCATABLE :: X_QUAL_FLAG(:,:), M_QUAL_FLAG(:) + REAL*8, ALLOCATABLE :: TROPO_PRESSURE(:,:) + + INTEGER :: N_OMI_ORBITS + INTEGER, PARAMETER :: MAX_ORBITS = 50000 + INTEGER, PARAMETER :: N_OMI_SWATHS = 60 + INTEGER, PARAMETER :: N_OMI_LEVELS = 35 + + ! arrays to store diagnostic information + REAL*4:: OMI_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI columns + REAL*4:: OMI_GEOS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem columns + REAL*4:: OMI_NO2_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OMI observation errors + REAL*4:: OMI_BIAS(IIPAR,JJPAR)=0d0 ! Model biases + REAL*4:: OMI_VAR(IIPAR,JJPAR)=0d0 ! Model variances + REAL*4:: OMI_DELTA=0d0 ! temporary storage variable + REAL*4:: OMI_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations in grid box + REAL*4:: OMI_CHISQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + LOGICAL :: FIRST = .TRUE. + +CONTAINS + + !-----------------------------------------------------------------------------! + + SUBROUTINE READ_OMI_NO2_FILE ( YYYYMMDD, N_OMI_ORBITS ) + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_MONTH, GET_YEAR + USE HDF5 + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD!, HHMMSS + + CHARACTER(LEN=255) :: DIR_OMI + CHARACTER(LEN=255) :: FILENAME_OMI + CHARACTER(LEN=255) :: FILENAME_FULL + CHARACTER(LEN=255) :: DSET_NAME + CHARACTER(255) :: ORBIT_PATH,FILE_ORBIT, FILE_ORBIT2 + CHARACTER(2) :: I_CHAR + INTEGER :: IO_ORBIT_STATUS, IO_ORBIT_STATUS2 + INTEGER :: DAY + INTEGER(HID_T) :: file_id, dset_id, file_id2, dset_id2 + + !INTEGER(HSIZE_T) :: data_dims + INTEGER :: error, DIMS_COUNTER, DIMS_INDEX + INTEGER :: N_OMI_ORBITS + INTEGER(HID_T) :: file_id_orbit, file_id_orbit2 + INTEGER(HID_T) :: dset_id_orbit, dset_id_orbit2 + INTEGER(HID_T) :: dspace_id_orbit, dspace_id_orbit2 + INTEGER :: error_orbit, error_orbit2 + CHARACTER(LEN=255) :: filename_orbit, dsetname, filename_orbit2, dsetname2 + + INTEGER :: rank_orbit, rank_orbit2 + INTEGER(HSIZE_T) :: dims_orbit(3), maxdims_orbit(3), dims_count(3), maxdims_orbit2(3) + INTEGER(HSIZE_T) :: DATA_DIMS_ORBIT(3) + INTEGER :: GC_HOUR + LOGICAL :: DATA_VALID + + CALL CLEANUP_OMI + + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + DIR_OMI = '/users/jk/15/xzhang/OMI_NO2/' + ORBIT_PATH = '/YYYY/MM/' + FILENAME_OMI = 'OMI-Aura_L2-OMNO2_YYYYmMMDD' + + CALL EXPAND_DATE( ORBIT_PATH, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OMI, YYYYMMDD, 9999 ) + WRITE(I_CHAR,'(I2.2)') DAY + !WRITE(I_CHAR2, '(I4.4)') YEAR + !WRITE(I_CHAR3, '(I2.2)') + !PRINT *, "PATH TO FILE", TRIM(ORBIT_PATH)//TRIM(FILENAME_OMI) + !CALL SYSTEM("ls "//TRIM(ORBIT_PATH)//"OMI-Aura_L2-OMNO2_2016m08"//I_CHAR//"* > omi_file_list"//I_CHAR//".txt") + CALL SYSTEM("ls "//TRIM(DIR_OMI)//TRIM(ORBIT_PATH)//TRIM(FILENAME_OMI)//"* > omi_file_list"//I_CHAR//".txt") + CLOSE(65) ! ugly... + + OPEN(65,FILE="omi_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + + N_OMI_ORBITS = 0 + DIMS_COUNTER = 1 + DIMS_INDEX = 0 + DO ! loop over all available OMI NO2 files for the current day + + READ(65,'(A)',IOSTAT=IO_ORBIT_STATUS2) FILE_ORBIT2 + + IF(IO_ORBIT_STATUS2 < 0) EXIT + !FILE_ORBIT = TRIM(ORBIT_PATH) // FILE_ORBIT + + PRINT *,"Reading OMI file "//TRIM(FILE_ORBIT2) + + !! open OMI orbit file + + CALL H5OPEN_F(error_orbit2) + + CALL H5FOPEN_f (FILE_ORBIT2, H5F_ACC_RDWR_F,file_id_orbit2,error_orbit2) + + !PRINT *,"OMI file status: ",error_orbit + + ! Open an existing dataset. + + DSETNAME2 = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT2, DSETNAME2, DSET_ID_ORBIT2, ERROR_ORBIT2) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID_ORBIT2, DSPACE_ID_ORBIT2, ERROR_ORBIT2) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID_ORBIT2, RANK_ORBIT2,ERROR_ORBIT2) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID_ORBIT2, DIMS_COUNT, MAXDIMS_ORBIT2, ERROR_ORBIT2) + + CALL H5DCLOSE_F(DSET_ID_ORBIT2,ERROR_ORBIT2) + IF (ERROR_ORBIT2 < 0) THEN + DIMS_COUNT(3) = 0 + ENDIF + N_OMI_ORBITS = N_OMI_ORBITS + DIMS_COUNT(3) + CALL H5FCLOSE_F(FILE_ID_ORBIT2,ERROR_ORBIT2) + CALL H5CLOSE_F(ERROR_ORBIT2) + !PRINT *, "DIMS3", DIMS_ORBIT(3) + ENDDO + !PRINT *, "DATA_DIMS", N_OMI_ORBITS + CLOSE(65) + !PRINT *, "N_OMI_ORBITS TOTAL", N_OMI_ORBITS + ALLOCATE(TIME_ORBIT(N_OMI_ORBITS)) + ALLOCATE(LON_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(LAT_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(AMF_TROP_ORBIT(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(NO2_TROP(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(NO2_TROP_STD(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(VIEW_ZENITH(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(SOLAR_ZENITH(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(CLOUDFR(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(X_QUAL_FLAG(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(M_QUAL_FLAG(N_OMI_ORBITS)) + ALLOCATE(SCW_P(N_OMI_LEVELS)) + ALLOCATE(TROPO_PRESSURE(N_OMI_SWATHS,N_OMI_ORBITS)) + ALLOCATE(SCATTERING_WEIGHTS(N_OMI_LEVELS,N_OMI_SWATHS,N_OMI_ORBITS)) + CLOSE(75) + OPEN(75,FILE="omi_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + DO + READ(75,'(A)',IOSTAT=IO_ORBIT_STATUS) FILE_ORBIT + + IF(IO_ORBIT_STATUS < 0) EXIT + DATA_VALID = .TRUE. + !FILE_ORBIT = TRIM(ORBIT_PATH) // FILE_ORBIT + + !PRINT *,"Reading OMI file "//TRIM(FILE_ORBIT) + + !! open OMI orbit file + + CALL H5OPEN_F(error_orbit) + + CALL H5FOPEN_f (FILE_ORBIT, H5F_ACC_RDWR_F,file_id_orbit,error_orbit) + + ! Open an existing dataset. + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + ! open dataspace + + CALL H5DGET_SPACE_F(DSET_ID_ORBIT, DSPACE_ID_ORBIT, ERROR_ORBIT) + + CALL H5SGET_SIMPLE_EXTENT_NDIMS_F(DSPACE_ID_ORBIT, RANK_ORBIT,ERROR_ORBIT) + + CALL H5SGET_SIMPLE_EXTENT_DIMS_F(DSPACE_ID_ORBIT, DIMS_ORBIT, MAXDIMS_ORBIT, ERROR_ORBIT) + + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + IF ( REAL(DIMS_ORBIT(3)) == 0d0 ) THEN + DATA_VALID = .FALSE. + ELSEIF ( REAL(DIMS_ORBIT(1)) .NE. REAL(N_OMI_LEVELS)) THEN + DATA_VALID = .FALSE. + ELSEIF ( REAL(DIMS_ORBIT(2)) .NE. REAL(N_OMI_SWATHS)) THEN + DATA_VALID = .FALSE. + ELSEIF ( ERROR_ORBIT < 0 ) THEN + DATA_VALID = .FALSE. + ENDIF + + IF (DATA_VALID == .FALSE.) THEN + CALL H5FCLOSE_F(FILE_ID_ORBIT,ERROR_ORBIT) + CALL H5CLOSE_F(ERROR_ORBIT) + CYCLE + ENDIF + !PRINT *,"Found matching OMI file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORBIT) + !PRINT *,"Found matching OMI file for hour ", DAY, ",",GC_HOUR, ":", TRIM(FILE_ORBIT) + + ALLOCATE(OMI_TIME(DIMS_ORBIT(3))) + ALLOCATE(OMI_LON(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_LAT(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_AMF_TROP(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_NO2_TROP(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_NO2_TROP_STD(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_VIEW_ZENITH(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_SOLAR_ZENITH(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_CLOUDFR(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_X_QUAL_FLAG(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_M_QUAL_FLAG(DIMS_ORBIT(3))) + ALLOCATE(OMI_SCW_P(DIMS_ORBIT(1))) + ALLOCATE(OMI_TROPO_PRESSURE(DIMS_ORBIT(2),DIMS_ORBIT(3))) + ALLOCATE(OMI_SCATTERING_WEIGHTS(DIMS_ORBIT(1),DIMS_ORBIT(2),DIMS_ORBIT(3)) ) + + DIMS_INDEX = DIMS_COUNTER+DIMS_ORBIT(3)-1 + + !! read in OMI data + !! read time + dsetname = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Time' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + !PRINT *, "DATA_DIMS_ORBIT", DATA_DIMS_ORBIT(3) + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_TIME, (/DATA_DIMS_ORBIT(3)/), ERROR_ORBIT) + !PRINT *, "DIMS_COUNTER", DIMS_COUNTER + !PRINT *, "DIMS_COUNTER2", DIMS_INDEX + !PRINT *, "SHAPE1", SHAPE(TIME_ORBIT(DIMS_COUNTER:DIMS_INDEX)) + !PRINT *, "SHAPE2", SHAPE(OMI_TIME) + TIME_ORBIT(DIMS_COUNTER:DIMS_INDEX) = OMI_TIME + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read tropospheric air mass factors + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/AmfTrop' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_AMF_TROP, DATA_DIMS_ORBIT, ERROR_ORBIT) + AMF_TROP_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_AMF_TROP + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "AMF_TROP_ORBIT", SHAPE(AMF_TROP_ORBIT) + + !! read tropospheric NO2 column + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ColumnAmountNO2Trop' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_NO2_TROP, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + NO2_TROP(:,DIMS_COUNTER:DIMS_INDEX) = OMI_NO2_TROP + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "NO2_TROP", NO2_TROP(:,DIMS_ORBIT(3)) + !! read tropospheric NO2 column + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/TropopausePressure' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_TROPO_PRESSURE, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + TROPO_PRESSURE(:,DIMS_COUNTER:DIMS_INDEX) = OMI_TROPO_PRESSURE + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !! read longitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ColumnAmountNO2TropStd' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_NO2_TROP_STD, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + NO2_TROP_STD(:,DIMS_COUNTER:DIMS_INDEX) = OMI_NO2_TROP_STD + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read longitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Longitude' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_LON, DATA_DIMS_ORBIT, ERROR_ORBIT) + LON_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_LON + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "LONG", LON_ORBIT(:,DIMS_ORBIT(3)) + + + !! read latitudes + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/Latitude' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_LAT, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + LAT_ORBIT(:,DIMS_COUNTER:DIMS_INDEX) = OMI_LAT + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "LON", LAT_ORBIT(:,DIMS_ORBIT(3)) + + !! read viewing zenith angles + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/ViewingZenithAngle' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_VIEW_ZENITH, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + VIEW_ZENITH(:,DIMS_COUNTER:DIMS_INDEX) = OMI_VIEW_ZENITH + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read solar zenith angles + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Geolocation Fields/SolarZenithAngle' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SOLAR_ZENITH, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + SOLAR_ZENITH(:,DIMS_COUNTER:DIMS_INDEX) = OMI_SOLAR_ZENITH + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read cloud fraction + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/CloudFraction' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_CLOUDFR, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + CLOUDFR(:,DIMS_COUNTER:DIMS_INDEX) = OMI_CLOUDFR + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + + !! read scattering weight pressures + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWtPressure' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SCW_P, (/DATA_DIMS_ORBIT(1),0/), ERROR_ORBIT) + SCW_P = OMI_SCW_P + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "data_dims_orbit", (/DATA_DIMS_ORBIT(1),0/) + !! read scattering weights + + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/ScatteringWeight' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_SCATTERING_WEIGHTS, DATA_DIMS_ORBIT, ERROR_ORBIT) + SCATTERING_WEIGHTS(:,:,DIMS_COUNTER:DIMS_INDEX) = OMI_SCATTERING_WEIGHTS + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "SCATTERING WEIGHTS", SHAPE(SCATTERING_WEIGHTS) + !! close file + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/XTrackQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_X_QUAL_FLAG, DATA_DIMS_ORBIT(2:3), ERROR_ORBIT) + X_QUAL_FLAG(:,DIMS_COUNTER:DIMS_INDEX) = OMI_X_QUAL_FLAG + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "X QUAL FLAG", SHAPE(OMI_X_QUAL_FLAG) + DSETNAME = '/HDFEOS/SWATHS/ColumnAmountNO2/Data Fields/MeasurementQualityFlags' + + CALL H5DOPEN_F(FILE_ID_ORBIT, DSETNAME, DSET_ID_ORBIT, ERROR_ORBIT) + + CALL H5DREAD_F(DSET_ID_ORBIT, H5T_NATIVE_DOUBLE, OMI_M_QUAL_FLAG, (/DATA_DIMS_ORBIT(3)/), ERROR_ORBIT) + M_QUAL_FLAG(DIMS_COUNTER:DIMS_INDEX) = OMI_M_QUAL_FLAG + CALL H5DCLOSE_F(DSET_ID_ORBIT,ERROR_ORBIT) + !PRINT *, "M_QUAL_FLAG", SHAPE(OMI_M_QUAL_FLAG) + + CALL H5FCLOSE_F(FILE_ID_ORBIT,ERROR_ORBIT) + DIMS_COUNTER = DIMS_COUNTER+DIMS_ORBIT(3) + CALL H5CLOSE_F(ERROR_ORBIT) + ! deallocate OMI arrays + IF(ALLOCATED(OMI_LON)) DEALLOCATE(OMI_LON) + IF(ALLOCATED(OMI_LAT)) DEALLOCATE(OMI_LAT) + IF(ALLOCATED(OMI_TIME)) DEALLOCATE(OMI_TIME) + IF(ALLOCATED(OMI_AMF_TROP)) DEALLOCATE(OMI_AMF_TROP) + IF(ALLOCATED(OMI_NO2_TROP)) DEALLOCATE(OMI_NO2_TROP) + IF(ALLOCATED(OMI_NO2_TROP_STD)) DEALLOCATE(OMI_NO2_TROP_STD) + IF(ALLOCATED(OMI_VIEW_ZENITH)) DEALLOCATE(OMI_VIEW_ZENITH) + IF(ALLOCATED(OMI_SOLAR_ZENITH)) DEALLOCATE(OMI_SOLAR_ZENITH) + IF(ALLOCATED(OMI_CLOUDFR)) DEALLOCATE(OMI_CLOUDFR) + IF(ALLOCATED(OMI_SCW_P)) DEALLOCATE(OMI_SCW_P) + IF(ALLOCATED(OMI_X_QUAL_FLAG)) DEALLOCATE(OMI_X_QUAL_FLAG) + IF(ALLOCATED(OMI_M_QUAL_FLAG)) DEALLOCATE(OMI_M_QUAL_FLAG) + IF(ALLOCATED(OMI_TROPO_PRESSURE)) DEALLOCATE(OMI_TROPO_PRESSURE) + IF(ALLOCATED(OMI_SCATTERING_WEIGHTS)) DEALLOCATE(OMI_SCATTERING_WEIGHTS) + ENDDO + CLOSE(75) + !N_OMI_ORBITS = DATA_DIMS + END SUBROUTINE READ_OMI_NO2_FILE +!================================================================================================================================ + SUBROUTINE CALC_OMI_NO2_FORCE + + USE HDF5 + + !! + !! Subroutine CALC_OMI_NO2_FORCE computes the NO2 adjoint forcing and cost function contribution from OMI column data + !! + !! References: + !! + !! Bucsela2013: + !! "A new stratospheric and tropospheric NO2 retrieval algorithm for nadir-viewing satellite instruments: applications to OMI" + !! E.J. Bucsela et.al + !! Atmos. Meas. Tech., 6, 2607-2626, 2013 + !! www.atmos-meas-tech.net/6/2607/2013/ + !! doi:10.5194/amt-6-2607-2013 + !! + !! Chan83 + !! "Algorithms for Computing the Sample Variance: Analysis and Recommendations" + !! Tony F. Chan, Gene H. Golub, Randall J. LeVeque + !! The American Statistician + !! Vol. 37, No. 3 (Aug. 1983), pp. 242-247 + !! + + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TS_CHEM + USE DAO_MOD, ONLY : BXHEIGHT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE TRACERID_MOD, ONLY : IDNO2 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + + + INTEGER :: I,J,L + INTEGER :: I_OMI, J_OMI, K_OMI, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: DAY + INTEGER :: NTSTART_OMI, NTSTOP_OMI + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: OMI_NO2_GC(IIPAR,JJPAR) + REAL*8 :: SCW_GC(LLPAR), DP(LLPAR) + REAL*8 :: AMF_GC + REAL*8 :: GC_NO2(LLPAR) + REAL*8 :: GC_NO2_COL + REAL*8 :: DIFF, FORCE_COL, COST_CONTRIB_COL + REAL*8 :: OBS_ERROR + REAL*8, SAVE :: OMI_HOUR(MAX_ORBITS) + REAL*8 :: OLD_COST_OMI + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + REAL*8 :: NEW_COST(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OMI(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( SECOND ) THEN + FILENAME = 'lat_orb_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 301, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 302, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_gc_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 303, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_obs_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 304, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'sobs_count_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 305, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 312, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_OMI_NO2_FORCE begins here! + !================================================================= + ! initialize arrays + + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + OMI_NO2_GC = 0d0 + OLD_COST_OMI = COST_FUNC + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + GC_ADJ_COUNT = 0d0 + NEW_COST = 0d0 + SOBS_GC = 0d0 + SOBS_OMI = 0d0 + SOBS_BIAS = 0d0 + SOBS_CHISQUARED = 0d0 + !DATA_DIMS_ORBIT(:) = 4565449537985793824 + ! Loop through data to find observations + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + IF ( GET_NHMS() == 236000 - GET_TS_CHEM()* 100 ) THEN + CALL READ_OMI_NO2_FILE(GET_NYMD(), N_OMI_ORBITS)!GET_NHMS()) + DO I_OMI = 1, N_OMI_ORBITS + IF (TIME_ORBIT(I_OMI) > 0) THEN + CALL TAI2UTC(TIME_ORBIT(I_OMI),IY,IM,ID,IH,IMIN,SEC) + IF (ID == DAY) THEN + OMI_HOUR(I_OMI) = IH + ELSE + OMI_HOUR(I_OMI) = -999 + ENDIF + ENDIF + ENDDO + ENDIF + !! loop over data + CALL GET_NT_RANGE_OMI(N_OMI_ORBITS, GET_NHMS(), OMI_HOUR(1:N_OMI_ORBITS), NTSTART_OMI, NTSTOP_OMI) + IF ( NTSTART_OMI == 0 .and. NTSTOP_OMI == 0 ) THEN + + print*, ' No matching OMI NO2 obs for this hour' + RETURN + ENDIF + PRINT *, 'found record range:', NTSTART_OMI, NTSTOP_OMI + !PRINT *, 'X_QUAL_FLAG',X_QUAL_FLAG(:,NTSTOP_OMI-1:NTSTART_OMI) + !PRINT *, 'M_QUAL_FLAG',M_QUAL_FLAG(NTSTOP_OMI-1:NTSTART_OMI) + !PRINT *, "TIME_FRAC", TIME_FRAC(1:N_OMI_ORBITS) + DO I_OMI=NTSTART_OMI,NTSTOP_OMI,-1 + DO J_OMI=1,N_OMI_SWATHS + !PRINT *, "QFLAG", M_QUAL_FLAG(I_OMI), X_QUAL_FLAG(J_OMI,I_OMI), NO2_TROP(J_OMI,I_OMI) + ! A number of conditions have to be met for OMI NO2 data to actually be assimilated + IF ( ( TIME_ORBIT(I_OMI) > 0 ) .AND. & +#if defined(NESTED_NA) || defined(NESTED_CH) + ( LON_ORBIT(J_OMI,I_OMI) >= GET_XMID(1) ) .AND. & + ( LON_ORBIT(J_OMI,I_OMI) <= GET_XMID(IIPAR)) .AND. & + ( LAT_ORBIT(J_OMI,I_OMI) >= GET_YMID(1) ) .AND. & + ( LAT_ORBIT(J_OMI,I_OMI) <= GET_YMID(JJPAR)) .AND. & +#endif + ( ABS(LAT_ORBIT(J_OMI,I_OMI)) < 60d0 ) .AND. & + ( NO2_TROP(J_OMI,I_OMI) > 0d0 ) .AND. & + ( NO2_TROP_STD(J_OMI,I_OMI) > 0d0 ) .AND. & + ( ABS(SOLAR_ZENITH(J_OMI,I_OMI)) < 75d0 ) .AND. & + ( ABS(VIEW_ZENITH(J_OMI,I_OMI)) < 65d0 ) .AND. & + ( AMF_TROP_ORBIT(J_OMI,I_OMI) > 0d0 ) .AND. & + ( REAL(X_QUAL_FLAG(J_OMI,I_OMI)) < 1d0 ) .AND. & + ( M_QUAL_FLAG(I_OMI) == 0d0 ) .AND. & + ( CLOUDFR(J_OMI,I_OMI) >= 0d0 ) .AND. & + ( CLOUDFR(J_OMI,I_OMI) < 200 ) ) THEN + ! Get model grid coordinate indices that correspond to the observation + + IIJJ = GET_IJ(REAL(LON_ORBIT(J_OMI,I_OMI),4), REAL(LAT_ORBIT(J_OMI,I_OMI),4)) + + I = IIJJ(1) + J = IIJJ(2) + + ! initialize variables & arrays + + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + SCW_GC = 0d0 + DP = 0d0 + COST_CONTRIB_COL = 0d0 + FORCE_COL = 0d0 + + ! Get GEOS-CHEM NO2 values [#/cm3] + + DO L = 1, LLPAR + + !IF( ITS_IN_THE_TROP(I,J,L) ) THEN + IF ( GET_PEDGE(I,J,L) >= TROPO_PRESSURE(J_OMI,I_OMI) ) THEN + JLOOP = JLOP(I,J,L) + IF (GET_PEDGE(I,J,L) >= 400d0) THEN + GC_NO2(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDNO2)) + ELSEIF + GC_NO2(L) = CSPEC(JLOOP,IDNO2) + ENDIF + !PRINT *, "GC_NO2", GC_NO2(2) + ENDIF + + ENDDO + + ! Compute tropospheric NO2 vertical column [#/cm2] + + GC_NO2_COL = SUM(GC_NO2(:) * BXHEIGHT(I,J,:)*100d0) + + ! interpolate scattering weights to GEOS-Chem grid to compute GEOS-Chem air mass factors + ! question: how do differences in surface pressures used in the retrieval and GEOS-Chem affect the computation below? + + DO L=1,LLPAR + DO K_OMI = 2,N_OMI_LEVELS + + IF( GET_PCENTER(I,J,L) < SCW_P(K_OMI-1) .AND. GET_PCENTER(I,J,L) > SCW_P(K_OMI) ) THEN + + ! linearly interpolate scattering weights to GEOS-Chem center pressures + + SCW_GC(L) = SCATTERING_WEIGHTS(K_OMI,J_OMI,I_OMI) + & + ( SCATTERING_WEIGHTS(K_OMI-1,J_OMI,I_OMI) - SCATTERING_WEIGHTS(K_OMI,J_OMI,I_OMI) ) * & + ( GET_PCENTER(I,J,L) - SCW_P(K_OMI) ) / ( SCW_P(K_OMI-1) - SCW_P(K_OMI) ) + + ! save pressure difference of edge pressures + + DP(L) = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! apply temperature correction, as in Bucsela2013, eq. (4) + + SCW_GC(L) = SCW_GC(L) * ( 1 - 0.003 * ( T(I,J,L) - 220 ) ) + + ! convert NO2 concentrations from number density to mixing ratio, as required for the calculation of the air mass factors from scattering weights + + GC_NO2(L) = GC_NO2(L) *1d6 / ( AIRDEN(L,I,J) * XNUMOLAIR ) + + EXIT ! exit loop over K_OMI to go to next cycle in loop over L + + ENDIF + + ENDDO + ENDDO + + ! Use GEOS-Chem tropospheric air mass factors to convert vertical column to slant column + AMF_GC = SUM(GC_NO2 * DP * SCW_GC)/SUM(GC_NO2 * DP) + !PRINT *, "AMF_GC", AMF_GC + GC_NO2_COL = AMF_GC*GC_NO2_COL + + ! The computation above is a little awkward, since the slant column can be computed directly from equation (2) in Bucsela2013 without + ! computing the airmass factors and NO2 column first. + ! I chose to compute the slant column from the computed air mass factors (which already included the computation of the slant column) + ! since the air mass factors might be of diagnostic interest and can be computed and saved + ! alongside other observation operator diagnostics. Furthermore, this formulation makes the adjoint of the observation operator somewhat simpler to handle. + + ! compute slant column difference + + DIFF = GC_NO2_COL - (NO2_TROP(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI)) + !PRINT *, "GC_NO2_COL", GC_NO2_COL + !PRINT *, "NO2_TROP", GC_NO2_COL-DIFF + !PRINT *, "AMF_GC", AMF_GC + !PRINT *, "AMF_OBS", AMF_TROP_ORBIT(J_OMI,I_OMI) + ! compute slant column standard deviation + !PRINT *, "CHECK" + OBS_ERROR = 0.05*NO2_TROP_STD(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI) + IF (OBS_ERROR>0d0) THEN + FORCE_COL = DIFF/(OBS_ERROR**2) + COST_CONTRIB_COL = 0.5d0 * DIFF * FORCE_COL + ELSE + FORCE_COL = 0d0 + COST_CONTRIB_COL = 0d0 + ENDIF + ! update adjoint NO2 concentration + IF ( ( COST_CONTRIB_COL > 0d0 ) .AND. & + ( COST_CONTRIB_COL <= 80000d0) ) THEN + DO L = 1, LLPAR + IF (ITS_IN_THE_TROP(I,J,L)) THEN + ! question: how do errors in retrieved surface pressure impact the NO2 column values? + ! question: how do errors in simulated surface pressures impact the NO2 column values? + + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) & + + FORCE_COL * BXHEIGHT(I,J,L) * 100d0 * AMF_GC + ENDIF + ENDIF + + ENDDO + ! update cost function + + IF(SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONTRIB_COL + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONTRIB_COL + ENDIF + + ENDIF + + WRITE(301,110) ( LAT_ORBIT(J_OMI,I_OMI) ) + WRITE(302,110) ( LON_ORBIT(J_OMI,I_OMI) ) + !WRITE(303,110) ( AMF_GC ) + !WRITE(304,110) ( AMF_TROP_ORBIT(J_OMI,I_OMI) ) + WRITE(312,110) ( DIFF/1e10 ) +110 FORMAT(F18.6,1X) + + ! update diagnostic arrays + + IF( SUPER_OBS) THEN + SOBS_GC(I,J) = SOBS_GC(I,J) + GC_NO2_COL + SOBS_OMI(I,J) = SOBS_OMI(I,J) + NO2_TROP(J_OMI,I_OMI) + SOBS_BIAS(I,J) = SOBS_BIAS(I,J) + DIFF + SOBS_CHISQUARED(I,J) = SOBS_CHISQUARED(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + ELSE + + OMI_BIAS_COUNT(I,J) = OMI_BIAS_COUNT(I,J) + 1d0 + + OMI_NO2_MEAN(I,J) = OMI_NO2_MEAN(I,J) + NO2_TROP(J_OMI,I_OMI) * AMF_TROP_ORBIT(J_OMI, I_OMI) + + OMI_GEOS_NO2_MEAN(I,J) = OMI_GEOS_NO2_MEAN(I,J) + GC_NO2_COL + + OMI_NO2_ERR_MEAN(I,J) = OMI_NO2_ERR_MEAN(I,J) + OBS_ERROR + + OMI_DELTA = DIFF - OMI_BIAS(I,J) + + OMI_BIAS(I,J) = OMI_BIAS(I,J) + OMI_DELTA/OMI_BIAS_COUNT(I,J) + + OMI_VAR(I,J) = OMI_VAR(I,J) + OMI_DELTA*(DIFF-OMI_BIAS(I,J)) + + OMI_CHISQUARED(I,J) = OMI_CHISQUARED(I,J) + ( DIFF/OBS_ERROR )**2 + + ENDIF + ENDIF ! data selection IF statement + + ENDDO ! J + ENDDO ! I + + IF(SUPER_OBS) THEN + + DO J=1,JJPAR + DO I=1,IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + + DO L=1,LLPAR + JLOOP = JLOP(I,J,L) + IF( ( ITS_IN_THE_TROP(I,J,L) ).AND. & + ( GC_ADJ_COUNT(I,J,L) > 0 ) .AND. & + ( JLOOP > 0 ) ) THEN + + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) & + + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDDO + WRITE(305,110) (SOBS_COUNT(I,J)) + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + + OMI_BIAS_COUNT(I,J) = OMI_BIAS_COUNT(I,J) + 1d0 + + OMI_NO2_MEAN(I,J) = OMI_NO2_MEAN(I,J) + SOBS_OMI(I,J)/SOBS_COUNT(I,J) + + OMI_GEOS_NO2_MEAN(I,J) = OMI_GEOS_NO2_MEAN(I,J) + SOBS_GC(I,J)/SOBS_COUNT(I,J) + + OMI_NO2_ERR_MEAN(I,J) = OMI_NO2_ERR_MEAN(I,J) + OBS_ERROR ! mkeller: need to change this to reflect super observation error, but how? + + ! calculate bias and variance of GC-OMI bias using numerically stable one-pass algorithm (Chan83) + + OMI_DELTA = SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMI_BIAS(I,J) + + OMI_BIAS(I,J) = OMI_BIAS(I,J) + OMI_DELTA/OMI_BIAS_COUNT(I,J) + + OMI_VAR(I,J) = OMI_VAR(I,J) + OMI_DELTA*(SOBS_BIAS(I,J)/SOBS_COUNT(I,J) - OMI_BIAS(I,J)) + + OMI_CHISQUARED(I,J) = OMI_CHISQUARED(I,J) + SOBS_CHISQUARED(I,J)/SOBS_COUNT(I,J) + + ENDIF + + ENDDO + ENDDO + + ENDIF + PRINT *, "OMI NO2 COST FUNCTION", COST_FUNC-OLD_COST_OMI + END SUBROUTINE CALC_OMI_NO2_FORCE + + !-----------------------------------------------------------------------------! + SUBROUTINE CLEANUP_OMI + ! deallocate OMI arrays + + IF(ALLOCATED(LON_ORBIT)) DEALLOCATE(LON_ORBIT) + IF(ALLOCATED(LAT_ORBIT)) DEALLOCATE(LAT_ORBIT) + IF(ALLOCATED(TIME_ORBIT)) DEALLOCATE(TIME_ORBIT) + IF(ALLOCATED(AMF_TROP_ORBIT)) DEALLOCATE(AMF_TROP_ORBIT) + IF(ALLOCATED(NO2_TROP)) DEALLOCATE(NO2_TROP) + IF(ALLOCATED(NO2_TROP_STD)) DEALLOCATE(NO2_TROP_STD) + IF(ALLOCATED(VIEW_ZENITH)) DEALLOCATE(VIEW_ZENITH) + IF(ALLOCATED(SOLAR_ZENITH)) DEALLOCATE(SOLAR_ZENITH) + IF(ALLOCATED(CLOUDFR)) DEALLOCATE(CLOUDFR) + IF(ALLOCATED(SCW_P)) DEALLOCATE(SCW_P) + IF(ALLOCATED(X_QUAL_FLAG)) DEALLOCATE(X_QUAL_FLAG) + IF(ALLOCATED(M_QUAL_FLAG)) DEALLOCATE(M_QUAL_FLAG) + IF(ALLOCATED(TROPO_PRESSURE)) DEALLOCATE(TROPO_PRESSURE) + IF(ALLOCATED(SCATTERING_WEIGHTS)) DEALLOCATE(SCATTERING_WEIGHTS) + + END SUBROUTINE CLEANUP_OMI +!---------------------------------------------------------------------------------- + SUBROUTINE GET_NT_RANGE_OMI( N_OMI_ORBITS, HHMMSS, OMI_HOUR, NTSTART_OMI, NTSTOP_OMI) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE_OMI retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART_OMI (INTEGER) : TES record number at which to start +! (1 ) NTSTOP_OMI (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: N_OMI_ORBITS + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: OMI_HOUR(N_OMI_ORBITS) + INTEGER, INTENT(OUT) :: NTSTART_OMI + INTEGER, INTENT(OUT) :: NTSTOP_OMI + + ! Local variables + INTEGER, SAVE :: NTSAVE_OMI + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST_OMI + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE_OMI begins here! + !================================================================= + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART_OMI = 0 + NTSTOP_OMI = 0 + + ! set NTSAVE_OMI to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE_OMI = N_OMI_ORBITS + !print*, ' GET_NT_RANGE_OMI for ', HHMMSS + !print*, ' NTSAVE_OMI ', NTSAVE_OMI + !print*, ' N_IASI_NOB ', N_IASI_NOB + DO WHILE (OMI_HOUR(NTSAVE_OMI) < 0 ) + NTSAVE_OMI = NTSAVE_OMI - 1 + IF (NTSAVE_OMI == 0) EXIT + ENDDO + + !PRINT *, "TIME_FRAC", TIME_FRAC(NTSAVE_OMI-1000:NTSAVE_OMI) + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) + ! one hour as a fraction of day + H1_FRAC = 0d0 + + + ! All records have been read already + IF ( NTSAVE_OMI == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( OMI_HOUR(NTSAVE_OMI) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( OMI_HOUR(NTSAVE_OMI) + H1_FRAC >= GC_HH_FRAC ) THEN + ! Starting record found + NTSTART_OMI = NTSAVE_OMI + + !print*, ' Starting : TIME_FRAC(NTSTART_OMI) ', TIME_FRAC(NTSTART_OMI), NTSTART_OMI + + ! Now search forward to find stopping record + NTEST_OMI = NTSTART_OMI + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST_OMI = NTEST_OMI - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST_OMI == 0 ) THEN + + NTSTOP_OMI = NTEST_OMI + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMI, NTSTOP_OMI = ', NTSTART_OMI, NTSTOP_OMI + ! Reset NTSAVE_OMI + NTSAVE_OMI = NTEST_OMI + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( OMI_HOUR(NTEST_OMI) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', TIME_FRAC(NTEST_OMI), NTEST_OMI + + NTSTOP_OMI = NTEST_OMI + 1 + FOUND_ALL_RECORDS = .TRUE. + + !print*, ' Records found ' + !print*, ' NTSTART_OMI, NTSTOP_OMI = ', NTSTART_OMI, NTSTOP_OMI + + ! Reset NTSAVE_OMI + NTSAVE_OMI = NTEST_OMI + !ELSE + !print*, ' still looking ', NTEST_OMI + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE_OMI' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE_OMI +!================================================================================================================================ + + SUBROUTINE TAI2UTC(tai93,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE TAI2UTC converts TAI93 time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! code.google.com/p/miyoshi/source/browse/trunk/common/common.f90 + !! + + IMPLICIT NONE + + INTEGER,PARAMETER :: N=10 ! number of leap seconds after Jan. 1, 1993 + !-----------------------------------93/06/30---94/06/30--95/12/31---97/06/30---98/12/31---05/12/31---08/12/31--12/06/30---15/06/30--16/12/31 + INTEGER,PARAMETER :: LEAPSEC(N) = (/ 15638399, 47174400, 94608001, 141868802, 189302403, 410227204, 504921605, 615254406, 709862407, 757382408/) + REAL*8,INTENT(IN) :: TAI93 + INTEGER,INTENT(OUT) :: IY,IM,ID,IH,IMIN + REAL*8,INTENT(OUT) :: SEC + REAL*8,PARAMETER :: MINS = 60.0D0 + REAL*8,PARAMETER :: HOUR = 60.0D0*MINS + REAL*8,PARAMETER :: DAY = 24.0D0*HOUR + REAL*8,PARAMETER :: YEAR = 365.0D0*DAY + INTEGER,PARAMETER :: MDAYS(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + REAL*8 :: WK,TAI + INTEGER :: DAYS,I,LEAP + + TAI = TAI93 + SEC = 0.0D0 + + DO I=1,N + + IF(FLOOR(TAI93) == LEAPSEC(I)+1) THEN + SEC = 60.0D0 + TAI93-FLOOR(TAI93) + ENDIF + + IF(FLOOR(TAI93) > LEAPSEC(I)) TAI = TAI -1.0D0 + + END DO + + IY = 1993 + FLOOR(TAI /YEAR) + WK = TAI - REAL(IY-1993)*YEAR - FLOOR(REAL(IY-1993)/4.0)*DAY + + IF(WK < 0.0D0) THEN + IY = IY -1 + WK = TAI - REAL(IY-1993)*YEAR - FLOOR(REAL(IY-1993)/4.0)*DAY + END IF + + DAYS = FLOOR(WK/DAY) + WK = WK - REAL(DAYS)*DAY + IM = 1 + + DO I=1,12 + + LEAP = 0 + IF(IM == 2 .AND. MOD(IY,4)==0) LEAP=1 + IF(IM == I .AND. DAYS >= MDAYS(I)+LEAP) THEN + IM = IM + 1 + DAYS = DAYS - MDAYS(I)-LEAP + END IF + + END DO + + ID = DAYS +1 + + IH = FLOOR(WK/HOUR) + WK = WK - REAL(IH)*HOUR + IMIN = FLOOR(WK/MINS) + + IF(SEC < 60.0D0) SEC = WK - REAL(IMIN)*MINS + + RETURN + + END SUBROUTINE TAI2UTC + + !---------------------------------------------------------- +END MODULE OMI_NO2_OBS_MOD diff --git a/code/obs_operators/omi_so2_obs_mod.f b/code/obs_operators/omi_so2_obs_mod.f new file mode 100644 index 0000000..99168ba --- /dev/null +++ b/code/obs_operators/omi_so2_obs_mod.f @@ -0,0 +1,1706 @@ +! $Id: omi_so2_obs_mod.f + MODULE OMI_SO2_OBS_MOD +! +!***************************************************************************** +! MODULE OMI_SO2_OBS_MOD contians subroutines necessary to +! 1. Read OMI L3 SO2 observations +! 2. Compute OMI-GEOS-Chem difference, cost function, and adjoint +! forcing +! +! (ywang (yi.wang@huskers.unl.edu), 07/16/04) +! +! Module Variables: +! =========================================================================== +! +! Module Routines: +! =========================================================================== +! ( 1) CALC_OMI_SO2_FORCE +! ( 2) CHECK : Check status for calling netCDF +! ( 1) INIT_OMI_SO2_OBS : Initialize OMI SO2 observation operator +! ( 3) WRITE_GC_OMI_SO2_OBS +! ( 4) READ_GC_OMI_SO2_OBS +! ( 5) MAKE_CURRENT_OMI_SO2 : +! ( ) MAKE_AVERAGE_OMI_SO2 : +! +! =========================================================================== +! NOTES: +! ( 1) The original OMI L3 SO2 HDFEOS5 data are preprocessed by +! IDL code OMI_SO2_L3_preprocess.pro. Quality control is done through +! the IDL code. +! ( 2) OMI L3 SO2 contains ColumnAmountSO2_PBL (Center Mass of +! Alitude = 0.9km), ColumnAmountSO2_TRL (CMA = 2.5km), ColumnAmountSO2_TRM +! (CMA = 7.5km), and ColumnAmountSO2_STL (CMA = 17km). Only the first +! three are used in the observation operatpor. The prior GEOS-Chem CMA +! (where SO2 peaks in the vertical column) is calculated. We choose the +! observation whose CMA is closest to GEOS-Chem CMA to be assimilated. +! +!***************************************************************************** +! + + IMPLICIT NONE + + ! Header files +# include "define.h" +# include "CMN_SIZE" ! Size parameters + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep centain internal variables + ! and routines from being seen outside "omi_so2_obs_mod.f" + !================================================================= + + ! Make everything PRIVATE... + PRIVATE + + ! ... except these routines + PUBLIC :: CALC_OMI_SO2_FORCE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + CHARACTER(LEN=255) :: FILENAME = 'OMI_L3_SO2_grid_YYYYMMDD.nc' + INTEGER, PARAMETER :: TIME_WINDOW = 60 ! (units: min) + + ! Variables + + ! Recored to store OMI SO2 observations + TYPE OMI_SO2_OBS + REAL :: LON ! Latitude (units: degree) + REAL :: LAT ! Longitude (units: dgeree) + REAL*8 :: TIME ! Time at start of scan (TAI93) (units: s) + REAL*8 :: SO2_PBL ! ColumnAmountSO2_PBL (units: DU) + REAL*8 :: SO2_TRL ! ColumnAmountSO2_TRL (units: DU) + REAL*8 :: SO2_TRM ! ColumnAmountSO2_TRM (units: DU) + REAL*8 :: SO2 ! OMI SO2 whose CMA is closest to GEOS-Chem CMA (units: DU) + REAL*8 :: ERR_PBL ! SO2_PBL error (units: DU) + REAL*8 :: ERR_TRL ! SO2_TRL error (units: DU) + REAL*8 :: ERR_TRM ! SO2_TRM error (units: DU) + REAL*8 :: ERR ! SO2 error (units: DU) +! INTEGER :: MARK ! Mark of which observation is expected. 0: No observation, 1: PBL, 2: TRL, 3: TRM + INTEGER :: OPT ! Mark of which observation whose CMA is close to GEOS-Chem CMA, though the observation may not exists + INTEGER :: FLAG ! Does the observation expected really exits? + ENDTYPE OMI_SO2_OBS + + TYPE(OMI_SO2_OBS), ALLOCATABLE :: OMI_SO2(:) + + LOGICAL, ALLOCATABLE :: FLAGS(:) + + REAL*8 :: CURR_GC_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_PBL_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_TRL_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_TRM_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_DIFF_SO2(IIPAR, JJPAR) + REAL*8 :: CURR_FORCING(IIPAR, JJPAR) + REAL*8 :: CURR_COST(IIPAR, JJPAR) + REAL*8 :: CURR_CMA(IIPAR, JJPAR) + INTEGER :: CURR_COUNT(IIPAR, JJPAR) ! number of observations in current time window + INTEGER :: CURR_PBL_C(IIPAR, JJPAR) ! number of PBL observations used in current time window + INTEGER :: CURR_TRL_C(IIPAR, JJPAR) ! number of TRL observations used in current time window + INTEGER :: CURR_TRM_C(IIPAR, JJPAR) ! numberof TRM observations used in current time window + INTEGER :: CURR_OPT(IIPAR, JJPAR) ! + + REAL*8 :: ALL_GC_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_PBL_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_TRL_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_TRM_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_DIFF_SO2(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_FORCING(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_COST(IIPAR, JJPAR) = 0D0 + REAL*8 :: ALL_CMA(IIPAR, JJPAR) = 0D0 + INTEGER :: ALL_COUNT(IIPAR, JJPAR) = 0 ! number of observations in simulation time + INTEGER :: ALL_PBL_C(IIPAR, JJPAR) = 0 + INTEGER :: ALL_TRL_C(IIPAR, JJPAR) = 0 + INTEGER :: ALL_TRM_C(IIPAR, JJPAR) = 0 + INTEGER :: ALL_OPT(IIPAR, JJPAR) = 0 ! number of "best" observations used + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAIN" statement + !================================================================= + CONTAINS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE INIT_OMI_SO2_OBS +! +!***************************************************************************** +! Subroutine INIT_OMI_SO2_OBS initialize the OMI SO2 observation +! ( 1) Check if SO2 observation is specified by the adjoint input +! files +! (ywang, 07/16/14) +!***************************************************************************** +! + ! Reference to f90 modules + USE TRACER_MOD, ONLY : TRACER_NAME + USE TRACERID_MOD, ONLY : IDTSO2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ERROR_MOD, ONLY : ERROR_STOP + + !================================================================= + ! INIT_OMI_SO2_OBS begins here! + !================================================================= + + IF ( OBS_THIS_TRACER(IDTSO2) ) THEN + + WRITE( 6, 100 ) IDTSO2, TRACER_NAME(IDTSO2) + + ELSE + + CALL ERROR_STOP( 'Error: Obs SO2 tracer is not specified in + &OBSERVATION MENU in input.gcadj', + & 'INIT_OMI_SO2_OBS (omi_so2_obs_mod.f)' ) + + END IF + + 100 FORMAT( 3X, 'Tracer ID: ', I4, 'Use OMI L3 ', A6 ) + + ! Return to the calling routine + END SUBROUTINE INIT_OMI_SO2_OBS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE READ_GC_OMI_SO2_OBS( YYYYMMDD, N_SO2 ) +! +!***************************************************************************** +! Subroutine READ_OMI_SO2_OBS read OMI SO2 data preprocessed by +! OMI_SO2_L3_preprocess.pro if N_CALC > 1 (ref: note 1) or +! observations whose CMA are close to GEOS-Chem CMA if N_CALC == 1 +! (ref: note 2) +! (ywang, 07/16/14) +! +! Arguements as Input: +! =========================================================================== +! ( 1) YYYYMMDD (INTEGER) : Current year-month-day +! Arguements as Output: +! =========================================================================== +! ( 1) N_SO2 (INTEGER) : Number of OMI SO2 observations for +! current day +! +! Module variable as Output: +! =========================================================================== +! ( 1) OMI_SO2 (OMI_SO2_OBS) : OMI SO2 observations +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD + + ! Arguements + INTEGER, INTENT( IN) :: YYYYMMDD + INTEGER, INTENT(OUT) :: N_SO2 + + ! Local variables + INTEGER :: FID, N_ID + INTEGER :: LON_ID, LAT_ID, TIME_ID + INTEGER :: SO2_PBL_ID, SO2_TRL_ID, SO2_TRM_ID + INTEGER :: SO2_ID + INTEGER :: ERR_PBL_ID, ERR_TRL_ID, ERR_TRM_ID + INTEGER :: ERR_ID +! INTEGER :: MARK_ID + INTEGER :: OPT_ID ! (ywang, 09/12/14) + INTEGER :: FLAG_ID ! (ywang, 09/12/14) + CHARACTER(LEN=255) :: DIR + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=4) :: TMP + INTEGER, ALLOCATABLE :: TMPINT(:) + REAL*4, ALLOCATABLE :: TMP4(:) + REAL*8, ALLOCATABLE :: TMP8(:) + LOGICAL :: LF + + !================================================================= + ! READ_OMI_SO2_OBS begins here! + !================================================================= + + ! Filename root + IF (N_CALC ==1 ) THEN + + READ_FILENAME = TRIM( FILENAME ) + + ELSE IF (N_CALC > 1) THEN + + READ_FILENAME = 'GC_' // TRIM( FILENAME ) + + ELSE + + STOP + + END IF + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + DIR = './data/OMI_SO2/' + READ_FILENAME = TRIM( DIR ) // TRIM( READ_FILENAME ) + + ! Does data file exist? If not, it means no data in the day. + ! (ywang, 09/23/2014) + INQUIRE( FILE = TRIM( READ_FILENAME ), EXIST = LF ) + IF ( .NOT. LF ) THEN + + ! No data + N_SO2 = 0 + + PRINT*, ' - READ_GC_OMI_SO2_OBS: No data file (warning)' + + RETURN + + END IF + + + + ! Print to screen + WRITE(6, 100) TRIM( READ_FILENAME ) + 100 FORMAT(' - READ_GC_OMI_SO2_OBS: reading file: ', A) + +! PRINT*, 'N_CALC:', N_CALC + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !----------------------------------- + ! Get data record IDs + !----------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "time", N_ID ), 100 ) + CALL CHECK( NF90_INQ_VARID( FID, "lon", LON_ID ), 101 ) + CALL CHECK( NF90_INQ_VARID( FID, "lat", LAT_ID ), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "time", TIME_ID ), 103 ) + CALL CHECK( NF90_INQ_VARID( FID, "SO2_PBL", SO2_PBL_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "SO2_TRL", SO2_TRL_ID ), 105 ) + CALL CHECK( NF90_INQ_VARID( FID, "SO2_TRM", SO2_TRM_ID ), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "ERR_PBL", ERR_PBL_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "ERR_TRL", ERR_TRL_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "ERR_TRM", ERR_TRM_ID ), 110 ) + + IF ( N_CALC > 1 ) THEN + + CALL CHECK( NF90_INQ_VARID( FID, "SO2", SO2_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "ERR", ERR_ID ), 111 ) +! CALL CHECK( NF90_INQ_VARID( FID, "MARK", MARK_ID ), 112 ) + CALL CHECK( NF90_INQ_VARID( FID, "OPT", OPT_ID ), 113 ) + ! (ywang, 09/12/14) + CALL CHECK( NF90_INQ_VARID( FID, "FLAG", FLAG_ID ), 114 ) + + END IF + + !------------------------------------ + ! Read dimensions + !------------------------------------ + + ! Read number of observations, N_SO2 + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, N_ID, TMP, N_SO2 ), 200 ) + + ! Print to screen + WRITE(6, 110) N_SO2, GET_NYMD() + 110 FORMAT(' Number of OMI SO2 observations: ' I10, ' in ' I10) + + !------------------------------------- + ! Read 1D data + !------------------------------------- + + ! Allocate temporal arrays for 1D data + ALLOCATE( TMPINT(N_SO2) ) + ALLOCATE( TMP4(N_SO2) ) + ALLOCATE( TMP8(N_SO2) ) + TMPINT = 0 + TMP4 = 0E0 + TMP8 = 0D0 + + ! Allocate OMI SO2 observations array + IF ( ALLOCATED( OMI_SO2 ) ) DEALLOCATE( OMI_SO2 ) + ALLOCATE( OMI_SO2(N_SO2) ) + + IF ( ALLOCATED( FLAGS) ) DEALLOCATE( FLAGS ) + ALLOCATE( FLAGS(N_SO2) ) + + + ! Read longitude + CALL CHECK( NF90_GET_VAR( FID, LON_ID, TMP4 ), 301 ) + OMI_SO2(1:N_SO2)%LON = TMP4(1:N_SO2) + + ! Read latitude + CALL CHECK( NF90_GET_VAR( FID, LAT_ID, TMP4 ), 302 ) + OMI_SO2(1:N_SO2)%LAT = TMP4(1:N_SO2) + + ! Read time + CALL CHECK( NF90_GET_VAR( FID, TIME_ID, TMP8 ), 303 ) + OMI_SO2(1:N_SO2)%TIME = TMP8(1:N_SO2) + + ! Read ColumnAmountSO2_PBL + CALL CHECK( NF90_GET_VAR( FID, SO2_PBL_ID, TMP4 ), 304 ) + OMI_SO2(1:N_SO2)%SO2_PBL = TMP4(1:N_SO2) + + ! Read ColumnAmountSO2_TRL + CALL CHECK( NF90_GET_VAR( FID, SO2_TRL_ID, TMP4 ), 305 ) + OMI_SO2(1:N_SO2)%SO2_TRL = TMP4(1:N_SO2) + + ! Read ColumnAmountSO2_TRM + CALL CHECK( NF90_GET_VAR( FID, SO2_TRM_ID, TMP4 ), 306 ) + OMI_SO2(1:N_SO2)%SO2_TRM = TMP4(1:N_SO2) + + ! Read ColumnAmountSO2_PBL error + CALL CHECK( NF90_GET_VAR( FID, ERR_PBL_ID, TMP4 ), 308 ) + OMI_SO2(1:N_SO2)%ERR_PBL = TMP4(1:N_SO2) + + ! Read ColumnAmountSO2_TRL error + CALL CHECK( NF90_GET_VAR( FID, ERR_TRL_ID, TMP4 ), 309 ) + OMI_SO2(1:N_SO2)%ERR_TRL = TMP4(1:N_SO2) + + ! Read ColumnAmountSO2_TRM error + CALL CHECK( NF90_GET_VAR( FID, ERR_TRM_ID, TMP4 ), 310 ) + OMI_SO2(1:N_SO2)%ERR_TRM = TMP4(1:N_SO2) + + IF ( N_CALC > 1 ) THEN + + ! Read SO2 Whose CMA is closest to GEOS-Chem CMA + CALL CHECK( NF90_GET_VAR( FID, SO2_ID, TMP4 ), 307 ) + OMI_SO2(1:N_SO2)%SO2 = TMP4(1:N_SO2) + + ! Read SO2 error + CALL CHECK( NF90_GET_VAR( FID, ERR_ID, TMP4 ), 311 ) + OMI_SO2(1:N_SO2)%ERR = TMP4(1:N_SO2) + +! ! Read MARK +! CALL CHECK( NF90_GET_VAR( FID, MARK_ID, TMPINT ), 312 ) +! OMI_SO2(1:N_SO2)%MARK = TMPINT(1:N_SO2) + + ! Read OPT + CALL CHECK( NF90_GET_VAR( FID, OPT_ID, TMPINT ), 313 ) + OMI_SO2(1:N_SO2)%OPT = TMPINT(1:N_SO2) + + ! Read FLAG + CALL CHECK( NF90_GET_VAR( FID, FLAG_ID, TMPINT ), 314 ) + OMI_SO2(1:N_SO2)%FLAG = TMPINT(1:N_SO2) + + END IF + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + DEALLOCATE( TMPINT ) + DEALLOCATE( TMP4 ) + DEALLOCATE( TMP8 ) + +! IF ( N_CALC > 1 ) THEN +! WRITE(*,*) '-----------SO2-----------' +! WRITE(*,*) OMI_SO2(1:N_SO2)%SO2 +! WRITE(*,*) '-----------SO2-----------' +! WRITE(*,*) '-----------ERR-----------' +! WRITE(*,*) OMI_SO2(1:N_SO2)%ERR +! WRITE(*,*) '-----------ERR-----------' +! WRITE(*,*) '-----------MARK-----------' +! WRITE(*,*) OMI_SO2(1:N_SO2)%MARK +! WRITE(*,*) '-----------MARK-----------' +! WRITE(*,*) '-----------OPT-----------' +! WRITE(*,*) OMI_SO2(1:N_SO2)%OPT +! WRITE(*,*) '-----------OPT-----------' +! END IF + + ! Return to the calling routines + END SUBROUTINE READ_GC_OMI_SO2_OBS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE WRITE_GC_OMI_SO2_OBS +! +!***************************************************************************** +! Subroutine WRITE_GC_OMI_SO2_OBS write observations whose CMA are +! close to GEOS-Chem CMA +! (ywang, 07/19/14) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD + + ! Local variables + INTEGER :: FID, N_ID + INTEGER :: LON_ID, LAT_ID, TIME_ID + INTEGER :: SO2_PBL_ID, SO2_TRL_ID, SO2_TRM_ID + INTEGER :: SO2_ID + INTEGER :: ERR_PBL_ID, ERR_TRL_ID, ERR_TRM_ID + INTEGER :: ERR_ID +! INTEGER :: MARK_ID + INTEGER :: OPT_ID + INTEGER :: FLAG_ID + CHARACTER(LEN=255) :: DIR + CHARACTER(LEN=255) :: WRITE_FILENAME + INTEGER :: ICOUNT + REAL*4, ALLOCATABLE :: TMP4(:) + REAL*8, ALLOCATABLE :: TMP8(:) + + !================================================================= + ! WRITE_GC_OMI_SO2_OBS begins here! + !================================================================= + + ! Filename root + WRITE_FILENAME = 'GC_' // TRIM( FILENAME ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( WRITE_FILENAME, GET_NYMD(), 9999 ) + + ! Construct complete filename + DIR = './data/OMI_SO2/' + WRITE_FILENAME = TRIM( DIR ) // TRIM( WRITE_FILENAME ) + + ! Print to screen + WRITE(6, 100) TRIM( WRITE_FILENAME ) + 100 FORMAT(' - WRITE_GC_OMI_SO2_OBS: reading file: ', A) + + ! Create the netCDF file + CALL CHECK( NF90_CREATE( WRITE_FILENAME, 0, FID ), 0 ) + + ! Define time dimension + CALL CHECK( NF90_DEF_DIM( FID, 'time', NF90_UNLIMITED, N_ID ), + & 100 ) + + CALL CHECK( NF90_ENDDEF( FID ), 99 ) + + ICOUNT = SIZE( OMI_SO2 ) + + ALLOCATE( TMP4(ICOUNT) ) + ALLOCATE( TMP8(ICOUNT) ) + + ! put variable longitude + TMP4(:) = OMI_SO2(:)%LON + CALL NCIO_1D( FID, TMP4, 'lon', 'longitude', + & 'degree', N_ID, ICOUNT, 101 ) + + ! put variable latitude + TMP4(:) = OMI_SO2(:)%LAT + CALL NCIO_1D( FID, TMP4, 'lat', 'latitude', + & 'degree', N_ID, ICOUNT, 102 ) + + ! put variable time + TMP8(:) = OMI_SO2(:)%TIME + CALL NCIO_1D_DBL( FID, TMP8, 'time', + & 'time at start of scan (TAI93)', + & 's', N_ID, ICOUNT, 103 ) + + ! put variable ColumnAmountSO2_PBL + TMP4(:) = OMI_SO2(:)%SO2_PBL + CALL NCIO_1D( FID, TMP4, 'SO2_PBL', + & 'ColumnAmountSO2_PBL', + & 'DU', N_ID, ICOUNT, 104 ) + + ! put variable ColumnAmountSO2_TRL + TMP4(:) = OMI_SO2(:)%SO2_TRL + CALL NCIO_1D( FID, TMP4, 'SO2_TRL', + & 'ColumnAmountSO2_TRL', + & 'DU', N_ID, ICOUNT, 105 ) + + ! put variable ColumnAmountSO2_TRM + TMP4(:) = OMI_SO2(:)%SO2_TRM + CALL NCIO_1D( FID, TMP4, 'SO2_TRM', + & 'ColumnAmountSO2_TRM', + & 'DU', N_ID, ICOUNT, 106 ) + + ! put variable SO2 Whose CMA is closest to GEOS-Chem CMA + TMP4(:) = OMI_SO2(:)%SO2 + CALL NCIO_1D( FID, TMP4, 'SO2', + & 'GC_OMI_SO2', + & 'DU', N_ID, ICOUNT, 107 ) + + ! put variable ColumnAmountSO2_PBL error + TMP4(:) = OMI_SO2(:)%ERR_PBL + CALL NCIO_1D( FID, TMP4, 'ERR_PBL', + & 'ColumnAmountSO2_PBL error', + & 'DU', N_ID, ICOUNT, 108 ) + + ! put variable ColumnAmountSO2_TRL error + TMP4(:) = OMI_SO2(:)%ERR_TRL + CALL NCIO_1D( FID, TMP4, 'ERR_TRL', + & 'ColumnAmountSO2_TRL error', + & 'DU', N_ID, ICOUNT, 109 ) + + ! put variable ColumnAmountSO2_TRM error + TMP4(:) = OMI_SO2(:)%ERR_TRM + CALL NCIO_1D( FID, TMP4, 'ERR_TRM', + & 'ColumnAmountSO2_TRM error', + & 'DU', N_ID, ICOUNT, 110 ) + + ! put variable GC_OMI_SO2 error + TMP4(:) = OMI_SO2(:)%ERR + CALL NCIO_1D( FID, TMP4, 'ERR', + & 'GC_OMI_SO2 error', + & 'DU', N_ID, ICOUNT, 111 ) + +! ! put variable MARK +! CALL NCIO_1D_INT( FID, OMI_SO2(:)%MARK, 'MARK', +! & 'MARK', +! & 'unitless', N_ID, ICOUNT, 112 ) + + ! put variable OPT + CALL NCIO_1D_INT( FID, OMI_SO2(:)%OPT, 'OPT', + & 'OPT', + & 'unitless', N_ID, ICOUNT, 113 ) + + ! put variable FLAG (ywang, 09/12/14) + CALL NCIO_1D_INT( FID, OMI_SO2(:)%FLAG, 'FLAG', + & 'FLAG', + & 'unitless', N_ID, ICOUNT, 114 ) + + ! close netCDF file + CALL CHECK( NF90_CLOSE( FID ), 999 ) + + DEALLOCATE( TMP4 ) + DEALLOCATE( TMP8 ) + + ! Return to the calling routines + END SUBROUTINE WRITE_GC_OMI_SO2_OBS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE CALC_OMI_SO2_FORCE( COST_FUNC ) +! +!***************************************************************************** +! Subroutine CALC_OMI_SO2_FORCE calculate the adjoint forcing from OMI +! L3 SO2 observation and updates the cost function. +! (ywang, 07/16/14) +! +! Arguments as Input/Output: +! =========================================================================== +! ( 1) COST_FUNC (REAL*8) : Cost funtion [unitless] +! +! NOTES: +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ, N_CALC + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AIRVOL + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAUb, GET_TAU, GET_TAUe + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTSO2 + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + ! Arguements + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Parameters + REAL*8, PARAMETER :: M2DU = 2.69D20 ! 1 DU = 2.69D20 molec/m2 + + ! Local variables + INTEGER, SAVE :: N_SO2 = 0 + INTEGER :: N_CURR + INTEGER :: NT + INTEGER :: NC + INTEGER :: IIJJ(2), I, J, L + + REAL*8 :: OLD_COST + REAL*8 :: TMP_COST + REAL*8, ALLOCATABLE :: NEW_COST(:) + + REAL*8 :: GC_CMA ! GEOS-Chem Center Mass of Alitude. (units: km) + REAL*8 :: GC_SO2_CONC(LLPAR) ! GEOS-Chem SO2 at each layer (units: kg/m3) + REAL*8 :: LAYER_GC_SO2(LLPAR) ! GEOS-Chem SO2 at each layer (units: DU) + REAL*8 :: COLUMN_GC_SO2 ! GEOS-Chem column SO2 (units: DU) + REAL*8 :: DIFF + REAL*8 :: FORCING + + + + !================================================================= + ! CALC_OMI_SO2_FORCE begins here! + !================================================================= + + PRINT*, ' - CALC_OMI_SO2_FORCE: OMI SO2 forcing ' + + ! Initialize + CALL INIT_OMI_SO2_OBS + + ! Save a value of the cost function first + OLD_COST = COST_FUNC +! PRINT*, 'OLD_COST', OLD_COST, COST_FUNC + + ! Check if it is the last time of a day + IF ( OBS_FREQ > 60 ) THEN + PRINT*, '236000 - OBS_FREQ * 100 is not valid' + STOP + END IF + IF ( GET_NHMS() == 236000 - OBS_FREQ * 100 ) THEN +! IF ( (GET_NHMS() == 236000 - OBS_FREQ * 100) .OR. +! & ( ABS(GET_TAU() -GET_TAUe()) < 1e-6 ) ) THEN + + CALL READ_GC_OMI_SO2_OBS( GET_NYMD(), N_SO2 ) + + END IF + + ! No observations for current day + IF ( N_SO2 == 0 ) THEN + + PRINT*, ' - CALC_OMI_SO2_FORCE: No OMI SO2 obsevations for + ¤t day' + + IF ( ABS( GET_TAUb() - GET_TAU() ) < 1E-6) THEN + + CALL MAKE_AVERAGE_OMI_SO2 + + END IF + + ! The start time of one day + IF ( GET_NHMS() == 0 ) THEN + + CALL WRITE_GC_OMI_SO2_OBS + + END IF + + + RETURN + + END IF + + + ! GET observations in time window + CALL GET_OBS( N_SO2, N_CURR ) + + ! No observations for time window + IF ( N_CURR == 0 ) THEN + + PRINT*, ' - CALC_OMI_SO2_FORCE: No OMI SO2 obsevations for + ¤t time window' + + IF ( ABS( GET_TAUb() - GET_TAU() ) < 1E-6) THEN + + CALL MAKE_AVERAGE_OMI_SO2 + + END IF + + ! The start time of one day + IF ( GET_NHMS() == 0 ) THEN + + CALL WRITE_GC_OMI_SO2_OBS + + END IF + + RETURN + + END IF + + ! Reset + CURR_GC_SO2 = 0D0 + CURR_PBL_SO2 = 0D0 + CURR_TRL_SO2 = 0D0 + CURR_TRM_SO2 = 0D0 + CURR_SO2 = 0D0 + CURR_DIFF_SO2 = 0D0 + CURR_FORCING = 0D0 + CURR_COST = 0D0 + CURR_CMA = 0D0 + CURR_COUNT = 0 + CURR_PBL_C = 0 + CURR_TRL_C = 0 + CURR_TRM_C = 0 + CURR_OPT = 0 + + ! Reset + IF ( ALLOCATED( NEW_COST ) ) DEALLOCATE( NEW_COST ) + ALLOCATE ( NEW_COST(N_CURR) ) + NEW_COST = 0D0 + + NC = 0 + ! Loop for all observations + DO NT = 1, N_SO2, 1 + + ! Observations in time window and simulation area + IF ( FLAGS(NT) ) THEN + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(OMI_SO2(NT)%LON ,4), + & REAL(OMI_SO2(NT)%LAT ,4) ) + + I = IIJJ(1) + J = IIJJ(2) + +! These code is moved below +! ! Count observations in gridbox +! CURR_COUNT(I,J) = CURR_COUNT(I,J) + 1 +! ALL_COUNT(I,J) = ALL_COUNT(I,J) + 1 + + ! SO2 outside troposphere is set to 0 + GC_SO2_CONC = 0D0 + LAYER_GC_SO2 = 0D0 + DO L = 1, LLPAR, 1 + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + ! Units conversion [ kg/gridbox => DU ] + ! Units of LAYER_GC_SO2: DU + ! GC_SO2_CONC: kg/m3 + ! CHK_STT : kg/gridbox + ! AIRVOL : m3/gridbox + ! BXHEIGHT : m + ! XNUMOL : molec/kg + ! M2DU = 2.69D20 , 1 DU = 2.69D20 molec/m2 + + GC_SO2_CONC(L) = CHK_STT(I,J,L,IDTSO2) / + & AIRVOL(I,J,L) + + LAYER_GC_SO2(L) = GC_SO2_CONC(L) * + & BXHEIGHT(I,J,L) * + & XNUMOL(IDTSO2) / + & M2DU + + END IF + + END DO + + COLUMN_GC_SO2 = SUM( LAYER_GC_SO2 ) + +! These code is moved below +! CURR_GC_SO2(I,J) = CURR_GC_SO2(I,J) + COLUMN_GC_SO2 +! ALL_GC_SO2(I,J) = ALL_GC_SO2(I,J) + COLUMN_GC_SO2 + + ! Get GEOS-Chem CMA + CALL CALC_CMA( I, J, GC_SO2_CONC, GC_CMA ) + +! These code is moved below +! CURR_CMA(I,J) = CURR_CMA(I,J) + GC_CMA +! ALL_CMA(I,J) = ALL_CMA(I,J) + GC_CMA + + ! Determine SO2 observations whoes CMA is closest to GEOS-Chem CMA + ! DETERMINE_OBS is modified (ywang, 09/12/14) + IF ( N_CALC == 1 ) CALL DETERMINE_OBS(GC_CMA, NT) + + + IF ( OMI_SO2(NT)%FLAG == 1 ) THEN ! expected observation exist + + ! Count observations in gridbox + CURR_COUNT(I,J) = CURR_COUNT(I,J) + 1 + ALL_COUNT(I,J) = ALL_COUNT(I,J) + 1 + + CURR_GC_SO2(I,J) = CURR_GC_SO2(I,J) + COLUMN_GC_SO2 + ALL_GC_SO2(I,J) = ALL_GC_SO2(I,J) + COLUMN_GC_SO2 + + CURR_CMA(I,J) = CURR_CMA(I,J) + GC_CMA + ALL_CMA(I,J) = ALL_CMA(I,J) + GC_CMA + + CURR_OPT(I,J) = CURR_OPT(I,J) + 1 + ALL_OPT(I,J) = ALL_OPT(I,J) + 1 + + ! Calculate sum here. In the end, average will be calculated + CURR_SO2(I,J) = CURR_SO2(I,J) + OMI_SO2(NT)%SO2 + ALL_SO2(I,J) = ALL_SO2(I,J) + OMI_SO2(NT)%SO2 + +! The code is moved below +! IF ( OMI_SO2(NT)%SO2_PBL > 0.0 ) THEN +! +! CURR_PBL_SO2(I,J) = CURR_PBL_SO2(I,J) + +! & OMI_SO2(NT)%SO2_PBL +! CURR_PBL_C(I,J) = CURR_PBL_C(I,J) + 1 +! +! ALL_PBL_SO2(I,J) = ALL_PBL_SO2(I,J) + +! & OMI_SO2(NT)%SO2_PBL +! ALL_PBL_C(I,J) = ALL_PBL_C(I,J) + 1 +! +! END IF +! +! IF ( OMI_SO2(NT)%SO2_TRL > 0.0 ) THEN +! +! CURR_TRL_SO2(I,J) = CURR_TRL_SO2(I,J) + +! & OMI_SO2(NT)%SO2_TRL +! CURR_TRL_C(I,J) = CURR_TRL_C(I,J) + 1 +! +! ALL_TRL_SO2(I,J) = ALL_TRL_SO2(I,J) + +! & OMI_SO2(NT)%SO2_TRL +! ALL_TRL_C(I,J) = ALL_TRL_C(I,J) + 1 +! +! END IF +! +! IF ( OMI_SO2(NT)%SO2_TRM > 0.0 ) THEN +! +! CURR_TRM_SO2(I,J) = CURR_TRM_SO2(I,J) + +! & OMI_SO2(NT)%SO2_TRM +! CURR_TRM_C(I,J) = CURR_TRM_C(I,J) + 1 +! +! ALL_TRM_SO2(I,J) = ALL_TRM_SO2(I,J) + +! & OMI_SO2(NT)%SO2_TRM +! ALL_TRM_C(I,J) = ALL_TRM_C(I,J) + 1 +! +! END IF + + !----------------------------- + ! Calculate adjoint forcing + !----------------------------- + + ! The difference between GEOS-Chem SO2 and OMI SO2 + DIFF = COLUMN_GC_SO2 - OMI_SO2(NT)%SO2 + CURR_DIFF_SO2(I,J) = CURR_DIFF_SO2(I,J) + DIFF + ALL_DIFF_SO2(I,J) = ALL_DIFF_SO2(I,J) + DIFF + + ! S_{obs}^{-1} * DIFF + FORCING = DIFF / (OMI_SO2(NT)%ERR ** 2) + CURR_FORCING(I,J) = CURR_FORCING(I,J) + FORCING + ALL_FORCING(I,J) = ALL_FORCING(I,J) + FORCING + + ! Contribution to the cost function + TMP_COST = 0.5D0 * DIFF * FORCING + NC = NC + 1 + NEW_COST(NC) = NEW_COST(NC) + TMP_COST + CURR_COST(I,J) = CURR_COST(I,J) + TMP_COST + ALL_COST(I,J) = ALL_COST(I,J) + TMP_COST + + + ! Now pass the adjoint back to the adjoint tracer array + DO L = 1, LLPAR, 1 + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + STT_ADJ(I,J,L,IDTSO2) = STT_ADJ(I,J,L,IDTSO2) + + & FORCING / AIRVOL(I,J,L) * + & BXHEIGHT(I,J,L) * + & XNUMOL(IDTSO2) / M2DU + + END IF + + END DO + + END IF !OMI_SO2(NT)%FLAG == 1 + + IF ( OMI_SO2(NT)%SO2_PBL > 0.0 ) THEN + + CURR_PBL_SO2(I,J) = CURR_PBL_SO2(I,J) + + & OMI_SO2(NT)%SO2_PBL + CURR_PBL_C(I,J) = CURR_PBL_C(I,J) + 1 + + ALL_PBL_SO2(I,J) = ALL_PBL_SO2(I,J) + + & OMI_SO2(NT)%SO2_PBL + ALL_PBL_C(I,J) = ALL_PBL_C(I,J) + 1 + + END IF + + IF ( OMI_SO2(NT)%SO2_TRL > 0.0 ) THEN + + CURR_TRL_SO2(I,J) = CURR_TRL_SO2(I,J) + + & OMI_SO2(NT)%SO2_TRL + CURR_TRL_C(I,J) = CURR_TRL_C(I,J) + 1 + + ALL_TRL_SO2(I,J) = ALL_TRL_SO2(I,J) + + & OMI_SO2(NT)%SO2_TRL + ALL_TRL_C(I,J) = ALL_TRL_C(I,J) + 1 + + END IF + + IF ( OMI_SO2(NT)%SO2_TRM > 0.0 ) THEN + + CURR_TRM_SO2(I,J) = CURR_TRM_SO2(I,J) + + & OMI_SO2(NT)%SO2_TRM + CURR_TRM_C(I,J) = CURR_TRM_C(I,J) + 1 + + ALL_TRM_SO2(I,J) = ALL_TRM_SO2(I,J) + + & OMI_SO2(NT)%SO2_TRM + ALL_TRM_C(I,J) = ALL_TRM_C(I,J) + 1 + + END IF + + END IF ! FLAGS(NT) + + END DO ! NT + + + ! Update cost function + COST_FUNC = COST_FUNC + SUM( NEW_COST ) + PRINT*, ' Update value of COST_FUNC = ', COST_FUNC + PRINT*, ' OMI SO2 contribution = ', COST_FUNC - OLD_COST + + PRINT*, ' MIN/MAX STT_ADJ = ', MINVAL(STT_ADJ), MAXVAL(STT_ADJ) + PRINT*, ' MIN/MAX in = ', MINLOC(STT_ADJ), MAXLOC(STT_ADJ) + PRINT*, ' MIN/MAX NEW_COST = ', MINVAL(NEW_COST), MAXVAL(NEW_COST) + PRINT*, ' MIN/MAX cost in = ', MINLOC(NEW_COST),MAXLOC(NEW_COST) + + + CALL MAKE_CURRENT_OMI_SO2 + + + IF ( ABS( GET_TAUb() - GET_TAU() ) < 1E-6) THEN + + CALL MAKE_AVERAGE_OMI_SO2 + + END IF + + ! The start time of one day + IF ( ( GET_NHMS() == 0 ) .AND. ( N_CALC == 1 ) ) THEN + + CALL WRITE_GC_OMI_SO2_OBS + + END IF + + ! Return to the calling routines + END SUBROUTINE CALC_OMI_SO2_FORCE +! +!----------------------------------------------------------------------------- +! + SUBROUTINE MAKE_CURRENT_OMI_SO2 +! +!***************************************************************************** +! Subroutine MAKE_CURRENT_OMI_SO2 output some dignostic data for +! current assimilation time window +! (ywang, 07/19/14) +! +!***************************************************************************** +! + ! Reference to f90 module + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TAU + + REAL*4, PARAMETER :: UNDEF = -999.0 + + ! Local Variables + INTEGER :: I, I0, J, J0, L + REAL*4 :: SO2(IIPAR,JJPAR,14) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=255) :: OUTPUT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_CURRENT_OMI_SO2 begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FILE = 'gctm.omi.so2.YYYYMMDD.hhmm.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM diag File: ' // + & 'OMI SO2' + UNIT = 'DU' + CATEGORY = 'IJ-AVG-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FILE ) + + ! Replace YYMMDD and hhmmss token w/ actucl value + CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add DIAGADJ_DIR prefix to FILENAME + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CURRENT_OMI_SO2: Writing ', a ) + + ! Open file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + SO2 = 0.0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( CURR_COUNT(I,J) > 0 ) THEN + SO2(I,J, 1) = REAL(CURR_GC_SO2(I,J)) / CURR_COUNT(I,J) + SO2(I,J, 5) = REAL(CURR_SO2(I,J)) / CURR_COUNT(I,J) + SO2(I,J, 6) = REAL(CURR_DIFF_SO2(I,J)) / CURR_COUNT(I,J) + SO2(I,J, 7) = REAL(CURR_FORCING(I,J)) + SO2(I,J, 8) = REAL(CURR_COST(I,J)) + SO2(I,J, 9) = REAL(CURR_CMA(I,J)) / CURR_COUNT(I,J) + SO2(I,J,10) = REAL(CURR_COUNT(I,J)) + SO2(I,J,11) = REAL(CURR_PBL_C(I,J)) + SO2(I,J,12) = REAL(CURR_TRL_C(I,J)) + SO2(I,J,13) = REAL(CURR_TRM_C(I,J)) + SO2(I,J,14) = REAL(CURR_OPT(I,J)) + END IF + + IF ( CURR_PBL_C(I,J) > 0 ) THEN + SO2(I,J,2) = REAL(CURR_PBL_SO2(I,J)) / CURR_PBL_C(I,J) + END IF + + IF ( CURR_TRL_C(I,J) > 0 ) THEN + SO2(I,J,3) = REAL(CURR_TRL_SO2(I,J)) / CURR_TRL_C(I,J) + END IF + + IF ( CURR_TRM_C(I,J) > 0 ) THEN + SO2(I,J,4) = REAL(CURR_TRM_SO2(I,J)) / CURR_TRM_C(I,J) + END IF + + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 26, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 14, I0+1, + & J0+1, 1, SO2 ) + + ! Close file + CLOSE( IU_RST ) + + ! Return to the calling routines + END SUBROUTINE MAKE_CURRENT_OMI_SO2 +! +!----------------------------------------------------------------------------- +! + SUBROUTINE MAKE_AVERAGE_OMI_SO2 +! +!***************************************************************************** +! Subroutine MAKE_AVERAGE_OMI_SO2 output some dignostic data for +! simulation time +! (ywang, 07/19/14) +! +!***************************************************************************** +! + ! Reference to f90 module + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe + + REAL*4, PARAMETER :: UNDEF = -999.0 + + ! Local Variables + INTEGER :: I, I0, J, J0, L + REAL*4 :: SO2(IIPAR,JJPAR,14) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=255) :: OUTPUT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_AVERAGE_OMI_SO2 begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FILE = 'gctm.omi.so2.ave.YYYYMMDD.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM diag File: ' // + & 'OMI SO2' + UNIT = 'DU' + CATEGORY = 'IJ-AVG-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FILE ) + + ! Replace YYMMDD token w/ actucl value + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 9999 ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add DIAGADJ_DIR prefix to FILENAME + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_AVERAGE_OMI_SO2: Writing ', a ) + + ! Open file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + SO2 = 0.0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( ALL_COUNT(I,J) > 0 ) THEN + SO2(I,J, 1) = REAL(ALL_GC_SO2(I,J)) / ALL_COUNT(I,J) + SO2(I,J, 5) = REAL(ALL_SO2(I,J)) / ALL_COUNT(I,J) + SO2(I,J, 6) = REAL(ALL_DIFF_SO2(I,J)) / ALL_COUNT(I,J) + SO2(I,J, 7) = REAL(ALL_FORCING(I,J)) + SO2(I,J, 8) = REAL(ALL_COST(I,J)) + SO2(I,J, 9) = REAL(ALL_CMA(I,J)) / ALL_COUNT(I,J) + SO2(I,J,10) = REAL(ALL_COUNT(I,J)) + SO2(I,J,11) = REAL(ALL_PBL_C(I,J)) + SO2(I,J,12) = REAL(ALL_TRL_C(I,J)) + SO2(I,J,13) = REAL(ALL_TRM_C(I,J)) + SO2(I,J,14) = REAL(ALL_OPT(I,J)) + END IF + + IF ( ALL_PBL_C(I,J) > 0 ) THEN + SO2(I,J,2) = REAL(ALL_PBL_SO2(I,J)) / ALL_PBL_C(I,J) + END IF + + IF ( ALL_TRL_C(I,J) > 0 ) THEN + SO2(I,J,3) = REAL(ALL_TRL_SO2(I,J)) / ALL_TRL_C(I,J) + END IF + + IF ( ALL_TRM_C(I,J) > 0 ) THEN + SO2(I,J,4) = REAL(ALL_TRM_SO2(I,J)) / ALL_TRM_C(I,J) + END IF + + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 26, + & UNIT, GET_TAUb(), GET_TAUe(), RESERVED, + & IIPAR, JJPAR, 14, I0+1, + & J0+1, 1, SO2 ) + + ! Close file + CLOSE( IU_RST ) + + ! Return to the calling routines + END SUBROUTINE MAKE_AVERAGE_OMI_SO2 +! +!----------------------------------------------------------------------------- +! + SUBROUTINE GET_OBS( N_SO2, N_CURR ) +! +!***************************************************************************** +! Subroutine GET_OBS finds all obsevations in the current time window +! and simulation area. +! (ywang, 07/17/14) +! +! Arguements as Input: +! =========================================================================== +! ( 1) N_SO2 (INTEGER) : Number of observation in current day +! Arguements as Output: +! =========================================================================== +! ( 2) N_CURR (INTEGER) : Number of obsevations in the current time +! window and simulation area. +! +! Module variable as Output: +! =========================================================================== +! ( 1) FLAGS (LOGICAL) : Whether or not a speicific obsevation is +! in current time window and simulation area. +! +!***************************************************************************** +! + ! Reference to f90 module + USE GRID_MOD, ONLY : GET_XEDGE, GET_YEDGE + USE TIME_MOD, ONLY : GET_JD, GET_TAU + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + + ! Arguemens + INTEGER, INTENT( IN) :: N_SO2 + INTEGER, INTENT(OUT) :: N_CURR + + ! Local variables + REAL*8 :: HALF_TIME_WINDOW + REAL*8 :: WINDOW_BEGIN, WINDOW_END + REAL*8 :: JD85, JD93, JD93_85 + REAL*8 :: CURRENT_TAU + INTEGER :: NT + +#if defined( NESTED_CH ) || defined( NESTED_NA ) || defined( NESTED_SD ) + REAL*8, SAVE :: XEDGE_MIN, XEDGE_MAX + REAL*8, SAVE :: YEDGE_MIN, YEDGE_MAX +#endif + + !================================================================= + ! GET_OBS begins here! + !================================================================= + + ! Get the difference between JD93 and JD85 + ! In GEOS-Chem, it is since 1/1/1985, while in OMI, it is since + ! 1/1/1993 + JD85 = GET_JD( 19850000, 000000 ) + JD93 = GET_JD( 19930000, 000000 ) + JD93_85 = JD93 - JD85 + JD93_85 = JD93_85 * 24D0 ! days => hours + +! write(*, '(A15, f30.15)' ) 'JD85', JD85 +! write(*, '(A15, f30.15)' ) 'JD93', JD93 +! write(*, '(A15, f30.15)' ) 'JD93_85', JD93_85 + + ! Get current GEOS-Chem TAU + CURRENT_TAU = GET_TAU() +! write(*,'(A15, f30.15)') 'CURRENT_TAU',CURRENT_TAU + + ! Change current GEOS-Chem TAU into OMI TAU + CURRENT_TAU = CURRENT_TAU - JD93_85 +! write(*,'(A15, f30.15)') 'CURRENT_TAU',CURRENT_TAU + + ! Change TAU units ( hours => second ) + CURRENT_TAU = CURRENT_TAU * 3600D0 +! write(*,'(A15, f30.15)') 'CURRENT_TAU',CURRENT_TAU + + ! Get half time window + HALF_TIME_WINDOW = TIME_WINDOW / 2D0 + HALF_TIME_WINDOW = HALF_TIME_WINDOW * 60D0 ! ( minute => second ) +! write(*, '(A15, f30.15)') 'HALF_TIME_WINDOW',HALF_TIME_WINDOW + + ! Get current time window + WINDOW_BEGIN = CURRENT_TAU - HALF_TIME_WINDOW + WINDOW_END = CURRENT_TAU + HALF_TIME_WINDOW + +! write(*, '(A15,f30.15)') 'WINDOW_BEGIN',WINDOW_BEGIN +! write(*, '(A15,f30.15)') 'WINDOW_END',WINDOW_END + +#if defined( NESTED_CH ) || defined( NESTED_NA ) || defined( NESTED_SD ) + XEDGE_MIN = GET_XEDGE( 1 ) + XEDGE_MAX = GET_XEDGE( IIPAR+1 ) + YEDGE_MIN = GET_YEDGE( 1 ) + YEDGE_MAX = GET_YEDGE( JJPAR+1 ) + PRINT*, 'Nested region edge limit' + PRINT*, 'XEDGE_MIN: ', XEDGE_MIN + PRINT*, 'XEDGE_MAX: ', XEDGE_MAX + PRINT*, 'YEDGE_MIN: ', YEDGE_MIN + PRINT*, 'YEDGE_MAX: ', YEDGE_MAX +#endif +! Write(*, '(f30.15)') OMI_SO2(1:10)%TIME + N_CURR = 0 + ! Find observations in current time window and simulation area + DO NT = 1, N_SO2, 1 + + IF ( ( OMI_SO2(NT)%TIME >= WINDOW_BEGIN ) + & .AND. ( OMI_SO2(NT)%TIME < WINDOW_END ) +#if defined( NESTED_CH ) || defined( NESTED_NA ) || defined( NESTED_SD ) + & .AND. ( OMI_SO2(NT)%LON >= XEDGE_MIN ) + & .AND. ( OMI_SO2(NT)%LON <= XEDGE_MAX ) + & .AND. ( OMI_SO2(NT)%LAT >= YEDGE_MIN ) + & .AND. ( OMI_SO2(NT)%LAT <= YEDGE_MAX ) +#endif + & ) THEN + + + FLAGS(NT) = .TRUE. + + N_CURR = N_CURR + 1 + + ELSE + + FLAGS(NT) = .FALSE. + + END IF + + END DO + + WRITE(6, 100) N_CURR, GET_NHMS() + 100 FORMAT(' Number of OMI SO2 observations: ' I10 ' at ' I10.6) + + ! Return to calling program + END SUBROUTINE GET_OBS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE CALC_CMA( I, J, GC_SO2_CONC, GC_CMA ) +! +!***************************************************************************** +! Subroutine CALC_CMA calculate GEOS-Chem Center Mass of Altitude ( +! The height where SO2 reach its maximum value ) +! (ywang, 07/17/14) +! +! Arguements as Input: +! =========================================================================== +! ( 1) I (INTEGER) : LON INDEX +! ( 2) J (INTEGER) : LAT INDEX +! ( 3) GC_SO2_CONC(LLPAR) (REAL*8) : SO2 concentration at each layer +! Arguements as Output: +! =========================================================================== +! ( 1) GC_CMA (REAL*8) : Center Mass of Altitude (km) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE DAO_MOD, ONLY : BXHEIGHT + + ! Arguements + INTEGER, INTENT( IN) :: I, J + REAL*8, INTENT( IN) :: GC_SO2_CONC(LLPAR) + REAL*8, INTENT(OUT) :: GC_CMA + + ! Local variabls + INTEGER :: L, MAX_SO2_L + + !================================================================= + ! CALC_CMA begins here! + !================================================================= + + MAX_SO2_L = 1 + + ! Find the layer SO2 concentration reaches its maximum value + DO L = 2, LLPAR, 1 + + IF ( GC_SO2_CONC(L) > GC_SO2_CONC(MAX_SO2_L) ) THEN + + MAX_SO2_L = L + + END IF + + END DO +! MAX_SO2_L = MAXLOC( GC_SO2_CONC ) + + ! Calculate CMA + GC_CMA = 0D0 + IF ( MAX_SO2_L == 1) THEN + + GC_CMA = BXHEIGHT(I,J,MAX_SO2_L) / 2D0 + + ELSE + + DO L = 1, MAX_SO2_L-1, 1 + + GC_CMA = GC_CMA + BXHEIGHT(I,J,L) + + END DO + + GC_CMA = GC_CMA + BXHEIGHT(I,J,MAX_SO2_L) / 2D0 + + END IF + + ! m => km + GC_CMA = GC_CMA / 1000D0 + + ! Return to calling program + END SUBROUTINE CALC_CMA +! +!----------------------------------------------------------------------------- +! + SUBROUTINE DETERMINE_OBS( GC_CMA, NT ) +! +!***************************************************************************** +! Subroutine DETERMINE_OBS finds the OMI SO2 observation whose CMA is +! closest to GEOS-Chem CMA +! (ywang, 07/18/14) +! +! Arguements as Input: +! =========================================================================== +! ( 1) GC_CMA (REAL*8 ) : GEOS-Chem Center Mass of Altitude (km) +! ( 2) NT (INTEGER) : OMI_SO2 index +! 1: PBL, 2: TRL, 3: TRM +! +! Moudule variables as Output: +! ( 1) OMI_SO2(NT)%SO2 (REAL*8) : OMI SO2 will be used +! ( 2) OMI_SO2(NT)%ERR (REAL*8) : OMI SO2 error will be used +!! ( 3) OMI_SO2(NT)%MARK (INTEGER) : Marks of which observation is +! expected +! ( 4) OMI_SO2(NT)%OPT (INTEGER) : Mark of which observation whose CMA +! is close to GEOS-Chem CMA, though the observation may not exists +! ( 5) OMI_SO2(NT)%FLAG (INTEGER) : Does the observartion expected +! really exist? 0: not exist, 1: exist +! +! Notes: +! ( 1) The alogrithm is changed. Now if the expected obsevation does +! not exit, we shall not use other observation to substutite it. +! +!***************************************************************************** +! + ! Parameters +! ! PBL_CMA, TRL_CMA, and TRM_CMA references to moudle note 2 +! REAL*8, PARAMETER :: PBL_CMA = 0.9D0 ! units: km +! REAL*8, PARAMETER :: TRL_CMA = 2.5D0 ! units: km +! REAL*8, PARAMETER :: TRM_CMA = 7.5D0 ! units: km + REAL*8, PARAMETER :: MIN_PBL = 0.0D0 ! units: km + REAL*8, PARAMETER :: MAX_PBL = 1.7D0 ! units: km + REAL*8, PARAMETER :: MIN_TRL = MAX_PBL + REAL*8, PARAMETER :: MAX_TRL = 5.0D0 ! units: km + REAL*8, PARAMETER :: MIN_TRM = MAX_TRL + REAL*8, PARAMETER :: MAX_TRM = 10.0D0 ! units: km + + ! minimum valid observations + REAL*8, PARAMETER :: MIN_VAL = -10.0 ! units: DU + + REAL*8, PARAMETER :: UNDEF = -999.0D0 + + ! Arguments + REAL*8, INTENT( IN) :: GC_CMA + INTEGER, INTENT( IN) :: NT + +! ! Local variables +! REAL*8 :: DIST1(3), DIST2(3) +! INTEGER :: I(1) + + !================================================================= + ! DETERMINE_OBS begins here! + !================================================================= + +! ! for OPT +! DIST1(1) = ABS( GC_CMA-PBL_CMA ) +! DIST1(2) = ABS( GC_CMA-TRL_CMA ) +! DIST1(3) = ABS( GC_CMA-TRM_CMA ) + +! I = MINLOC( DIST1 ) +! +! SELECT CASE ( I(1) ) +! +! CASE ( 1 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_PBL +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_PBL +! +! CASE ( 2 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRL +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRL +! CASE ( 3 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRM +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRM +! +! CASE DEFAULT +! PRINT*, 'DETERMINE_OBS ERROR' +! STOP +! +! END SELECT +! +! OMI_SO2(NT)%OPT = I(1) + +! ! for MARK +! DIST2 = 1D10 +! IF ( OMI_SO2(NT)%SO2_PBL > 0.0 ) DIST2(1) = ABS( GC_CMA-PBL_CMA ) +! IF ( OMI_SO2(NT)%SO2_TRL > 0.0 ) DIST2(2) = ABS( GC_CMA-TRL_CMA ) +! IF ( OMI_SO2(NT)%SO2_TRM > 0.0 ) DIST2(3) = ABS( GC_CMA-TRM_CMA ) +! +! I = MINLOC( DIST2 ) +! +! SELECT CASE ( I(1) ) +! +! CASE ( 1 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_PBL +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_PBL +! +! CASE ( 2 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRL +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRL +! CASE ( 3 ) +! OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRM +! OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRM +! +! CASE DEFAULT +! PRINT*, 'DETERMINE_OBS ERROR' +! STOP +! +! END SELECT +! +! OMI_SO2(NT)%MARK = I(1) + + OMI_SO2(NT)%SO2 = UNDEF + OMI_SO2(NT)%ERR = UNDEF + + IF ( (GC_CMA >= MIN_PBL) .AND. (GC_CMA < MAX_PBL) ) THEN + + OMI_SO2(NT)%OPT = 1 + + IF ( OMI_SO2(NT)%SO2_PBL >= MIN_VAL ) THEN + OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_PBL + OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_PBL + END IF + + ELSE IF ( (GC_CMA >= MIN_TRL) .AND. (GC_CMA < MAX_TRL) ) THEN + + OMI_SO2(NT)%OPT = 2 + + IF ( OMI_SO2(NT)%SO2_TRL >= MIN_VAL ) THEN + OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRL + OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRL + END IF + + ELSE IF ( (GC_CMA >= MIN_TRM) .AND. (GC_CMA < MAX_TRM) ) THEN + + OMI_SO2(NT)%OPT = 3 + + IF ( OMI_SO2(NT)%SO2_TRM >= MIN_VAL ) THEN + OMI_SO2(NT)%SO2 = OMI_SO2(NT)%SO2_TRM + OMI_SO2(NT)%ERR = OMI_SO2(NT)%ERR_TRM + END IF + + ELSE + + OMI_SO2(NT)%OPT = 0 + + END IF + + IF ( OMI_SO2(NT)%SO2 > MIN_VAL ) THEN + + OMI_SO2(NT)%FLAG = 1 + + ELSE + + OMI_SO2(NT)%FLAG = 0 + + END IF + + + ! Return to calling program + END SUBROUTINE DETERMINE_OBS +! +!----------------------------------------------------------------------------- +! + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!***************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries +! routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! =========================================================================== +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was +! made +! +! NOTES: +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'omi_so2_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK +! +!----------------------------------------------------------------------------- +! + SUBROUTINE NCIO_1D (NCID, VAR1D, VARNAME, LONGNAME, VARUNIT, + & DIMID, DIMV, INDEX) + + ! References to F90 modules + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: NCID, DIMID, DIMV, INDEX + REAL*4, INTENT(IN) :: VAR1D(DIMV) + CHARACTER(LEN=*), INTENT(IN) :: VARNAME, LONGNAME, VARUNIT + + ! Local variable + INTEGER :: DIMS(1) + INTEGER :: VAR_ID + + CALL CHECK( NF90_REDEF(NCID), INDEX ) + + DIMS(1) = DIMID + CALL CHECK( NF90_DEF_VAR(NCID, TRIM(VARNAME), + & NF90_FLOAT, DIMS, VAR_ID), INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"name",TRIM(LONGNAME)),INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"units",TRIM(VARUNIT)),INDEX) + CALL CHECK( NF90_ENDDEF(NCID), INDEX ) + CALL CHECK( NF90_PUT_VAR(NCID, VAR_ID, VAR1D ), INDEX ) + + END SUBROUTINE NCIO_1D +! +!----------------------------------------------------------------------------- +! + SUBROUTINE NCIO_1D_DBL (NCID, VAR1D, VARNAME, LONGNAME, VARUNIT, + & DIMID, DIMV, INDEX) + + ! References to F90 modules + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: NCID, DIMID, DIMV, INDEX + REAL*8, INTENT(IN) :: VAR1D(DIMV) + CHARACTER(LEN=*), INTENT(IN) :: VARNAME, LONGNAME, VARUNIT + + ! Local variable + INTEGER :: DIMS(1) + INTEGER :: VAR_ID + + CALL CHECK( NF90_REDEF(NCID), INDEX ) + + DIMS(1) = DIMID + CALL CHECK( NF90_DEF_VAR(NCID, TRIM(VARNAME), + & NF90_DOUBLE, DIMS, VAR_ID), INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"name",TRIM(LONGNAME)),INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"units",TRIM(VARUNIT)),INDEX) + CALL CHECK( NF90_ENDDEF(NCID), INDEX ) + CALL CHECK( NF90_PUT_VAR(NCID, VAR_ID, VAR1D ), INDEX ) + + END SUBROUTINE NCIO_1D_DBL +! +!----------------------------------------------------------------------------- +! + SUBROUTINE NCIO_1D_INT (NCID, VAR1D, VARNAME, LONGNAME, VARUNIT, + & DIMID, DIMV, INDEX) + + ! References to F90 modules + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: NCID, DIMID, DIMV, INDEX + INTEGER, INTENT(IN) :: VAR1D(DIMV) + CHARACTER(LEN=*), INTENT(IN) :: VARNAME, LONGNAME, VARUNIT + + ! Local variable + INTEGER :: DIMS(1) + INTEGER :: VAR_ID + + CALL CHECK( NF90_REDEF(NCID), INDEX ) + + DIMS(1) = DIMID + CALL CHECK( NF90_DEF_VAR(NCID, TRIM(VARNAME), + & NF90_INT, DIMS, VAR_ID), INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"name",TRIM(LONGNAME)),INDEX) + CALL CHECK( NF90_PUT_ATT(NCID,VAR_ID,"units",TRIM(VARUNIT)),INDEX) + CALL CHECK( NF90_ENDDEF(NCID), INDEX ) + CALL CHECK( NF90_PUT_VAR(NCID, VAR_ID, VAR1D ), INDEX ) + + END SUBROUTINE NCIO_1D_INT +! +!----------------------------------------------------------------------------- +! + END MODULE OMI_SO2_OBS_MOD diff --git a/code/obs_operators/osiris_no2_obs_mod.f90 b/code/obs_operators/osiris_no2_obs_mod.f90 new file mode 100644 index 0000000..ea0ac2b --- /dev/null +++ b/code/obs_operators/osiris_no2_obs_mod.f90 @@ -0,0 +1,637 @@ +MODULE OSIRIS_NO2_OBS_MOD + + ! + ! Module OSIRIS_NO2_OBS contains all subroutines and variables needed to assimilate OSIRIS NO2 tropospheric column data + ! + ! Module Routines: + ! + ! (1) CALC_OSIRIS_NO2_FORCE : calculates adjoint forcing and cost function contribution for OSIRIS tropospheric NO2 columns + ! (2) TAI2UTC : converts TAI93 (seconds since 1.1.1993) to UTC + ! (3) MAKE_OSIRIS_BIAS_FILE_HDF5 : writes OSIRIS satellite diagnostics in satellite diagnostic HDF5 file + ! + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC CALC_OSIRIS_NO2_FORCE + + ! Module variables + + ! Arrays for diagnostic output + + TYPE FLEX_REAL ! Type to store information for "flexible" arrays. Think of this as a cruddy + INTEGER :: CURRENT_N, MAX_N ! implementation of some of the features of the C++ std::vector container + REAL*8,ALLOCATABLE :: DATA(:) ! This only works in Fortran 2003, would have to use a pointer in Fortran 95 + ENDTYPE FLEX_REAL + + ! arrays to store diagnostic information + REAL*4:: OSIRIS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OSIRIS columns + REAL*4:: OSIRIS_GEOS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem columns + REAL*4:: OSIRIS_NO2_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OSIRIS observation errors + REAL*4:: OSIRIS_BIAS(IIPAR,JJPAR)=0d0 ! Model biases + REAL*4:: OSIRIS_VAR(IIPAR,JJPAR)=0d0 ! Model variances + REAL*4:: OSIRIS_DELTA=0d0 ! temporary storage variable + REAL*4:: OSIRIS_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations in grid box + REAL*4:: OSIRIS_CHISQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + LOGICAL :: FIRST = .TRUE. + TYPE(FLEX_REAL) :: FLEX_LON, FLEX_LAT, FLEX_TIME, FLEX_OSIRIS_NO2, FLEX_GC_NO2 ! flex arrays to store satellite diagnostics sequentially + +CONTAINS + + !-----------------------------------------------------------------------------! + + SUBROUTINE CALC_OSIRIS_NO2_FORCE + + + !! + !! Subroutine CALC_OSIRIS_NO2_FORCE computes the NO2 adjoint forcing and cost function contribution from OSIRIS column data + !! + !! References: + !! + !! Bucsela2013: + !! "A new stratospheric and tropospheric NO2 retrieval algorithm for nadir-viewing satellite instruments: applications to OSIRIS" + !! E.J. Bucsela et.al + !! Atmos. Meas. Tech., 6, 2607-2626, 2013 + !! www.atmos-meas-tech.net/6/2607/2013/ + !! doi:10.5194/amt-6-2607-2013 + !! + !! Chan83 + !! "Algorithms for Computing the Sample Variance: Analysis and Recommendations" + !! Tony F. Chan, Gene H. Golub, Randall J. LeVeque + !! The American Statistician + !! Vol. 37, No. 3 (Aug. 1983), pp. 242-247 + !! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY, GET_YEAR, GET_MONTH + USE DAO_MOD, ONLY : BXHEIGHT, AD, AIRDEN + USE FILE_MOD, ONLY : IOERROR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE TRACER_MOD, ONLY : TCVV, XNUMOLAIR + USE TRACERID_MOD, ONLY : IDTNOX, IDNO2 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : IT_IS_NAN + + + INTEGER :: I,J,L,K,KK,MM,DD,CC + INTEGER :: I_OSIRIS, J_OSIRIS, K_OSIRIS, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: DAY, YEAR, MONTH, MJD_CALC, MJD_INI, MJD_FIN + INTEGER :: UNIT, MAX_OBS_PER_DAY + CHARACTER(255) :: ORBIT_PATH, FILE_ORBIT, ALT_PATH, FILE_ALT + CHARACTER(2) :: I_CHAR, I_CHAR_1, I_CHAR_2 + INTEGER :: IO_ORBIT_STATUS + INTEGER, PARAMETER :: OLMAX = 100 + CHARACTER(LEN=255) :: filename_orbit, dsetname + + REAL*8, ALLOCATABLE :: LON_ORBIT(:), LAT_ORBIT(:), LON_ORBIT2(:) + REAL*8, ALLOCATABLE :: TIME_ORBIT(:) + REAL*8, ALLOCATABLE :: NO2_STRAT(:,:), NO2_STRAT_STD(:), NO2_STRAT2(:) + REAL*8, ALLOCATABLE :: ALT_OSIRIS_NO2(:) + REAL*8 :: TIME_ORBIT_START, TIME_ORBIT_END + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR, MIN_DAY, MAX_DAY + + ! variables for observation operator and adjoint thereof + + REAL*8 :: NO2_STRAT_GC(LLPAR), NO2_STRAT_GC_STD(LLPAR) + REAL*8 :: GC_NO2_NATIVE(LLPAR), NCP(LLPAR), GC_ALT_NO2(IIPAR, JJPAR, LLPAR+1) + REAL*8 :: GC_NO2_COL + REAL*8 :: GC_NO2(OLMAX), DIFF(OLMAX), DIFF_ADJ(OLMAX) + REAL*8 :: OBS_ERROR(OLMAX) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR), ALT_SURF(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(IIPAR,JJPAR) + REAL*8 :: ADJ_FORCING(LLPAR) + REAL*8 :: OSIRIS_NO2_STD(27) + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: SOBS_COST_CONTRIBUTION(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OSIRIS(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IU_FILE, IU_DATA, IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_ALT + + IF ( SECOND ) THEN + FILENAME = 'lat_orb_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 601, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 602, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_gc_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 603, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_obs_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 604, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 605, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 612, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_OSIRIS_NO2_FORCE begins here! + !================================================================= + + IF(FIRST) THEN + + ! initialize flexible arrays + CALL INIT_FLEX_REAL(FLEX_LON) + CALL INIT_FLEX_REAL(FLEX_LAT) + CALL INIT_FLEX_REAL(FLEX_TIME) + CALL INIT_FLEX_REAL(FLEX_OSIRIS_NO2) + CALL INIT_FLEX_REAL(FLEX_GC_NO2) + + FIRST = .FALSE. + + ENDIF + + ! initialize arrays + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + GC_ALT_NO2 = 0d0 + OSIRIS_NO2_STD(1:27) = (/6.0,5.14,4.9,3.91,3.23,3.48,3.64,4.15,4.12,3.85,3.75,3.92,4.67,4.81,4.95,5.18,5.54,6.75,4.08,4.08,3.19,3.19,3.22,2.4,1.58,1.22,10/) + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + SOBS_COST_CONTRIBUTION = 0d0 + SOBS_GC = 0d0 + KK = 0 + !DD = MAX_OBS_PER_DAY + ! Loop through data to find observations + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + MONTH = GET_MONTH() + YEAR = GET_YEAR() + !USE REAL OR FLOOR + MJD_CALC = FLOOR(2-FLOOR(REAL(YEAR/100))+FLOOR(REAL(FLOOR(REAL(YEAR)/100))/4)+REAL(DAY)+365.25*REAL(YEAR+4716)+30.6001*REAL(MONTH+1)-1524.5-2400000.5) + MJD_INI = MJD_CALC - 50337 + MJD_FIN = MJD_INI + 2 + + ORBIT_PATH = '/users/jk/07/xzhang/OSIRIS_NO2/ORBIT_DATA/2009/05/' + ALT_PATH = '/users/jk/07/xzhang/met_field/' + FILE_ALT = '20000101.cn.4x5.dat' + + FILENAME_ALT = TRIM(ALT_PATH) // TRIM(FILE_ALT) + + WRITE(I_CHAR,'(I2.2)') DAY + + CALL SYSTEM("ls "//TRIM(ORBIT_PATH)//"OMPS_L2_200905"//I_CHAR//"* > osiris_file_list"//I_CHAR//".txt") + + OPEN(UNIT = 18, FILE = "/users/jk/07/xzhang/met_field/20000101.cn.4x5.dat", STATUS="old",ACTION="read") + READ(18,*) ALT_SURF + CLOSE(18) + IU_DATA = 20 + IU_FILE = 13 + !PRINT *, "IU_FILE IS INITIALIZED" + CLOSE(IU_FILE) ! ugly... + + OPEN(IU_FILE,FILE="osiris_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + +271 DO + READ(IU_FILE,'(A)',IOSTAT=IO_ORBIT_STATUS) FILE_ORBIT + IF(IO_ORBIT_STATUS < 0) EXIT + WRITE(6,*) ' - READ_OSIRIS_NO2_FILE: reading: ', FILE_ORBIT + IU_DATA = IU_DATA + KK + KK = KK + 1 + OPEN(IU_DATA, FILE=FILE_ORBIT,IOSTAT=IOS) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_DATA, 'osiris:1' ) + + !======================== + ! Read in data blocks + !======================== + ! Needs to be true until end of file + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_DATA, 'osiris:2' ) + READ( IU_DATA, * ) MAX_OBS_PER_DAY + !PRINT *, "MAX_OBS_PER_DAY", MAX_OBS_PER_DAY + MM = 1 + DD = MAX_OBS_PER_DAY + ! Read altitude, ozone and error profiles + ALLOCATE(NO2_STRAT2(OLMAX*MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(NO2_STRAT2(K), K=1,OLMAX*MAX_OBS_PER_DAY) + ALLOCATE(NO2_STRAT(OLMAX,MAX_OBS_PER_DAY)) + NO2_STRAT = RESHAPE(NO2_STRAT2,(/OLMAX,MAX_OBS_PER_DAY/)) + !PRINT *, "NO2_STRAT", NO2_STRAT + + ALLOCATE(ALT_OSIRIS_NO2(OLMAX)) + READ( IU_DATA, * )(ALT_OSIRIS_NO2(K), K=1,OLMAX) + !PRINT *, "ALT_OSI_NO2", ALT_OSIRIS_NO2 + + ALLOCATE(LAT_ORBIT(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(LAT_ORBIT(K), K=1,MAX_OBS_PER_DAY) + + ALLOCATE(LON_ORBIT2(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(LON_ORBIT2(K), K=1,MAX_OBS_PER_DAY) + ALLOCATE(LON_ORBIT(MAX_OBS_PER_DAY)) + LON_ORBIT = MOD(REAL(LON_ORBIT2+180d0),360d0) -180d0 + + ALLOCATE(TIME_ORBIT(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(TIME_ORBIT(K), K=1,MAX_OBS_PER_DAY) + !PRINT *, "TIME_ORBIT", TIME_ORBIT + CLOSE( IU_DATA ) + +289 IF ( IT_IS_NAN(TIME_ORBIT(MM))) THEN + MM = MM + 1 + GO TO 289 + ELSE + !PRINT *, "MM", MM + TIME_ORBIT_START = TIME_ORBIT(MM) + !PRINT *, "TIME_ORBIT_START", TIME_ORBIT_START + ENDIF + +296 IF ( IT_IS_NAN(TIME_ORBIT(DD)) ) THEN + DD = DD - 1 + GO TO 296 + ELSE + !PRINT *, "DD", DD + !PRINT *, "TIME_ORBIT_END", TIME_ORBIT_END + TIME_ORBIT_END = TIME_ORBIT(DD) + ENDIF + + ! check if current hour is in dataset + CALL MJD2UTC(TIME_ORBIT_START,IY,IM,ID,IH,IMIN,SEC) + MIN_HOUR = IH + MIN_DAY = ID + !PRINT *, "TIME_START", IY, IM, ID, IH, IMIN, SEC + CALL MJD2UTC(TIME_ORBIT_END,IY,IM,ID,IH,IMIN,SEC) + MAX_HOUR = IH + MAX_DAY = ID + !PRINT *, "TIME_FINISH", IY, IM, ID, IH, IMIN, SEC + ! go to next dataset if current hour is not contained in dataset + IF ( (GC_HOURMAX_HOUR) .OR. & + (DAYMAX_DAY) ) THEN + DEALLOCATE(TIME_ORBIT) + DEALLOCATE(NO2_STRAT) + DEALLOCATE(NO2_STRAT2) + DEALLOCATE(ALT_OSIRIS_NO2) + DEALLOCATE(LAT_ORBIT) + DEALLOCATE(LON_ORBIT) + DEALLOCATE(LON_ORBIT2) + !ALLOCATE(NO2_STRAT_STD(OLMAX)) + !GO TO 263 + CYCLE + ENDIF + ALLOCATE(NO2_STRAT_STD(OLMAX)) + !PRINT *, "data_dims_orbit", (/DATA_MAX_OBS_PER_DAY,0/) + !! close file + DO J_OSIRIS = 1, OLMAX + IF ( IT_IS_NAN(ALT_OSIRIS_NO2(J_OSIRIS)) ) THEN + NO2_STRAT_STD(J_OSIRIS) = 0d0 + ELSEIF ( ALT_OSIRIS_NO2(J_OSIRIS) < 12 ) THEN + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(1) * 1d8 + ELSEIF (ALT_OSIRIS_NO2(J_OSIRIS) > 36) THEN + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(27) * 1d8 + ELSE + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(J_OSIRIS-11) * 1d8 + ENDIF + ENDDO + + !! loop over data + + DO I_OSIRIS= MM,DD + + IF(TIME_ORBIT(I_OSIRIS)>0d0) THEN ! very basic quality check, most likely not needed anymore + ! Convert TAI93 to UTC + CALL MJD2UTC(TIME_ORBIT(I_OSIRIS),IY,IM,ID,IH,IMIN,SEC) + ! A number of conditions have to be met for OSIRIS NO2 data to actually be assimilated + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + (REAL(LAT_ORBIT(I_OSIRIS),4) < 60d0) .AND. & + (REAL(LAT_ORBIT(I_OSIRIS),4) > -60d0) .AND. & + ( DAY .EQ. id ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(LON_ORBIT(I_OSIRIS),4), REAL(LAT_ORBIT(I_OSIRIS),4)) + + I = IIJJ(1) + J = IIJJ(2) + ! initialize variables & arrays + + GC_NO2_NATIVE = 0d0 + GC_NO2_COL = 0d0 + ! Get GEOS-CHEM NO2 values [#/cm3] + GC_ALT_NO2(I,J,1) = ALT_SURF(I,J)*1d-3 + DO L = 1, LLPAR + GC_ALT_NO2(I,J,L+1) = (SUM(BXHEIGHT(I,J,1:L)) + ALT_SURF(I,J))*1d-3 + IF (ITS_IN_THE_TROP(I,J,L)) THEN + JLOOP=JLOP(I,J,L) + GC_NO2_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDNO2)) + ENDIF + ENDDO + CALL BIN_OSIRIS_NO2(GC_ALT_NO2(I,J,:), ALT_OSIRIS_NO2, GC_NO2_NATIVE(:), GC_NO2, OLMAX, 1) + DIFF_ADJ(:) = 0 + DO J_OSIRIS = 1, OLMAX + L = J_OSIRIS + OBS_ERROR(L) = 2*NO2_STRAT_STD(J_OSIRIS) + !PRINT *, "GC_NO2", GC_NO2(L) + IF( ( ALT_OSIRIS_NO2(J_OSIRIS) < 37d0 ) .AND. & + ( ALT_OSIRIS_NO2(J_OSIRIS) > 6d0 ) .AND. & + ( NO2_STRAT(J_OSIRIS,I_OSIRIS ) > 0d0 ) .AND. & + ( GC_NO2(L) > 0d0 ) ) THEN + DIFF(L) = GC_NO2(L) - NO2_STRAT(J_OSIRIS,I_OSIRIS) + !PRINT *, "GC_NO2", GC_NO2(L) + !PRINT *, "NO2_STRAT", NO2_STRAT(J_OSIRIS,I_OSIRIS) + ELSE + DIFF(L) = 0d0 + ENDIF + !IF (GC_NO2(L) < 50*NO2_STRAT(J_OSIRIS,I_OSIRIS)) THEN + IF (SUPER_OBS) THEN + SOBS_COST_CONTRIBUTION(I,J) = SOBS_COST_CONTRIBUTION(I,J) + 0.5 * (DIFF(L)/OBS_ERROR(L)) ** 2 + !OBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF(L)/(OBS_ERROR(L)**2) * TCVV(IDTNOX) * 1d-6 * XNUMOLAIR * AIRDEN(L,I,J)/AD(I,J,L)*BXHEIGHT(I,J,L)*100d0 + !SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF(L)/(OBS_ERROR(L)**2) + DIFF_ADJ(L) = DIFF(L)/OBS_ERROR(L)**2 + ELSE + !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + DIFF(L)/(OBS_ERROR(L)**2) + !TT_ADJ(I,J,L,IDTNOX) = STT_ADJ(I,J,L,IDTNOX) + DIFF(L)/(OBS_ERROR(L)**2) * TCVV(IDTNOX) * 1d-6 * XNUMOLAIR * AIRDEN(L,I,J)/AD(I,J,L)*BXHEIGHT(I,J,L)*100d0 + COST_FUNC = COST_FUNC + 0.5 * (DIFF(L)/OBS_ERROR(L))**2 + ENDIF + !ENDIF + ENDDO + !PRINT *, "DIFF_ADJ", DIFF_ADJ(:) + CALL BIN_OSIRIS_NO2(GC_ALT_NO2(I,J,:), ALT_OSIRIS_NO2, ADJ_FORCING, DIFF_ADJ, OLMAX, -1) + !PRINT *, "ADJ_FORCING", ADJ_FORCING(:) + DO L = 1, LLPAR + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + ADJ_FORCING(L) + ELSE + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + ADJ_FORCING(L) + ENDIF + ENDDO + + WRITE(601,110) (LAT_ORBIT(I_OSIRIS)) + WRITE(602,110) (LON_ORBIT(I_OSIRIS)) + WRITE(612,110) (DIFF(L), L = LLPAR-1,1,-1) +110 FORMAT(F18.6,1X) + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE(I,J,:) + ! update cost function + IF (SUPER_OBS) THEN + + !SOBS_COST_CONTRIBUTION(I,J) = SOBS_COST_CONTRIBUTION(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ENDIF + ENDIF + ENDIF + ENDDO + !PRINT *, "CHK_STT", CHK_STT(:,:,:,IDNO2) + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + !PRINT *, "SUPER_COST_CONTRIBUTION", SOBS_COST_CONTRIBUTION + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + DO L = 1,LLPAR + IF( (GC_ALT_NO2(I,J,L) < 37d0 ) .AND. ( GC_ALT_NO2(I,J,L) > 6d0 ) ) THEN + !JLOOP = JLOP(I,J,L) + !ELSE + !PRINT *, "STT_ADJ BEF", STT_ADJ(I,J,L,IDNO2) + !TT_ADJ(I,J,L,IDTNOX) = STT_ADJ(I,J,L,IDTNOX) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + IF(ITS_IN_THE_TROP(I,J,L)) THEN + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + !RINT *, "STT_ADJ AFT", STT_ADJ(I,J,L,IDTNOX) + !IF (SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) > 0) THEN + !PRINT *, "STT_ADJ_FORCING", SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + !ENDIF + ENDIF + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + SOBS_COST_CONTRIBUTION(I,J)/SOBS_COUNT(I,J) + !WRITE(104,110) ( GC_STT_ADJ(L), L=LLPAR,1,-1 ) + ENDIF + ENDDO + ENDDO + ENDIF + + !PRINT *, "STT_ADJ AFTER MLS O3", SOBS_ADJ_FORCE + PRINT *, "COST FUNCTION OF OSIRIS NO2", COST_FUNC + + ! deallocate OSIRIS arrays + +483 IF(ALLOCATED(LON_ORBIT)) DEALLOCATE(LON_ORBIT) + IF(ALLOCATED(LON_ORBIT2)) DEALLOCATE(LON_ORBIT2) + IF(ALLOCATED(LAT_ORBIT)) DEALLOCATE(LAT_ORBIT) + IF(ALLOCATED(TIME_ORBIT)) DEALLOCATE(TIME_ORBIT) + IF(ALLOCATED(NO2_STRAT)) DEALLOCATE(NO2_STRAT) + IF(ALLOCATED(NO2_STRAT2)) DEALLOCATE(NO2_STRAT2) + IF(ALLOCATED(NO2_STRAT_STD)) DEALLOCATE(NO2_STRAT_STD) + IF(ALLOCATED(ALT_OSIRIS_NO2)) DEALLOCATE(ALT_OSIRIS_NO2) + !KK = KK + 1 + ENDDO ! loop over OSIRIS files + + CLOSE(IU_FILE) + !IF ( CC < 2 ) THEN + ! CC = CC + 1 + ! GO TO 262 + !PRINT *, "CC is updated to", CC + ! ENDIF + !ENDDO + + END SUBROUTINE CALC_OSIRIS_NO2_FORCE + + !-----------------------------------------------------------------------------! + + SUBROUTINE MJD2UTC(mjd_input,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE MJD2UTC converts MJD time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! http://aa.usno.navy.mil/faq/docs/JD_Formula.php + !! + + IMPLICIT NONE + + REAL*8,INTENT(IN) :: MJD_INPUT + INTEGER,INTENT(OUT) :: IY,IM,ID,IH,IMIN + REAL*8,INTENT(OUT) :: SEC + REAL*8 :: JD,JDF,JDL,JDK,JDH,JDMIN,JDSEC + INTEGER :: JDI,JDJ,JDN + !PRINT *, "MJD_INPUT", MJD_INPUT + JD = MJD_INPUT + 2400001 + JDF = JD - FLOOR(JD) + JDL = FLOOR(JD) + 68569 + JDN = FLOOR(REAL(4*JDL)/146097) + JDL = JDL - FLOOR((REAL(146097*JDN)+3)/4) + JDI = FLOOR(4000*REAL(JDL+1)/1461001) + JDL = JDL - FLOOR(REAL(1461*JDI)/4) + 31 + JDJ = FLOOR(REAL(80*JDL)/2447) + JDK = JDL - FLOOR(REAL(2447*JDJ)/80) + JDL = FLOOR(REAL(JDJ)/11) + JDJ = JDJ +2 - REAL(12*JDL) + JDI = 100*REAL(JDN-49)+JDI+JDL + JDH = REAL(JDF)*24 + IY = JDI + IM = JDJ + ID = JDK + IH = FLOOR(JDH) + JDMIN = (JDH-FLOOR(JDH))*60 + IMIN = FLOOR(JDMIN) + JDSEC = (JDMIN-FLOOR(JDMIN))*60 + SEC = FLOOR(JDSEC) + + RETURN + + END SUBROUTINE MJD2UTC + !-------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_OSIRIS_NO2( GC_EDGE, OBS_MODEL, DATA_MODEL, DATA_OSI, LOSIRIS, FB ) + + !****************************************************************************** + !Based on the code from Monika. (zhe 1/19/11) + !FB = 1 for forward + !FB = -1 for adjoint + !****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: LOSIRIS, NB + REAL*8 :: ALT_MODEL(LLPAR), GC_EDGE(LLPAR+1) + REAL*8 :: DATA_MODEL(LLPAR), DATA_OSI(LOSIRIS), DATA_TEM + REAL*8 :: OBS_MODEL(LOSIRIS) + + !================================================================= + ! BIN_DATA_V4 begins here! + !================================================================= + IF (FB > 0) THEN + + DO L = 1, LOSIRIS + DO LL = 1, LLPAR + IF ( GC_EDGE(LL) >= OBS_MODEL(L) ) THEN + DATA_OSI(L) = DATA_MODEL(LL) + EXIT + ENDIF + ENDDO + ENDDO + !PRINT *, "DATA_MODEL", DATA_MODEL(:) + !PRINT *, "GC_EDGE", GC_EDGE(:) + !PRINT *, "OBS_MODEL", OBS_MODEL(:) + DO L = 1, LOSIRIS-1 + NB = 0 + DATA_TEM = 0 + DO LL = 1, LLPAR + IF ( ( GC_EDGE(LL) >= OBS_MODEL(L)) .and. ( GC_EDGE(LL) < OBS_MODEL(L+1)) ) THEN + !PRINT *, "GC_EDGE", GC_EDGE(LL) + !PRINT *, "OBS_MODEL", OBS_MODEL(L) + DATA_TEM = DATA_TEM + DATA_MODEL(LL) + NB = NB + 1 + ENDIF + ENDDO + IF (NB > 0) DATA_OSI(L) = DATA_TEM / NB + ENDDO + + ELSE + DATA_MODEL(:) = 0 + DO L = 1, LOSIRIS-1 + DO LL = 1, LLPAR + IF ( ( GC_EDGE(LL) >= OBS_MODEL(L)) .and. ( GC_EDGE(LL) < OBS_MODEL(L+1)) ) THEN + DATA_MODEL(LL) = DATA_OSI(L) + !PRINT *, "DATA_MODEL", DATA_MODEL(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_OSIRIS_NO2 +!------------------------------------------------------------------------------------------------- + !mkeller: helper routines for managing flexible arrays + ! reinventing the wheel here, but hey... + + SUBROUTINE INIT_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL + + SUBROUTINE GROW_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:) + ALLOCATE(TEMP_ARRAY(INPUT%MAX_N * 2)) + TEMP_ARRAY(1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL + + SUBROUTINE PUSH_FLEX_REAL(INPUT, NEW_VAL) + + TYPE(FLEX_REAL) :: INPUT + REAL*8 :: NEW_VAL + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(INPUT%CURRENT_N) = NEW_VAL + + END SUBROUTINE PUSH_FLEX_REAL + + SUBROUTINE CLEAR_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL + +END MODULE OSIRIS_NO2_OBS_MOD diff --git a/code/obs_operators/osiris_no2_obs_mod.f90~ b/code/obs_operators/osiris_no2_obs_mod.f90~ new file mode 100644 index 0000000..28da047 --- /dev/null +++ b/code/obs_operators/osiris_no2_obs_mod.f90~ @@ -0,0 +1,637 @@ +MODULE OSIRIS_NO2_OBS_MOD + + ! + ! Module OSIRIS_NO2_OBS contains all subroutines and variables needed to assimilate OSIRIS NO2 tropospheric column data + ! + ! Module Routines: + ! + ! (1) CALC_OSIRIS_NO2_FORCE : calculates adjoint forcing and cost function contribution for OSIRIS tropospheric NO2 columns + ! (2) TAI2UTC : converts TAI93 (seconds since 1.1.1993) to UTC + ! (3) MAKE_OSIRIS_BIAS_FILE_HDF5 : writes OSIRIS satellite diagnostics in satellite diagnostic HDF5 file + ! + + IMPLICIT NONE + +#include "CMN_SIZE" + + PRIVATE + + PUBLIC CALC_OSIRIS_NO2_FORCE + + ! Module variables + + ! Arrays for diagnostic output + + TYPE FLEX_REAL ! Type to store information for "flexible" arrays. Think of this as a cruddy + INTEGER :: CURRENT_N, MAX_N ! implementation of some of the features of the C++ std::vector container + REAL*8,ALLOCATABLE :: DATA(:) ! This only works in Fortran 2003, would have to use a pointer in Fortran 95 + ENDTYPE FLEX_REAL + + ! arrays to store diagnostic information + REAL*4:: OSIRIS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OSIRIS columns + REAL*4:: OSIRIS_GEOS_NO2_MEAN(IIPAR,JJPAR) = 0d0 ! Mean GEOS-Chem columns + REAL*4:: OSIRIS_NO2_ERR_MEAN(IIPAR,JJPAR) = 0d0 ! Mean OSIRIS observation errors + REAL*4:: OSIRIS_BIAS(IIPAR,JJPAR)=0d0 ! Model biases + REAL*4:: OSIRIS_VAR(IIPAR,JJPAR)=0d0 ! Model variances + REAL*4:: OSIRIS_DELTA=0d0 ! temporary storage variable + REAL*4:: OSIRIS_BIAS_COUNT(IIPAR,JJPAR) = 0d0 ! counter for number of observations in grid box + REAL*4:: OSIRIS_CHISQUARED(IIPAR,JJPAR) = 0d0 ! Chi-squared values + LOGICAL :: FIRST = .TRUE. + TYPE(FLEX_REAL) :: FLEX_LON, FLEX_LAT, FLEX_TIME, FLEX_OSIRIS_NO2, FLEX_GC_NO2 ! flex arrays to store satellite diagnostics sequentially + +CONTAINS + + !-----------------------------------------------------------------------------! + + SUBROUTINE CALC_OSIRIS_NO2_FORCE + + + !! + !! Subroutine CALC_OSIRIS_NO2_FORCE computes the NO2 adjoint forcing and cost function contribution from OSIRIS column data + !! + !! References: + !! + !! Bucsela2013: + !! "A new stratospheric and tropospheric NO2 retrieval algorithm for nadir-viewing satellite instruments: applications to OSIRIS" + !! E.J. Bucsela et.al + !! Atmos. Meas. Tech., 6, 2607-2626, 2013 + !! www.atmos-meas-tech.net/6/2607/2013/ + !! doi:10.5194/amt-6-2607-2013 + !! + !! Chan83 + !! "Algorithms for Computing the Sample Variance: Analysis and Recommendations" + !! Tony F. Chan, Gene H. Golub, Randall J. LeVeque + !! The American Statistician + !! Vol. 37, No. 3 (Aug. 1983), pp. 242-247 + !! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY, GET_YEAR, GET_MONTH + USE DAO_MOD, ONLY : BXHEIGHT, AD, AIRDEN + USE FILE_MOD, ONLY : IOERROR + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE TRACER_MOD, ONLY : TCVV, XNUMOLAIR + USE TRACERID_MOD, ONLY : IDTNOX, IDNO2 + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TRACER_MOD, ONlY : XNUMOLAIR + USE DAO_MOD, ONLY : T, AIRDEN + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : IT_IS_NAN + + + INTEGER :: I,J,L,K,KK,MM,DD,CC + INTEGER :: I_OSIRIS, J_OSIRIS, K_OSIRIS, JLOOP + INTEGER :: IIJJ(2) + INTEGER :: DAY, YEAR, MONTH, MJD_CALC, MJD_INI, MJD_FIN + INTEGER :: UNIT, MAX_OBS_PER_DAY + CHARACTER(255) :: ORBIT_PATH, FILE_ORBIT, ALT_PATH, FILE_ALT + CHARACTER(2) :: I_CHAR, I_CHAR_1, I_CHAR_2 + INTEGER :: IO_ORBIT_STATUS + INTEGER, PARAMETER :: OLMAX = 100 + CHARACTER(LEN=255) :: filename_orbit, dsetname + + REAL*8, ALLOCATABLE :: LON_ORBIT(:), LAT_ORBIT(:), LON_ORBIT2(:) + REAL*8, ALLOCATABLE :: TIME_ORBIT(:) + REAL*8, ALLOCATABLE :: NO2_STRAT(:,:), NO2_STRAT_STD(:), NO2_STRAT2(:) + REAL*8, ALLOCATABLE :: ALT_OSIRIS_NO2(:) + REAL*8 :: TIME_ORBIT_START, TIME_ORBIT_END + + ! variables for time unit conversion + REAL*8 :: tai93 + INTEGER :: iy,im,id,ih,imin + REAL*8 :: sec + INTEGER :: GC_HOUR, MIN_HOUR, MAX_HOUR, MIN_DAY, MAX_DAY + + ! variables for observation operator and adjoint thereof + + REAL*8 :: NO2_STRAT_GC(LLPAR), NO2_STRAT_GC_STD(LLPAR) + REAL*8 :: GC_NO2_NATIVE(LLPAR), NCP(LLPAR), GC_ALT_NO2(IIPAR, JJPAR, LLPAR+1) + REAL*8 :: GC_NO2_COL + REAL*8 :: GC_NO2(OLMAX), DIFF(OLMAX), DIFF_ADJ(OLMAX) + REAL*8 :: OBS_ERROR(OLMAX) + REAL*8 :: COUNT_GRID(IIPAR,JJPAR), ALT_SURF(IIPAR,JJPAR) + REAL*8 :: COST_CONTRIB(IIPAR,JJPAR) + REAL*8 :: ADJ_FORCING(LLPAR) + REAL*8 :: OSIRIS_NO2_STD(27) + + ! arrays needed for superobservations + LOGICAL :: SUPER_OBS = .TRUE. ! do super observations? + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) ! super observation count + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) ! super observation adjoint forcing + REAL*8 :: SOBS_COST_CONTRIBUTION(IIPAR,JJPAR) ! super observation cost function contribution + REAL*8 :: SOBS_GC(IIPAR,JJPAR) + REAL*8 :: SOBS_OSIRIS(IIPAR,JJPAR) + REAL*8 :: SOBS_BIAS(IIPAR,JJPAR) + REAL*8 :: SOBS_CHISQUARED(IIPAR,JJPAR) + + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IU_FILE, IU_DATA, IOS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_ALT + + IF ( SECOND ) THEN + FILENAME = 'lat_orb_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 601, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lon_orb_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 602, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_gc_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 603, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'amf_obs_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 604, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 605, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 612, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + + !================================================================= + ! CALC_OSIRIS_NO2_FORCE begins here! + !================================================================= + + IF(FIRST) THEN + + ! initialize flexible arrays + CALL INIT_FLEX_REAL(FLEX_LON) + CALL INIT_FLEX_REAL(FLEX_LAT) + CALL INIT_FLEX_REAL(FLEX_TIME) + CALL INIT_FLEX_REAL(FLEX_OSIRIS_NO2) + CALL INIT_FLEX_REAL(FLEX_GC_NO2) + + FIRST = .FALSE. + + ENDIF + + ! initialize arrays + COUNT_GRID = 0d0 + COST_CONTRIB = 0d0 + GC_NO2 = 0d0 + GC_NO2_COL = 0d0 + GC_ALT_NO2 = 0d0 + OSIRIS_NO2_STD(1:27) = (/6.0,5.14,4.9,3.91,3.23,3.48,3.64,4.15,4.12,3.85,3.75,3.92,4.67,4.81,4.95,5.18,5.54,6.75,4.08,4.08,3.19,3.19,3.22,2.4,1.58,1.22,10/) + SOBS_COUNT = 0d0 + SOBS_ADJ_FORCE = 0d0 + SOBS_COST_CONTRIBUTION = 0d0 + SOBS_GC = 0d0 + KK = 0 + !DD = MAX_OBS_PER_DAY + ! Loop through data to find observations + !PRINT *, "ID2C(IDNO2)", ID2C(IDNO2) + GC_HOUR = GET_HOUR() + DAY = GET_DAY() + MONTH = GET_MONTH() + YEAR = GET_YEAR() + !USE REAL OR FLOOR + MJD_CALC = FLOOR(2-FLOOR(REAL(YEAR/100))+FLOOR(REAL(FLOOR(REAL(YEAR)/100))/4)+REAL(DAY)+365.25*REAL(YEAR+4716)+30.6001*REAL(MONTH+1)-1524.5-2400000.5) + MJD_INI = MJD_CALC - 50337 + MJD_FIN = MJD_INI + 2 + + ORBIT_PATH = '/users/jk/07/xzhang/OSIRIS_NO2/ORBIT_DATA/2009/05/' + ALT_PATH = '/users/jk/07/xzhang/met_field/' + FILE_ALT = '20000101.cn.4x5.dat' + + FILENAME_ALT = TRIM(ALT_PATH) // TRIM(FILE_ALT) + + WRITE(I_CHAR,'(I2.2)') DAY + + CALL SYSTEM("ls "//TRIM(ORBIT_PATH)//"OMPS_L2_200905"//I_CHAR//"* > osiris_file_list"//I_CHAR//".txt") + + OPEN(UNIT = 18, FILE = "/users/jk/07/xzhang/met_field/20000101.cn.4x5.dat", STATUS="old",ACTION="read") + READ(18,*) ALT_SURF + CLOSE(18) + IU_DATA = 20 + IU_FILE = 13 + !PRINT *, "IU_FILE IS INITIALIZED" + CLOSE(IU_FILE) ! ugly... + + OPEN(IU_FILE,FILE="osiris_file_list"//I_CHAR//".txt",ACTION="read",ACCESS="sequential",FORM="FORMATTED") + +271 DO + READ(IU_FILE,'(A)',IOSTAT=IO_ORBIT_STATUS) FILE_ORBIT + IF(IO_ORBIT_STATUS < 0) EXIT + WRITE(6,*) ' - READ_OSIRIS_NO2_FILE: reading: ', FILE_ORBIT + IU_DATA = IU_DATA + KK + KK = KK + 1 + OPEN(IU_DATA, FILE=FILE_ORBIT,IOSTAT=IOS) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_DATA, 'osiris:1' ) + + !======================== + ! Read in data blocks + !======================== + ! Needs to be true until end of file + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_DATA, 'osiris:2' ) + READ( IU_DATA, * ) MAX_OBS_PER_DAY + !PRINT *, "MAX_OBS_PER_DAY", MAX_OBS_PER_DAY + MM = 1 + DD = MAX_OBS_PER_DAY + ! Read altitude, ozone and error profiles + ALLOCATE(NO2_STRAT2(OLMAX*MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(NO2_STRAT2(K), K=1,OLMAX*MAX_OBS_PER_DAY) + ALLOCATE(NO2_STRAT(OLMAX,MAX_OBS_PER_DAY)) + NO2_STRAT = RESHAPE(NO2_STRAT2,(/OLMAX,MAX_OBS_PER_DAY/)) + !PRINT *, "NO2_STRAT", NO2_STRAT + + ALLOCATE(ALT_OSIRIS_NO2(OLMAX)) + READ( IU_DATA, * )(ALT_OSIRIS_NO2(K), K=1,OLMAX) + !PRINT *, "ALT_OSI_NO2", ALT_OSIRIS_NO2 + + ALLOCATE(LAT_ORBIT(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(LAT_ORBIT(K), K=1,MAX_OBS_PER_DAY) + + ALLOCATE(LON_ORBIT2(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(LON_ORBIT2(K), K=1,MAX_OBS_PER_DAY) + ALLOCATE(LON_ORBIT(MAX_OBS_PER_DAY)) + LON_ORBIT = MOD(REAL(LON_ORBIT2+180d0),360d0) -180d0 + + ALLOCATE(TIME_ORBIT(MAX_OBS_PER_DAY)) + READ( IU_DATA, * )(TIME_ORBIT(K), K=1,MAX_OBS_PER_DAY) + !PRINT *, "TIME_ORBIT", TIME_ORBIT + CLOSE( IU_DATA ) + +289 IF ( IT_IS_NAN(TIME_ORBIT(MM))) THEN + MM = MM + 1 + GO TO 289 + ELSE + !PRINT *, "MM", MM + TIME_ORBIT_START = TIME_ORBIT(MM) + !PRINT *, "TIME_ORBIT_START", TIME_ORBIT_START + ENDIF + +296 IF ( IT_IS_NAN(TIME_ORBIT(DD)) ) THEN + DD = DD - 1 + GO TO 296 + ELSE + !PRINT *, "DD", DD + !PRINT *, "TIME_ORBIT_END", TIME_ORBIT_END + TIME_ORBIT_END = TIME_ORBIT(DD) + ENDIF + + ! check if current hour is in dataset + CALL MJD2UTC(TIME_ORBIT_START,IY,IM,ID,IH,IMIN,SEC) + MIN_HOUR = IH + MIN_DAY = ID + !PRINT *, "TIME_START", IY, IM, ID, IH, IMIN, SEC + CALL MJD2UTC(TIME_ORBIT_END,IY,IM,ID,IH,IMIN,SEC) + MAX_HOUR = IH + MAX_DAY = ID + !PRINT *, "TIME_FINISH", IY, IM, ID, IH, IMIN, SEC + ! go to next dataset if current hour is not contained in dataset + IF ( (GC_HOURMAX_HOUR) .OR. & + (DAYMAX_DAY) ) THEN + DEALLOCATE(TIME_ORBIT) + DEALLOCATE(NO2_STRAT) + DEALLOCATE(NO2_STRAT2) + DEALLOCATE(ALT_OSIRIS_NO2) + DEALLOCATE(LAT_ORBIT) + DEALLOCATE(LON_ORBIT) + DEALLOCATE(LON_ORBIT2) + !ALLOCATE(NO2_STRAT_STD(OLMAX)) + !GO TO 263 + CYCLE + ENDIF + ALLOCATE(NO2_STRAT_STD(OLMAX)) + !PRINT *, "data_dims_orbit", (/DATA_MAX_OBS_PER_DAY,0/) + !! close file + DO J_OSIRIS = 1, OLMAX + IF ( IT_IS_NAN(ALT_OSIRIS_NO2(J_OSIRIS)) ) THEN + NO2_STRAT_STD(J_OSIRIS) = 0d0 + ELSEIF ( ALT_OSIRIS_NO2(J_OSIRIS) < 12 ) THEN + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(1) * 1d8 + ELSEIF (ALT_OSIRIS_NO2(J_OSIRIS) > 36) THEN + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(27) * 1d8 + ELSE + NO2_STRAT_STD(J_OSIRIS) = OSIRIS_NO2_STD(J_OSIRIS-11) * 1d8 + ENDIF + ENDDO + + !! loop over data + + DO I_OSIRIS= MM,DD + + IF(TIME_ORBIT(I_OSIRIS)>0d0) THEN ! very basic quality check, most likely not needed anymore + ! Convert TAI93 to UTC + CALL MJD2UTC(TIME_ORBIT(I_OSIRIS),IY,IM,ID,IH,IMIN,SEC) + ! A number of conditions have to be met for OSIRIS NO2 data to actually be assimilated + + IF ( ( GC_HOUR .EQ. ih ) .AND. & + (REAL(LAT_ORBIT(I_OSIRIS),4) < 60d0) .AND. & + (REAL(LAT_ORBIT(I_OSIRIS),4) > -60d0) .AND. & + ( DAY .EQ. id ) ) THEN + + ! Get model grid coordinate indices that correspond to the observation + IIJJ = GET_IJ(REAL(LON_ORBIT(I_OSIRIS),4), REAL(LAT_ORBIT(I_OSIRIS),4)) + + I = IIJJ(1) + J = IIJJ(2) + ! initialize variables & arrays + + GC_NO2_NATIVE = 0d0 + GC_NO2_COL = 0d0 + ! Get GEOS-CHEM NO2 values [#/cm3] + GC_ALT_NO2(I,J,1) = ALT_SURF(I,J)*1d-3 + DO L = 1, LLPAR + GC_ALT_NO2(I,J,L+1) = (SUM(BXHEIGHT(I,J,1:L)) + ALT_SURF(I,J))*1d-3 + IF (ITS_IN_THE_TROP(I,J,L)) THEN + JLOOP=JLOP(I,J,L) + GC_NO2_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDNO2)) + ENDIF + ENDDO + CALL BIN_OSIRIS_NO2(GC_ALT_NO2(I,J,:), ALT_OSIRIS_NO2, GC_NO2_NATIVE(:), GC_NO2, OLMAX, 1) + DIFF_ADJ(:) = 0 + DO J_OSIRIS = 1, OLMAX + L = J_OSIRIS + OBS_ERROR(L) = NO2_STRAT_STD(J_OSIRIS) + !PRINT *, "GC_NO2", GC_NO2(L) + IF( ( ALT_OSIRIS_NO2(J_OSIRIS) < 37d0 ) .AND. & + ( ALT_OSIRIS_NO2(J_OSIRIS) > 6d0 ) .AND. & + ( NO2_STRAT(J_OSIRIS,I_OSIRIS ) > 0d0 ) .AND. & + ( GC_NO2(L) > 0d0 ) ) THEN + DIFF(L) = GC_NO2(L) - NO2_STRAT(J_OSIRIS,I_OSIRIS) + !PRINT *, "GC_NO2", GC_NO2(L) + !PRINT *, "NO2_STRAT", NO2_STRAT(J_OSIRIS,I_OSIRIS) + ELSE + DIFF(L) = 0d0 + ENDIF + !IF (GC_NO2(L) < 50*NO2_STRAT(J_OSIRIS,I_OSIRIS)) THEN + IF (SUPER_OBS) THEN + SOBS_COST_CONTRIBUTION(I,J) = SOBS_COST_CONTRIBUTION(I,J) + 0.5 * (DIFF(L)/OBS_ERROR(L)) ** 2 + !OBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF(L)/(OBS_ERROR(L)**2) * TCVV(IDTNOX) * 1d-6 * XNUMOLAIR * AIRDEN(L,I,J)/AD(I,J,L)*BXHEIGHT(I,J,L)*100d0 + !SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + DIFF(L)/(OBS_ERROR(L)**2) + DIFF_ADJ(L) = DIFF(L)/OBS_ERROR(L)**2 + ELSE + !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + DIFF(L)/(OBS_ERROR(L)**2) + !TT_ADJ(I,J,L,IDTNOX) = STT_ADJ(I,J,L,IDTNOX) + DIFF(L)/(OBS_ERROR(L)**2) * TCVV(IDTNOX) * 1d-6 * XNUMOLAIR * AIRDEN(L,I,J)/AD(I,J,L)*BXHEIGHT(I,J,L)*100d0 + COST_FUNC = COST_FUNC + 0.5 * (DIFF(L)/OBS_ERROR(L))**2 + ENDIF + !ENDIF + ENDDO + !PRINT *, "DIFF_ADJ", DIFF_ADJ(:) + CALL BIN_OSIRIS_NO2(GC_ALT_NO2(I,J,:), ALT_OSIRIS_NO2, ADJ_FORCING, DIFF_ADJ, OLMAX, -1) + !PRINT *, "ADJ_FORCING", ADJ_FORCING(:) + DO L = 1, LLPAR + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + ADJ_FORCING(L) + ELSE + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + ADJ_FORCING(L) + ENDIF + ENDDO + + WRITE(601,110) (LAT_ORBIT(I_OSIRIS)) + WRITE(602,110) (LON_ORBIT(I_OSIRIS)) + WRITE(612,110) (DIFF(L), L = LLPAR-1,1,-1) +110 FORMAT(F18.6,1X) + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE(I,J,:) + ! update cost function + IF (SUPER_OBS) THEN + + !SOBS_COST_CONTRIBUTION(I,J) = SOBS_COST_CONTRIBUTION(I,J) + 0.5 * (DIFF/OBS_ERROR)**2 + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ENDIF + ENDIF + ENDIF + ENDDO + !PRINT *, "CHK_STT", CHK_STT(:,:,:,IDNO2) + !PRINT *, "SUPER_OBS_FORCE", SOBS_ADJ_FORCE + !PRINT *, "SUPER_COST_CONTRIBUTION", SOBS_COST_CONTRIBUTION + + IF (SUPER_OBS) THEN + + DO J = 1,JJPAR + DO I = 1, IIPAR + + IF(SOBS_COUNT(I,J) > 0d0) THEN + DO L = 1,LLPAR + IF( (GC_ALT_NO2(I,J,L) < 37d0 ) .AND. ( GC_ALT_NO2(I,J,L) > 6d0 ) ) THEN + !JLOOP = JLOP(I,J,L) + !ELSE + !PRINT *, "STT_ADJ BEF", STT_ADJ(I,J,L,IDNO2) + !TT_ADJ(I,J,L,IDTNOX) = STT_ADJ(I,J,L,IDTNOX) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + IF(ITS_IN_THE_TROP(I,J,L)) THEN + JLOOP = JLOP(I,J,L) + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) = CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDNO2)) + SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + !RINT *, "STT_ADJ AFT", STT_ADJ(I,J,L,IDTNOX) + !IF (SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) > 0) THEN + !PRINT *, "STT_ADJ_FORCING", SOBS_ADJ_FORCE(I,J,L)/SOBS_COUNT(I,J) + !ENDIF + ENDIF + ENDIF + ENDDO + + COST_FUNC = COST_FUNC + SOBS_COST_CONTRIBUTION(I,J)/SOBS_COUNT(I,J) + !WRITE(104,110) ( GC_STT_ADJ(L), L=LLPAR,1,-1 ) + ENDIF + ENDDO + ENDDO + ENDIF + + !PRINT *, "STT_ADJ AFTER MLS O3", SOBS_ADJ_FORCE + PRINT *, "COST FUNCTION OF OSIRIS NO2", COST_FUNC + + ! deallocate OSIRIS arrays + +483 IF(ALLOCATED(LON_ORBIT)) DEALLOCATE(LON_ORBIT) + IF(ALLOCATED(LON_ORBIT2)) DEALLOCATE(LON_ORBIT2) + IF(ALLOCATED(LAT_ORBIT)) DEALLOCATE(LAT_ORBIT) + IF(ALLOCATED(TIME_ORBIT)) DEALLOCATE(TIME_ORBIT) + IF(ALLOCATED(NO2_STRAT)) DEALLOCATE(NO2_STRAT) + IF(ALLOCATED(NO2_STRAT2)) DEALLOCATE(NO2_STRAT2) + IF(ALLOCATED(NO2_STRAT_STD)) DEALLOCATE(NO2_STRAT_STD) + IF(ALLOCATED(ALT_OSIRIS_NO2)) DEALLOCATE(ALT_OSIRIS_NO2) + !KK = KK + 1 + ENDDO ! loop over OSIRIS files + + CLOSE(IU_FILE) + !IF ( CC < 2 ) THEN + ! CC = CC + 1 + ! GO TO 262 + !PRINT *, "CC is updated to", CC + ! ENDIF + !ENDDO + + END SUBROUTINE CALC_OSIRIS_NO2_FORCE + + !-----------------------------------------------------------------------------! + + SUBROUTINE MJD2UTC(mjd_input,iy,im,id,ih,imin,sec) + + !! + !! SUBROUTINE MJD2UTC converts MJD time (seconds since 1.1.1993) to UTC + !! + !! adapted from + !! http://aa.usno.navy.mil/faq/docs/JD_Formula.php + !! + + IMPLICIT NONE + + REAL*8,INTENT(IN) :: MJD_INPUT + INTEGER,INTENT(OUT) :: IY,IM,ID,IH,IMIN + REAL*8,INTENT(OUT) :: SEC + REAL*8 :: JD,JDF,JDL,JDK,JDH,JDMIN,JDSEC + INTEGER :: JDI,JDJ,JDN + !PRINT *, "MJD_INPUT", MJD_INPUT + JD = MJD_INPUT + 2400001 + JDF = JD - FLOOR(JD) + JDL = FLOOR(JD) + 68569 + JDN = FLOOR(REAL(4*JDL)/146097) + JDL = JDL - FLOOR((REAL(146097*JDN)+3)/4) + JDI = FLOOR(4000*REAL(JDL+1)/1461001) + JDL = JDL - FLOOR(REAL(1461*JDI)/4) + 31 + JDJ = FLOOR(REAL(80*JDL)/2447) + JDK = JDL - FLOOR(REAL(2447*JDJ)/80) + JDL = FLOOR(REAL(JDJ)/11) + JDJ = JDJ +2 - REAL(12*JDL) + JDI = 100*REAL(JDN-49)+JDI+JDL + JDH = REAL(JDF)*24 + IY = JDI + IM = JDJ + ID = JDK + IH = FLOOR(JDH) + JDMIN = (JDH-FLOOR(JDH))*60 + IMIN = FLOOR(JDMIN) + JDSEC = (JDMIN-FLOOR(JDMIN))*60 + SEC = FLOOR(JDSEC) + + RETURN + + END SUBROUTINE MJD2UTC + !-------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------ + + SUBROUTINE BIN_OSIRIS_NO2( GC_EDGE, OBS_MODEL, DATA_MODEL, DATA_OSI, LOSIRIS, FB ) + + !****************************************************************************** + !Based on the code from Monika. (zhe 1/19/11) + !FB = 1 for forward + !FB = -1 for adjoint + !****************************************************************************** + + INTEGER :: L, LL, FB + INTEGER :: LOSIRIS, NB + REAL*8 :: ALT_MODEL(LLPAR), GC_EDGE(LLPAR+1) + REAL*8 :: DATA_MODEL(LLPAR), DATA_OSI(LOSIRIS), DATA_TEM + REAL*8 :: OBS_MODEL(LOSIRIS) + + !================================================================= + ! BIN_DATA_V4 begins here! + !================================================================= + IF (FB > 0) THEN + + DO L = 1, LOSIRIS + DO LL = 1, LLPAR + IF ( GC_EDGE(LL) >= OBS_MODEL(L) ) THEN + DATA_OSI(L) = DATA_MODEL(LL) + EXIT + ENDIF + ENDDO + ENDDO + !PRINT *, "DATA_MODEL", DATA_MODEL(:) + !PRINT *, "GC_EDGE", GC_EDGE(:) + !PRINT *, "OBS_MODEL", OBS_MODEL(:) + DO L = 1, LOSIRIS-1 + NB = 0 + DATA_TEM = 0 + DO LL = 1, LLPAR + IF ( ( GC_EDGE(LL) >= OBS_MODEL(L)) .and. ( GC_EDGE(LL) < OBS_MODEL(L+1)) ) THEN + !PRINT *, "GC_EDGE", GC_EDGE(LL) + !PRINT *, "OBS_MODEL", OBS_MODEL(L) + DATA_TEM = DATA_TEM + DATA_MODEL(LL) + NB = NB + 1 + ENDIF + ENDDO + IF (NB > 0) DATA_OSI(L) = DATA_TEM / NB + ENDDO + + ELSE + DATA_MODEL(:) = 0 + DO L = 1, LOSIRIS-1 + DO LL = 1, LLPAR + IF ( ( GC_EDGE(LL) >= OBS_MODEL(L)) .and. ( GC_EDGE(LL) < OBS_MODEL(L+1)) ) THEN + DATA_MODEL(LL) = DATA_OSI(L) + !PRINT *, "DATA_MODEL", DATA_MODEL(LL) + ENDIF + ENDDO + ENDDO + + ENDIF + + + ! Return to calling program + END SUBROUTINE BIN_OSIRIS_NO2 +!------------------------------------------------------------------------------------------------- + !mkeller: helper routines for managing flexible arrays + ! reinventing the wheel here, but hey... + + SUBROUTINE INIT_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL + + SUBROUTINE GROW_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:) + ALLOCATE(TEMP_ARRAY(INPUT%MAX_N * 2)) + TEMP_ARRAY(1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL + + SUBROUTINE PUSH_FLEX_REAL(INPUT, NEW_VAL) + + TYPE(FLEX_REAL) :: INPUT + REAL*8 :: NEW_VAL + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(INPUT%CURRENT_N) = NEW_VAL + + END SUBROUTINE PUSH_FLEX_REAL + + SUBROUTINE CLEAR_FLEX_REAL(INPUT) + + TYPE(FLEX_REAL) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL + +END MODULE OSIRIS_NO2_OBS_MOD diff --git a/code/obs_operators/osiris_obs_mod.f90 b/code/obs_operators/osiris_obs_mod.f90 new file mode 100644 index 0000000..29e56e2 --- /dev/null +++ b/code/obs_operators/osiris_obs_mod.f90 @@ -0,0 +1,666 @@ +! $Id: osiris_obs_mod.f,v 1.0 2012/02/23 06:47:07 twalker Exp $ +MODULE OSIRIS_OBS_MOD + +!****************************************************************************** +! Module OSIRIS_OBS_MOD contains subroutines necessary to +! 1. Read OSIRIS (ASCII) file with O3 observations, preprocessed onto model grid +! 2. Determine when OSIRIS O3 obs are available +! 3. Compute adjoint forcing in model space +! +! Module Variables: +! ============================================================================ +! (1 ) OSIRIS_DATA : OSIRIS data pre-averaged onto 4x5 grid +! (2 ) ADJ_FORCE_OSIRIS : Adjoint forcing +! (3 ) LOCATION_DATA : Array of locations and times of observations +! (4 ) FILEDATE : Date associated with file currently read +! (5 ) COUNT_TOTAL : Number of observations +! (6 ) OSIRIS_ERR : OSIRIS error values pre-averaged onto 4x5 grid +! +! Module Routines: +! ============================================================================ +! (1 ) READ_OSIRIS_FILE : Read OSIRIS ASCII file +! (2 ) ITS_TIME_FOR_OSIRIS_OBS : Checks model time +! (3 ) CALC_OSIRIS_FORCE : Calculates cost fnc and ADJ_STT increments +! (4 ) INIT_OSIRIS : Allocates memory of arrays +! (5 ) CLEANUP_OSIRIS : Deallocates memory of arrays +! (6 ) IS_OSIRIS_NONZERO : Determines if OSIRIS observed a grid +! +! ============================================================================ +! NOTES: +! (1 ) Based on obs operators implemented in v8 adjoint. (tww, 20120223) +! +!****************************************************************************** + + IMPLICIT NONE + +#include "CMN_SIZE" ! Size parameters + + ! Everything PRIVATE unless specified otherwise + ! PRIVATE module variables + ! PRIVATE module routines + PRIVATE + + PUBLIC :: READ_OSIRIS_FILE + PUBLIC :: ITS_TIME_FOR_OSIRIS_OBS + PUBLIC :: CALC_OSIRIS_FORCE + PUBLIC :: COUNT_TOTAL + PUBLIC :: IS_OSIRIS_NONZERO + PUBLIC :: CALC_GC_O3 + + REAL*8, ALLOCATABLE :: OSIRIS_DATA(:,:) + REAL*8, ALLOCATABLE :: OSIRIS_ERR(:,:) + REAL*8, ALLOCATABLE :: ADJ_FORCE_OSIRIS(:,:,:) + INTEGER, ALLOCATABLE :: LOCATION_DATA(:,:) + INTEGER, ALLOCATABLE :: TIME_DATA(:) + + INTEGER :: FILEDATE + INTEGER :: NOCC + REAL*8 :: COUNT_TOTAL + INTEGER, PARAMETER :: MAX_OBS_PER_DAY=1000 + +CONTAINS + + +!---------------------------------------------------------------------- + + SUBROUTINE READ_OSIRIS_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_OSIRIS_FILE reads an ASCII file containing OSIRIS data +! for the given day. Data are already averaged onto 4x5 grid, but are given +! every km altitude from 0.5km to 64.5km. (tww, 20120223) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : Hour-Min-Sec +! + + USE DAO_MOD, ONLY : BXHEIGHT + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + +#include "CMN_SIZE" ! size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + CHARACTER(LEN=255) :: DIR_OSIRIS + CHARACTER(LEN=255) :: DIR_MONTH_OSIRIS + CHARACTER(LEN=255) :: FILENAME_OSIRIS + CHARACTER(LEN=255) :: FILENAME + + CHARACTER(LEN=*), PARAMETER :: FMT1 = "(I8,I5,I5,I5,F8.2,F8.2,F8.2,I9)" + INTEGER, PARAMETER :: OSIRIS_LVL=65 + + REAL*8 :: TEMPALT(OSIRIS_LVL) + REAL*8 :: TEMPO3DATA(OSIRIS_LVL) + REAL*8 :: TEMPO3ERR(OSIRIS_LVL) + REAL*8 :: TEMPLAT, TEMPLON, TEMPH, Z1, Z2 + INTEGER :: IU_FILE, IOS + INTEGER :: NOBS, I, J, L, K + INTEGER :: OCCID, OLMAX, LATIND, LONIND + INTEGER :: TEMPYMD + INTEGER :: NDAT + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=255) :: FILENAME_DIAG + + + !================================================================= + ! READ_OSIRIS_FILE begins here! + !================================================================= + + !============================= + ! FIRST CLEANUP IF NECESSARY: + !============================= + CALL CLEANUP_OSIRIS + CALL INIT_OSIRIS + + IF ( FIRST ) THEN + COUNT_TOTAL = 0 + + FILENAME_DIAG = 'lat_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 405, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME_DIAG = 'lon_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 406, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FIRST = .FALSE. + ENDIF + + !======================== + ! FILENAME + !========================= + + DIR_OSIRIS = '/users/jk/15/xzhang/OSIRIS_O3/' + DIR_MONTH_OSIRIS = '/YYYY/MM/' + FILENAME_OSIRIS = TRIM( 'OSIRIS_507_4x5_YYYYMMDD_O3.data' ) + ! FILENAME_OSIRIS = TRIM( 'osiristestfile_YYYYMMDD.data' ) + IU_FILE = 15 + ! EXPAND_DATE replaces tokens like 'YYYY' with the year + CALL EXPAND_DATE( DIR_MONTH_OSIRIS, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OSIRIS, YYYYMMDD, 9999 ) + FILENAME = TRIM( DIR_OSIRIS ) // TRIM(DIR_MONTH_OSIRIS) // FILENAME_OSIRIS + + WRITE(6,*) ' - READ_OSIRIS_FILE: reading: ', FILENAME + + NOCC = 0 + + ! Open file + OPEN( IU_FILE, FILE=FILENAME, IOSTAT=IOS ) + IF ( IOS == 0 ) RETURN + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:1' ) + + !======================== + ! Read in data blocks + !======================== + ! Needs to be true until end of file + DO I = 1, MAX_OBS_PER_DAY + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:2' ) + + ! Read meta data line (OCCID, RETLVLS, LONIND, + ! LATIND, LON, LAT, HH, YMD) + READ( IU_FILE, FMT1, IOSTAT=IOS) OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:3' ) + + !DEBUG, tww + !print*, 'METADATA is: ', OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + LOCATION_DATA(I,1) = LONIND + LOCATION_DATA(I,2) = LATIND + TIME_DATA(I) = FLOOR(TEMPH)*10000d0 + + ! Read altitude, ozone and error profiles + READ( IU_FILE, * )(TEMPALT(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3DATA(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3ERR(K), K=1,OLMAX) + + ! OSIRIS data comes every km + ! Compute average of data on each GEOS-Chem vertical level + Z1 = 0d0 + Z2 = 0d0 + DO L = 1, LLPAR + Z1 = Z2 + Z2 = Z1 + BXHEIGHT(LONIND,LATIND,L)/1000d0 + NDAT = 0 + DO K = 1, OSIRIS_LVL + IF (TEMPALT(K) > Z1 .AND. TEMPALT(K) <=Z2) THEN + IF (TEMPO3DATA(K)>0d0) THEN + OSIRIS_DATA( I, L ) = OSIRIS_DATA( I, L ) + TEMPO3DATA( K ) + OSIRIS_ERR( I, L ) = OSIRIS_ERR( I, L ) + TEMPO3ERR( K ) ** 2 + NDAT = NDAT + 1 + ENDIF + ELSEIF (TEMPALT(K) > Z2) THEN + EXIT + ENDIF + ENDDO + IF (NDAT>0) THEN + OSIRIS_DATA(I,L) = OSIRIS_DATA(I,L)/NDAT + OSIRIS_ERR(I,L) = SQRT(OSIRIS_ERR(I,L))/NDAT + ENDIF + ENDDO + + NOCC = NOCC + 1 + !debug, tww + !print*, 'o3data read: ', TEMPO3DATA + !print*, 'o3err read: ', TEMPO3ERR + WRITE(405,118) ( TEMPLAT ) + WRITE(406,118) ( TEMPLON ) +118 FORMAT(F18.6,1X) + ENDDO + + FILEDATE = TEMPYMD !- 10000 + + ! Close file + CLOSE( IU_FILE ) + + ! DEBUG, tww + !print*, 'FINISHED READING OSIRIS FILE' + !print*, 'NOCC = ', NOCC + !print*, 'FILEDATE = ', FILEDATE + !print*, 'LOCATIONS = ', LOCATION_DATA + !print*, 'TIMES = ', TIME_DATA + !print*, 'OSIRIS_DATA = ', OSIRIS_DATA(1:3,:) + !print*, 'OSIRIS_ERR = ', OSIRIS_ERR(1:3,:) + + END SUBROUTINE READ_OSIRIS_FILE + + +!---------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_OSIRIS_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_OSIRIS_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day). (tww, 20120223) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + INTEGER :: N + + !================================================================= + ! ITS_TIME_FOR_OSIRIS_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + ! Observation times on this day are stored in TIME_DATA + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + ! DEBUG + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found at: ',N + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found: ', GET_NHMS() + FLAG = .TRUE. + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', FILEDATE + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION ITS_TIME_FOR_OSIRIS_OBS + + +!---------------------------------------------------------------------- + + FUNCTION IS_OSIRIS_NONZERO( I,J,L ) RESULT ( FLAG ) + +!****************************************************************************** +! Function IS_OSIRIS_NONZERO returns TRUE if there are observations +! available for particular location. (tww, 20120229) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + ! Arguments + INTEGER :: I, J, L + + INTEGER :: N + + !================================================================= + ! IS_OSIRIS_NONZERO begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + IF ( ( LOCATION_DATA(N,1)==I ) .AND. & + ( LOCATION_DATA(N,2)==J ) .AND. & + ( OSIRIS_DATA(N,L) > 0 )) THEN + WRITE(6,*) 'IS_OSIRIS_NONZERO - yes, at: ', I, J, L + FLAG = .TRUE. + ENDIF + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', FILEDATE + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION IS_OSIRIS_NONZERO + + +!---------------------------------------------------------------------- + + SUBROUTINE CALC_OSIRIS_FORCE( COST_FUNC ) + +!****************************************************************************** +! Subroutine CALC_OSIRIS_FORCE (tww, 20120223) +! + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE TIME_MOD, ONLY : GET_NHMS + USE TRACERID_MOD, ONLY : IDTOX + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Parameters + REAL*8, PARAMETER :: ADJ_TCVVOX = 28.97d0/48.d0 + + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: GC_PRES(LLPAR), DIFF(LLPAR) + REAL*8 :: OBS_ERRCOV(LLPAR) + REAL*8 :: GC_O3(LLPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR), COST_CONT(LLPAR) + INTEGER :: I, J, L, N + INTEGER :: THISYMD + + LOGICAL :: SUPER_OBS = .TRUE. + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'gc_press_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 401, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 402, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 403, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_adj_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 404, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'obs_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 409, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'err_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 412, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'cfn_l_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 413, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ENDIF + + !================================================================ + ! CALC_OSIRIS_FORCE begins here! + !================================================================ + +! this comes from old CALC_ADJ_FORCE, same for v7 and v8 (tww, 20101027) + + ! Initialize to be safe + NEW_COST(:,:) = 0d0 + SOBS_COUNT(:,:) = 0d0 + SOBS_ADJ_FORCE(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + + + + + DO N = 1, NOCC + + DIFF(:) = 0d0 + OBS_ERRCOV(:) = 0d0 + GC_PRES(:) = 0d0 + GC_O3(:) = 0d0 + COST_CONT = 0d0 + + ! Only get obs at this time + IF( TIME_DATA(N) == GET_NHMS() ) THEN + + I = LOCATION_DATA(N,1) + J = LOCATION_DATA(N,2) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ! DEBUG, tww + !print*, 'ADDING FORCING AT: ', I, J, L + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + ! Make sure data and error are not zero or fill + IF( ( OSIRIS_DATA(N,L) > 0d0 ) .AND. & + ( OSIRIS_ERR(N,L) > 0d0 ) ) THEN + ! Only force below level 40 (about 25km) + ! Try without this condition (tww, 20120317) + !IF( L < 40 ) THEN + ! Condition data with very small errors + ! errors smaller than 1% on a single obs are removed + + IF( OSIRIS_DATA(N,L) < 100d0 * OSIRIS_ERR(N,L) ) THEN + ! CHK_STT is in units of [kg/box] here. Convert to ppb + DIFF(L) = ( GC_O3(L) - OSIRIS_DATA(N,L) * 1d9 ) + + ! Get obs error covariance + OBS_ERRCOV(L) = OSIRIS_ERR(N,L) * OSIRIS_ERR(N,L) * 1d18 + + COST_CONT(L) = 0.5d0 * (DIFF(L)**2)/ OBS_ERRCOV(L) + ! Calculate new additions to cost function + IF ( ( COST_CONT(L) > 0d0) .AND. & + ( GET_PCENTER(I,J,L) < 300d0) ) THEN + IF (SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONT(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONT(L) + ENDIF + + ! Force the adjoint variables x with dJ/dx + ! Change to get units right [kg/box] + ADJ_FORCE_OSIRIS(I,J,L) = DIFF(L) / OBS_ERRCOV(L) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + ADJ_FORCE_OSIRIS(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + ADJ_FORCE_OSIRIS(I,J,L) + ENDIF + ENDIF + ELSE + !print*, 'removed outlier at ', N, L + !print*, 'outlier is ', OSIRIS_DATA(N,L) + !print*, 'outlier error is ', OSIRIS_ERR(N,L) + ENDIF + !ENDIF + ENDIF + + ENDDO + !SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + !WRITE(6,102) (DIFF(L), L=LLPAR,1,-1) +102 FORMAT(1X,d14.6) + !WRITE(401,110) ( GC_PRES(L), L=LLPAR,1,-1 ) + !WRITE(402,110) ( DIFF(L), L=LLPAR,1,-1 ) + !WRITE(403,110) ( GC_O3(L), L=LLPAR,1,-1 ) + !WRITE(404,110) ( GC_STT_ADJ(L), L=LLPAR,1,-1 ) + !WRITE(409,110) ( OSIRIS_DATA(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(412,110) ( OSIRIS_ERR(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(413,110) ( COST_CONT(L), L=LLPAR,1,-1 ) + +110 FORMAT(F18.6,1X) + ENDIF + ENDDO + IF (SUPER_OBS) THEN + DO I=1,IIPAR + DO J=1,JJPAR + IF ( SOBS_COUNT(I,J) > 0d0 ) THEN + DO L=1,LLPAR + IF ( ( GET_PCENTER(I,J,L) < 300d0 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0d0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + ENDIF + + ENDDO + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ELSE + WRITE(6,*) ' CALC_OSIRIS_FORCE: NEW_COST = ', SUM( NEW_COST(:,:)) + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST(:,:) ) + COUNT_TOTAL = COUNT_TOTAL + SUM (SOBS_COUNT(:,:) ) + print*, ' Total observation number = ', COUNT_TOTAL + ENDIF + ! dkh debug + !print*, ' CHK_STT = ', CHK_STT(25,35,1:8,IDTOX) + !print*, ' AD = ', AD(25,35,1:8) + !print*, ' OSIRIS_DATA = ', OSIRIS_DATA(25,35,1:8) + !print*, ' OSIRIS_ERR = ', OSIRIS_ERR(25,35,1:8) + !print*, ' NEW_COST = ', NEW_COST(25,35,1:8) + + ! Error check + IF ( IT_IS_NAN( COST_FUNC ) ) THEN + CALL ERROR_STOP( 'COST_FUNC IS NaN', 'CALC_OSIRIS_FORCE') + ENDIF + + END SUBROUTINE CALC_OSIRIS_FORCE + + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_OSIRIS +! +!***************************************************************************** +! Subroutine INIT_OSIRIS allocates all module arrays. (dkh, 11/16/06) +! +! NOTES: +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +#include "CMN_SIZE" ! IIPAR, JJPAR, LLPAR + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_OSIRIS begins here + !================================================================= + ALLOCATE( LOCATION_DATA( MAX_OBS_PER_DAY, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOCATION_DATA' ) + LOCATION_DATA = 0 + + ALLOCATE( TIME_DATA( MAX_OBS_PER_DAY ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TIME_DATA' ) + TIME_DATA = 0 + + ALLOCATE( OSIRIS_DATA( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_DATA' ) + OSIRIS_DATA = 0d0 + + ALLOCATE( OSIRIS_ERR( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_ERR' ) + OSIRIS_ERR = 0d0 + + ALLOCATE( ADJ_FORCE_OSIRIS( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_FORCE_OSIRIS' ) + ADJ_FORCE_OSIRIS = 0d0 + + FILEDATE = 0 + NOCC = 0 + + END SUBROUTINE INIT_OSIRIS + + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_OSIRIS + +!****************************************************************************** +! Deallocate all memory (done before reading each monthly file) +! + + ! Deallocate + IF ( ALLOCATED( LOCATION_DATA ) ) DEALLOCATE( LOCATION_DATA ) + IF ( ALLOCATED( TIME_DATA ) ) DEALLOCATE( TIME_DATA ) + IF ( ALLOCATED( OSIRIS_DATA ) ) DEALLOCATE( OSIRIS_DATA ) + IF ( ALLOCATED( OSIRIS_ERR ) ) DEALLOCATE( OSIRIS_ERR ) + IF ( ALLOCATED( ADJ_FORCE_OSIRIS ) ) DEALLOCATE( ADJ_FORCE_OSIRIS ) + + END SUBROUTINE CLEANUP_OSIRIS + +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------------- + + SUBROUTINE CALC_GC_O3 + +!! +!! Subroutine CALC_OMI_O3_FORCE computes the O3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE TIME_MOD, ONLY : GET_HOUR + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TRACER_MOD, ONLY : TCVV + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,L + + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_O3(LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'stt_o3_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 407, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + GC_HOUR = GET_HOUR() + GC_O3 = 0d0 + + DO I = 1, IIPAR + DO J = 1, JJPAR + GC_O3 = 0d0 + DO L = 1, LLPAR + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) * 1d9 + ENDDO + !WRITE(407,117) ( GC_O3(L), L=LLPAR,1,-1 ) +117 FORMAT(F18.6,1X) + ENDDO + ENDDO + + END SUBROUTINE CALC_GC_O3 + +!--------------------------------------------------------------------------------------------------------------------------- + +END MODULE OSIRIS_OBS_MOD diff --git a/code/obs_operators/osiris_obs_mod.f90~ b/code/obs_operators/osiris_obs_mod.f90~ new file mode 100644 index 0000000..da891ba --- /dev/null +++ b/code/obs_operators/osiris_obs_mod.f90~ @@ -0,0 +1,665 @@ +! $Id: osiris_obs_mod.f,v 1.0 2012/02/23 06:47:07 twalker Exp $ +MODULE OSIRIS_OBS_MOD + +!****************************************************************************** +! Module OSIRIS_OBS_MOD contains subroutines necessary to +! 1. Read OSIRIS (ASCII) file with O3 observations, preprocessed onto model grid +! 2. Determine when OSIRIS O3 obs are available +! 3. Compute adjoint forcing in model space +! +! Module Variables: +! ============================================================================ +! (1 ) OSIRIS_DATA : OSIRIS data pre-averaged onto 4x5 grid +! (2 ) ADJ_FORCE_OSIRIS : Adjoint forcing +! (3 ) LOCATION_DATA : Array of locations and times of observations +! (4 ) FILEDATE : Date associated with file currently read +! (5 ) COUNT_TOTAL : Number of observations +! (6 ) OSIRIS_ERR : OSIRIS error values pre-averaged onto 4x5 grid +! +! Module Routines: +! ============================================================================ +! (1 ) READ_OSIRIS_FILE : Read OSIRIS ASCII file +! (2 ) ITS_TIME_FOR_OSIRIS_OBS : Checks model time +! (3 ) CALC_OSIRIS_FORCE : Calculates cost fnc and ADJ_STT increments +! (4 ) INIT_OSIRIS : Allocates memory of arrays +! (5 ) CLEANUP_OSIRIS : Deallocates memory of arrays +! (6 ) IS_OSIRIS_NONZERO : Determines if OSIRIS observed a grid +! +! ============================================================================ +! NOTES: +! (1 ) Based on obs operators implemented in v8 adjoint. (tww, 20120223) +! +!****************************************************************************** + + IMPLICIT NONE + +#include "CMN_SIZE" ! Size parameters + + ! Everything PRIVATE unless specified otherwise + ! PRIVATE module variables + ! PRIVATE module routines + PRIVATE + + PUBLIC :: READ_OSIRIS_FILE + PUBLIC :: ITS_TIME_FOR_OSIRIS_OBS + PUBLIC :: CALC_OSIRIS_FORCE + PUBLIC :: COUNT_TOTAL + PUBLIC :: IS_OSIRIS_NONZERO + PUBLIC :: CALC_GC_O3 + + REAL*8, ALLOCATABLE :: OSIRIS_DATA(:,:) + REAL*8, ALLOCATABLE :: OSIRIS_ERR(:,:) + REAL*8, ALLOCATABLE :: ADJ_FORCE_OSIRIS(:,:,:) + INTEGER, ALLOCATABLE :: LOCATION_DATA(:,:) + INTEGER, ALLOCATABLE :: TIME_DATA(:) + + INTEGER :: FILEDATE + INTEGER :: NOCC + REAL*8 :: COUNT_TOTAL + INTEGER, PARAMETER :: MAX_OBS_PER_DAY=1000 + +CONTAINS + + +!---------------------------------------------------------------------- + + SUBROUTINE READ_OSIRIS_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_OSIRIS_FILE reads an ASCII file containing OSIRIS data +! for the given day. Data are already averaged onto 4x5 grid, but are given +! every km altitude from 0.5km to 64.5km. (tww, 20120223) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : Hour-Min-Sec +! + + USE DAO_MOD, ONLY : BXHEIGHT + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + +#include "CMN_SIZE" ! size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + CHARACTER(LEN=255) :: DIR_OSIRIS + CHARACTER(LEN=255) :: DIR_MONTH_OSIRIS + CHARACTER(LEN=255) :: FILENAME_OSIRIS + CHARACTER(LEN=255) :: FILENAME + + CHARACTER(LEN=*), PARAMETER :: FMT1 = "(I8,I5,I5,I5,F8.2,F8.2,F8.2,I9)" + INTEGER, PARAMETER :: OSIRIS_LVL=65 + + REAL*8 :: TEMPALT(OSIRIS_LVL) + REAL*8 :: TEMPO3DATA(OSIRIS_LVL) + REAL*8 :: TEMPO3ERR(OSIRIS_LVL) + REAL*8 :: TEMPLAT, TEMPLON, TEMPH, Z1, Z2 + INTEGER :: IU_FILE, IOS + INTEGER :: NOBS, I, J, L, K + INTEGER :: OCCID, OLMAX, LATIND, LONIND + INTEGER :: TEMPYMD + INTEGER :: NDAT + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=255) :: FILENAME_DIAG + + + !================================================================= + ! READ_OSIRIS_FILE begins here! + !================================================================= + + !============================= + ! FIRST CLEANUP IF NECESSARY: + !============================= + CALL CLEANUP_OSIRIS + CALL INIT_OSIRIS + + IF ( FIRST ) THEN + COUNT_TOTAL = 0 + + FILENAME_DIAG = 'lat_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 405, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME_DIAG = 'lon_orb_osi.NN.m' + CALL EXPAND_NAME( FILENAME_DIAG, N_CALC ) + FILENAME_DIAG = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME_DIAG ) + OPEN( 406, FILE=TRIM( FILENAME_DIAG ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FIRST = .FALSE. + ENDIF + + !======================== + ! FILENAME + !========================= + + DIR_OSIRIS = '/users/jk/15/xzhang/OSIRIS_O3/' + DIR_MONTH_OSIRIS = '/YYYY/MM/' + FILENAME_OSIRIS = TRIM( 'OSIRIS_507_4x5_YYYYMMDD_O3.data' ) + ! FILENAME_OSIRIS = TRIM( 'osiristestfile_YYYYMMDD.data' ) + IU_FILE = 15 + ! EXPAND_DATE replaces tokens like 'YYYY' with the year + CALL EXPAND_DATE( DIR_MONTH_OSIRIS, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( FILENAME_OSIRIS, YYYYMMDD, 9999 ) + FILENAME = TRIM( DIR_OSIRIS ) // TRIM(DIR_MONTH_OSIRIS) // FILENAME_OSIRIS + + WRITE(6,*) ' - READ_OSIRIS_FILE: reading: ', FILENAME + + NOCC = 0 + + ! Open file + OPEN( IU_FILE, FILE=FILENAME, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:1' ) + + !======================== + ! Read in data blocks + !======================== + ! Needs to be true until end of file + DO I = 1, MAX_OBS_PER_DAY + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:2' ) + + ! Read meta data line (OCCID, RETLVLS, LONIND, + ! LATIND, LON, LAT, HH, YMD) + READ( IU_FILE, FMT1, IOSTAT=IOS) OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'osiris:3' ) + + !DEBUG, tww + !print*, 'METADATA is: ', OCCID, OLMAX, LONIND, LATIND, TEMPLON, TEMPLAT, TEMPH, TEMPYMD + + LOCATION_DATA(I,1) = LONIND + LOCATION_DATA(I,2) = LATIND + TIME_DATA(I) = FLOOR(TEMPH)*10000d0 + + ! Read altitude, ozone and error profiles + READ( IU_FILE, * )(TEMPALT(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3DATA(K), K=1,OLMAX) + READ( IU_FILE, * )(TEMPO3ERR(K), K=1,OLMAX) + + ! OSIRIS data comes every km + ! Compute average of data on each GEOS-Chem vertical level + Z1 = 0d0 + Z2 = 0d0 + DO L = 1, LLPAR + Z1 = Z2 + Z2 = Z1 + BXHEIGHT(LONIND,LATIND,L)/1000d0 + NDAT = 0 + DO K = 1, OSIRIS_LVL + IF (TEMPALT(K) > Z1 .AND. TEMPALT(K) <=Z2) THEN + IF (TEMPO3DATA(K)>0d0) THEN + OSIRIS_DATA( I, L ) = OSIRIS_DATA( I, L ) + TEMPO3DATA( K ) + OSIRIS_ERR( I, L ) = OSIRIS_ERR( I, L ) + TEMPO3ERR( K ) ** 2 + NDAT = NDAT + 1 + ENDIF + ELSEIF (TEMPALT(K) > Z2) THEN + EXIT + ENDIF + ENDDO + IF (NDAT>0) THEN + OSIRIS_DATA(I,L) = OSIRIS_DATA(I,L)/NDAT + OSIRIS_ERR(I,L) = SQRT(OSIRIS_ERR(I,L))/NDAT + ENDIF + ENDDO + + NOCC = NOCC + 1 + !debug, tww + !print*, 'o3data read: ', TEMPO3DATA + !print*, 'o3err read: ', TEMPO3ERR + WRITE(405,118) ( TEMPLAT ) + WRITE(406,118) ( TEMPLON ) +118 FORMAT(F18.6,1X) + ENDDO + + FILEDATE = TEMPYMD !- 10000 + + ! Close file + CLOSE( IU_FILE ) + + ! DEBUG, tww + !print*, 'FINISHED READING OSIRIS FILE' + !print*, 'NOCC = ', NOCC + !print*, 'FILEDATE = ', FILEDATE + !print*, 'LOCATIONS = ', LOCATION_DATA + !print*, 'TIMES = ', TIME_DATA + !print*, 'OSIRIS_DATA = ', OSIRIS_DATA(1:3,:) + !print*, 'OSIRIS_ERR = ', OSIRIS_ERR(1:3,:) + + END SUBROUTINE READ_OSIRIS_FILE + + +!---------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_OSIRIS_OBS( ) RESULT( FLAG ) + +!****************************************************************************** +! Function ITS_TIME_FOR_OSIRIS_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day). (tww, 20120223) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + INTEGER :: N + + !================================================================= + ! ITS_TIME_FOR_OSIRIS_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + ! Observation times on this day are stored in TIME_DATA + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + ! DEBUG + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found at: ',N + !WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS found: ', GET_NHMS() + FLAG = .TRUE. + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', FILEDATE + WRITE(6,*) ' - ITS_TIME_FOR_OSIRIS_OBS wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION ITS_TIME_FOR_OSIRIS_OBS + + +!---------------------------------------------------------------------- + + FUNCTION IS_OSIRIS_NONZERO( I,J,L ) RESULT ( FLAG ) + +!****************************************************************************** +! Function IS_OSIRIS_NONZERO returns TRUE if there are observations +! available for particular location. (tww, 20120229) +! + + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +#include "CMN_SIZE" ! Size parameters + + ! Function value + LOGICAL :: FLAG + + ! Arguments + INTEGER :: I, J, L + + INTEGER :: N + + !================================================================= + ! IS_OSIRIS_NONZERO begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO N = 1, NOCC + IF( TIME_DATA( N ) == GET_NHMS() ) THEN + IF ( ( LOCATION_DATA(N,1)==I ) .AND. & + ( LOCATION_DATA(N,2)==J ) .AND. & + ( OSIRIS_DATA(N,L) > 0 )) THEN + WRITE(6,*) 'IS_OSIRIS_NONZERO - yes, at: ', I, J, L + FLAG = .TRUE. + ENDIF + ENDIF + ENDDO + + ! If we have the wrong day + IF( GET_NYMD() /= FILEDATE ) THEN + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', FILEDATE + WRITE(6,*) ' - IS_OSIRIS_NONZERO wrong day: ', GET_NYMD() + FLAG = .FALSE. + ENDIF + + END FUNCTION IS_OSIRIS_NONZERO + + +!---------------------------------------------------------------------- + + SUBROUTINE CALC_OSIRIS_FORCE( COST_FUNC ) + +!****************************************************************************** +! Subroutine CALC_OSIRIS_FORCE (tww, 20120223) +! + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE TIME_MOD, ONLY : GET_NHMS + USE TRACERID_MOD, ONLY : IDTOX + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Parameters + REAL*8, PARAMETER :: ADJ_TCVVOX = 28.97d0/48.d0 + + REAL*8 :: NEW_COST(IIPAR,JJPAR) + REAL*8 :: GC_PRES(LLPAR), DIFF(LLPAR) + REAL*8 :: OBS_ERRCOV(LLPAR) + REAL*8 :: GC_O3(LLPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR), COST_CONT(LLPAR) + INTEGER :: I, J, L, N + INTEGER :: THISYMD + + LOGICAL :: SUPER_OBS = .TRUE. + REAL*8 :: SOBS_COUNT(IIPAR,JJPAR) + REAL*8 :: SOBS_ADJ_FORCE(IIPAR,JJPAR,LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'gc_press_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 401, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 402, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 403, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_stt_adj_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 404, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'obs_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 409, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'err_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 412, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'cfn_l_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 413, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ENDIF + + !================================================================ + ! CALC_OSIRIS_FORCE begins here! + !================================================================ + +! this comes from old CALC_ADJ_FORCE, same for v7 and v8 (tww, 20101027) + + ! Initialize to be safe + NEW_COST(:,:) = 0d0 + SOBS_COUNT(:,:) = 0d0 + SOBS_ADJ_FORCE(:,:,:) = 0d0 + GC_ADJ_COUNT(:,:,:) = 0d0 + + + + + DO N = 1, NOCC + + DIFF(:) = 0d0 + OBS_ERRCOV(:) = 0d0 + GC_PRES(:) = 0d0 + GC_O3(:) = 0d0 + COST_CONT = 0d0 + + ! Only get obs at this time + IF( TIME_DATA(N) == GET_NHMS() ) THEN + + I = LOCATION_DATA(N,1) + J = LOCATION_DATA(N,2) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ! DEBUG, tww + !print*, 'ADDING FORCING AT: ', I, J, L + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + ! Make sure data and error are not zero or fill + IF( ( OSIRIS_DATA(N,L) > 0d0 ) .AND. & + ( OSIRIS_ERR(N,L) > 0d0 ) ) THEN + ! Only force below level 40 (about 25km) + ! Try without this condition (tww, 20120317) + !IF( L < 40 ) THEN + ! Condition data with very small errors + ! errors smaller than 1% on a single obs are removed + + IF( OSIRIS_DATA(N,L) < 100d0 * OSIRIS_ERR(N,L) ) THEN + ! CHK_STT is in units of [kg/box] here. Convert to ppb + DIFF(L) = ( GC_O3(L) - OSIRIS_DATA(N,L) * 1d9 ) + + ! Get obs error covariance + OBS_ERRCOV(L) = OSIRIS_ERR(N,L) * OSIRIS_ERR(N,L) * 1d18 + + COST_CONT(L) = 0.5d0 * (DIFF(L)**2)/ OBS_ERRCOV(L) + ! Calculate new additions to cost function + IF ( ( COST_CONT(L) > 0d0) .AND. & + ( GET_PCENTER(I,J,L) < 300d0) ) THEN + IF (SUPER_OBS) THEN + NEW_COST(I,J) = NEW_COST(I,J) + COST_CONT(L) + SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + ELSE + COST_FUNC = COST_FUNC + COST_CONT(L) + ENDIF + + ! Force the adjoint variables x with dJ/dx + ! Change to get units right [kg/box] + ADJ_FORCE_OSIRIS(I,J,L) = DIFF(L) / OBS_ERRCOV(L) * ADJ_TCVVOX / AD(I,J,L) * 1d9 + IF (SUPER_OBS) THEN + SOBS_ADJ_FORCE(I,J,L) = SOBS_ADJ_FORCE(I,J,L) + ADJ_FORCE_OSIRIS(I,J,L) + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1 + ELSE + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + ADJ_FORCE_OSIRIS(I,J,L) + ENDIF + ENDIF + ELSE + !print*, 'removed outlier at ', N, L + !print*, 'outlier is ', OSIRIS_DATA(N,L) + !print*, 'outlier error is ', OSIRIS_ERR(N,L) + ENDIF + !ENDIF + ENDIF + + ENDDO + !SOBS_COUNT(I,J) = SOBS_COUNT(I,J) + 1d0 + !WRITE(6,102) (DIFF(L), L=LLPAR,1,-1) +102 FORMAT(1X,d14.6) + !WRITE(401,110) ( GC_PRES(L), L=LLPAR,1,-1 ) + !WRITE(402,110) ( DIFF(L), L=LLPAR,1,-1 ) + !WRITE(403,110) ( GC_O3(L), L=LLPAR,1,-1 ) + !WRITE(404,110) ( GC_STT_ADJ(L), L=LLPAR,1,-1 ) + !WRITE(409,110) ( OSIRIS_DATA(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(412,110) ( OSIRIS_ERR(N,L) * 1d9, L=LLPAR,1,-1 ) + !WRITE(413,110) ( COST_CONT(L), L=LLPAR,1,-1 ) + +110 FORMAT(F18.6,1X) + ENDIF + ENDDO + IF (SUPER_OBS) THEN + DO I=1,IIPAR + DO J=1,JJPAR + IF ( SOBS_COUNT(I,J) > 0d0 ) THEN + DO L=1,LLPAR + IF ( ( GET_PCENTER(I,J,L) < 300d0 ) .AND. & + ( GC_ADJ_COUNT(I,J,L) > 0d0 ) ) THEN + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + SOBS_ADJ_FORCE(I,J,L)/GC_ADJ_COUNT(I,J,L) + ENDIF + + ENDDO + COST_FUNC = COST_FUNC + NEW_COST(I,J)/SOBS_COUNT(I,J) + ENDIF + ENDDO + ENDDO + ELSE + WRITE(6,*) ' CALC_OSIRIS_FORCE: NEW_COST = ', SUM( NEW_COST(:,:)) + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST(:,:) ) + COUNT_TOTAL = COUNT_TOTAL + SUM (SOBS_COUNT(:,:) ) + print*, ' Total observation number = ', COUNT_TOTAL + ENDIF + ! dkh debug + !print*, ' CHK_STT = ', CHK_STT(25,35,1:8,IDTOX) + !print*, ' AD = ', AD(25,35,1:8) + !print*, ' OSIRIS_DATA = ', OSIRIS_DATA(25,35,1:8) + !print*, ' OSIRIS_ERR = ', OSIRIS_ERR(25,35,1:8) + !print*, ' NEW_COST = ', NEW_COST(25,35,1:8) + + ! Error check + IF ( IT_IS_NAN( COST_FUNC ) ) THEN + CALL ERROR_STOP( 'COST_FUNC IS NaN', 'CALC_OSIRIS_FORCE') + ENDIF + + END SUBROUTINE CALC_OSIRIS_FORCE + + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_OSIRIS +! +!***************************************************************************** +! Subroutine INIT_OSIRIS allocates all module arrays. (dkh, 11/16/06) +! +! NOTES: +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +#include "CMN_SIZE" ! IIPAR, JJPAR, LLPAR + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_OSIRIS begins here + !================================================================= + ALLOCATE( LOCATION_DATA( MAX_OBS_PER_DAY, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOCATION_DATA' ) + LOCATION_DATA = 0 + + ALLOCATE( TIME_DATA( MAX_OBS_PER_DAY ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TIME_DATA' ) + TIME_DATA = 0 + + ALLOCATE( OSIRIS_DATA( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_DATA' ) + OSIRIS_DATA = 0d0 + + ALLOCATE( OSIRIS_ERR( MAX_OBS_PER_DAY, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OSIRIS_ERR' ) + OSIRIS_ERR = 0d0 + + ALLOCATE( ADJ_FORCE_OSIRIS( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_FORCE_OSIRIS' ) + ADJ_FORCE_OSIRIS = 0d0 + + FILEDATE = 0 + NOCC = 0 + + END SUBROUTINE INIT_OSIRIS + + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_OSIRIS + +!****************************************************************************** +! Deallocate all memory (done before reading each monthly file) +! + + ! Deallocate + IF ( ALLOCATED( LOCATION_DATA ) ) DEALLOCATE( LOCATION_DATA ) + IF ( ALLOCATED( TIME_DATA ) ) DEALLOCATE( TIME_DATA ) + IF ( ALLOCATED( OSIRIS_DATA ) ) DEALLOCATE( OSIRIS_DATA ) + IF ( ALLOCATED( OSIRIS_ERR ) ) DEALLOCATE( OSIRIS_ERR ) + IF ( ALLOCATED( ADJ_FORCE_OSIRIS ) ) DEALLOCATE( ADJ_FORCE_OSIRIS ) + + END SUBROUTINE CLEANUP_OSIRIS + +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------------- + + SUBROUTINE CALC_GC_O3 + +!! +!! Subroutine CALC_OMI_O3_FORCE computes the O3 adjoint forcing from OMI column data +!! + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE TIME_MOD, ONLY : GET_HOUR + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TRACER_MOD, ONLY : TCVV + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#include "CMN_SIZE" ! size parameters + + INTEGER :: I,J,L + + INTEGER :: GC_HOUR + + ! variables for observation operator and adjoint thereof + + REAL*8 :: GC_O3(LLPAR) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + IF ( FIRST ) THEN + FILENAME = 'stt_o3_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 407, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + GC_HOUR = GET_HOUR() + GC_O3 = 0d0 + + DO I = 1, IIPAR + DO J = 1, JJPAR + GC_O3 = 0d0 + DO L = 1, LLPAR + GC_O3(L) = CHK_STT(I,J,L,IDTOX) * TCVV(IDTOX) / AD(I,J,L) * 1d9 + ENDDO + !WRITE(407,117) ( GC_O3(L), L=LLPAR,1,-1 ) +117 FORMAT(F18.6,1X) + ENDDO + ENDDO + + END SUBROUTINE CALC_GC_O3 + +!--------------------------------------------------------------------------------------------------------------------------- + +END MODULE OSIRIS_OBS_MOD diff --git a/code/obs_operators/population_mod.f b/code/obs_operators/population_mod.f new file mode 100644 index 0000000..5e797ba --- /dev/null +++ b/code/obs_operators/population_mod.f @@ -0,0 +1,404 @@ +!$Id: population_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE POPULATION_MOD +! +!****************************************************************************** +! Module POPULATION_MOD contains code for incorporating population weighting +! into cost functions / exposure metrics. Population data taken from: +! +! Center for International Earth Science Information Network (CIESIN), +! Columbia University; and Centro Internacional de Agricultura Tropical +! (CIAT). 2005. Gridded Population of the World, Version 3 (GPWv3): +! Population Count Grid. Palisades, NY: Socioeconomic Data and Applications +! Center (SEDAC), Columbia University. +! Available at http://sedac.ciesin.columbia.edu/gpw. 2/11/2012. +! +! Steven Vogel, jk, dkh, 02/04/2012, adj32_024 +! +! Module Variables: +! ============================================================================ +! (1 ) POP_REDUCED (REAL*8) : Array of census population +! +! Module Routines: +! =========================================================================== +! (1 ) POP_WEIGHT_COST : Computes population weighted cost function +! (2 ) READ_IN_POPULATION : Reads in gridded population data file +! (3 ) INIT_POPULATOIN_MOD : Allocates & zeroes module arrays +! (4 ) CLEANUP_POPULATION_MOD : Deallocates module arrays +! +! NOTES: +! +!***************************************************************************** + IMPLICIT NONE + + PUBLIC + + !================================================================= + ! MODULE VARIABLES + !================================================================= + REAL*8, ALLOCATABLE :: POP_REDUCED(:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE POP_WEIGHT_COST +! +!****************************************************************************** +! This subroutine based on CALC_ADJ_FORCE_FOR_SENSE in geos_chem_adj_mod.f +! Calculates population weighted cost function when called in +! geos_chem_adj_mod.f +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AIRVOL, AD + USE LOGICAL_MOD, ONLY : LPRT + USE TRACER_MOD, ONLY : N_TRACERS + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + + ! Header files +# include "CMN_SIZE" ! Size parameters + + ! Local variables + REAL*8 :: ADJ_FORCE(IIPAR,JJPAR,LLPAR,N_TRACERS) + INTEGER :: I, J, N, NN + LOGICAL, SAVE :: FIRST = .TRUE. + + REAL*8, DIMENSION(IIPAR,JJPAR,NOBS) :: COST_NUMM + REAL*8, DIMENSION(IIPAR,JJPAR) :: DENOMM_POP + REAL*8, DIMENSION(IIPAR,JJPAR) :: DENOMM_VOL + REAL*4, DIMENSION(IIPAR,JJPAR) :: N_INCLUDE + REAL*8 :: NEW_COST_SCALAR + REAL*8 :: POP_TOT + REAL*8 :: VOL_TOT + REAL*8 :: N_TOT + REAL*8 :: FACTORR + + !================================================================= + ! POP_WEIGHT_COST begins here! + !================================================================= + + ! Get population data + IF ( FIRST ) THEN + + CALL INIT_POPULATION_MOD + CALL READ_IN_POPULATION + + ! replace NOBS2STT with TRACER_IND + + FIRST = .FALSE. + + ENDIF + + IF ( LPRT ) THEN + print*, 'SEV DEBUG = ', maxval(POP_REDUCED) + print*, 'SEV DEBUG = ', minval(POP_REDUCED) + ENDIF + + ! Initialze cost fnc variables + NEW_COST_SCALAR = 0d0 + COST_NUMM = 0d0 + DENOMM_POP = 0d0 + DENOMM_VOL = 0d0 + N_INCLUDE = 0e0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N, NN ) + DO N = 1, NOBS + DO J = 1, JJPAR + DO I = 1, IIPAR + + NN = TRACER_IND(N) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + COST_NUMM(I,J,N) = GET_CF_REGION(I,J,1) + & * CHK_STT(I,J,1,NN) + & * POP_REDUCED(I,J) + + ! Set denominator population and volume + IF ( N == 1 .and. GET_CF_REGION(I,J,1) > 0d0 + & .and. POP_REDUCED(I,J) > 0d0 ) THEN + + DENOMM_POP(I,J) = + & POP_REDUCED(I,J) * GET_CF_REGION(I,J,1) + + DENOMM_VOL(I,J) = + & AIRVOL(I,J,1) * GET_CF_REGION(I,J,1) + + N_INCLUDE(I,J) = 1e0 + +! For debugging: +! WRITE(55,100) I, J, GET_XMID(I), GET_YMID(J), POP_REDUCED(I,J), +! & AIRVOL(I,J,1), CHK_STT(I,J,1,27), +! & CHK_STT(I,J,1,31), CHK_STT(I,J,1,32), CHK_STT(I,J,1,34:37) +! 100 FORMAT(1X,I6,1X,I6,1X,F16.8,1X,F16.8,1X,E16.8,1X,E16.8,1X,F16.8,1X, +! & F16.8,1X, F16.8,1X, F16.8,1X,F16.8,1X,F16.8,1X,F16.8) + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + POP_TOT = SUM(DENOMM_POP) + VOL_TOT = SUM(DENOMM_VOL) + N_TOT = SUM(N_INCLUDE) + + print*, 'SEV DEBUG TOTAL VOLUME = ', VOL_TOT + print*, 'SEV DEBUG TOTAL POP = ', POP_TOT + print*, 'SEV DEBUG TOTAL N = ', N_TOT +#if defined ( GRID2x25 ) + print*, 'SEV DEBUG DENOM POP= ', DENOMM_POP(117,64) +#endif + + FACTORR = 1d9 / ( POP_TOT * VOL_TOT * NSPAN ) * N_TOT + + NEW_COST_SCALAR = SUM(COST_NUMM(:,:,:)) * FACTORR + + ! Update cost function + COST_FUNC = COST_FUNC + NEW_COST_SCALAR + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N, NN ) + DO N = 1, NOBS + DO J = 1, JJPAR + DO I = 1, IIPAR + + NN = TRACER_IND(N) + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,1,NN) = GET_CF_REGION(I,J,1) + & * POP_REDUCED(I,J) + & * FACTORR + + STT_ADJ(I,J,1,NN) = STT_ADJ(I,J,1,NN) + ADJ_FORCE(I,J,1,NN) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE POP_WEIGHT_COST + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_IN_POPULATION +! +!****************************************************************************** +! Subroutine READ_IN_POPULATION reads in gridded population data. +! by Steven Vogel, based on code from Jamin Koo (dkh, 02/13/12, adj32_024) +! +! NOTES: +! +!****************************************************************************** +! + + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE LOGICAL_MOD, ONLY : LPRT + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FNAME + INTEGER :: IOS, IOS2 + + !================================================================= + ! READ_IN_POPULATION begins here! + !================================================================= + + ! Generate population data filename + FNAME = TRIM( DATA_DIR ) // 'population_201202/' // + & 'world_population.' // GET_RES_EXT() + + ! Read the population from ascii file. + WRITE( 6, '(a)' ) ' Reading in population from ', FNAME + + OPEN( UNIT=11, FILE=FNAME, STATUS='OLD', IOSTAT=IOS) + + IF ( IOS /= 0 ) THEN + CALL ERROR_STOP('ERROR opening weight' , + & 'READ_IN_POPULATION, population_mod.f') + ELSE + READ( UNIT=11, FMT=*, IOSTAT=IOS2 ) POP_REDUCED + IF ( IOS2 < 0 ) THEN + CALL ERROR_STOP( 'Unexpected End of File encountered', + & 'READ_IN_POPULATION, population_mod.f') + ELSE IF ( IOS > 0 ) THEN + CALL ERROR_STOP( 'Error occurred reading pop data!', + & 'READ_IN_POPULATION, population_mod.f') + ENDIF + ENDIF + + CLOSE( UNIT=10 ) + + IF ( LPRT ) THEN + PRINT *, 'sum of population', sum(POP_REDUCED) + PRINT *, 'Population Grid Test Max', maxval(POP_REDUCED) + PRINT *, 'Population Grid Test Min', minval(POP_REDUCED) + PRINT *, 'Population Grid Test Size', size(POP_REDUCED) + ENDIF + + !CALL MAKE_POP_FILE() + + ! Return to calling program + END SUBROUTINE READ_IN_POPULATION + +!------------------------------------------------------------------------------ + SUBROUTINE MAKE_POP_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_POP_FILE creates binary world population file. +! (dkh, 9/01/04) +! +!****************************************************************************** + ! References to F90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : GET_TAU + +# include "CMN_SIZE" ! Size parameters + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + + !================================================================= + ! MAKE_POP_FILE begins here! + !================================================================= + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM OBS File: ' // + & 'Observation Concentrations (kg/box)' + UNIT = 'people' + CATEGORY = 'IJ-POP-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the observation file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( 'pop.bpch' ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_POP_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write pop + !================================================================= + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, REAL(POP_REDUCED,4) ) + + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_POP_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_POP_FILE +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_POPULATION_MOD +! +!****************************************************************************** +! Subroutine INIT_POPULATION_MOD initializes and zeros all allocatable arrays +! declared in "population_mod.f" +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters + + ! local variables + INTEGER :: AS + + !================================================================= + ! INIT_POPULATION_MOD + !================================================================= + + ALLOCATE( POP_REDUCED(IIPAR,JJPAR) , STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'POP_REDUCED' ) + POP_REDUCED = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_POPULATION_MOD + +!----------------------------------------------------------------------------- + SUBROUTINE CLEANUP_POPULATION_MOD +! +!****************************************************************************** +! Subroutine CLEANUP_POPULATION_MOD deallocates all previously allocated arrays +! +! NOTES: +! +!****************************************************************************** +! + !================================================================= + ! CLEANUP_POPULATION_MOD begins here! + !================================================================= + IF ( ALLOCATED( POP_REDUCED ) ) DEALLOCATE( POP_REDUCED ) + + ! Return to calling program + END SUBROUTINE CLEANUP_POPULATION_MOD + +!------------------------------------------------------------------------------ + + END MODULE POPULATION_MOD diff --git a/code/obs_operators/scia_ch4_mod.f b/code/obs_operators/scia_ch4_mod.f new file mode 100644 index 0000000..2c721f2 --- /dev/null +++ b/code/obs_operators/scia_ch4_mod.f @@ -0,0 +1,1892 @@ +!$Id: scia_ch4_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ + MODULE SCIA_CH4_MOD +! +!****************************************************************************** +! Module SCIA_CH4_MOD for SCIAMACHY CH4 observations. +! By kjw, added adj32_023 (dkh, 02/12/12) +! +!****************************************************************************** +! + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: LLSCIA = 12 + INTEGER, PARAMETER :: MAXSCIA = 50000 + REAL*8, PARAMETER :: ERR_FRAC = 0.015 + + + ! Record to store data from each TES obs + TYPE SCIA_CH4_OBS + INTEGER :: NYMD + INTEGER :: NHMS + INTEGER :: QFLAG + INTEGER :: TFLAG + REAL*8 :: TIME + REAL*8 :: XCH4 + REAL*8, DIMENSION(LLSCIA) :: AVGKERNEL + REAL*8, DIMENSION(LLSCIA) :: PRESCEN + REAL*8, DIMENSION(LLSCIA+1) :: PRESEDGE + REAL*8, DIMENSION(LLSCIA) :: PRIOR + REAL*8, DIMENSION(50) :: GCII + REAL*8, DIMENSION(50) :: GCJJ + REAL*8, DIMENSION(50) :: GCFRAC + ENDTYPE SCIA_CH4_OBS + + TYPE(SCIA_CH4_OBS) :: SCIA(MAXSCIA) + + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_SCIA_CH4_OBS( YYYYMMDD, NSCIA ) +! +!****************************************************************************** +! Subroutine READ_SCIA_CH4_OBS reads the file and passes back info contained +! therein. (kjw, 07/20/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (REAL*8) : SCIA observation filename to read +! +! Arguments as Output: +! ============================================================================ +! (1 ) NSCIA (INTEGER) : Number of SCIA retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) SCIA_CH4_OBS : SCIA retrieval for current day +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE NETCDF_UTIL_MOD, ONLY : NCDF_OPEN_FOR_READ + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VARID + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VAR + USE NETCDF_UTIL_MOD, ONLY : NCDF_CLOSE + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" + + ! Arguments + INTEGER, INTENT(OUT) :: NSCIA + INTEGER, INTENT(IN) :: YYYYMMDD + + ! Information to be stored in module varialbe SCIA_CH4_OBS + !REAL*8 :: XCH4 + !REAL*8 :: AVG_KERNEL(LLSCIA) + !REAL*8 :: PRES(LLSCIA) + !REAL*8 :: PRIOR(LLSCIA) + !INTEGER :: QFLAG + !REAL*8 :: GCII(50) + !REAL*8 :: GCJJ(50) + !REAL*8 :: GCfrac(50) + + ! netCDF id's + INTEGER :: NCID + INTEGER :: nobs_id, yyyymmdd_id, hhmmss_id + INTEGER :: qflag_id, xch4_id, ch4ak_id + INTEGER :: tflag_id + INTEGER :: ch4presedge_id + INTEGER :: ch4prescen_id, ch4prior_id + INTEGER :: gcii_id, gcjj_id, gcfrac_id + + ! Arrays to hold info from NETCDF files + INTEGER, ALLOCATABLE :: Xqflag(:) + INTEGER, ALLOCATABLE :: Xtflag(:) + INTEGER, ALLOCATABLE :: Xnhms(:) + INTEGER, ALLOCATABLE :: Xnymd(:) + REAL*8, ALLOCATABLE :: Xxch4(:) + REAL*8, ALLOCATABLE :: Xch4ak(:,:) + REAL*8, ALLOCATABLE :: Xch4prescen(:,:) + REAL*8, ALLOCATABLE :: Xch4presedge(:,:) + REAL*8, ALLOCATABLE :: Xch4prior(:,:) + INTEGER, ALLOCATABLE :: Xgcii(:,:) + INTEGER, ALLOCATABLE :: Xgcjj(:,:) + REAL*8, ALLOCATABLE :: Xgcfrac(:,:) + + ! Loop indexes, and error handling. + LOGICAL :: file_exist + INTEGER :: NT, NB, AS, NGCFRAC + INTEGER :: HH, MM, SS, NG, LS + REAL*8 :: frac + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + + + + !================================================================= + ! READ_SCIA_CH4_OBS begins here! + !================================================================= + + ! Construct complete filename + READ_FILENAME = TRIM( '/home/kjw/scia/data/imapv55/netcdf/ ' ) // + & TRIM( 'YYYY/MM/' ) // + & TRIM( 'SCIA_CH4_YYYYMMDD.nc' ) + CALL EXPAND_DATE( READ_FILENAME, GET_NYMD(), 0 ) + + ! Determine if there are observations today + INQUIRE( FILE=READ_FILENAME, exist=file_exist ) + + ! If there is no observation file for this day, + ! Return to calling program + IF ( .not. file_exist ) THEN + WRITE(6,*) ' - READ_SCIA_CH4_OBS: file does not exist: ', + & TRIM( READ_FILENAME ) + WRITE(6,*) ' no observations today.' + + ! Set NSCIA = 0 and Return to calling program + NSCIA = 0 + RETURN + ENDIF + + + + WRITE(6,*) ' - READ_SCIA_CH4_OBS: reading file: ', READ_FILENAME + + ! Open file and assign file id (FID) + CALL NCDF_OPEN_FOR_READ( NCID, TRIM( READ_FILENAME ) ) + + + ! Get variable IDs for all variables to be read + nobs_id = ncdf_get_varid( NCID, 'Nobs' ) + yyyymmdd_id = ncdf_get_varid( NCID, 'YYYYMMDD' ) + hhmmss_id = ncdf_get_varid( NCID, 'HHMMSS' ) + qflag_id = ncdf_get_varid( NCID, 'Qflag' ) + xch4_id = ncdf_get_varid( NCID, 'Xch4' ) + ch4AK_id = ncdf_get_varid( NCID, 'ch4AK' ) + ch4presedge_id = ncdf_get_varid( NCID, 'ch4presedge' ) + ch4prescen_id = ncdf_get_varid( NCID, 'ch4prescen' ) + ch4prior_id = ncdf_get_varid( NCID, 'ch4prior' ) + IF ( GET_RES_EXT() .EQ. '4x5' ) THEN + gcii_id = ncdf_get_varid( NCID, 'GCII4' ) + gcjj_id = ncdf_get_varid( NCID, 'GCJJ4' ) + gcfrac_id = ncdf_get_varid( NCID, 'GCfrac4' ) + tflag_id = ncdf_get_varid( NCID, 'Tflag4' ) + ngcfrac = 8 + ELSE IF ( GET_RES_EXT() .EQ. '2x25' ) THEN + gcii_id = ncdf_get_varid( NCID, 'GCII2' ) + gcjj_id = ncdf_get_varid( NCID, 'GCJJ2' ) + gcfrac_id = ncdf_get_varid( NCID, 'GCfrac2' ) + tflag_id = ncdf_get_varid( NCID, 'Tflag2' ) + ngcfrac = 20 + ELSE IF ( GET_RES_EXT() .EQ. '05x0667' ) THEN + gcii_id = ncdf_get_varid( NCID, 'GCII05' ) + gcjj_id = ncdf_get_varid( NCID, 'GCJJ05' ) + gcfrac_id = ncdf_get_varid( NCID, 'GCfrac05' ) + tflag_id = ncdf_get_varid( NCID, 'Tflag05' ) + ngcfrac = 50 + ENDIF + + + ! Read Variables from NETCDF data file + !print*,' Reading NSCIA' + ! ---- Number of observations for the day + CALL NCDF_GET_VAR( NCID, nobs_id, NSCIA ) ! integer + !print*,NSCIA + !print*,'---------------------------------------------' + + ! ---- SCIAMACHY Quality Flag + !print*,' Reading QFLAG' + ALLOCATE( Xqflag( NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xqflag(:) = -999d0 + CALL NCDF_GET_VAR( NCID, qflag_id, Xqflag ) ! array of integers + !print*,XQFLAG(1) + !print*,'---------------------------------------------' + + ! ---- Tesselation Quality Flag + !print*,' Reading TFLAG' + ALLOCATE( Xtflag( NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xtflag(:) = -999d0 + CALL NCDF_GET_VAR( NCID, tflag_id, Xtflag ) ! array of integers + !print*,XTFLAG(1) + !print*,'---------------------------------------------' + + ! ---- Date of observation (YYYYMMDD) + !print*,' Reading YYYYMMDD' + ALLOCATE( Xnymd( NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xnymd(:) = -999d0 + CALL NCDF_GET_VAR( NCID, yyyymmdd_id, Xnymd ) ! array of integers + !print*,XNYMD(1) + !print*,'---------------------------------------------' + + ! ---- Time of observation (HHMMSS) + !print*,' Reading HHMMSS' + ALLOCATE( Xnhms( NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xnhms(:) = -999d0 + CALL NCDF_GET_VAR( NCID, hhmmss_id, Xnhms ) ! array of integers + !print*,XNHMS(1) + !print*,'---------------------------------------------' + + ! ---- SCIA CH4 volume mixing ratio [v/v] + !print*,' Reading XCH4' + ALLOCATE( Xxch4( NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xxch4(:) = -999d0 + CALL NCDF_GET_VAR( NCID, xch4_id, Xxch4 ) ! array of real*8 + !print*,XXCH4(1) + !print*,'---------------------------------------------' + + ! ---- SCIA CH4 Averaging Kernel + !print*,' Reading CH4AK' + ALLOCATE( Xch4ak( LLSCIA, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xch4ak(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, ch4AK_id, Xch4ak ) ! array of real*8 x 12 + !print*,XCH4AK(:,1) + !print*,'---------------------------------------------' + + ! ---- SCIA Pressure Centers [hPa] + !print*,' Reading CH4PRES Centers' + ALLOCATE( Xch4prescen( LLSCIA, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xch4prescen(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, ch4prescen_id, Xch4prescen ) + ! array of real*8 x 12 + !print*,XCH4PRESCEN(:,1) + !print*,'---------------------------------------------' + + ! ---- SCIA Pressure Edges [hPa] + !print*,' Reading CH4PRES Edges' + ALLOCATE( Xch4presedge( LLSCIA+1, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xch4presedge(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, ch4presedge_id, Xch4presedge ) + ! array of real*8 x 13 + !print*,XCH4PRESEDGE(:,1) + !print*,'---------------------------------------------' + + ! ---- SCIA CH4 Prior [v/v] + !print*,' Reading CH4PRIOR' + ALLOCATE( Xch4prior( LLSCIA, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + Xch4prior(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, ch4prior_id, Xch4prior) ! array of real*8 x 12 + !print*,XCH4PRIOR(:,1) + !print*,'---------------------------------------------' + + ! ---- GEOS-Chem I indices of observation + !print*,' Reading GCII' + ALLOCATE( Xgcii( NGCFRAC, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + XGCII(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, gcii_id, Xgcii ) ! array of integers x NGCFRAC + !print*,XGCII(:,1) + !print*,'---------------------------------------------' + + ! ---- GEOS-Chem J indices of observation + !print*,' Reading GCJJ' + ALLOCATE( Xgcjj( NGCFRAC, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + XGCJJ(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, gcjj_id, Xgcjj ) ! array of integers x NGCFRAC + !print*,XGCJJ(:,1) + !print*,'---------------------------------------------' + + ! ---- Fraction of observation in each GEOS-Chem grid box + !print*,' Reading GCFRAC' + ALLOCATE( Xgcfrac( NGCFRAC, NSCIA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + XGCFRAC(:,:) = -999d0 + CALL NCDF_GET_VAR( NCID, gcfrac_id, Xgcfrac ) ! array of real*8 x NGCFRAC + !print*,XGCFRAC(:,1) + !print*,'---------------------------------------------' + + + ! Done reading variables from NETCDF. Close file + CALL NCDF_CLOSE( NCID ) + + !NT = 1 + !IF ( NT .EQ. 1 ) THEN + ! WRITE( 6, * ) 'NSCIA = ', NSCIA + ! WRITE( 6, * ) 'QFLAG = ', XQFLAG(NT) + ! WRITE( 6, * ) 'NYMD = ', XNYMD(NT) + ! WRITE( 6, * ) 'NHMS = ', XNHMS(NT) + ! WRITE( 6, * ) 'XCH4 = ', XXCH4(NT) + ! WRITE( 6, * ) 'CH4AK = ', XCH4AK(:,NT) + ! WRITE( 6, * ) 'CH4PRESCEN = ', XCH4PRESCEN(:,NT) + ! WRITE( 6, * ) 'CH4PRESEDGE = ', XCH4PRESEDGE(:,NT) + ! WRITE( 6, * ) 'CH4PRIOR = ', XCH4PRIOR(:,NT) + ! WRITE( 6, * ) 'GCII = ', XGCII(:,NT) + ! WRITE( 6, * ) 'GCJJ = ', XGCJJ(:,NT) + ! WRITE( 6, * ) 'GCFRAC = ', XGCFRAC(:,NT) + !ENDIF + print*,'Xqflag #good= ',count(Xqflag .gt. 0) + + ! Assign variable output to module variable SCIA_CH4_OBS + DO NT=1,NSCIA + ! First initialize variables + SCIA(NT)%qflag = -999. + SCIA(NT)%tflag = -999. + SCIA(NT)%nymd = -999. + SCIA(NT)%nhms = -999. + SCIA(NT)%xch4 = -999. + DO LS=1,LLSCIA + SCIA(NT)%avgkernel(LS) = -999. + SCIA(NT)%prescen(LS) = -999. + SCIA(NT)%presedge(LS) = -999. + SCIA(NT)%prior(LS) = -999. + ENDDO + SCIA(NT)%presedge(13) = -999. + DO NG=1,NGCFRAC + SCIA(NT)%gcii(NG) = -999. + SCIA(NT)%gcjj(NG) = -999. + SCIA(NT)%gcfrac(NG) = -999. + ENDDO + + ! Place variables into SCIA structure + SCIA(NT)%qflag = Xqflag(NT) + SCIA(NT)%tflag = Xtflag(NT) + SCIA(NT)%nymd = Xnymd(NT) + SCIA(NT)%nhms = Xnhms(NT) + SCIA(NT)%xch4 = Xxch4(NT) + SCIA(NT)%avgkernel = Xch4ak(:,NT) + SCIA(NT)%prescen = Xch4prescen(:,NT) + SCIA(NT)%presedge = Xch4presedge(:,NT) + SCIA(NT)%prior = Xch4prior(:,NT) + SCIA(NT)%gcii(1:NGCFRAC) = Xgcii(1:NGCFRAC,NT) + SCIA(NT)%gcjj(1:NGCFRAC) = Xgcjj(1:NGCFRAC,NT) + SCIA(NT)%gcfrac(1:NGCFRAC) = Xgcfrac(1:NGCFRAC,NT) + ENDDO + + + ! Calculate fraction of day from NHMS + DO NT=1,NSCIA + HH = 0 + MM = 0 + SS = 0 + HH = floor( SCIA(NT)%nhms / 1d4 ) + MM = floor( ( SCIA(NT)%nhms - 1d4*HH ) / 1d2 ) + SS = floor( SCIA(NT)%nhms - 1d4*HH - 1d2*MM ) + frac = HH / 24d0 + + & MM / (24d0 * 60d0) + + & SS / (24d0 * 60d0 * 60d0) + SCIA(NT)%TIME = frac + !IF (NT .eq. 1 ) then + ! print*,'nhms = ', scia(nt)%nhms + ! print*,' hh = ', hh + ! print*,' mm = ', mm + ! print*,' ss = ', ss + ! print*,'frac = ', frac + !endif + ENDDO + + + ! Cleanup allocated arrays + IF ( ALLOCATED( Xqflag ) ) DEALLOCATE( Xqflag ) + IF ( ALLOCATED( Xnymd ) ) DEALLOCATE( Xnymd ) + IF ( ALLOCATED( Xnhms ) ) DEALLOCATE( Xnhms ) + IF ( ALLOCATED( Xxch4 ) ) DEALLOCATE( Xxch4 ) + IF ( ALLOCATED( Xch4ak ) ) DEALLOCATE( Xch4ak ) + IF ( ALLOCATED( Xch4prescen ) ) DEALLOCATE( Xch4prescen ) + IF ( ALLOCATED( Xch4presedge ) ) DEALLOCATE( Xch4presedge ) + IF ( ALLOCATED( Xch4prior ) ) DEALLOCATE( Xch4prior ) + IF ( ALLOCATED( Xgcii ) ) DEALLOCATE( Xgcii ) + IF ( ALLOCATED( Xgcjj ) ) DEALLOCATE( Xgcjj ) + IF ( ALLOCATED( Xgcfrac ) ) DEALLOCATE( Xgcfrac ) + + + + ! Return to calling program + END SUBROUTINE READ_SCIA_CH4_OBS +!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_SCIA_CH4_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_SCIA_CH4_FORCE calculates the adjoint forcing from the SCIA +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, TROPP + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : TCVV + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NT, LG, LS, I, J, NB + INTEGER, SAVE :: NSCIA + INTEGER :: NTSTART, NTSTOP, nboxes + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisad1 + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GRIDMAP(LLPAR,LLSCIA) + REAL*8 :: GC_CH4_onSCIA(LLSCIA) + REAL*8 :: molec_air_onSCIA(LLSCIA) + REAL*8 :: CH4_PRIOR(LLSCIA) + REAL*8 :: frac, frac_total + REAL*8 :: thistrop, GC_TROP + REAL*8 :: fracreplace + REAL*8 :: mass_air, mole_air, molec_air_total + REAL*8 :: LHS, RHS, GC_XCH4, GC_CH4 + REAL*8 :: Sobs, DIFF, FORCE + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_XCH4_ADJ, DIFF_ADJ, GC_CH4_ADJ + REAL*8 :: GC_CH4_onSCIA_ADJ(LLSCIA) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXSCIA) + REAL*8 :: TIME_FRAC(MAXSCIA) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: DO_FDTEST = .TRUE. + INTEGER :: IOS, ncount + CHARACTER(LEN=255) :: FILENAME + + ! Variables for FD testing + REAL*8 :: cost_func_pos, cost_func_neg + REAL*8 :: cost_func_0 + REAL*8 :: PERT(LLPAR) + REAL*8 :: ADJ_SAVE(LLPAR, 50) + REAL*8 :: ADJ(LLPAR, 50) + REAL*8 :: FD_CEN(LLPAR, 50) + REAL*8 :: FD_POS(LLPAR, 50) + REAL*8 :: FD_NEG(LLPAR, 50) + + + !================================================================= + ! CALC_SCIA_CH4_FORCE begins here! + !================================================================= + + print*, ' - CALC_SCIA_CH4_FORCE ' + + NEW_COST(:) = 0d0 + + + ! Open files for output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_nh3_pert.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat_dbl.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + !kjw for testing adjoint of obs operator + FILENAME = 'test_adjoint_obs.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 116, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FIRST = .FALSE. ! only open files on first call to + ENDIF + + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day. + ! If so, read SCIA CH4 observations for the day + IF ( GET_NHMS() == 230000 ) THEN + + ! Read the SCIA CH4 file for this day + CALL READ_SCIA_CH4_OBS( GET_NYMD(), NSCIA ) + + ! If NTES = 0, it means there are no observations today. + ! Return to calling procedure + IF ( NSCIA == 0 ) THEN + WRITE(6,*) ' No SCIA CH4 obs today. Returning 01 ... ' + RETURN + ENDIF + + ENDIF + + + ! If here and NSCIA = 0, there are no more observations today. + ! There were some, but they've been processed already. + ! Return to calling procedure + IF ( NSCIA == 0 ) THEN + WRITE(6,*) ' No more SCIA CH4 obs today. Returning 02 ... ' + RETURN + ENDIF + + + ! Get the range of SCIA retrievals to assimilate in the current hour + TIME_FRAC(1:NSCIA) = SCIA(1:NSCIA)%TIME + CALL GET_NT_RANGE( NSCIA, GET_NHMS(), TIME_FRAC, + & NTSTART, NTSTOP ) + + + ! If no SCIA CH4 observations during this hour, return + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + print*, ' No matching SCIA CH4 obs for this hour' + RETURN + ENDIF + + + ! Begin counting number of observations processed in this time step + ncount = 0 + + +!kjw DO NOT write satellite diagnostic file. It will take up too much space +! for SCIA assimilations +! ! Open file for this hour's satellite diagnostics +! FILENAME = 'diag_sat.YYYYMMDD.hhmm.NN' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +!kjw + + +! need to update this in order to do i/o with this loop parallel +! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, ncount, nboxes, NB, LG, I, J, LS ) +!!$OMP+PRIVATE( LHS, RHS, GC_CH4, GC_XCH4 ) +!!$OMP+PRIVATE( frac_total, frac, thistrop, thispcen ) +!!$OMP+PRIVATE( fracreplace, molec_air_onSCIA, molec_air_total ) +!!$OMP+PRIVATE( thispedg, thisad, thisch4, thisforce ) +!!$OMP+PRIVATE( GC_PCENTER, GC_PEDGE, GC_CH4_NATIVE ) +!!$OMP+PRIVATE( GC_TROP, GRIDMAP, GC_CH4_onSCIA ) +!!$OMP+PRIVATE( Sobs, DIFF, FORCE, thisad1 ) +!!$OMP+PRIVATE( DIFF_ADJ, GC_XCH4_ADJ, GC_CH4_ADJ ) +!!$OMP+PRIVATE( GC_CH4_onSCIA_ADJ, GC_CH4_NATIVE_ADJ ) + + DO NT = NTSTART, NTSTOP, -1 +! DO NT = NTSTART,NTSTART-10,-1 +! DO NT = 8776, 8776 + ! Check quality of retrieval + IF ( ( SCIA(NT)%QFLAG .ne. 1 ) .OR. + & ( SCIA(NT)%TFLAG .ne. 1 ) ) THEN + !print*, ' SKIPPING record ', NT + !print*, ' QFLAG = ', SCIA(NT)%QFLAG + CYCLE + ENDIF + + print*, ' - CALC_SCIA_CH4_FORCE: analyzing record ', NT + + ! Count this observation + ncount = ncount + 1 + + + ! For safety, initialize these up to LLSCIA + CH4_PRIOR(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GRIDMAP(:,:) = 0d0 + + + ! Get GEOS-Chem pressure and CH4 column corresponding to SCIA + ! observation. This will not be from a single grid box but + ! rather from many as determined by GCII, GCJJ and GCFRAC. + ! CH4 in [v/v] and pressure in [hPa] + + ! Initialize + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + frac_total = 0d0 + + + ! Determine number of GEOS-Chem boxes covered by the observation + nboxes = count( SCIA(NT)%GCfrac(:) .gt. 0.0 ) + + ! Loop over boxes + DO NB=1,nboxes + + ! Clear variables to be safe + I = 0 + J = 0 + frac = 0d0 + thispcen(:) = 0d0 + thispedg(:) = 0d0 + thisad(:) = 0d0 + thisch4(:) = 0d0 + thistrop = 0d0 + + + ! I and J indices and fractional influence of this box + I = SCIA(NT)%GCII(NB) + J = SCIA(NT)%GCJJ(NB) + frac = SCIA(NT)%GCfrac(NB) + thistrop = TROPP(I,J) + + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + thispcen(LG) = GET_PCENTER(I,J,LG) + + ! Pressure edges [hPa] + thispedg(LG) = GET_PEDGE(I,J,LG) + + ! mass per box [kg] + thisad(LG) = AD(I,J,LG) + + ENDDO + + ! CH4 [kg/box] --> [v/v] + ! Numerator = moles CH4/box + ! Denominator = moles air/box + thisch4(:) = ( CHK_STT(I,J,:,1 ) * XNUMOL(1) ) / + & ( thisad(:) * XNUMOLAIR ) + + ! Add pressure and ch4 columns to total + GC_PCENTER(:) = GC_PCENTER(:) + thispcen(:) * frac + GC_PEDGE(:) = GC_PEDGE(:) + thispedg(:) * frac + GC_CH4_NATIVE(:) = GC_CH4_NATIVE(:) + thisch4(:) * frac + GC_TROP = thistrop * frac + + ! Error checking. sum of fracs should = 1 + frac_total = frac_total + frac + + ENDDO + !print*,'SCIA(NT)%GCFLAG = ',SCIA(NT)%GCFRAC(1:50) + !print*,'frac_total = ',frac_total + + ! Error checking. sum of fracs should = 1 within reason + IF ( abs(frac_total-1) .gt. 1d-5 ) THEN + WRITE( 6, * ) 'ERROR in CALC_SCIA_CH4_FORCE: ' + CALL ERROR_STOP( 'fractions /= 1','GET_GC_PROFILE' ) + ENDIF + + ! Done constructing representative GEOS-Chem profile from + ! multiple grid boxes + +! ! dkh debug: compare profiles: +! print*, ' GC_PCENTER, GC_CH4_NATIVE in [v/v] ' +! WRITE(6,100) (GC_PCENTER(LG), GC_CH4_NATIVE(LG), +! & LG = LLPAR, 1, -1 ) + + + ! Get interpolation matrix that maps GEOS-Chem to SCIAMACHY grid + ! GEOS-Chem grid now in [v/v] + GRIDMAP(1:LLPAR, 1:LLSCIA) = GET_INTMAP( GC_PEDGE, + & SCIA(NT)%PRESEDGE(:) ) + + ! Interpolate GEOS-Chem CH4 column [v/v] to SCIA grid [v/v] + DO LS = 1, LLSCIA + GC_CH4_onSCIA(LS) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onSCIA(LS) = GC_CH4_onSCIA(LS) + & + GRIDMAP(LG,LS) * GC_CH4_NATIVE(LG) + ENDDO + ENDDO +! print*,'GRIDMAP = ',GRIDMAP + + CH4_PRIOR(:) = SCIA(NT)%PRIOR + !print*, ' SCIA_PRES, GC_CH4_onSCIA [v/v], SCIA_PRIOR ' +! WRITE(6,101) ( SCIA(NT)%PRES(LS), GC_CH4_onSCIA(LS), +! & CH4_PRIOR(LS), LS, LS = LLSCIA, 1, -1 ) + + + + ! Replace GEOS-Chem stratosphere with SCIAMACHY a priori strat + DO LS=1,LLSCIA + + ! If tropopause pressure less than upper box edge, continue + IF ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS+1) ) CONTINUE + + ! If trop pressure greater than lower box edge, + ! replace entire box with prior values + IF ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS) ) THEN + GC_CH4_onSCIA(LS) = CH4_PRIOR(LS) + ENDIF + + ! If trop pressure within grid box, replace fraction of value + IF ( ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS) ) .AND. + & ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS+1) ) ) THEN + fracreplace = ( GC_TROP - SCIA(NT)%PRESEDGE(LS+1) ) / + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + GC_CH4_onSCIA(LS) = (1-fracreplace) * GC_CH4_onSCIA(LS) + + & fracreplace * CH4_PRIOR(LS) + ENDIF + ENDDO + + + + ! Convert [v/v] --> [molec/cm2] for application of SCIA AK. + molec_air_onSCIA(:) = 0d0 + CH4_PRIOR(:) = SCIA(NT)%PRIOR + DO LS=1,LLSCIA + + ! Get molecules / cm2 of air in each pressure level = molec_air + ! F=ma where F in one square meter is dPressure + ! molec/cm2 of air in column + molec_air_onSCIA(LS) = + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + & * 1d2 / 9.8 * 1d-4 * 1d3 * (1/28.9644) * 6.022d23 + + ! CH4 [molec/cm2] = CH4 [v/v] * total_air [molec/cm2] + CH4_PRIOR(LS) = CH4_PRIOR(LS) * molec_air_onSCIA(LS) + GC_CH4_onSCIA(LS) = GC_CH4_onSCIA(LS) * molec_air_onSCIA(LS) + + ENDDO + + + + +! ! dkh debug: compare profiles: +! print*, ' GC_PCENTER, GC_CH4_NATIVE in [v/v]' +! WRITE(6,100) (GC_PEDGE(LG), GC_CH4_NATIVE(LG), +! & LG = LLPAR, 1, -1 ) +! print*, ' SCIA_PRES, GC_CH4_onSCIA [molec/cm2], SCIA_PRIOR ' +! WRITE(6,101) ( SCIA(NT)%PRES(LS), GC_CH4_onSCIA(LS), +! & CH4_PRIOR(LS), LS, LS = LLSCIA, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,E24.12) +! print*,'total GC on SCIA molec/cm2 = ',SUM(GC_CH4_onSCIA) + + +! !-------------------------------------------------------------- +! ! Apply SCIA observation operator +! ! +! ! x_hat = A ( x_m ) + ( 1 - A ) x_a +! ! +! ! where +! ! x_hat = GC modeled column as seen by SCIA [molec/cm2] +! ! x_a = SCIA apriori column [molec/cm2] +! ! x_m = GC modeled column [molec/cm2] +! ! A = SCIA averaging kernel +! !-------------------------------------------------------------- + + !-------------------------------------------------------------- + ! Apply SCIA observation operator + ! + ! x_hat = A ( x_m ) + ( 1 - A ) x_a + ! + ! where + ! x_hat = GC modeled column as seen by SCIA [v/v] + ! x_a = SCIA apriori column [v/v] + ! x_m = GC modeled column [v/v] + ! A = SCIA averaging kernel + !-------------------------------------------------------------- + + + ! A ( x_m ) + LHS = 0d0 + DO LS = 1, LLSCIA + LHS = LHS + SCIA(NT)%AVGKERNEL(LS) + & * GC_CH4_onSCIA(LS) + ENDDO + + ! ( 1 - A ) x_a + RHS = 0d0 + DO LS = 1, LLSCIA + RHS = RHS + ( ( 1 - SCIA(NT)%AVGKERNEL(LS) ) + & * CH4_PRIOR(LS) ) + ENDDO + + ! x_hat = A ( x_m ) + ( 1 - A ) x_a + GC_CH4 = RHS + LHS + + + ! Convert Units from [molec/cm2] --> [v/v] + ! Get molecules of air in column using F=ma + molec_air_total = 0d0 + molec_air_total = SCIA(NT)%PRESEDGE(1) * 1d2 / 9.8 * 1d-4 ! air [kg/cm2] + & * 1d3 * (1/28.9644) * 6.022d23 ! air [molec/cm2] + + ! [molec ch4 / cm2] --> [v/v] = molec CH4 / molec air in one cm^2 + GC_XCH4 = GC_CH4 / molec_air_total + !print*,'gc_xch4 = ',gc_xch4 + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + + ! Calculate error on this day, + ! given in fractional terms as a module variable + ! Sobs in [v/v]^2 + Sobs = ( ERR_FRAC * 1d-9 * SCIA(NT)%XCH4 ) **2 + + + ! Calculate difference between modeled and observed profile + DIFF = GC_XCH4 - 1d-9 * SCIA(NT)%XCH4 + !print*,'NORMAL : DIFF',DIFF + + + ! Calculate J(x) = DIFF^T * S_{obs}^{-1} * DIFF + NEW_COST(NT) = DIFF**2 / Sobs + + ! Calculate dJ/dx = 2 * DIFF * S_{obs}^{-1} + FORCE = 0d0 + FORCE = 2 * DIFF / Sobs + !print*,'NORMAL : FORCE',FORCE + + !print*,'gc_xch4 = ',gc_xch4 + !print*,'SCIA(NT)%XCH4 = ',1d-9 * SCIA(NT)%XCH4 + !print*,'diff = ',diff + !print*,'force = ',force + !print*,'Sobs = ',Sobs + ! dkh debug: compare profiles: + !print*, ' SCIA_PRIOR, XCH4_SCIA, XCH4_GC' +! WRITE(6,101) (SCIA(NT)%PRIOR(LS), SCIA(NT)%XCH4, GC_XCH4, +! & LS, LS = LLSCIA, 1, -1 ) +! 101 FORMAT(1X,E24.16,1X,E24.16,1X,E24.16,1x,i3) + WRITE(105,101) gc_xch4*1d9, SCIA(NT)%XCH4, + & gc_xch4*1d9-SCIA(NT)%XCH4 + 101 FORMAT(F15.8,5X,E15.8,5X,F15.8) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug +! print*, 'DIFF , FORCE, Sobs ' +! WRITE(6,102) (DIFF, FORCE, Sobs) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + + ! Adjoint of GEOS-Chem - SCIAMACHY difference + GC_XCH4_ADJ = DIFF_ADJ + + ! Adjoint of unit conversion from [molec/cm2] --> [v/v] + GC_CH4_ADJ = GC_XCH4_ADJ / molec_air_total + !print*,'NORMAL : GC_CH4_ADJ',GC_CH4_ADJ + + + ! Adjoint of SCIA observation operator + DO LS=1,LLSCIA + GC_CH4_onSCIA_ADJ(LS) = SCIA(NT)%AVGKERNEL(LS) * + & GC_CH4_ADJ + ENDDO + !print*,'NORMAL : GC_CH4_ONSCIA_ADJ',GC_CH4_ONSCIA_ADJ + + ! Adjoint of unit conversion [v/v] --> [molec/cm2] + DO LS=1,LLSCIA + GC_CH4_onSCIA_ADJ(LS) = GC_CH4_onSCIA_ADJ(LS) + & * molec_air_onSCIA(LS) + ENDDO + !print*,'NORMAL : GC_CH4_ONSCIA_ADJ',GC_CH4_ONSCIA_ADJ + + + ! Adjoint of replacing GEOS-Chem stratosphere with SCIA prior + DO LS=1,LLSCIA + ! If trop pressure within grid box, replace fraction of value + IF ( ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS) ) .AND. + & ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS+1) ) ) THEN + fracreplace = ( GC_TROP - SCIA(NT)%PRESEDGE(LS+1) ) / + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + GC_CH4_onSCIA_ADJ(LS) = + & (1-fracreplace) * GC_CH4_onSCIA_ADJ(LS) + ENDIF + + ! If trop pressure gt lower grid box boundary, GC_CH4_onSCIA(LS)=0 + IF ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS) ) THEN + GC_CH4_onSCIA_ADJ(LS) = 0d0 + ENDIF + + ENDDO + + + ! Adjoint of interpolation + DO LG=1,LLPAR + DO LS=1,LLSCIA + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LS) * GC_CH4_onSCIA_ADJ(LS) + ENDDO + ENDDO + !print*,'NORMAL : GC_CH4_NATIVE_ADJ',GC_CH4_NATIVE_ADJ + + + + + ! Adjoint of GEOS-Chem column averaging + ! Distribute adjoint forcing across GEOS-Chem grid boxes from + ! which the original GEOS-Chem column was calculated. + ! Adjoint forcing added to adjoint tracer array in this subroutine + + ! Determine number of GEOS-Chem boxes covered by the observation + nboxes = count( SCIA(NT)%GCfrac(:) .gt. 0.0 ) + + ! Loop over boxes, placing adjoint variable into the STT_ADJ array + DO NB=1,nboxes + + ! Clear variables to be safe + I = 0 + J = 0 + frac = 0d0 + + ! I and J indices and fractional influence of this box + I = SCIA(NT)%GCII(NB) + J = SCIA(NT)%GCJJ(NB) + frac = SCIA(NT)%GCfrac(NB) + + ! Adjoint of unit conversion from [kg/box] to [v/v] + DO LG=1,LLPAR + + ! Get mass in this grid box + thisad1 = 0d0 + thisad1 = AD(I,J,LG) + + ! adjoint of unit conversion + thisforce(LG) = GC_CH4_NATIVE_ADJ(LG) * XNUMOL(1) / + & ( thisad1 * XNUMOLAIR ) * frac + + + ! Place adjoint forcing back to adjoint array + STT_ADJ(I,J,LG,1) = STT_ADJ(I,J,LG,1) + thisforce(LG) + + + ENDDO + + ENDDO + + ! End distributing adjoint forcing to STT_ADJ array + ! print*,'thisforce = ',thisforce + + + +! ----------------------------------------------------------------------- +! Use this section to test the adjoint of the TES_CH4 operator by +! slightly perturbing model [CH4] and recording resultant change +! in calculated contribution to the cost function. +! +! This routine will write the following information for each observation +! to rundir/diagadj/test_adjoint_obs.NN.m +! +! The adjoint of the observation operator has been tested and validated +! as of 7/20/10, kjw. +! +! !IF (( DO_FDTEST ) .AND. ( nboxes .gt. 1 )) THEN + IF ( DO_FDTEST ) THEN + WRITE(116,210) ' LG' , ' box', ' TROP', + & ' GC_PRES', + & ' FD_POS', ' FD_NEG', ' FD_CEN', + & ' ADJ', ' COST_POS', ' COST_NEG', + & ' FD_POS/ADJ', ' FD_NEG/ADJ', ' FD_CEN/ADJ' + PERT(:) = 0D0 + + COST_FUNC_0 = 0d0 + CALL CALC_SCIA_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ, NT, NB ) + ADJ_SAVE(:,:) = ADJ(:,:) + + ! Write identifying information to top of satellite diagnostic file + WRITE(116,212) 'GC_PSURF ', GC_PEDGE(1) + WRITE(116,212) 'SCIA PSURF ', SCIA(NT)%presedge(1) + WRITE(116,212) 'NEW_COST: ', NEW_COST(NT) + WRITE(116,212) 'COST_FUNC_0:', COST_FUNC_0 + + ! Determine number of GEOS-Chem boxes covered by the observation + nboxes = count( SCIA(NT)%GCfrac(:) .gt. 0.0 ) + + ! Perform finite difference testing at each vertical level + ! and for each horizontal grid box in this observation + DO LG = 1, 47 + DO NB = 1, nboxes + + ! Positive perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = 0.1 + COST_FUNC_pos = 0D0 + CALL CALC_SCIA_CH4_FORCE_FD( COST_FUNC_pos, PERT, ADJ, NT, NB ) + + ! Negative perturbation to GEOS-Chem CH4 columns + PERT(:) = 0.0 + PERT(LG) = -0.1 + COST_FUNC_neg = 0D0 + CALL CALC_SCIA_CH4_FORCE_FD( COST_FUNC_neg, PERT, ADJ, NT, NB ) + + ! Calculate dJ/dCH4 from perturbations + FD_CEN(LG,NB) = ( COST_FUNC_pos - COST_FUNC_neg ) / 0.2d0 + FD_POS(LG,NB) = ( COST_FUNC_pos - COST_FUNC_0 ) / 0.1d0 + FD_NEG(LG,NB) = ( COST_FUNC_0 - COST_FUNC_neg ) / 0.1d0 + + ! Write information to satellite diagnostic file + WRITE(116, 211) LG, NB, GC_PCENTER(LG), + & FD_POS(LG,NB), FD_NEG(LG,NB), + & FD_CEN(LG,NB), ADJ_SAVE(LG,NB), + & COST_FUNC_pos, COST_FUNC_neg, + & FD_POS(LG,NB)/ADJ_SAVE(LG,NB), + & FD_NEG(LG,NB)/ADJ_SAVE(LG,NB), + & FD_CEN(LG,NB)/ADJ_SAVE(LG,NB) + ENDDO + ENDDO + + + WRITE(116,'(a)') '----------------------------------------------' + + 210 FORMAT(A4,2x,A4,A6,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x, + & A12,2x,A12,2x,A12,2x,A12,2x) + 211 FORMAT(I4,2x,I4,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6, + & 2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6) + 212 FORMAT(A12,F22.6) + 213 FORMAT(A12,I4) + 214 FORMAT(I4,2x,F18.6,2x,F18.6) +! ----------------------------------------------------------------------- + DO_FDTEST = .FALSE. + + ENDIF ! IF ( DO_FDTEST ) + + + + + ENDDO ! NT +!!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' SCIA contribution = ', COST_FUNC - OLD_COST + print*, ' # Good Observations analyzed = ', ncount + print*, ' # Total Observations read = ', NTSTART-NTSTOP + + + ! Return to calling program + END SUBROUTINE CALC_SCIA_CH4_FORCE + +!------------------------------------------------------------------------------ + + + + + + + SUBROUTINE CALC_SCIA_CH4_FORCE_FD( COST_FUNC_A, PERT, ADJ, + & NT, boxnum ) +! +!****************************************************************************** +! Subroutine CALC_SCIA_CH4_FORCE calculates the adjoint forcing from the SCIA +! CH4 observations and updates the cost function. (kjw, 07/20/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC_A (REAL*8) : Cost funciton (INOUT) [unitless] +! (2 ) PERT (Real*8) : Array of perturbations to CH4 column (+/- 0.1, for ex.) +! (5 ) ADJ (REAL*8) : Array of adjoint forcings (OUT) +! (3 ) NT (INTEGER) : Observation number to process +! (4 ) NB (INTEGER) : Box number in which to make perturbation +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD, TROPP + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : TCVV + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC_A + REAL*8, INTENT(OUT) :: ADJ(LLPAR,50) + REAL*8, INTENT(IN) :: PERT(LLPAR) + INTEGER, INTENT(IN) :: NT + INTEGER, INTENT(IN) :: boxnum + + + ! Local variables + INTEGER :: LG, LS, I, J, NB + INTEGER :: NSCIA, nboxes + INTEGER :: NTSTART, NTSTOP + REAL*8 :: GC_PCENTER(LLPAR) + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: thispcen(LLPAR) + REAL*8 :: thispedg(LLPAR) + REAL*8 :: thisad(LLPAR) + REAL*8 :: thisad1 + REAL*8 :: thisch4(LLPAR) + REAL*8 :: GRIDMAP(LLPAR,LLSCIA) + REAL*8 :: GC_CH4_onSCIA(LLSCIA) + REAL*8 :: molec_air_onSCIA(LLSCIA) + REAL*8 :: CH4_PRIOR(LLSCIA) + REAL*8 :: frac, frac_total + REAL*8 :: thistrop, GC_TROP + REAL*8 :: fracreplace + REAL*8 :: mass_air, mole_air, molec_air_total + REAL*8 :: LHS, RHS, GC_XCH4, GC_CH4 + REAL*8 :: Sobs, DIFF, FORCE + REAL*8 :: thisforce(LLPAR) + REAL*8 :: GC_XCH4_ADJ, DIFF_ADJ, GC_CH4_ADJ + REAL*8 :: GC_CH4_onSCIA_ADJ(LLSCIA) + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: NEW_COST(MAXSCIA) + REAL*8 :: OLD_COST + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + + + !================================================================= + ! CALC_SCIA_CH4_FORCE_FD begins here! + !================================================================= + + + ! Initialize for safety + ADJ(:,:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + GRIDMAP(:,:) = 0d0 + + + ! Get GEOS-Chem pressure and CH4 column corresponding to SCIA + ! observation. This will not be from a single grid box but + ! rather from many as determined by GCII, GCJJ and GCFRAC. + ! CH4 in [v/v] and pressure in [hPa] + + ! Initialize + GC_PCENTER(:) = 0d0 + GC_PEDGE(:) = 0d0 + GC_CH4_NATIVE(:) = 0d0 + frac_total = 0d0 + + + ! Determine number of GEOS-Chem boxes covered by the observation + nboxes = count( SCIA(NT)%GCfrac(:) .gt. 0.0 ) + + ! Loop over boxes + DO NB=1,nboxes + + ! Clear variables to be safe + I = 0 + J = 0 + frac = 0d0 + thispcen(:) = 0d0 + thispedg(:) = 0d0 + thisad(:) = 0d0 + thisch4(:) = 0d0 + thistrop = 0d0 + + + ! I and J indices and fractional influence of this box + I = SCIA(NT)%GCII(NB) + J = SCIA(NT)%GCJJ(NB) + frac = SCIA(NT)%GCfrac(NB) + thistrop = TROPP(I,J) + + ! Get column of pressure centers and CH4 values + DO LG=1,LLPAR + + ! Pressure centers [hPa] + thispcen(LG) = GET_PCENTER(I,J,LG) + + ! Pressure edges [hPa] + thispedg(LG) = GET_PEDGE(I,J,LG) + + ! mass per box [kg] + thisad(LG) = AD(I,J,LG) + + ENDDO + + ! CH4 [kg/box] --> [v/v] + ! Numerator = moles CH4/box + ! Denominator = moles air/box + ! Only perturb one box given by boxnum input + IF ( NB .EQ. boxnum ) THEN + DO LG=1,LLPAR + thisch4(LG) = ( CHK_STT(I,J,LG,1 ) * ( 1+PERT(LG) ) + & * XNUMOL(1) ) / ( thisad(LG) * XNUMOLAIR ) + ENDDO + ELSE + DO LG=1,LLPAR + thisch4(LG) = ( CHK_STT(I,J,LG,1 ) + & * XNUMOL(1) ) / ( thisad(LG) * XNUMOLAIR ) + ENDDO + ENDIF + + ! Add pressure and ch4 columns to total + GC_PCENTER(:) = GC_PCENTER(:) + thispcen(:) * frac + GC_PEDGE(:) = GC_PEDGE(:) + thispedg(:) * frac + GC_CH4_NATIVE(:) = GC_CH4_NATIVE(:) + thisch4(:) * frac + GC_TROP = thistrop * frac + + ! Error checking. sum of fracs should = 1 + frac_total = frac_total + frac + + ENDDO + + + ! Error checking. sum of fracs should = 1 + IF ( abs(frac_total-1) .gt. 1d-5 ) THEN + WRITE( 6, * ) 'ERROR in GET_GC_PROFILE: fractions /= 1' + CALL ERROR_STOP( 'problem','GET_GC_PROFILE' ) + ENDIF + + ! Done getting representative GEOS-Chem profile from many grid boxes + + + + ! Get interpolation matrix that maps GEOS-Chem to SCIAMACHY grid + ! GEOS-Chem grid now in [molec/m2] + GRIDMAP(1:LLPAR, 1:LLSCIA) = GET_INTMAP( GC_PEDGE, + & SCIA(NT)%PRESEDGE(:) ) + + + + ! Interpolate GEOS-Chem CH4 column to SCIA grid [v/v] --> [v/v] + DO LS = 1, LLSCIA + GC_CH4_onSCIA(LS) = 0d0 + DO LG = 1, LLPAR + GC_CH4_onSCIA(LS) = GC_CH4_onSCIA(LS) + & + GRIDMAP(LG,LS) * GC_CH4_NATIVE(LG) + ENDDO + ENDDO + + + CH4_PRIOR(:) = SCIA(NT)%PRIOR + ! Replace GEOS-Chem stratosphere with SCIAMACHY a priori strat + DO LS=1,LLSCIA + + ! If tropopause pressure less than upper box edge, continue + IF ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS+1) ) CONTINUE + + ! If trop pressure greater than lower box edge, + ! replace entire box with prior values + IF ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS) ) THEN + GC_CH4_onSCIA(LS) = CH4_PRIOR(LS) + ENDIF + + ! If trop pressure within grid box, replace fraction of value + IF ( ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS) ) .AND. + & ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS+1) ) ) THEN + fracreplace = ( GC_TROP - SCIA(NT)%PRESEDGE(LS+1) ) / + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + GC_CH4_onSCIA(LS) = (1-fracreplace) * GC_CH4_onSCIA(LS) + + & fracreplace * CH4_PRIOR(LS) + ENDIF + ENDDO + + + ! Convert [v/v] --> [molec/cm2] for application of SCIA AK. + molec_air_onSCIA(:) = 0d0 + CH4_PRIOR(:) = SCIA(NT)%PRIOR + DO LS=1,LLSCIA + + ! Get molecules / cm2 of air in each pressure level = molec_air + ! F=ma where F in one square meter is dPressure + ! molec/cm2 of air in column + molec_air_onSCIA(LS) = + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + & * 1d2 / 9.8 * 1d-4 * 1d3 * (1/28.9644) * 6.022d23 + + ! CH4 [molec/cm2] = CH4 [v/v] * total_air [molec/cm2] + CH4_PRIOR(LS) = CH4_PRIOR(LS) * molec_air_onSCIA(LS) + GC_CH4_onSCIA(LS) = GC_CH4_onSCIA(LS) * molec_air_onSCIA(LS) + + ENDDO + + ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_CH4_NATIVE ' +! WRITE(6,100) (GC_PRES(LG), GC_CH4_NATIVE(LG), +! & LG = LLPAR, 1, -1 ) +! print*, ' SCIA_PRES, GC_CH4_onSCIA ' +! WRITE(6,100) (SCIA(NT)%PRES(LS), GC_CH4_onSCIA(LS), +! & LS = LLSCIA, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) + + + !-------------------------------------------------------------- + ! Apply SCIA observation operator + ! + ! x_hat = A ( x_m ) + ( 1 - A ) x_a + ! + ! where + ! x_hat = GC modeled column as seen by SCIA [molec/cm2] + ! x_a = SCIA apriori column [molec/cm2] + ! x_m = GC modeled column [molec/cm2] + ! A = SCIA averaging kernel + !-------------------------------------------------------------- + + ! A ( x_m ) + LHS = 0d0 + DO LS = 1, LLSCIA + LHS = LHS + SCIA(NT)%AVGKERNEL(LS) * GC_CH4_onSCIA(LS) + ENDDO + + ! ( 1 - A ) x_a + RHS = 0d0 + DO LS = 1, LLSCIA + RHS = RHS + ( ( 1 - SCIA(NT)%AVGKERNEL(LS) ) + & * CH4_PRIOR(LS) ) + ENDDO + + ! x_hat = A ( x_m ) + ( 1 - A ) x_a + GC_CH4 = RHS + LHS + + ! Convert Units from [molec/cm2] --> [v/v] + ! Get molecules of air in column using F=ma + molec_air_total = 0d0 + molec_air_total = SCIA(NT)%PRESEDGE(1) * 1d2 / 9.8 * 1d-4 ! air [kg/cm2] + & * 1d3 * (1/28.9644) * 6.022d23 ! air [molec/cm2] + + ! [molec ch4 / cm2] --> [v/v] = molec CH4 / molec air in one cm^2 + GC_XCH4 = GC_CH4 / molec_air_total +! print*,'FDTEST : GC_XCH4 = ',GC_XCH4 + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is observation error covariance matrix + ! Sobs = 1x1 array [ (molec/cm2) ^2 ] + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + + ! Calculate error on this day. + ! Fractional error = ERR_FRAC, a module variable + Sobs = ( ERR_FRAC * 1d-9 * SCIA(NT)%XCH4 ) **2 + + + ! Calculate difference between modeled and observed profile + DIFF = GC_XCH4 - 1d-9 * SCIA(NT)%XCH4 +! print*,'FDTEST : DIFF = ',DIFF + + + ! Calculate J(x) = DIFF^T * S_{obs}^{-1} * DIFF + COST_FUNC_A = DIFF**2 / Sobs + + ! Calculate dJ/dx = 2 * DIFF * S_{obs}^{-1} + FORCE = 0d0 + FORCE = 2 * DIFF / Sobs + !print*,'FDTEST : FORCE = ',FORCE + + + + ! dkh debug: compare profiles: +! print*, ' SCIA_PRIOR, XCH4_SCIA, XCH4_GC' +! WRITE(6,101) (SCIA(NT)%PRIOR(L), SCIA(NT)%PRIOR(L), GC_XCH4, +! & L, L = LLSCIA, 1, -1 ) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1x,i3) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug +! print*, 'DIFF , FORCE, Sobs ' +! WRITE(6,102) (DIFF, FORCE, Sobs) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + + ! Adjoint of GEOS-Chem - SCIAMACHY difference + GC_XCH4_ADJ = DIFF_ADJ + + ! Adjoint of unit conversion from [molec/cm2] --> [v/v] + GC_CH4_ADJ = GC_XCH4_ADJ / molec_air_total + !print*,'FDTEST : GC_CH4_ADJ = ',GC_CH4_ADJ + + + ! Adjoint of SCIA observation operator + DO LS=1,LLSCIA + GC_CH4_onSCIA_ADJ(LS) = SCIA(NT)%AVGKERNEL(LS) * + & GC_CH4_ADJ + ENDDO + !print*,'FDTEST : GC_CH4_ONSCIA_ADJ = ',GC_CH4_ONSCIA_ADJ + + ! Adjoint of unit conversion [v/v] --> [molec/cm2] + DO LS=1,LLSCIA + GC_CH4_onSCIA_ADJ(LS) = GC_CH4_onSCIA_ADJ(LS) + & * molec_air_onSCIA(LS) + ENDDO + !print*,'FDTEST : GC_CH4_ONSCIA_ADJ = ',GC_CH4_ONSCIA_ADJ + + ! Adjoint of replacing GEOS-Chem stratosphere with SCIA prior + DO LS=1,LLSCIA + ! If trop pressure within grid box, replace fraction of value + IF ( ( GC_TROP .lt. SCIA(NT)%PRESEDGE(LS) ) .AND. + & ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS+1) ) ) THEN + fracreplace = ( GC_TROP - SCIA(NT)%PRESEDGE(LS+1) ) / + & ( SCIA(NT)%PRESEDGE(LS) - SCIA(NT)%PRESEDGE(LS+1) ) + GC_CH4_onSCIA_ADJ(LS) = + & (1-fracreplace) * GC_CH4_onSCIA_ADJ(LS) + ENDIF + + ! If trop pressure gt lower grid box boundary, GC_CH4_onSCIA(LS)=0 + IF ( GC_TROP .gt. SCIA(NT)%PRESEDGE(LS) ) THEN + GC_CH4_onSCIA_ADJ(LS) = 0d0 + ENDIF + + ENDDO + + + + ! Adjoint of interpolation + DO LG=1,LLPAR + DO LS=1,LLSCIA + GC_CH4_NATIVE_ADJ(LG) = GC_CH4_NATIVE_ADJ(LG) + + & GRIDMAP(LG,LS) * GC_CH4_onSCIA_ADJ(LS) + ENDDO + ENDDO + !print*,'FDTEST : GC_CH4_NATIVE_ADJ = ',GC_CH4_NATIVE_ADJ + + + + ! Adjoint of GEOS-Chem column averaging + ! Distribute adjoint forcing across GEOS-Chem grid boxes from + ! which the original GEOS-Chem column was calculated. + ! Adjoint forcing added to adjoint tracer array in this subroutine + + ! Determine number of GEOS-Chem boxes covered by the observation + nboxes = count( SCIA(NT)%GCfrac(:) .gt. 0.0 ) + + ! Loop over boxes, placing adjoint variable into the STT_ADJ array + DO NB=1,nboxes + + ! Clear variables to be safe + I = 0 + J = 0 + frac = 0d0 + + ! I and J indices and fractional influence of this box + I = SCIA(NT)%GCII(NB) + J = SCIA(NT)%GCJJ(NB) + frac = SCIA(NT)%GCfrac(NB) + + ! Adjoint of unit conversion from [kg/box] to [v/v] + DO LG=1,LLPAR + + ! Get mass in this grid box + thisad1 = 0d0 + thisad1 = AD(I,J,LG) + + ! adjoint of unit conversion + thisforce(LG) = GC_CH4_NATIVE_ADJ(LG) * XNUMOL(1) / + & ( thisad1 * XNUMOLAIR ) * frac + + + ! Calculate adjoint sensitivity for output + ADJ(LG,NB) = thisforce(LG) * CHK_STT(I,J,LG,1) + + ENDDO + + ENDDO + + ! End distributing adjoint forcing to STT_ADJ array + !print*,'-------------- FDTEST thisforce ------------------' + !print*,thisforce + + + + ! Return to calling program + END SUBROUTINE CALC_SCIA_CH4_FORCE_FD + +!------------------------------------------------------------------------------ + + + + SUBROUTINE GET_NT_RANGE( NSCIA, GCNHMS, TIME_FRAC, + & NTSTART, NTSTOP ) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) GCNYMD (INTEGER) : Current model YYYYMMDD +! (2 ) GCNHMS (INTEGER) : Current model HHMMSS +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : SCIA record number at which to start +! (1 ) NTSTOP (INTEGER) : SCIA record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NSCIA + INTEGER, INTENT(IN) :: GCNHMS + REAL*8, INTENT(IN) :: TIME_FRAC(NSCIA) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( GCNHMS == 230000 ) NTSAVE = NSCIA + + + print*, ' GET_NT_RANGE ', GCNHMS + print*, ' NTSAVE ', NTSAVE + print*, ' NSCIA', NSCIA + + CALL YMD_EXTRACT( GCNHMS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + !kjw + ! shouldn't the line below be: + ! ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC/2d0 < GC_HH_FRAC ) THEN + ! (difference is dividing H1_FRAC by 2) + ! necessary to round to nearest half hour instead of full hour + !kjw + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( GC_PEDGE, SCIA_PEDGE ) + & RESULT ( M ) +! +!****************************************************************************** +! Function GET_INTMAP creates the matrix that places GEOS-Chem column methane +! [molec/cm2] onto the 12-level pressure grid used by SCIAMACHY, M. +! GC[1x47] * M[47x12] = SCIA[1x12] (kjw, 7/21/11) +! +! Arguments as Input: +! ============================================================================ +! (3 ) GC_PEDGE (REAL*8) : LLPAR bottom pressure edges of GEOS-Chem column +! (4 ) SCIA_PEDGE (REAL*8) : LLSCIA+1 pressure edges of SCIA column +! +! Arguments as Output: +! ============================================================================ +! (1 ) M (REAL*8) : Interpolation matrix that maps GEOS-Chem to SCIA grid +! +! NOTES: +! (1 ) Based on GET_INTMAP by Daven Henze (I think). See tes_nh3_mod.f for example +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8 :: GC_PEDGE(LLPAR) + REAL*8 :: SCIA_PEDGE(LLSCIA+1) + + ! Return value + REAL*8 :: M(LLPAR,LLSCIA) + + ! Local variables + INTEGER :: LGC, LTM, LS, LG + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: GUP, GLO, SUP, SLO + REAL*8 :: column_total(LLSCIA) + + !================================================================= + ! GET_INTMAP begins here! + !================================================================= + + ! Initialize output + M(:,:) = 0D0 + + ! Loop over each pressure level of GEOS-Chem and SCIAMACHY grids + DO LG=1,LLPAR-1 + + ! Get upper and lower pressure edges of GEOS-Chem box + GUP = GC_PEDGE( LG+1 ) + GLO = GC_PEDGE( LG ) + + DO LS=1,LLSCIA + + ! Get top and bottom pressures of SCIA box + SUP = SCIA_PEDGE( LS+1 ) + SLO = SCIA_PEDGE( LS ) + + ! If both GEOS-Chem edges are within the SCIA box, map value = 1 + IF ( ( GUP .gt. SUP ) .AND. ( GLO .lt. SLO ) ) THEN + M(LG,LS) = 1 + ENDIF + + ! If both GEOS-Chem stradles a SCIA pressure level, interpolate + IF ( ( GUP .lt. SUP ) .AND. ( GLO .gt. SUP ) ) THEN + DIFF = GLO - GUP + M(LG,LS+1) = ( SUP - GUP ) / DIFF + M(LG,LS ) = ( GLO - SUP ) / DIFF + ENDIF + + ENDDO + ENDDO + + ! Add value for uppermost GEOS-Chem grid box + M(LLPAR,LLSCIA) = 1 + + + ! Correct for case in which GEOS-Chem pressure is higher than SCIAMACHY + IF ( GC_PEDGE(1) .GT. SCIA_PEDGE(1) ) THEN + + + ! If any part of GEOS-Chem box are under SCIA_PEDGE(1), let + ! this GEOS-Chem grid box contribute to the observation because + ! SCIA and GEOS-Chem should have same surface pressure. map value = 1 + DO LG=1,LLPAR-1 + + ! If GEOS-Chem box entirely below SCIA surface pressure + IF ( ( GC_PEDGE(LG) .GT. SCIA_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .GT. SCIA_PEDGE(1) ) ) THEN + M(LG,1) = 1 + ENDIF + + ! If GEOS-Chem box straddles SCIA surface pressure + IF ( ( GC_PEDGE(LG) .GT. SCIA_PEDGE(1) ) .AND. + & ( GC_PEDGE(LG+1) .LT. SCIA_PEDGE(1) ) ) THEN + DIFF = GC_PEDGE(LG) - GC_PEDGE( LG+1 ) + M(LG,1) = ( SCIA_PEDGE(1) - GC_PEDGE(LG+1) ) / DIFF + ENDIF + + ENDDO + ENDIF + + + ! Correct for case in which GEOS-Chem surface pressure is within 2nd SCIA + ! pressure level. + IF ( GC_PEDGE(1) .LT. SCIA_PEDGE(2) ) THEN + M(1,1) = 1 + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 3rd SCIA + ! pressure level. + IF ( GC_PEDGE(1) .LT. SCIA_PEDGE(3) ) THEN + M(1,2) = 1 + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 4th SCIA + ! pressure level. + IF ( GC_PEDGE(1) .LT. SCIA_PEDGE(4) ) THEN + M(1,3) = 1 + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 5th SCIA + ! pressure level. + IF ( GC_PEDGE(1) .LT. SCIA_PEDGE(5) ) THEN + M(1,4) = 1 + ENDIF + ! Correct for case in which GEOS-Chem surface pressure is within 6th SCIA + ! pressure level. + IF ( GC_PEDGE(1) .LT. SCIA_PEDGE(6) ) THEN + M(1,5) = 1 + ENDIF + + ! Normalize each column of M to 1 so that we are not creating any molecules + ! when mapping from GEOS-Chem to SCIA grids. + + ! DO NOT do this since we are mapping molc/cm2, not + ! Initialize to be safe and calculate column total + column_total(:) = 0d0 + column_total(:) = SUM( M, DIM=1 ) + + ! Normalize columns to column_total + DO LS=1,LLSCIA + M(:,LS) = M(:,LS) / column_total(LS) + ENDDO + + + + ! Return to calling program + END FUNCTION GET_INTMAP + +!----------------------------------------------------------------------------- + + + + END MODULE SCIA_CH4_MOD diff --git a/code/obs_operators/sciabr_co_obs_mod.f b/code/obs_operators/sciabr_co_obs_mod.f new file mode 100644 index 0000000..db6ec7b --- /dev/null +++ b/code/obs_operators/sciabr_co_obs_mod.f @@ -0,0 +1,1793 @@ +!$Id: sciabr_co_obs_mod.f,v 1.3 2012/03/01 22:00:27 daven Exp $ + MODULE SCIAbr_CO_OBS_MOD + +!****************************************************************************** +! Module SCIAbr_CO_OBS_MOD contains subroutines necessary to +! 1. Read SCIA Bremen (ASCII) file with CO observations (monthly data files) +! 2. Determine when SCIA CO obs are available +! 3. Transform CHK_STT into SCIA levels and then columns +! 4. Compute adjoint forcing, including transforming the difference between +! model and MOPITT back to model space using the adjoint of averaging +! kernel and interpolation code. +! +! Module Routines: +! ============================================================================ +! (1 ) READ_SCIA_CO_FILE : Read SCIA ASCII file +! (2 ) ITS_TIME_FOR_SCIA_CO_OBS: function checks model time vs. OBS_HOUR array +! (3 ) CALC_OBS_HOUR : calculates OBS_HOUR_SCIA_CO +! (4 ) COMPUTE_COLUMN : vertical gridding of CHK_STT, bin data +! (5 ) READ_ERROR_VARIANCE : Reads error variance file +! (6 ) CALC_SCIA_CO_FORCE : Calculates cost function and ADJ_STT increments +! (7 ) CLEANUP_SCIA : Deallocates memory of arrays +! +! ============================================================================ +! Module Variables: +! ============================================================================ +! (1 ) SCIACOcol(nobss) : columns read from AIRS file +! (2 ) SCIACOcol_err(nobss) : +! (3 ) COpressure(nlevs, nobss) : +! (4 ) Longitude(nobss) : vector of longitudes read from AIRS file +! (5 ) Latitude(nobss) : vector of latitudes read from AIRS file +! (6 ) COUNT_GRID(:,:,:) : array of # obs/gridsquare (in 1 day) +! (7 ) SCIA_COL_GRID(:,:,:) : gridded AIRS CO columns (computed and from file) +! (8 ) iday(:) : is a fraction of the day since beginning +! of the year +! (9 ) NObss : number of observation in each SCIA file +! (10 ) GRID_SCIA +! (11) SZA(nobs) : vector of solar zenith angle read from file +! (12) mday(nobs) : vector with day of month of obs +! (13) time_h(nobs) : vector with hour of day of obs +! (13) local_t(nobs) : vector with local time of obs +! (14) Cloud(nobs) : vector with cloud-free(0) or contam (1) + +! +! NOTES: +! (1 ) Filter on MOPITT data: morning over pass only (in mop_mod.f) and +! only use obs that are greater than 5e17 (mak, 11/18/05) +! (2 ) Now READ(read data, calculate OBS_HOUR_SCIA_CO), then +! CALC_SCIA_CO_FORCE(GRID_SCIA, compute adj forcing): (mak, 8/1/07) +! (3 ) Fixed conflict with NOBS in CMN_ADJ, now we have NObss for SCIA. +! (4 ) Move NLev to obs modules from CMN_ADJ. this variable controls the +! vertical levels on which cost function is computed; NLev=1 indicates +! we're comparing model-satellite columns (mak, 8/14/07) +! +!****************************************************************************** + + IMPLICIT NONE + + !============================================================= + ! MODULE VARIABLES + !============================================================= + PRIVATE + + PUBLIC :: READ_SCIAbr_CO_FILE + PUBLIC :: ITS_TIME_FOR_SCIABR_CO_OBS + PUBLIC :: CALC_SCIABr_CO_FORCE + + REAL*8, ALLOCATABLE :: SCIACOcol_err(:) + REAL*8, ALLOCATABLE :: SCIACOcol(:) + REAL*8, ALLOCATABLE :: Longitude(:) + REAL*8, ALLOCATABLE :: Latitude(:) + REAL*8, ALLOCATABLE :: SZA(:) + INTEGER, ALLOCATABLE :: COUNT_GRID(:,:,:) + INTEGER, ALLOCATABLE :: iday(:) + INTEGER, ALLOCATABLE :: mday(:) + REAL*8, ALLOCATABLE :: time_h(:) + INTEGER, ALLOCATABLE :: Cloud(:) + REAL*8, ALLOCATABLE :: SCIA_COL_GRID(:,:,:,:) + REAL*8, ALLOCATABLE :: ERR_COL_GRID(:,:,:) + REAL*8, ALLOCATABLE :: CHK_STT_SCIA(:,:) + INTEGER :: NObss + !INTEGER, PARAMETER :: NLev = 1 + INTEGER, PARAMETER :: NLevs = 60 + INTEGER :: NDays + INTEGER :: fId + INTEGER :: TRCNUM + INTEGER, ALLOCATABLE :: OBS_HOUR_SCIA_CO(:,:,:) + REAL*4, ALLOCATABLE :: FRACTION(:,:,:,:) + REAL*8, ALLOCATABLE :: AirMass(:,:,:) + REAL*8, ALLOCATABLE :: ADJ_SCIA_ALL(:,:,:) + REAL*4, ALLOCATABLE :: ERR_PERCENT(:,:) + INTEGER, ALLOCATABLE :: DOMAIN_OBS(:,:) + + CONTAINS + + SUBROUTINE READ_SCIAbr_CO_FILE( YYYYMMDD, HHMMSS ) + +!****************************************************************************** +! Subroutine READ_SCIA_FILE reads the SCIA ASCII file and assigns OBS_HOUR +! array based on available data. SCIA CO data are stored in a 1 month/file +! frequency. (mak, 7/12/07) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! + USE ErrorModule, ONLY : ReplaceNanAndInf + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE, YMD_EXTRACT, GET_MONTH + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, L, N + CHARACTER(LEN=255) DIR_SCIA + CHARACTER(LEN=255) FILENAME_SCIA + CHARACTER(LEN=255) FILENAME + + + integer ipx,ist,iread,it + real dsr_time,t_int,lat_c,lon_c,lat_1 + real lon_1, lat_2,lon_2,lat_3,lon_3,lat_4,lon_4 + real sza_in,los,azi + integer cld,lnd + real rms,snrad,alt,h20,h20_err,ch4,ch4_err,co,co_err + real co_corr, co_corr_err + integer coq + integer counter, count_day + INTEGER :: IU_FILE, IOS, IOS1 + CHARACTER(LEN=255) :: header + INTEGER :: LINECOUNT + INTEGER :: YEAR, MONTH, DAY + INTEGER :: DAYOM_year(12), days_so_far + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: LASTMONTH = -999 + + !============================= + ! FIRST CLEANUP IF NECESSARY: + !============================= + CALL CLEANUP_SCIA + + !======================== + ! FILENAME + !========================= + + DIR_SCIA = '/as/data/scia/monthly_good/' + !DIR_SCIA = '/as/home/ctm/mak/sciamachy/data_scia/monthly_good/' + !DIR_SCIA = '/as/home/ctm/jaf/SCIA/data/' + FILENAME_SCIA = 'SCI_WFMD_L2_w8003_YYYYMM_v0.6.was' + IU_FILE = 15 + days_so_far = -1 + DAYOM_year(:) = -1 + + + MONTH = YYYYMMDD/100 - (YYYYMMDD/10000)*100 + YEAR = YYYYMMDD/10000 + + ! Determine Ndays, number of days in the given month + SELECT CASE (MONTH) + CASE(4,6,9,11) + Ndays = 30 + CASE(2) + IF (YEAR .eq. 2004) Ndays = 29 + IF (YEAR .ne. 2004) Ndays = 28 + CASE DEFAULT + Ndays = 31 + END SELECT + + IF( YEAR ==2004) THEN + DAYOM_year = (/31,29,31,30,31,30,31,31,30,31,30,31/) + ELSEIF (YEAR ==2005) THEN + DAYOM_year = (/31,28,31,30,31,30,31,31,30,31,30,31/) + ENDIF + days_so_far = sum(DAYOM_year(1:MONTH-1)) + + CALL EXPAND_DATE( FILENAME_SCIA, YYYYMMDD, 0 ) + FILENAME = trim(DIR_SCIA)//FILENAME_SCIA + + !print*, 'filename:', FILENAME + + ! zero counters + counter = 0 + count_day = 0 + LINECOUNT = 0 + + ! Figure out how many observations to read (#lines in the file): + CALL SYSTEM('wc -l '//trim(fileName)//' > tmp.txt') + + OPEN( 5, FILE='tmp.txt', IOSTAT=IOS1 ) + IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:1' ) + + ! Read #lines + READ( 5, *, IOSTAT=IOS1 ) linecount + IF ( IOS1 /= 0 ) CALL IOERROR( IOS1, 5, 'tmp:2' ) + + ! Close file + CLOSE( 5 ) + + !PRINT*, 'There are:', LINECOUNT-39, 'good observations' + IF ( LINECOUNT == 0 ) THEN + PRINT*, 'There are no obs available, exit' + CALL GEOS_CHEM_STOP + ENDIF + + OPEN( IU_FILE, FILE=fileName, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'scia:1' ) + + NObss = linecount-39 + + ! Read SCIA header (first 41 lines, 39 lines for monthly files) + READ(IU_FILE,'(a)') HEADER + WRITE(*,*) TRIM( HEADER ) + + ! rest of header + do i=2,39 + read(IU_FILE, *) + enddo + + !========================================================= + ! ALLOCATE ARRAYS: (now that we read in their dimensions!) + !========================================================= + + ALLOCATE( iday( NObss ) ) + iday(:) = 0d0 + ALLOCATE( mday( NObss ) ) + mday(:) = 0d0 + ALLOCATE( SCIACOcol( NObss ) ) + SCIACOcol(:) = 0d0 + ALLOCATE( SCIACOcol_err( NObss ) ) + SCIACOcol_err(:) = 0d0 + ALLOCATE( Longitude( NObss ) ) + Longitude(:) = 0d0 + ALLOCATE( Latitude( NObss ) ) + Latitude(:) = 0d0 + ALLOCATE( SZA( NObss ) ) + SZA(:) = 0d0 + ALLOCATE( time_h(NObss ) ) + time_h(:) = 0d0 + ALLOCATE( Cloud( NObss ) ) + Cloud(:) = 0d0 + + !compute iday based on the input file, meaning August 1, for july file + ! then subtract iday_input - iday = day fraction within the given month + ! multiply the fraction times the NDAYS (from above), get, e.g. 15.5 + ! meaning it's July 15 at noon. use the modulus command to get day and + ! hour + + DO i = 40, NObss+39 + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'scia:2' ) + + ! Read SCIA data + read( IU_FILE, + & '(i6,i4,i6,i2,f14.9,f9.5,10f10.5,3f8.3,2i4,11e13.9,i3)', + & IOSTAT=IOS) ipx,ist,iread,it,dsr_time,t_int,lat_c,lon_c,lat_1, + & lon_1, lat_2,lon_2,lat_3,lon_3,lat_4,lon_4,sza_in,los,azi,cld, + & lnd, rms,snrad,alt,h20,h20_err,ch4,ch4_err,co,co_err,co_corr, + & co_corr_err,coq + + ! dsr_time is Starttime in frac.days since 1.1.2000 + ! time_h is obs hour for each obs + if(year == 2004) then + iday(i-39)=dsr_time-366-365*3+1 + time_h(i-39)=(dsr_time-366-365*3-iday(i-39)+1)*24 + Cloud(i-39) = cld + ELSEIF(year == 2005 ) then + iday(i-39)=dsr_time-366*2-365*3+1 + time_h(i-39)=(dsr_time-366*2-365*3-iday(i-39)+1)*24 + Cloud(i-39) = cld + else + print*, 'year is:', year + print*, 'only looking at 2004 and 2005 data' + CALL GEOS_CHEM_STOP + endif + mday(i-39)=iday(i-39)-days_so_far !gives day of the month + + ! if it's a good data (quality flag coq != 1) + + SCIACOcol(i-39) = co + SCIACOcol_err(i-39) = co_err + Latitude(i-39) = lat_c + Longitude(i-39) = lon_c !-180 ! for -180..180 range + SZA(i-39) = sza_in + + counter = counter+1 + + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + ! Echo info + !PRINT*, '### number of observations (total): ', counter + !PRINT*, 'NObss: ', NObss +! PRINT*, '### Longitude min, max: ', MINVAL( Longitude ), +! & MAXVAL( Longitude ) +! PRINT*, '### Latitude min, max: ', MINVAL( Latitude ), +! & MAXVAL( Latitude ) + !PRINT*, '### SZA min, max: ', MINVAL( SZA ), MAXVAL( SZA ) + !PRINT*, '### COcol min, max:', MINVAL(SCIACOcol),MAXVAL(SCIACOcol) +! PRINT*, '### COcol_err min, max:', MINVAL(SCIACOcol_err), +! & MAXVAL(SCIACOcol_err) + !print*, 'min/max of day of the month:', minval(mday), maxval(mday) + !print*, 'min/max hour of day:', minval(time_h), maxval(time_h) + + ! Decide how many arrays to read/store, for now 2 CO col computed + ! and CO col read from file + + TRCNUM = 1 + + !========================================================= + ! ALLOCATE ARRAYS: (now that we read in their dimensions!) + !========================================================= + + ! Allocate 2 CO column matrices for CO columns computed and read in + !from file + ALLOCATE( SCIA_COL_GRID(IIPAR, JJPAR, Ndays,TRCNUM)) + SCIA_COL_GRID(:,:,:,:) = 0d0 + ALLOCATE( ERR_COL_GRID(IIPAR, JJPAR, Ndays)) + ERR_COL_GRID(:,:,:) = 0d0 + ALLOCATE ( COUNT_GRID(IIPAR, JJPAR, Ndays)) + COUNT_GRID(:,:,:) = 0 + ALLOCATE( OBS_HOUR_SCIA_CO(IIPAR, JJPAR, NDAYS )) + OBS_HOUR_SCIA_CO(:,:,:) = 0d0 + ALLOCATE( ERR_PERCENT(IIPAR,JJPAR) ) + ERR_PERCENT(:,:) = 0d0 + + ! only compute SCIA_OBS_HOUR; grid when computing forcing + CALL CALC_OBS_HOUR + + CALL INIT_DOMAIN + + ! READ ERROR FILE + IF(GET_MONTH() .NE. LASTMONTH) THEN + CALL READ_ERROR_VARIANCE + LASTMONTH = GET_MONTH() + ENDIF + + END SUBROUTINE READ_SCIAbr_CO_FILE + +!---------------------------------------------------------------------- + + SUBROUTINE COMPUTE_COLUMN +!************************************************************************* +! This subroutine computes SCIA column, based on the averaging kernels +! COverticality from SCIA file. (jaf, 7/07) It now includes vertical +! regridding, previously done in IDL ( mak, 8/2/07) +! +! Notes: +! (1 ) The subroutine does vertical regridding of GC column. +! Then reads averaging kernels, a priori guess and pressure levels +! Then it does retrieval to get a GC column * SCIA AK. +! (2 ) CHK_STT(IIPAR,JJPAR,LLPAR,1) -> Model_CO_MR(IIPAR,JJPAR,LLPAR)-> +! ->CHK_STT_SCIA_VGRID(IIPAR,JJPAR,NLevs)->CHK_STT_STT(IIPAR,JJPAR) +!************************************************************************* + + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_HOUR, GET_DAY + USE DAO_MOD, ONLY : AD + USE TRACER_MOD, ONLY : TCVV + +# include "CMN_SIZE" ! Size parameters + + REAL*8 :: T(NLevs) + REAL*8 :: delP(NLevs) + REAL*8 :: Pedge(NLevs) + REAL*8 :: Pa(NLevs+1) + REAL*8 :: sciapress(NLevs) + REAL*8 :: xa(NLevs) + REAL*8 :: ap(NLevs) + REAL*8 :: AK(NLevs) + REAL*8 :: A(NLevs) + + REAL*8 :: alt(NLevs) + REAL*8 :: temp(NLevs) + REAL*8 :: sza20(NLevs), sza30(NLevs), sza40(NLevs) + REAL*8 :: sza50(NLevs), sza60(NLevs), sza65(NLevs) + REAL*8 :: sza70(NLevs), sza75(NLevs),sza80(NLevs),sza85(NLevs) + + INTEGER :: L, N, I, J, K, D, w, LL + INTEGER :: IU_FILE, IOS + INTEGER :: ILON, ILAT + CHARACTER(LEN=255) :: HEADER + LOGICAL, SAVE :: FIRST = .TRUE. + + REAL*8 :: Model_CO_MR(IIPAR, JJPAR, NLevs) + + xa(:) = 0d0 + ap(:) = 0d0 + Pa(:) = 0d0 + sciapress(:) = 0d0 + T(:) = 0d0 + delP(:) = 0d0 + PEdge(:) = 0d0 + + + IF ( FIRST ) THEN + ALLOCATE( CHK_STT_SCIA( IIPAR,JJPAR ) ) + CHK_STT_SCIA(:,:) = 0d0 + ALLOCATE( FRACTION(IIPAR,JJPAR,LLPAR,NLevs)) + FRACTION(:,:,:,:) = 0e0 + ALLOCATE( Airmass(IIPAR,JJPAR,NLevs)) + Airmass(:,:,:) = 0d0 + ALLOCATE( ADJ_SCIA_ALL(IIPAR,JJPAR,LLPAR)) + ADJ_SCIA_ALL= 0d0 + FIRST = .FALSE. + ELSE + CHK_STT_SCIA(:,:) = 0d0 + FRACTION(:,:,:,:) = 0e0 + Airmass(:,:,:) = 0d0 + ADJ_SCIA_ALL(:,:,:)= 0d0 + ENDIF + + Model_CO_MR(:,:,:) = 0d0 + + ! xcol = AK*geos_raw + (I - AK) *xapriori + ! OR xcol = AK*COppbv + (I-COverticality) *xapriori + ! OR model_col(1) = T.xa + A.(geos_raw - xa) + ! where T is COverticality and xa is read from file + ! READ AIRS FIRST GUESS (A PRIORI) FROM A TEXT FILE: + + !-------------------------------------------------------- + ! Open file with SCIA a priori (xa) and averaging kernels + !-------------------------------------------------------- + + IU_FILE = 15 + + OPEN( IU_FILE, FILE='ak_co_wfmdscia_V2.dat', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'aveker:1' ) + + ! Read SCIA AK file header (first 4 lines) + READ(IU_FILE,'(a)') HEADER + !WRITE(*,*) TRIM( HEADER ) + + ! rest of header + DO I = 2, 4 + READ(IU_FILE, *) + ENDDO + + DO I = 5, NLevs+4 + + L = I - 4 + ! Read SCIA info + ! Note: Pressure (Pa) is in hPa, a priori (xa) is ppmv!!! + READ( IU_FILE, 100, IOSTAT=IOS ) alt(L), sciapress(L), + & temp(L), ap(L), sza20(L), sza30(L), sza40(L), + & sza50(L), sza60(L), sza65(L), sza70(L), sza75(L), + & sza80(L), sza85(L) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'aveker:2' ) + 100 FORMAT(f7.2,2f8.2,f14.5,2x,10f8.3) + + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + ! ak file lists first row starting w/ highest altitude + ! Need to reverse order for Pa, xa; AK reversal done below + Pa(1:NLevs) = sciapress(NLevs:1:-1) + xa(1:NLevs) = ap(NLevs:1:-1) + + ! Assign top pressure (not given in AK file). + ! For this, I assume the first pressure given is halfway + ! between the pressure below (given) and the pressure + ! above (not given) + Pa(NLevs+1) = 2*Pa(NLevs) - Pa(NLevs-1) + + !--------------------------------------------------------- + ! GEOS-Chem profile on LLPAR levels, convert to NLevs =60 + !--------------------------------------------------------- + ! have: GC profile for particular day of the month and for particular + ! hour in the day CHK_STT(I,J,L) + CALL REGRIDV_SCIA( Model_CO_MR ) + print*, 'max/min of Model_CO_MR:', maxval(Model_CO_MR), + & minval(Model_CO_MR) +! print*, 'Model_CO_MR location of min',minloc(Model_CO_MR),'max ', +! & MAXLOC(Model_CO_MR) + + + ! CHK_STT is kg, since stored that way in geos_chem_mod + ! convert to v/v from kg +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L) +c$$$!$OMP+SCHEDULE( DYNAMIC ) +c$$$ DO L= 1,NLevs +c$$$ DO J= 1,JJPAR +c$$$ DO I= 1,IIPAR +c$$$ Model_CO_MR(I,J,L) = CHK_STT_SCIA_VGRID(I,J,L) +c$$$ & * ADJ_TCVV(1) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO + + !-------------------------------------------------------- + ! transfer function [molec/cm2/ppmv] + !DO L = 1, NLevs + ! t(L) = 2.12E+16*delP(L) ! FOR SCIA (since P is in hPa and have to + !ENDDO ! convert to 1/cm2 from 1/m2 + ! and a priori in ppmv) + ! column version of the averaging kernel + ! A in molec/cm2/ppmv (avgker: unitless) + + ! For each observation 1 to NObss: + DO w = 1, NObss ! loop over # of obs + + IF(floor(time_h(w)) == GET_HOUR() .AND. + & mday(w) == GET_DAY() .and. + & Cloud(w) == 0 ) THEN + + ! Look for model grid box corresponding to the SCIA observation: + ! Get I corresponding to PLON(IND) + ILON = INT( ( Longitude(w) + 180d0 ) / DISIZE + 1.5d0 ) + ! Handle date line correctly (bmy, 4/23/04) + IF (ILON > IIPAR ) ILON = ILON - IIPAR + ! Get J corresponding to PLAT(IND) + ILAT = INT( ( Latitude(w) + 90d0 ) / DJSIZE + 1.5d0 ) + + ! Initialize AK + AK(:) = 0d0 + + ! Get correct averaging kernel for given SZA of observation + IF ( (SZA(w) .ge. 0 ) .AND. (SZA(w) .lt. 25 ) ) + & AK = sza20(NLevs:1:-1) + IF ( (SZA(w) .ge. 25 ) .AND. (SZA(w) .lt. 35 ) ) + & AK = sza30(NLevs:1:-1) + IF ( (SZA(w) .ge. 35 ) .AND. (SZA(w) .lt. 45 ) ) + & AK = sza40(NLevs:1:-1) + IF ( (SZA(w) .ge. 45 ) .AND. (SZA(w) .lt. 55 ) ) + & AK = sza50(NLevs:1:-1) + IF ( (SZA(w) .ge. 55 ) .AND. (SZA(w) .lt. 62.5) ) + & AK = sza60(NLevs:1:-1) + IF ( (SZA(w) .ge. 62.5) .AND. (SZA(w) .lt. 67.5) ) + & AK = sza65(NLevs:1:-1) + IF ( (SZA(w) .ge. 67.5) .AND. (SZA(w) .lt. 72.5) ) + & AK = sza70(NLevs:1:-1) + IF ( (SZA(w) .ge. 72.5) .AND. (SZA(w) .lt. 77.5) ) + & AK = sza75(NLevs:1:-1) + IF ( (SZA(w) .ge. 77.5) .AND. (SZA(w) .lt. 82.5) ) + & AK = sza80(NLevs:1:-1) + IF ( (SZA(w) .ge. 82.5) .AND. (SZA(w) .le. 90 ) ) + & AK = sza85(NLevs:1:-1) + + ! Check that averaging kernel has been assigned + IF(MAXVAL(AK) .eq. 0) PRINT*, 'No averaging kernel assigned' + + !print*, 'scia col:', SCIACOcol(w) + + DO L = 1, NLevs ! loop over # of levels + + delP(L) = Pa(L) - Pa(L+1) + + ! Compute transfer function for particular level + T(L) = 2.12E+16*delP(L) + + ! If we have all info, compute the CO column + IF ( (T(L) .gt. 0) .AND. (AK(L) .gt. 0) ) THEN + + A(L) = T(L) * AK(L) + ! SCIA a priori info (xa) is in ppmv + ! Model profile is in v/v + CHK_STT_SCIA(ILON,ILAT) = + & CHK_STT_SCIA(ILON,ILAT) + & + T(L) * xa(L) + A(L) * + & (Model_CO_MR(ILON,ILAT,L)*1e6 - xa(L) ) + + ENDIF ! If we have all info + + ENDDO ! Loop over levels + +! print*, 'min max airmass:', minval(airmass), maxval(airmass) +! print*,'min max fraction:',minval(fraction),maxval(fraction) +! print*, 'min max ADJ_SCIA_ALL:', +! & minval(ADJ_SCIA_ALL(ILON,ILAT,:)), +! & MAXVAL(ADJ_SCIA_ALL(ILON,ILAT,:)) +! PRINT*, 'ADJ_TCVV:', ADJ_TCVV(1) +! print*, 'min max a:', minval(a), maxval(a) + DO L = 1,LLPAR + DO LL = 1,NLevs + ! d(CHK_STT_SCIA)/d(Model_CO_MR) = A(LL)*1e6 + IF (AirMass(ILON,ILAT,LL) .GT. 0) THEN + ADJ_SCIA_ALL(ILON,ILAT,L) = ADJ_SCIA_ALL(ILON,ILAT,L)+ + & (A(LL)*1e6) *(TCVV(1)/AirMass(ILON,ILAT,LL)) + & *FRACTION(ILON,ILAT,L,LL) + ENDIF + ENDDO + ENDDO + +! PRINT*, 'ADJ_SCIA_ALL:', ADJ_SCIA_ALL(ILON,ILAT,:) + + ! SCIA column + SCIA_COL_GRID(ILON,ILAT,mday(w),1) = + & SCIA_COL_GRID(ILON,ILAT,mday(w),1) + SCIACOcol(W)/0.9 + + ! SCIA column error + ERR_COL_GRID(ILON,ILAT,mday(w)) = + & ERR_COL_GRID(ILON,ILAT,mday(w))+ SCIACOcol_err(w) + !print*, 'model col:', CHK_STT_SCIA(ILON,ILAT) + + ENDIF !time and day of the model is the same as this obs + ENDDO ! Loop over observations + + !======================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !======================================= + + ! Getting a day of the month ok if one month at a time + D = GET_DAY() + +! print*, 'before averaging:' +! PRINT*, '### SCIA_COL_GRID min, max: ', +! & MINVAL( SCIA_COL_GRID(:,:,D,1) ), MAXVAL( SCIA_COL_GRID(:,:,D,1)) +! PRINT*, '### CHK_STT_SCIA min, max: ', +! & MINVAL( CHK_STT_SCIA ), MAXVAL( CHK_STT_SCIA ) +! PRINT*, '### ERR_COL_GRID min, max: ', +! & MINVAL( ERR_COL_GRID(:,:,D) ), MAXVAL( ERR_COL_GRID(:,:,D)) + + DO I = 1, IIPAR + DO J = 1, JJPAR + IF ( COUNT_GRID(I,J,D) .gt. 0. ) then + ! average SCIA + SCIA_COL_GRID(I,J,D,1) = SCIA_COL_GRID(I,J,D,1)/ + & COUNT_GRID(I,J,D) + + ! average SCIA error + ERR_COL_GRID(I,J,D) = ERR_COL_GRID(I,J,D)/COUNT_GRID(I,J,D) + + ! average model + CHK_STT_SCIA(I,J) = CHK_STT_SCIA(I,J)/COUNT_GRID(I,J,D) + + DO L = 1,LLPAR + ! d(CHK_STT_SCIA)/d(Model_CO_MR) = A(LL)*1e6 + ADJ_SCIA_ALL(I,J,L) = ADJ_SCIA_ALL(I,J,L)/COUNT_GRID(I,J,D) + ENDDO + ELSE + SCIA_COL_GRID(I,J,D,:) = -999. + ERR_COL_GRID(I,J,D) = -999. + CHK_STT_SCIA(I,J) = -999. + ADJ_SCIA_ALL(I,J,:) = 0d0 + ENDIF + ENDDO + ENDDO + + PRINT*, '### SCIA_COL_GRID min, max: ', + & MINVAL( SCIA_COL_GRID(:,:,D,1) ), MAXVAL( SCIA_COL_GRID(:,:,D,1)) + PRINT*, '### CHK_STT_SCIA min, max: ', + & MINVAL( CHK_STT_SCIA ), MAXVAL( CHK_STT_SCIA ) +! PRINT*, '### ERR_COL_GRID min, max: ', +! & MINVAL( ERR_COL_GRID(:,:,D) ), MAXVAL( ERR_COL_GRID(:,:,D)) +! PRINT*, '### ADJ_SCIA_ALL min, max:', +! & MINVAL( ADJ_SCIA_ALL ) , MAXVAL(ADJ_SCIA_ALL) +! call flush(6) +! PRINT*, '### COUNT_GRID min, max: ', +! & MINVAL( COUNT_GRID(:,:,:) ), MAXVAL( COUNT_GRID(:,:,:)) +! PRINT*, 'TODAY:' +! PRINT*, '### COUNT_GRID min, max: ', +! & MINVAL( COUNT_GRID(:,:,D) ), MAXVAL( COUNT_GRID(:,:,D) ) + + END SUBROUTINE COMPUTE_COLUMN + +!---------------------------------------------------------------------- + + SUBROUTINE READ_ERROR_VARIANCE + + USE ERROR_MOD, ONLY : ERROR_STOP, GEOS_CHEM_STOP + USE BPCH2_MOD + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_TAU + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=255) :: INPUT_FILE + INTEGER :: I, IOS, J, L + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + REAL*4 :: TRACER(IIPAR,JJPAR) + INTEGER :: HALFPOLAR + INTEGER :: CENTER180 + INTEGER :: NI, NJ, NL, k + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + REAL*8 :: ZTAU0, ZTAU1, TAUTMP + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + INTEGER :: IU_FILE + LOGICAL :: IT_EXISTS + + INPUT_FILE = 'RRE_seasonMay1sciabrGlobal.bpch' + IU_FILE = 66 + + PRINT*, 'SET ERROR TO 30% AS WE SAVE SCIA FOR RRE CALCULATION' + ERR_PERCENT(:,:) = 0.3 + GOTO 121 + + !================================================================ + ! READ OLD RESTART FILE + !================================================================ + FILENAME = TRIM( INPUT_FILE ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'O B S E R R O R F I L E' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_FILE: Reading ', a ) + + ERR_PERCENT(:,:) = -999d0 + + !READ SEASONAL ERRORS: + IF (((GET_TAU() .ge. 169440.) .and.(GET_TAU().lt. 170184.)) + &.or.((GET_TAU() .ge. 176736.) .and.(GET_TAU().lt. 178200.)))THEN + ! if May 2004, March 2005 or April 2005: read spring error + TAUTMP = 169440.00 + ELSEIF((GET_TAU() .ge. 170184.).and.(GET_TAU().lt. 172392.))THEN + ! if June 2004 through August 2004, read summer error + TAUTMP = 170184.00 + ELSEIF((GET_TAU() .ge. 172392.).and.(GET_TAU().lt. 174576.))THEN + ! if September 2004 through November 2004, read fall error + TAUTMP = 172392.00 + ELSEIF((GET_TAU().ge. 174576.).and.(GET_TAU() .lt. 176736.))THEN + TAUTMP = 174576.00 + ELSE + PRINT*, 'missing obs error for tau:', GET_TAU() + CALL GEOS_CHEM_STOP + ENDIF + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME ) + ! Echo more output + + !================================================================= + ! Read tracers -- store in the TRACER array + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:4' ) + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:5') + + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( TRACER(I,J), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'read_file:6') + + !============================================================== + ! Assign data from the TRACER array to the ERR_PERCENT array. + !============================================================== + IF ( ZTAU0 == TAUTMP ) THEN + PRINT*, 'Reading error for tau:', ztau0 + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !print*, 'inside the loop' + !print*, 'max value is:', maxval(TRACER(:,:,:)) + !print*, 'min value is:', minval(TRACER) + +! This OpenMP Pragma breaks compilation on ifort 12 (yd 10/22/2012) +!!yd!$OMP PARALLEL DO +!!yd!$OMP+DEFAULT( SHARED ) +!!yd!$OMP+PRIVATE( I, J , L) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF(TRACER(I,J) .ge. 0.05)THEN + ERR_PERCENT(I,J) = TRACER(I,J) + + ELSEIF((TRACER(I,J) .lt. 0.05).and.(TRACER(I,J).gt.0)) THEN + ERR_PERCENT(I,J) = 0.05 + + ELSE + ERR_PERCENT(I,J) = TRACER(I,J) + + ENDIF + + ENDDO + ENDDO +!!yd!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + 121 CONTINUE + + print*, 'max value is:', maxval(ERR_PERCENT(:,:)) + print*, 'min value is:', minval(ERR_PERCENT) + + CALL FLUSH(6) + END SUBROUTINE READ_ERROR_VARIANCE + +!--------------------------------------------------------------------------- + + SUBROUTINE GRID_SCIA +!********************************************************************* +! GRIDS SCIA ARRAYS ONTO GEOS-CHEM GRID OF CHOICE (e.g GEOS3 2x2.5) +!********************************************************************* + +# include "CMN_SIZE" + + INTEGER :: W, ILON, ILAT, I, J, M, D, count_day + + + !===================================================== + ! GRID_SCIA begins here + !===================================================== + + ! at time point while looping over all obs we need to figure out + ! what day is the obs from to assign it to the correct 3rd dimension. + count_day = 0 + + DO W = 1, NOBSS + ! COMPUTE LONGITUDE AND LATITUDE + !================================================================= + ! Look for model grid box corresponding to the MOPITT observation: + ! Get I corresponding to PLON(IND) + ILON = INT( ( Longitude(W) + 180d0 ) / DISIZE + 1.5d0 ) + ! Handle date line correctly (bmy, 4/23/04) + IF (ILON > IIPAR ) ILON = ILON - IIPAR + ! Get J corresponding to PLAT(IND) + ILAT = INT( ( Latitude(W) + 90d0 ) / DJSIZE + 1.5d0 ) + + ! IF valid column obs, increment the counter for that box + IF(SCIACOcol(W) .gt. 0) THEN + D = mday(w) + + DO I = 1, TRCNUM + IF (I .eq. 1 ) THEN + SCIA_COL_GRID(ILON,ILAT,D,I) = + & SCIA_COL_GRID(ILON,ILAT,D,I) + SCIACOcol(W) + ERR_COL_GRID(ILON,ILAT,D) = + & ERR_COL_GRID(ILON,ILAT,D) + SCIACOcol_err(w) + ELSEIF ( I .eq. 2 ) THEN +! CO_COL_GRID(ILON,ILAT,D,I) = +! & CO_COL_GRID(ILON,ILAT,D,I) + +! & (COcol(W) - COcol_pro(W)) + ENDIF + ENDDO + + ENDIF + + count_day = count_day+1 + ENDDO ! Loop over obs + + print*,'number of obs this month',count_day + +! print*,'Bin output model and scia data into array....' + + !======================================= + ! BIN OUTPUT INFO INTO MODEL GRID BOXES + !======================================= + + DO D = 1, NDays + DO I = 1, IIPAR + DO J = 1, JJPAR + IF ( COUNT_GRID(I,J,D) .gt. 0. ) then + DO M = 1, TRCNUM + SCIA_COL_GRID(I,J,D,M) = SCIA_COL_GRID(I,J,D,M)/ + & COUNT_GRID(I,J,D) + IF(M == 1) THEN + ERR_COL_GRID(I,J,D) = ERR_COL_GRID(I,J,D)/COUNT_GRID(I,J,D) + ENDIF + ENDDO + ELSE + SCIA_COL_GRID(I,J,D,:) = -999. + ERR_COL_GRID(I,J,D) = -999. + ENDIF + ENDDO + ENDDO + ENDDO ! Loop over days + + PRINT*, '### SCIA_COL_GRID min, max: ', + & MINVAL( SCIA_COL_GRID(:,:,:,1) ), MAXVAL( SCIA_COL_GRID(:,:,:,1)) + PRINT*, '### ERR_COL_GRID min, max: ', + & MINVAL( ERR_COL_GRID(:,:,:) ), MAXVAL( ERR_COL_GRID(:,:,:)) + + END SUBROUTINE GRID_SCIA + +!------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_SCIAbr_CO_OBS( ) RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_MOPITT_OBS returns TRUE if there are observations +! available for particular time (hour of a particular day) based on +! the OBS_HOUR array which holds the hour of obs in each gridbox (computed +! when file read in mop02_mod.f) (mak, 7/12/07) +! +! NOTES: +! +!****************************************************************************** +! + + USE TIME_MOD, ONLY : GET_HOUR, GET_MINUTE, GET_DAY + +# include "CMN_SIZE" ! Size params + + ! Function value + LOGICAL :: FLAG + + INTEGER :: I,J, D + + !================================================================= + ! ITS_TIME_FOR_SCIAbr_CO_OBS begins here! + !================================================================= + + ! Default to false + FLAG = .FALSE. + + DO J = 1,JJPAR + DO I = 1,IIPAR + IF(GET_HOUR() == OBS_HOUR_SCIA_CO(I,J,GET_DAY()) + & .AND. GET_MINUTE() == 0 ) THEN + print*, 'obs_hour was', GET_HOUR(), 'in box', i, j + FLAG = .TRUE. + GOTO 11 + ENDIF + ENDDO + ENDDO + + 11 CONTINUE + END FUNCTION ITS_TIME_FOR_SCIAbr_CO_OBS + +!--------------------------------------------------------------------------- + + SUBROUTINE CALC_SCIAbr_CO_FORCE + + ! References to F90 modules + USE ERROR_MOD, ONLY : IT_IS_NAN, ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TIME_MOD, ONLY : GET_HOUR, GET_NYMDe, GET_NHMSe, + & GET_DAY + USE ADJ_ARRAYS_MOD, ONLY : SET_OBS,SET_MODEL,SET_MODEL_BIAS, + & SET_FORCING,COST_ARRAY,OBS_COUNT, + & STT_ADJ, COST_FUNC, IFD, JFD, + & LFD, NFD, ADJ_FORCE, + & DAY_OF_SIM + ! if no AK, need access to STT + USE TRACER_MOD, ONLY : STT + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD, LDCOSAT + +# include "CMN_SIZE" ! Size parameters + + ! Internal variables + REAL*8 :: DIFF_COST + REAL*8 :: NEW_COST(IIPAR,JJPAR) + INTEGER :: I, J, L, N, LL + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D15 + REAL*8 :: MAX_ADJ_TMP + REAL*4 :: invSy(IIPAR,JJPAR) !error variance for column + INTEGER :: DAYOM + REAL*8 :: Sy + LOGICAL :: USING_AK = .TRUE. + + !================================================================ + ! CALC_SCIAbr_CO_FORCE begins here! + !================================================================ + + !print*, 'in CALC_SCIA_CO_FORCE' + + ! Some error checking stuff + MAX_ADJ_TMP = MAXVAL( STT_ADJ ) + ADJ_EXPLD_COUNT = 0 + Sy = 0d0 + + !initialize: + NEW_COST(:,:) = 0d0 + + ! reinitialize domain + CALL INIT_DOMAIN + + IF ( USING_AK ) THEN + ! grid scia and compute GC*AK (column value as CHK_STT_SCIA) + ! COL obs from GC to compare to scia + print*, 'using averaging kernels' + CALL COMPUTE_COLUMN + ELSE + ! NO AVERAGING KERNELS + print*, 'not using averaging kernels' + IF(.not. (ALLOCATED( CHK_STT_SCIA) )) THEN + ALLOCATE( CHK_STT_SCIA( IIPAR,JJPAR ) ) + CHK_STT_SCIA(:,:) = 0d0 + ENDIF + CALL GRID_SCIA + + ! compute straight column, no averaging kernels for now + !CHK_STT_SCIA(:,:) = SUM(CHK_STT,3) + ! this gives us a GC column in kg +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N) + DO N = 1, 1 !FOR NOW, UNTIL WE have more than just CO obs + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1, LLPAR + CHK_STT_SCIA(I,J) = CHK_STT_SCIA(I,J) + STT(I,J,L,N) + ENDDO + ! kg -> molec/cm2 conversion + ! molec/cm2 = kg * 1000g/kg / (28g/mole) * 6.02 *10^23 molec/mole + ! * (1/GET_AREA_CM2) + CHK_STT_SCIA(I,J) = CHK_STT_SCIA(I,J) * 1000 / 28 * 6.02 * 1e23 + & * (1/GET_AREA_CM2(J)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + print*, 'min/max GC/scia column:', minval(chk_stt_scia), + & maxval(chk_stt_scia) + + ENDIF !using AK + + ! DAY of the month: + DAYOM = GET_DAY() + + ! Compute error for each day of the obs and store its inverse in invSy + invSy(:,:) = 0d0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, Sy) + DO J = 1, JJPAR + DO I = 1, IIPAR + IF( (SCIA_COL_GRID(I,J,DAYOM,1) .GT. 1e15) .and. + & (GET_HOUR() .EQ. OBS_HOUR_SCIA_CO(I,J,DAYOM)) .and. + & (ERR_PERCENT(I,J) .gt. 0) .and. + & (DOMAIN_OBS(I,J) .eq. 1) )THEN +! invSy(I,J) = 1/((ERR_COL_GRID(I,J,DAYOM)/100.0)**2 * + ! 50% error +! invSy(I,J) = 1/((50.0/100.0)**2 * +! & SCIA_COL_GRID(I,J,DAYOM,1)**2) + Sy= ERR_PERCENT(I,J)**2 * + & SCIA_COL_GRID(I,J,DAYOM,1)**2 + invSy(I,J) = 1.0/Sy + + IF ( invSy(i,j) .gt. 1 ) THEN + CALL ERROR_STOP('invSy is too big', 'scia_co_obs_mod.f') + ENDIF + ELSE + !DOMAIN_OBS(I,J)=0 + + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! print*, 'min/max of % error:', +! & minval(err_col_grid(:,:,DAYOM)), maxval(err_col_grid(:,:,DAYOM)) +! print*, 'min/max of error:', +! & minval(invSy), maxval(invSy) + +! PRINT*, 'min/max of STT_ADJ, before obs:' +! PRINT*, minval(STT_ADJ), maxval(STT_ADJ) +! print*, 'STT_ADJ location of min', minloc(STT_ADJ),'max ', +! & MAXLOC(STT_ADJ) +! print*, 'adj stt(6,39,:)',adj_stt(6,39,:,1) + + !DO N = 1, NOBS + !DO L = 1, NLEV !for SCIA NLEV=1, since using column data +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, LL) +!$OMP+PRIVATE( DIFF_COST ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Determine the contribution to the cost function in each grid cell + ! from each species + ! CO_COL_GRID is SCIA observations + IF ( (SCIA_COL_GRID(I,J,DAYOM,1) .GT. 1e15) .and. + & (GET_HOUR() .EQ. OBS_HOUR_SCIA_CO(I,J,DAYOM)) .and. + & (DOMAIN_OBS(I,J) .eq. 1) )THEN + + DIFF_COST = (CHK_STT_SCIA(I,J) - SCIA_COL_GRID(I,J,DAYOM,1)) + + ! Calculate new additions to cost function + ! include all regions for which there are obs + ! NOTE: a bit of a mismatch in weight_obs in vertical + NEW_COST(I,J) = DOMAIN_OBS(I,J) * + ! Updated for consistency with merged CALC_APRIOR (dkh, 01/18/12, adj32_017) + ! (DIFF_COST ** 2) * invSy(I,J) + & 0.5d0 * (DIFF_COST ** 2) * invSy(I,J) + + ! Check for errors +!$OMP CRITICAL + IF ( IT_IS_NAN( NEW_COST(I,J) ) ) THEN + WRITE(6,*) ' Bad NEW_COST in ', I, J, + & ' from OBS, CHK, DOMAIN_OBS = ', +! & OBS_STT(I,J,L,N), CHK_STT_MOP(I,J,L,N), + & DOMAIN_OBS(I,J), DIFF_COST, invSy(i,j) + + CALL ERROR_STOP('NEW_COST is NaN', 'adjoint_mod.f') + ENDIF +!$OMP END CRITICAL + + ! update diagnostic arrays if we're saving these diagnostics + IF ( LDCOSAT ) THEN + CALL SET_MODEL(I,J,DAY_OF_SIM,2,CHK_STT_SCIA(I,J)) + CALL SET_OBS(I,J,DAY_OF_SIM,2,SCIA_COL_GRID(I,J,DAYOM,1)) + CALL SET_MODEL_BIAS(I,J,DAY_OF_SIM,2, + & DIFF_COST/SCIA_COL_GRID(I,J,DAYOM,1)) + CALL SET_FORCING(I,J,DAY_OF_SIM,NEW_COST(I,J)) + PRINT*, 'MODEL:', I,J,CHK_STT_SCIA(I,J) + PRINT*, 'SCIA:', SCIA_COL_GRID(I,J,DAYOM,1) + + ! Update cost array + COST_ARRAY(I,J,DAY_OF_SIM) = COST_ARRAY(I,J,DAY_OF_SIM) + + & NEW_COST(I,J) + + ENDIF + + OBS_COUNT(I,J) = OBS_COUNT(I,J) + 1 + + !Adjoint of obs operator, LOOP over all 30 levels + DO LL=1,LLPAR + + ! Force the adjoint variables x with dJ/dx + ! NO AVERAGING KERNERLS +! ADJ_FORCE(I,J,LL,1) = 2.0D0 * DOMAIN_OBS(I,J) +! & * DIFF_COST * invSy(I,J) * 1000.0/28.0*6.02 * 1e23 +! & * (1/GET_AREA_CM2(J)) + + ! WITH AVERAGING KERNERLS + ! Updated for consistency with merged CALC_APRIOR (dkh, 01/18/12, adj32_017) + !ADJ_FORCE(I,J,LL,1) = 2.0D0 * DOMAIN_OBS(I,J) + ADJ_FORCE(I,J,LL,1) = DOMAIN_OBS(I,J) + & * DIFF_COST * invSy(I,J)* ADJ_SCIA_ALL(I,J,LL) + + ! Update STT_ADJ, first tracer (CO) + STT_ADJ(I,J,LL,1) = STT_ADJ(I,J,LL,1) + ADJ_FORCE(I,J,LL,1) + + ENDDO + + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + !ENDDO + !ENDDO + + PRINT*, 'OBS this hour:', sum(domain_obs(:,:)) + print*, 'OBS so far:', sum(obs_count) + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + ! Update cost function + !PRINT*, 'min/max of ADJ_FORCE:' + !PRINT*, minval(ADJ_FORCE), maxval(ADJ_FORCE) + !print*, 'location of min/max of ADJ_FORCE' + !PRINT*, minloc(ADJ_FORCE), MAXLOC(ADJ_FORCE) + !print*, 'adj force(6,41,:)',adj_force(6,41,:,1) + + !PRINT*, 'min/max of STT_ADJ:' + !PRINT*, minval(STT_ADJ), maxval(STT_ADJ) + !PRINT*, 'min/max of ADJ_EMS:' + !PRINT*, minval(ADJ_EMS), maxval(ADJ_EMS) + !print*, 'location of min', minloc(ADJ_EMS),'max of ADJ_EMS', +! & MAXLOC(ADJ_EMS) +! print*, 'adj stt(6,41,:)',adj_stt(6,41,:,1) +! print*, 'adj_stt(9,39,:)',adj_stt(9,39,:,1) + + PRINT*, 'min/max of NEW_COST' + PRINT*, minval(NEW_COST), maxval(NEW_COST) + !PRINT*, 'NEW_COST(FD)=', NEW_COST(IFD,JFD,NFD) + PRINT*, 'TOTAL NEW_COST = ', SUM(NEW_COST) + PRINT*, 'COST_FUNC BEFORE ADDING NEW_COST=', COST_FUNC + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + !COST_ARRAY(1,1,1) = COST_ARRAY(1,1,1) + SUM ( NEW_COST ) + + ! Echo output to screen + IF ( LPRINTFD ) THEN + !WRITE(6,*) ' ADJ_FORCE(:) = ', ADJ_FORCE(IFD,JFD,:,NFD) + WRITE(6,*) ' Using predicted value (CHK_STT_SCIA) = ', + & CHK_STT_SCIA(IFD,JFD), '[molec/cm2]' + WRITE(6,*) ' Using observed value (SCIA_STT) = ', + & SCIA_COL_GRID(IFD,JFD,DAYOM,1), '[molec/cm2]' + WRITE(6,*) ' Using WEIGHT = ', DOMAIN_OBS (IFD,JFD) + WRITE(6,*) ' ADJ_FORCE = ', + & ADJ_FORCE(IFD,JFD,LFD,NFD) + WRITE(6,*) ' STT_ADJ = ', + & STT_ADJ(IFD,JFD,LFD,NFD) + WRITE(6,*) ' NEW_COST = ', + & NEW_COST(IFD,JFD) + ENDIF + + END SUBROUTINE CALC_SCIAbr_CO_FORCE + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_OBS_HOUR + +!*************************************************************************** +! Subroutine CALC_OBS_HOUR computes an array of hours for each day of obs. +! If there is an obs in a particular gridbox on that day, it assigns the +! hour (0..23). If there isn't, OBS_HOUR stays initialized to -1. Also, +! this subroutine computes COUNT_GRID array. +! (mak, 12/14/05) +!*************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE BPCH2_MOD, ONLY : GET_TAU0 + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, + & GET_YEAR, GET_HOUR + +# include "CMN_SIZE" + + INTEGER :: W, I, J, D + INTEGER :: ilon, ilat + REAL*4 :: OBS_HOURr(IIPAR,JJPAR, NDAYS) + integer :: count, as + + count_grid(:,:,:) = 0d0 + OBS_HOUR_SCIA_CO(:,:,:) = -99 + OBS_HOURr(:,:,:) = 0 + count = 0 + + !print*, 'in calc_obs_hour' + DO W = 1, NOBSS + + !================================================================= + ! COMPUTE LONGITUDE AND LATITUDE + !================================================================= + ! Look for model grid box corresponding to the MOPITT observation: + ! Get I corresponding to PLON(IND) + ILON = INT( ( Longitude(W) + 180d0 ) / DISIZE + 1.5d0 ) + ! Handle date line correctly (bmy, 4/23/04) + IF ( ILON > IIPAR ) ILON = ILON - IIPAR + ! Get J corresponding to PLAT(IND) + ILAT = INT( ( Latitude(W) + 90d0 ) / DJSIZE + 1.5d0 ) + if ( (ilon .eq. -999) .or. (ilat .eq. -999) ) then + print*,'ilon,ilat=',ilon,ilat + print*,'STOP' + stop + endif + + ! If there's an obs, calculate the time + IF(SCIACOcol(W) .gt. 0) THEN + + D = mday(w) + + OBS_HOURr(ILON,ILAT,D) = OBS_HOURr(ILON,ILAT,D) + & + time_h(w) + count_grid(ILON,ILAT,D) = count_grid(ILON, ILAT,D) + 1 + + ENDIF + +! print*, 'obs hour in:', ilon, ilat, 'is:', obs_hour(ilon,ilat) + + ENDDO + + ! average obs_hour on the grid +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, D, count) + DO D = 1, NDAYS + DO J = 1, jjPAR + DO I = 1, IIPAR + + IF ( COUNT_GRID(I,J,D) .gt. 0. ) then + + OBS_HOUR_SCIA_CO(I,J,D) = FLOOR(OBS_HOURr(I,J,D)/ + & COUNT_GRID(I,J,D)) + count = count + 1 + !IF( D == 2 ) THEN + ! PRINT*, I,J, OBS_HOUR_SCIA_CO(I,J,D) + !ENDIF + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !print*, 'obs hour in 144,45 is:', obs_hour(144,45) + !print*, 'today we have',sum(COUNT_GRID(:,:,GET_DAY()),'obs.' + + END SUBROUTINE CALC_OBS_HOUR +!--------------------------------------------------------------------------- + + SUBROUTINE REGRIDV_SCIA( Model_CO_MR ) +!*************************************************************************** +! Subroutine REGRIDV_SCIA regrids CHK_STT from LLPAR levels of the GC to +! NLevs of SCIA retrieval. This code is a direct Fortran translation +! of Jenny Fisher's IDL code, which was in turn constructed from +! gamap's regridv.pro It calls a subroutine REGRID_COLUMN, which is a +! Fortran translation of IDL code, which apparently was a translation of +! Fortran code that we can no longer locate, which is a shame. (mak, 8/8/07) +! +! NOTES: +! (1 ) Missing from the idl version (Not needed here): +! ! Airmass on input grid is AD(I,J,L) +! ! Convert data from [v/v] to mass +! ! CHK_STT is already in kg +! ! Regrid vertically -- preserve column mass (now in kg) +! !OutCol = Regrid_Column( InCol, InPEdge, OutPEdge, $! ! No_Check=No_Check, _EXTRA=e ) +! ! OutCol is now CHK_STT_SCIA_VGRID + +!*************************************************************************** + + USE ERROR_MOD, ONLY : ERROR_STOP + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : GET_DAY + USE PRESSURE_MOD, ONLY: GET_PEDGE + USE CHECKPT_MOD, ONLY : CHK_PSC + USE TRACER_MOD, ONLY : STT, TCVV + +# include "CMN_SIZE" ! PTOP, LLPAR, JJPAR, IIPAR + + ! NLevs = 60 levels of SCIA AKs and pressure levels + REAL*8, INTENT(INOUT):: Model_CO_MR(IIPAR, JJPAR, NLevs) + REAL*8 :: CHK_STT_SCIA_VGRID(IIPAR,JJPAR,NLevs) + REAL*8 :: SCIAPress(NLevs) + REAL*8 :: InPEdge(LLPAR+1) + REAL*8 :: OutPEdge(NLevs+1) + REAL*8 :: SCIAEdge(NLevs+1) + REAL*8 :: SCIAEdgePressure(NLevs+1) + REAL*8 :: surfP + !REAL*8 :: FRACTION(LLPAR,NLevs) + !REAL*8 :: AirMass(NLevs) + + INTEGER I, J, D, L, LL, IU_FILE, IOS, k + REAL*8 :: HI, LOW, DIFF + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: valid = .FALSE. + + !================================================================ + ! Read SCIA Pressure info + !================================================================ + + IU_FILE=16 + FRACTION(:,:,:,:) = 0d0 + + ! Read SCIA pressures + OPEN( IU_FILE, FILE='SCIA_pressure.dat', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'sciaP:1' ) + + READ( IU_FILE, 100, IOSTAT=IOS) SCIAPress + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'sciaP:2' ) + 100 FORMAT(f7.2) + + + ! Close file + CLOSE( IU_FILE ) + + ! SURFACE PRESSURE: use checkpointed pressure + !------------------- + SCIAEdge(1:60) = SCIAPress(60:1:-1) + !print*, 'scia pressure, max and min:' + !print*, maxval(sciaedge(1:60)), minval(sciaedge(1:60)) + + !Assume first given edge is 0.01hPa + SCIAEdge(61) = 0.01 + + !Store pressure edges + SCIAEdgePressure = SciaEDGE + + ! Convert to sigma scale + surfP=SCIAEdge(1) + DO k = 1,61 + SCIAEdge(k)=SCIAEdge(k)/surfP + ENDDO + + !------------------- + ! REGRID DATA + !------------------- + + CHK_STT_SCIA_VGRID(:,:,:) = 0d0 + + D = GET_DAY() + + ! Loop over surface grid boxes + ! WARNING: parallelization screws it up. (mak, 8/15/07) +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, LL, valid, first) + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( COUNT_GRID(I,J,D) .gt. 0. ) then + + !to be safe, remove junk values: + fraction(i,j,:,:) = 0d0 + + DO L = 1, LLPAR + ! OutVertEdge = AIRSEdgePressure / PSurf[I,J] + ! Pressure edges on INPUT and OUTPUT grids + ! both in and out pressures in hPa + InPEdge(L) = ( GET_PEDGE(I,J,L) ) !* Psurf(I,J)) + PTOP)/100 + ENDDO + InPEdge(LLPAR+1) = PTOP + + ! OutPEdge = ( OutVertEdge * PSurf[I,J] ) ;+ OutType.PTOP + OutPEdge(:) = SCIAEdgePressure(:) + + !===================================================== + ! Determine fraction of each INPUT box + ! which contributes to each OUTPUT box + !===================================================== + ! LM1 = LLPAR, L = L, LM2 = NLevs, K = LL + ! Loop over INPUT layers + FIRST = .TRUE. + valid = .false. + DO L = 1, LLPAR + + ! Reset VALID flag + Valid = .false. + + ! If the thickness of this pressure level is zero, then this + ! means that this pressure level lies below the surface + ! pressure (due to topography), as set up in the calling + ! program. Therefore, skip to the next INPUT level. + ! This also helps avoid divide by zero errors. (bmy, 8/6/01) + IF ( ( InPEdge(L) - InPedge(L+1) ) .lt. 1e-5 ) then + !print*, '1. going to 12' + goto 12 !NextL + ENDIF + + + ! Loop over OUTPUT layers + DO LL = 1, NLevs + + if( OutPEdge(LL) .lt. InPEdge(L) .and. + & OutPEdge(LL) .lt. InPEdge(L+1) .and. + & (ll .eq. 1) .and. (l.eq.1) ) THEN + Fraction(i,j,L,LL) = 1d0 + !print*, 'first GC layer lower than 1st SCIA layer' + ! Go to next iteration + goto 12 !NextL + endif + + !================================================= + ! No contribution if: + ! ------------------- + ! Bottom of OUTPUT layer above Top of INPUT layer OR + ! Top of OUTPUT layer below Bottom of INPUT layer + ! ..unless it's the first layer in GC (mak, 8/15/07) + !=================================================== + if ( OutPEdge(LL) .lt. InPEdge(L+1) .OR. + & OutPEdge(LL+1) .gt. InPEdge(L) ) THEN + goto 13 !NextLL + ENDIF + + !================================================== + ! Contribution if: + ! ---------------- + ! Entire INPUT layer in OUTPUT layer + !=================================================== + if ( OutPEdge(LL) .ge. InPEdge(L) .AND. + & OutPEdge(LL+1) .le. InPEdge(L+1) ) then + + Fraction(i,j,L,LL) = 1d0 + + !Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + endif + + !================================================== + ! Contribution if: + ! ---------------- + ! Top of OUTPUT layer in INPUT layer + !================================================== + if ( OutPEdge(LL+1) .le. InPEdge(L) .AND. + & OutPEdge(LL) .ge. InPEdge(L) ) THEN + + Fraction(i,j,L,LL) =(InPEdge(L) - OutPEdge(LL+1)) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + endif + + !================================================== + ! Contribution if: + ! ---------------- + ! Entire OUTPUT layer in INPUT layer + !================================================== + if ( OutPEdge(LL) .le. InPEdge(L) .AND. + & OutPEdge(LL+1) .ge. InPEdge(L+1) ) then + + Fraction(i,j,L,LL)=(OutPEdge(LL) - OutPEdge(LL+1))/ + & ( InPEdge(L) - InPEdge(L+1) ) + + ! Also add the to the first OUTPUT layer the fraction + ! of the first INPUT layer that is below sigma = 1.0 + ! This is a condition that can be found in GEOS-3 data. + if ( ( First ) .AND. + & ( LL .eq. 1 ) .AND. + & ( InPEdge(L) .gt. OutPEdge(1) ) ) then + + Fraction(i,j,L,LL) = Fraction(i,j,L,LL) + + & ( InPEdge(L) - OutPEdge(1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! We only need to do this once... + First = .false. + endif + + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + endif + + !=================================================== + ! Contribution if: + ! ---------------- + ! Bottom of OUTPUT layer in INPUT layer + !=================================================== + if ( OutPEdge(LL) .ge. InPEdge(L+1) .AND. + & OutPEdge(LL+1) .le. InPEdge(L+1) ) then + + Fraction(i,j,L,LL) = ( OutPEdge(LL) - InPEdge(L+1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! Also add the to the first OUTPUT layer the fraction + ! of the first INPUT layer that is below sigma = 1.0 + ! This is a condition that can be found in GEOS-3 data. + if ( ( First ) .AND. + & ( LL .eq. 1 ) .AND. + & ( InPEdge(L) .gt. OutPEdge(1) ) ) then + + Fraction(i,j,L,LL) = Fraction(i,j,L,LL) + + & ( InPEdge(L) - OutPEdge(1) ) / + & ( InPEdge(L) - InPEdge(L+1) ) + + ! We only need to do this once... + First = .false. + endif + + + ! Indicate a valid contribution from L to LL + Valid = .true. + + ! Go to next iteration + goto 13 !NextLL + endif + + 13 CONTINUE !NextLL + + ENDDO ! LL + + !====================================================== + ! Consistency Check: + ! ------------------ + ! If SUM( FRACTION(L,:) ) does not = 1, there is a problem. + ! Test those INPUT layers (L) which make a contribution to + ! OUTPUT layers (LL) for this criterion. + ! + !====================================================== + if ( Valid ) then + if ( Abs( 1e0 - sum( Fraction(i,j,L,:))) .ge. 1e-4 ) THEN + print*, 'Fraction does not add to 1' + print*, L, LL,sum( Fraction(i,j,L,:) ) + print*, 'frac(5,:):', fraction(i,j,L,:) + PRINT*, 'InPEdge:', InPEdge + print*, 'OutPEdge:', OutPEdge + + CALL ERROR_STOP ('REGRIDV still sucks', + & 'scia_co_obs_mod.f' ) + endif + endif + + 12 CONTINUE !NextL + ENDDO !L + + !========================================================== + ! Compute "new" data -- multiply "old" data by fraction of + ! "old" data residing in the "new" layer + !========================================================== + ! Map CO from GC to SCIA grid + DO LL = 1 , NLevs + DO L = 1 , LLPAR + CHK_STT_SCIA_VGRID(I,J,LL) = + & CHK_STT_SCIA_VGRID(I,J,LL) + & + STT(I,J,L,1)*FRACTION(i,j,L,LL) + ENDDO + ENDDO + + !print*, 'columns before and after regridding:' + !PRINT*,I,J,SUM(CHK_STT(I,J,:,1)),SUM(CHK_STT_SCIA_VGRID(I,J,:)) + IF(Abs( SUM(CHK_STT_SCIA_VGRID(I,J,:)) - SUM(STT(I,J,:,1))) + & /SUM(STT(I,J,:,1)) .gt. 1e-5 ) THEN + PRINT*, 'columns before and after regrid dont add up:' + print*, 'columns before and after regridding:' + PRINT*,I,J,SUM(STT(I,J,:,1)),SUM(CHK_STT_SCIA_VGRID(I,J,:)) + PRINT*, 'InPEdge:', InPEdge + print*, 'OutPEdge:', OutPEdge + print*, 'chk_stt' + print*, 'chk_stt_scia_vgrid:' + print*, chk_stt_scia_vgrid(i,j,:) + CALL ERROR_STOP ('REGRIDV sucks', + & 'scia_co_obs_mod.f' ) + ENDIF + + ! Airmass on output grid (in kg/box in each level) + AirMass(I,J,:) = RVR_GetAirMass( SCIAEdge, j, surfP ) + !AirMass = RVR_GetAirMass( OutVertEdge, OutArea[I,J], surfP ) + + ! Convert data from kg to [v/v] + ! Model_CO_MR = kgCO * gair/gCO / kgair = [v/v] + DO LL = 1, NLevs + Model_CO_MR(I,J,LL) = CHK_STT_SCIA_VGRID(I,J,LL) * + & TCVV(1)/AirMass(I,J,LL) + ENDDO +! DO L = 1, LLPAR +! DO LL = 1, NLev +! ADJ_SCIA_ALL(I,J,L) = ADJ_SCIA_ALL(I,J,L) + +! & A(LL)*1e6*ADJ_TCVV(1)/AirMass(I,J,LL)*FRACTION(L,LL) +! !ADJ_SCIA_REGRID(I,J,L,LL) = FRACTION(L,LL) +! ENDDO +! ENDDO + + + ! Model_CO_MR = [CHK_STT(L)*FRACTION(L,LL)]*ADJ_TCVV/Airmass + ! d(Model_CO_MR)/d(CHK_STT) = (ADJ_TCVV/Airmass)*FRACTION(L,LL) +! DO LL = 1,NLevs +! ADJ_SCIA_CONVERT(I,J,LL) = ADJ_TCVV(1)/AirMass(LL) +! ENDDO + + ENDIF + ENDDO + ENDDO +!!$OMP END PARALLEL DO + + + END SUBROUTINE REGRIDV_SCIA + +!--------------------------------------------------------------------------- + + FUNCTION RVR_GetAirMass( SCIAEdge, J, SurfP) RESULT ( AirMassloc ) + + !==================================================================== + ! Internal function RVR_GETAIRMASS returns a column vector of air + ! mass given the vertical coordinates, the surface area, + ! and surface pressure. (bmy, 12/19/03) + !==================================================================== + + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" + + INTEGER, INTENT(IN) :: J + REAL*8, INTENT(IN) :: SurfP + REAL*8 :: AirMassloc(NLevs) + REAL*8, INTENT(IN) :: SCIAEdge(NLevs+1) + INTEGER :: L + REAL*8 :: g100 + + AirMassloc(:) = 0d0 + + ! Constant 100/g + g100 = 100d0 / 9.8d0 + + ! Loop over levels + ! airmass(L) = hPa * m2 * 1 * 100Pa/hPa * 1/(m/s2) = + ! = N * 1/(m/s2) = kg + DO L = 1, NLevs + AirMassloc(L) = SurfP * GET_AREA_M2(J) * + & ( SCIAEdge(L) - SCIAEdge(L+1) ) * g100 + ENDDO + + END FUNCTION RVR_GetAirMass + +!--------------------------------------------------------------------------- + SUBROUTINE INIT_DOMAIN + + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" + + INTEGER I, J, as + LOGICAL, SAVE :: FIRST = .TRUE. + + IF ( FIRST ) THEN + ALLOCATE( DOMAIN_OBS( IIPAR,JJPAR ) ,stat=as ) + IF ( as /= 0 ) CALL ALLOC_ERR( 'DOMAIN_OBS' ) + FIRST = .FALSE. + ENDIF + + DOMAIN_OBS(:,:) = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( +! & .and. (I .ge. 93) .and. (I .le. 144) ! MOPITT TRACE-P.. +! & .and. (J .ge. 41) .and. (J .le. 73) ! ..region 2x2.5 +! & .and. (J .ge. 40) .and. (J .le. 72) ! ..region 2x2.5 +!! & .and. (EMS_orig(I,J,NEMS) .NE. 0 ) +!! & .and. L < LPAUSE(I,J) ! Only in the troposphere +!! & .and. IS_LAND(I,J) ! Only the land species +! & .and. ( MOD( I, 2 ) == 0 ) ! Only in every other cell +!! & .and. J >= 10 ! Not in antarctica +! & .and. L == 8 ! Only at ~500mb +! & .and. (J .ge. 24) ! only N.Hemisphere + & (J .le. 38) ! not poleward of 60N + & .and. (J .ge. 9) ! not poleward of 60S + & ) THEN + + DOMAIN_OBS(I,J) = 1 + ELSE + DOMAIN_OBS(I,J) = 0 + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + PRINT*, sum(DOMAIN_obs), 'MAX observations today' + + END SUBROUTINE INIT_DOMAIN +!----------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_SCIA + ! DEALLOCATE ALL MEMORY (DONE BEFORE READING REACH MONTHLY FILE) + + ! Deallocate + IF ( ALLOCATED( SCIACOcol ) ) DEALLOCATE( SCIACOcol ) + IF ( ALLOCATED( SCIACOcol_err ) ) DEALLOCATE( SCIACOcol_err ) + IF ( ALLOCATED( Longitude ) ) DEALLOCATE( Longitude ) + IF ( ALLOCATED( Latitude ) ) DEALLOCATE( Latitude ) + IF ( ALLOCATED( SZA ) ) DEALLOCATE( SZA ) + IF ( ALLOCATED( SCIA_COL_GRID ) ) DEALLOCATE( SCIA_COL_GRID ) + IF ( ALLOCATED( ERR_COL_GRID ) ) DEALLOCATE( ERR_COL_GRID ) + IF ( ALLOCATED( COUNT_GRID ) ) DEALLOCATE( COUNT_GRID ) + IF ( ALLOCATED( iday ) ) DEALLOCATE( iday ) + IF ( ALLOCATED( mday ) ) DEALLOCATE( mday ) + IF ( ALLOCATED( time_h ) ) DEALLOCATE( time_h ) + IF ( ALLOCATED( OBS_HOUR_SCIA_CO ) ) DEALLOCATE( OBS_HOUR_SCIA_CO) + IF ( ALLOCATED( ERR_PERCENT ) ) DEALLOCATE( ERR_PERCENT ) + IF ( ALLOCATED( Cloud ) ) DEALLOCATE( Cloud ) + + END SUBROUTINE CLEANUP_SCIA + +!--------------------------------------------------------------------------- + + END MODULE SCIAbr_CO_OBS_MOD diff --git a/code/obs_operators/tes_ch4_mod.f b/code/obs_operators/tes_ch4_mod.f new file mode 100644 index 0000000..ecc6e98 --- /dev/null +++ b/code/obs_operators/tes_ch4_mod.f @@ -0,0 +1,4508 @@ +!$Id: tes_ch4_mod.f,v 1.2 2012/03/01 23:27:52 daven Exp $ + MODULE TES_CH4_MOD +! +!****************************************************************************** +! Module TES_CH4_MOD contains variables and routines which are used to +! assimilate real or simulated TES CH4 observations. The module is based on +! TES_NH3_MOD (kjw, 7/06/11) +! Added to adj32_023 (dkh, 02/12/12) +!****************************************************************************** +! + + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 67 + INTEGER, PARAMETER :: MAXTES = 2000 + REAL*4, PARAMETER :: ERR_PPB = 40.0 !Stddev in TES obs + !LOGICAL :: LTES_PSO = .TRUE. + + ! Module Variables + REAL*4 :: BIAS_PPB + + ! Record to store data from each TES obs + TYPE TES_CH4_OBS + INTEGER :: LTES(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: ERR(1) + REAL*8 :: CH4(MAXLEV) + REAL*8 :: GC_CH4(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + ENDTYPE TES_CH4_OBS + + TYPE(TES_CH4_OBS) :: TES(MAXTES) + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_CH4_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine READ_TES_CH4_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) TES (TES_CH4_OBS) : TES retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +! (2 ) Now read data files in BPCH format for better compatibility with +! the standard GEOS-Chem distribution. (kjw, 06/05/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE TIME_MOD, ONLY : EXPAND_DATE + USE BPCH2_MOD, ONLY : READ_BPCH2, GET_TAU0 + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH, GET_DAY + USE FILE_MOD, ONLY : IU_FILE + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, EXPAND_NAME + USE LOGICAL_ADJ_MOD, ONLY : LTES_PSO + + ! From READ_BPCH2 + USE FILE_MOD, ONLY : IU_FILE, IOERROR + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + INTEGER, INTENT(OUT) :: NTES + + ! local variables + INTEGER :: FID + INTEGER :: LTES + INTEGER :: NT + INTEGER :: YYYY, MM, DD + INTEGER :: START + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: FILENAME + LOGICAL :: file_exist + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: XTAU + REAL*8 :: TEST(MAXLEV,MAXLEV) + + ! From READ_BPCH2 + INTEGER :: I, J, L, LL, IOS + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + + !Arrays in which to read BPCH files + REAL*4 :: DUMMY_NTES(1) + REAL*4 :: DUMMY_0D(MAXTES) + REAL*4 :: DUMMY_1D(MAXTES,MAXLEV,1) + REAL*4 :: DUMMY_2D(MAXTES,MAXLEV,MAXLEV) + + + !================================================================= + ! READ_TES_CH4_OBS begins here! + !================================================================= + + ! filename root + READ_FILENAME = TRIM( 'tes_ch4_YYYYMMDD.bpch' ) + !READ_FILENAME = TRIM( 'temp_test.bpch' ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + READ_FILENAME = TRIM( '/home/kjw/TES/data/V004/bpch/' ) // + & TRIM( READ_FILENAME ) + + INQUIRE( FILE=READ_FILENAME, exist=file_exist ) + + + ! If there is no observation file for this day, + ! Return to calling program + IF ( .not. file_exist ) THEN + WRITE(6,*) ' - READ_TES_CH4_OBS: file does not exist: ', + & TRIM( READ_FILENAME ) + WRITE(6,*) ' no observations today.' + + ! Set NTES = 0 and Return to calling program + NTES = 0 + RETURN + ENDIF + + + ! Start Reading Data from BPCH + WRITE(6,*) ' - READ_TES_CH4_OBS: reading file: ', + & TRIM( READ_FILENAME ) + + ! Read variables from bpch instead of netCDF (kjw, 06/05/10) + ! 1. Open BPCH file for today if it exists. If it doesn't, + ! return NTES = 0. + ! 2. Read nTES (tracer=1) from bpch + ! a. read LTES from bpch, store in TES struct + ! b. read remaining 0-d data, store in struct + ! c. read 1-d data, store in TES struct + ! d. read 2-d data, store in TES struct + + ! READ nTES from BPCH. Tracer numbers correspond to the following + ! variables in the TES BPCH files: + ! Tracer # Variable + ! 1 targets (# TES obs in file) + ! 2 LTES (# good vertical levels in each obs) + ! 3 Longitude + ! 4 Latitude + ! 5 YYYYMMDD + ! 6 Species + ! 7 Pressure + ! 8 Constraint Vector + ! 9 GEOS-Chem_obs + ! 10 Averaging Kernel + ! 11 Inverse of Observation Error Covar Matrix + !--------------------------------------------------------------- + + ! Tau for the bpch file + YYYY = INT( floor( YYYYMMDD / 1d4 ) ) + MM = INT( floor( YYYYMMDD - 1d4*YYYY ) / 1d2 ) + DD = NINT( YYYYMMDD - 1d4*YYYY - 1d2*MM ) + XTAU = GET_TAU0( MM, DD, YYYY ) + + ! Number of TES observations in the file + WRITE(6,*) ' - Reading: NTES ... ' + print*,'XTAU = ',XTAU + CALL READ_BPCH2( TRIM(READ_FILENAME), 'IJ-AVG-$', 1, + & XTAU, 1, 1, + & 1, DUMMY_NTES(1), QUIET=.TRUE. ) + NTES = INT( DUMMY_NTES(1) ) + print*, ' - Found # obs today: NTES = ,', NTES + + + !================================================================== + ! Read data for each TES observation in the current day. + ! Do NOT use READ_BPCH2 because output dimensions limited size + ! of global 1x1 grid. + ! The following lines are modified from READ_BPCH2 (kjw, 07/22/10) + ! + ! 0-D Data + ! 2. # good vertical levels for each obs. + ! 3. longitude + ! 4. latitude + ! 5. mmdd.frac-of-day + ! 1-D Data + ! 6. Species (CH4) + ! 7. Pressure + ! 8. Constraint Vector + ! 9. GEOS-Chem_obs + ! 2-D Data + ! 10. Averaging Kernel + ! 11. Inverse of Observation Error Covariance Matrix + !================================================================== + + + !================================================================= + ! Open binary punch file and read top-of-file header. + ! Do some error checking to make sure the file is the right format. + !================================================================= + CALL OPEN_BPCH2_FOR_READ( IU_FILE, READ_FILENAME ) + + !================================================================= + ! Read data from the binary punch file + ! + ! NOTE: IOS < 0 is end-of-file, IOS > 0 is error condition + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'tes_ch4_mod:1') + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'tes_ch4_mod:2' ) + + ! Place array into DUMMY_2D + DUMMY_2D(:,:,:) = 0d0 + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( DUMMY_2D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'tes_ch4_mod:3' ) + + + ! Test for a match + IF ( 'IJ-AVG-$' == TRIM( CATEGORY ) .and. XTAU == ZTAU0 ) THEN + + ! LTES + IF ( NTRACER == 2 ) THEN + WRITE(6,*) ' - Reading: LTES ... ' + TES(1:NTES)%LTES(1) = DUMMY_2D(1:NTES,1,1) + + ! Longitude + ELSEIF ( NTRACER == 3 ) THEN + WRITE(6,*) ' - Reading: Longitude ... ' + TES(1:NTES)%LON(1) = DUMMY_2D(1:NTES,1,1) + + ! Latitude + ELSEIF ( NTRACER == 4 ) THEN + WRITE(6,*) ' - Reading: Latitude ... ' + TES(1:NTES)%LAT(1) = DUMMY_2D(1:NTES,1,1) + + ! MMDD.frac-of-day + ELSEIF ( NTRACER == 5 ) THEN + WRITE(6,*) ' - Reading: Frac-of-day ... ' + TES(1:NTES)%TIME(1) = DUMMY_2D(1:NTES,1,1) + + & GET_YEAR()*1d4 + + ! Species (CH4) + ELSEIF ( NTRACER == 6 ) THEN + WRITE(6,*) ' - Reading: CH4 ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%CH4(1:LTES) = DUMMY_2D(NT,START:MAXLEV,1) + ENDDO + + ! Pressure + ELSEIF ( NTRACER == 7 ) THEN + WRITE(6,*) ' - Reading: Pressure ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%PRES(1:LTES) = DUMMY_2D(NT,START:MAXLEV,1) + ENDDO + + ! Constraint Vector + ELSEIF ( NTRACER == 8 ) THEN + WRITE(6,*) ' - Reading: Constraint Vector ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%PRIOR(1:LTES) = DUMMY_2D(NT,START:MAXLEV,1) + ENDDO + +! ! Kind of Useless now that LTES_PSO created, kjw 07/25/10 +! ! GEOS-Chem Obs + ELSEIF ( NTRACER == 9 ) THEN + WRITE(6,*) ' - Reading: GEOS-Chem Obs ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%GC_CH4(1:LTES) = DUMMY_2D(NT,START:MAXLEV,1) + ENDDO + + ! Averaging Kernel + ELSEIF ( NTRACER == 10) THEN + WRITE(6,*) ' - Reading: Averaging Kernel ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%AVG_KERNEL(1:LTES,1:LTES) = + & DUMMY_2D(NT,START:MAXLEV,START:MAXLEV) + ENDDO + + ! Inverse of Observation Error Covariance Matrix + ELSEIF ( NTRACER == 11) THEN + WRITE(6,*) ' - Reading: S_OER_INV ... ' + DO NT=1,NTES + LTES = TES(NT)%LTES(1) + START = MAXLEV - LTES + 1 + TES(NT)%S_OER_INV(1:LTES,1:LTES) = + & DUMMY_2D(NT,START:MAXLEV,START:MAXLEV) + ENDDO + + + ENDIF ! If tracer == # + + ENDIF ! If Category and Tau match + + ENDDO + + ! Close today's BPCH file of TES observations + CLOSE( IU_FILE ) + + + ! Read Errors and populate TES%GC_CH4 if using pseudo-obs + IF ( LTES_PSO ) THEN + + ! Make pseudo observations and save in TES%GC_CH4 + CALL MAKE_PSEUDO_OBS( YYYYMMDD, NTES ) + + ENDIF + +! ! Save AK and S_OER_INV for one observation. +! ! The plot to make sure they are correct order +! WRITE(6,'(a)') ' Writing AK and S_OER_INV files' +! FILENAME = 'test_ak.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! print*,'FILENAME1 = ',FILENAME +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! ! Save observation # 600 +! LTES = TES(600)%LTES(1) +! print*,'LTES of obs # 600 = ',LTES +! DO L=1,LTES +! WRITE(IU_FILE,'(65F16.12)') (TES(600)%AVG_KERNEL(L,LL), +! & LL=1,LTES) +! ENDDO +! CLOSE(IU_FILE) +! +! FILENAME = 'test_s_obs.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! print*,'FILENAME2 = ',FILENAME +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 189, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ! Save observation # 600 +! LTES = TES(600)%LTES(1) +! print*,'LTES of obs # 600 = ',LTES +! DO L=1,LTES +! WRITE(IU_FILE,'(65F16.12)') (TES(600)%S_OER_INV(L,LL), +! & LL=1,LTES) +! ENDDO +! WRITE(6,'(a)') ' Done writing AK and S_OER_INV files' +! +! CLOSE(IU_FILE) + + + ! Check reading against values read from BPCH in IDL + !print*,'TES(600)%LTES = ',TES(600)%LTES(1) + !print*,'TES(600)%LON = ',TES(600)%LON(1) + !print*,'TES(600)%LAT = ',TES(600)%LAT(1) + !print*,'TES(600)%TIME = ',TES(600)%TIME(1) + !print*,'TES(600)%PRES = ',TES(600)%PRES + !print*,'TES(600)%CH4 = ',TES(600)%CH4 + !print*,'TES(600)%AK = ',TES(600)%AVG_KERNEL(1:4,1) + !print*,'TES(600)%ERR = ',TES(600)%ERR(1) + ! Success as of kjw, 07/24/10 + + + + ! Return to calling program + END SUBROUTINE READ_TES_CH4_OBS +!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_TES_CH4_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_CH4_FORCE calculates the adjoint forcing from the TES +! CH4 observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (1 ) Add more diagnostics. Now read and write doubled CH4 (dkh, 11/08/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DAO_MOD, ONLY : TROPP + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_YEAR + USE TIME_MOD, ONLY : GET_MONTH, GET_DAY, GET_HOUR + USE TIME_MOD, ONLY : GET_TS_CHEM, EXPAND_DATE + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +!kjw + USE TRACER_MOD, ONLY : STT + USE FILE_MOD, ONLY : IU_FILE + USE TIME_MOD, ONLY : GET_TAUe, GET_TAU + USE LOGICAL_ADJ_MOD, ONLY : LTES_PSO +!kjw + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: CH4_HAT(MAXLEV) + REAL*8 :: CH4_HAT_EXP(MAXLEV) + REAL*8 :: CH4_PERT(MAXLEV) + REAL*8 :: FORCE + REAL*8 :: DIFF + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXTES) + INTEGER,SAVE :: NTES + REAL*8 :: DOFS + CHARACTER :: F117_STATUS + + !kjw for testing adjoint of tes obs operator + REAL*8 :: ADJ(LLPAR) + REAL*8 :: ADJ_SAVE(LLPAR) + REAL*8 :: PERT(LLPAR) + REAL*8 :: FD_CEN(LLPAR) + REAL*8 :: FD_POS(LLPAR) + REAL*8 :: FD_NEG(LLPAR) + REAL*8 :: COST_FUNC_0 + REAL*8 :: COST_FUNC_1 + REAL*8 :: COST_FUNC_2 + LOGICAL :: ori + !kjw for testing adjoint of tes obs operator + + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: CH4_HAT_ADJ(MAXLEV) + REAL*8 :: CH4_HAT_EXP_ADJ(MAXLEV) + REAL*8 :: CH4_PERT_ADJ(MAXLEV) + REAL*8 :: GC_CH4_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ + REAL*4 :: S_obs_inv + REAL*8 :: GC_avg + REAL*8 :: OBS_avg + REAL*8 :: GC_avg_ADJ +! REAL*8 :: Pres_ln(MAXLEV) +! REAL*8 :: Pedges_ln(MAXLEV) +! REAL*8 :: Pedges(MAXLEV) +! REAL*8 :: Pdiff(MAXLEV) +! REAL*8 :: Nmolec(MAXLEV) +! REAL*8 :: DIFF_onTES(MAXLEV) +! REAL*8 :: Totmolec + REAL*8 :: OBS_RTVMR, GC_RTVMR + REAL*8 :: OBS_RTVMR_ADJ, GC_RTVMR_ADJ + REAL*8 :: M_STAR(4,MAXLEV) + INTEGER :: reg + REAL*8 :: JJ_this(9) + REAL*8 :: Jforce_this(9) + REAL*8 :: Jdiff_this(9) + + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: VERYFIRST = .TRUE. + LOGICAL, SAVE :: GOD = .FALSE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + + + !================================================================= + ! CALC_TES_CH4_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_CH4_FORCE ' + + + !------------------GOD RETRIEVAL------------------- + ! The god retrieval assumes perfect observations in every grid box + ! at all time steps. The retrieval should perfectly reproduce + ! the "true" emission field in identical twin tests. If it does + ! not, then there is a bug in the code. (kjw, 10/07/10) + ! + ! OUTLINE + ! A. Get STT in [ppb] + ! B. Get pseudo-obs in [ppb] + ! C. Calculate forcing and adjoint variable + ! + + + ! If GOD == .TRUE. THEN do GOD retrieval + IF ( GOD == .TRUE. ) THEN + + ! Save a value of the cost function + OLD_COST = COST_FUNC + + + ! A. Get STT in [ppb] + + ! B. Get pseudo-obs in [ppb] + + ! C. Calculate forcing and adjoint variable + + + + ! Return to calling program + RETURN + + ENDIF ! End if GOD == .TRUE. + + !-------------------------------------------------- + + + !kjw for testing + ori=.TRUE. + !kjw for testing + + ! Reset + NEW_COST = 0D0 + JJ_this(:) = 0d0 + Jforce_this(:) = 0d0 + Jdiff_this(:) = 0d0 + + ! Calculate TES vs. GEOS-Chem bais + IF ( VERYFIRST .AND. (LTES_PSO == .FALSE.) ) CALL CALC_TES_GC_BIAS + VERYFIRST = .FALSE. + + ! Open files for diagnostic output + IF ( FIRST ) THEN + + ! Open files for diagnostic output + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_ch4.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'ch4_pert_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_ch4_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4_on_tes_woStrat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 115, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_ch4_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + !kjw for testing adjoint of obs operator + FILENAME = 'test_adjoint_obs.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 116, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + !kjw. Change this for methane or else we'll never read a file. + !kjw. For forcing every 1 hour, the following line should work: + ! IF ( GET_NHMS() == 230000 ) THEN + IF ( GET_NHMS() == 230000 ) THEN + + ! Read the TES CH4 file for this day + CALL READ_TES_CH4_OBS( GET_NYMD(), NTES ) + + ! If NTES = 0, it means there are no observations today. + ! Return to calling procedure + IF ( NTES == 0 ) THEN + WRITE(6,*) ' No TES CH4 obs today. Returning 01 ... ' + RETURN + ENDIF + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time frac + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() + + ENDIF + + ! If NTES = 0, it means there are no more observations today. + ! Return to calling procedure + IF ( NTES == 0 ) THEN + WRITE(6,*) ' No TES CH4 obs today. Returning 02 ... ' + RETURN + ENDIF + + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES CH4 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + + + ! Calculate S_obs_inv for stddev of ERR_PPB [ppb] + ! Expected difference = ln( 1800 +/- ERR_PPB ) - ln( 1800 ) + ! = ln( ( 1800 +/- ERR_PPB ) / 1800 ) + !S_obs_inv = 1. / ( LOG( ( 1800. + ERR_PPB ) / 1800. ) )**2 + S_obs_inv = 1. / ( (ERR_PPB*1d-9) ** 2 ) + + print*,'kjw debug: calculate S_obs_inv.' + print*, 'ERR_PPB = ', ERR_PPB + !print*,'S_obs_inv (should be ~2070) = ',S_obs_inv + print*,'S_obs_inv (should be ~6.25e14) = ',S_obs_inv + + + + ! Open file for this hour's satellite diagnostics + FILENAME = 'diag_sat.YYYYMMDD.hhmm.NN' + CALL EXPAND_NAME( FILENAME, N_CALC ) + CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CH4, DIFF ) +!!$OMP+PRIVATE( GC_CH4_NATIVE, CH4_PERT, CH4_HAT, FORCE ) +!!$OMP+PRIVATE( GC_CH4_NATIVE_ADJ, GC_CH4_ADJ ) +!!$OMP+PRIVATE( CH4_PERT_ADJ, CH4_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + DO NT = NTSTART, NTSTOP, -1 + + !IF ( NT .EQ. 600 ) THEN + print*, ' - CALC_TES_CH4_FORCE: analyzing record ', NT + + ! For safety, initialize these up to LLTES + GC_CH4(:) = 0d0 + MAP(:,:) = 0d0 + CH4_HAT_ADJ(:) = 0d0 + FORCE = 0d0 + + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + +! ! dkh debug +! print*, 'I,J = ', I, J +! print*,TES(NT)%TIME(1) +! print*,TES(NT)%LAT(1) +! print*,TES(NT)%LON(1) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), TES(NT)%PRES(1) ) + + + ! Get CH4 values at native model resolution + !DO L = 1, LLPAR + + + !kjw. JLOP and CSPEC are variables in comode_mod.f, associated + ! with smvgear. For getting CH4 values at native model + ! resolution, write my own thing, it'll probably have to do + ! with using CH4 from STT when below tropopause, and using + ! the TES retrieval above the tropopause. Therefore, there + ! will be no adjoint forcing above the tropopause. + !kjw. + + !kjw + ! Get CH4 from restored STT array + ! Find out units of STT (I think it's [kg/box]). + ! If so, convert to [v/v] before next step + GC_CH4_NATIVE(:) = CHK_STT(I,J,:,1) +! print*,'CHK_STT(14,14,14,1) = ',CHK_STT(14,14,14,1) +! print*,' STT(14,14,14,1) = ',STT(14,14,14,1) + + ! Unit Conversion + DO L=1,LLPAR + + ! Convert from [kg/box] --> [v/v] + ! Numerator = moles CH4/box + ! Denominator = moles air/box + GC_CH4_NATIVE(L) = (GC_CH4_NATIVE(L)*XNUMOL(1)/6.022d23 ) / + & ( AD(I,J,L) * XNUMOLAIR / 6.022d23 ) + !!!! Bypass unit conversion + !!!GC_CH4_NATIVE(:) = GC_CH4_NATIVE(:) + ENDDO + + + ! Interpolate GC CH4 column to TES grid + DO LL = 1, LTES + GC_CH4(LL) = 0d0 + DO L = 1, LLPAR + GC_CH4(LL) = GC_CH4(LL) + & + MAP(L,LL) * GC_CH4_NATIVE(L) + ENDDO + ENDDO + + IF ( NT == 600 ) THEN + !print*,'LTES = ',LTES + !print*,'LLPAR = ',LLPAR + !print*,'GC_PSURF = ',GC_PSURF + + !WRITE(6,'(a)') 'GEOS-Chem pressure grid' + !WRITE(6,'(F10.3)') ( GC_PRES(L), L=1,47 ) + + !WRITE(6,'(a)') 'TES pressure grid' + !WRITE(6,'(F10.3)') ( TES(NT)%PRES(L), L=1,65 ) + + !WRITE(6,'(a)') '20th row of MAP matrix in CALC_FORCE' + !WRITE(6,'(5F8.5)') ( MAP(20:24,L) , L=1,65 ) + !print*,'GC_CH4 (observation) = ', TES(NT)%GC_CH4(10) + !print*,'CH4 (model) = ', GC_CH4(10) + + + ENDIF + +! IF ( NT == 600 ) THEN +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_CH4 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_CH4_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_CH4 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_CH4(LL)*1d9, LL = LTES, 1, -1 ) +! ENDIF +! 100 FORMAT(1X,F16.8,1X,F16.8) + + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_CH4(L) = MAX(GC_CH4(L), 1d-10) + CH4_PERT(L) = LOG(GC_CH4(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + +! !kjw testing +! IF ( ori .EQ. .TRUE. ) THEN +! print*,'CH4_PERT(13) = ',CH4_PERT(13) +! ENDIF +! !kjw testing +!!!!!! ! Bypass !x_m - x_a +!!!!!! CH4_PERT(:) = GC_CH4(:) +!!!!!! + + ! x_a + A_k * ( x_m - x_a ) + ! AVG_KERNEL indexing may look backwards because BPCH files storing AK + ! values use IDL column major indexing. + DO L = 1, LTES + CH4_HAT(L) = 0d0 + DO LL = 1, LTES + CH4_HAT(L) = CH4_HAT(L) + & + TES(NT)%AVG_KERNEL(LL,L) * CH4_PERT(LL) + ENDDO + CH4_HAT(L) = CH4_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + ! Indexing of Averaging Kernel is seemingly backwards because + ! TES observation files processed in IDL, which is column major + +!!! ! Bypass !x_a + A_k * ( x_m - x_a ) +!!! CH4_HAT(:) = CH4_PERT(:) +!!! + +! !kjw testing +! IF ( ori .EQ. .TRUE. ) THEN +! print*,'CH4_HAT(13) = ',CH4_HAT(13) +! ENDIF +! !kjw testing + +! !-------------------------------------------------------------- +! ! Calculate column average ln(vmr) weighted by # density of TES grid +! ! This operation is self adjoint. +! ! To get # density [molec / m^2], get pressure differences in grid. +! ! Get kg/m^2 of air in each box. (F=ma) dP=kg*g +! ! Get molec/m^2 air molec/m2 = kg/m2 * XNUMOLAIR +! ! TES pressure grid linear in ln(pres). Get pressure at edge of boxes +! !-------------------------------------------------------------- +! pres_ln(1:LTES)=LOG(TES(NT)%pres(1:LTES)) ! [hPa] --> ln([hPa]) +! Pedges_ln(1)=pres_ln(1) ! Bottom edge is surface pressure +! DO L=2,LTES-1 +! Pedges_ln(L) = ( pres_ln(L) + pres_ln(L+1) ) / 2. +! ENDDO +! Pedges=EXP(pedges_ln) ! ln([hPa]) --> [hPa] +! Pedges(LTES)=0 ! Top of atmosphere +! !print*,' kjw debug: TES pressure edges' +! !print*, Pedges +! +! ! Calculate pressure difference of each LTES-1 boxes +! DO L=1,LTES-1 +! Pdiff(L) = Pedges(L) - Pedges(L+1) +! ENDDO +! +! ! Calculate # molecules air in each LTES-1 obxes +! Pdiff(:) = 100 * Pdiff(:) ! [hPa] --> [Pa] +! Pdiff(:) = Pdiff(:) / 9.8 ! [hPa] --> [kg] +! Nmolec(:)= Pdiff(:) * XNUMOLAIR ! [kg] --> [molec] +! Totmolec = 0d0 +! DO L=1,LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! Totmolec = Totmolec + Nmolec(L) +! ENDIF +! ENDDO +! +! IF ( NT .EQ. 600 ) THEN +! print*,' kjw debug:# molecules in column (should be ~2e29)' +! print*, Totmolec +! print*,' kjw debug: Nmolec' +! DO L=1,LTES +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! print*, Nmolec(L)/Totmolec +! ENDIF +! ENDDO +! print*,'SUM(Nmolec(1:22)/Totmolec)', +! & SUM(Nmolec(1:22)/Totmolec) +! print*,'SUM(NMOLEC) = ',SUM(Nmolec) +! ENDIF +! +! ! Calculate column average ln(vmr) weighted by # density of TES levels +! ! Only include levels with tropospheric air +! OBS_avg = 0d0 +! GC_avg = 0d0 +! DIFF_onTES(:) = 0d0 +! DIFF_onTES(1:LTES) = LOG(TES(NT)%GC_CH4(1:LTES)) - +! & CH4_HAT(1:LTES) +! DO L=1,LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! OBS_avg = OBS_avg + +! & LOG(TES(NT)%GC_CH4(L+1)) * Nmolec(L)/Totmolec +! GC_avg = GC_avg + +! & CH4_HAT(L+1) * Nmolec(L)/Totmolec +! ENDIF +! ENDDO + + ! Transform from [ln(vmr)] --> [vmr] + CH4_HAT_EXP = EXP(CH4_HAT) + + ! Calculate RTVMR for profiles. + CALL GET_RTVMR( NT, TES(NT)%CH4, OBS_RTVMR, M_STAR ) + CALL GET_RTVMR( NT, CH4_HAT_EXP, GC_RTVMR, M_STAR ) + + + ! kjw debug. Check RTVMR stuff + !IF ( NT == 600 ) THEN + ! print*,'Check RTVMR stuff' + ! print*,'Lat, Lon, PSURF of observation #600 ' + ! print*,TES(NT)%LAT(1),TES(NT)%LON(1),TES(NT)%PRES(1) + ! print*,'GC_RTVMR = ',GC_RTVMR + ! print*,'CH4_HAT = ',CH4_HAT + !ENDIF + + + + ! Retrieve RTVMR from TES structure for pseudo-observations + ! TES(NT)%GC_CH4(67) set during SUBROUTINE MAKE_PSEUDO_OBS + IF ( LTES_PSO ) THEN + OBS_RTVMR = 0d0 + OBS_RTVMR = TES(NT)%GC_CH4(67) + ENDIF + + ! DIFF = model - obs. units: [ln(vmr)] / m^2 + !IF ( NT == 600 ) THEN + ! print*,'Error difference [ppb]: ',TES(NT)%ERR(1)*1d9 + ! print*,'GC_RTVMR = ',GC_RTVMR*1d9 + ! print*,'OBS_RTVMR = ',OBS_RTVMR*1d9 +! ! WRITE(6, '(a)') 'Pseudo-obs GEOS-Chem ' +! ! WRITE(6, 545) ( TES(NT)%GC_CH4(L), EXP(CH4_HAT(L)), +! & ! L=1,LTES ) + !ENDIF + 545 FORMAT(F16.14,2x,F16.14) + + + ! Calculate DOFS for satellite diagnostic file + DOFS = 0d0 + DO L=1,LTES + DOFS = DOFS + TES(NT)%AVG_KERNEL(L,L) + ENDDO + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = [ model - obs ]^T S_{obs}^{-1} [ model - obs ] + !-------------------------------------------------------------- + + ! If using pseudo-obs, do not apply bias + DIFF = GC_RTVMR - OBS_RTVMR! + BIAS_PPB * 1d-9 + + + ! Calculate DIFF^T * S_{obs}^{-1} * DIFF + FORCE = 0d0 + FORCE = 2 * DIFF * S_obs_inv + NEW_COST(NT) = 0.5d0 * DIFF * FORCE + + + + + ! Write satellite information to file + ! I,J,LAT,LON,TIME,HOUR,model RTVMR,obs RTVMR,DOFS + IF ( NT == NTSTART ) THEN + WRITE(IU_FILE,301) 'I','J','LAT','LON','MONTH','DAY','HOUR', + & 'TIME_FRAC','MODEL_RTVMR','OBS_RTVMR','DOFS', + & 'ERROR' + ENDIF + WRITE(IU_FILE,302) I,J,TES(NT)%LAT(1),TES(NT)%LON(1), + & GET_MONTH(), GET_DAY(), GET_HOUR(), + & TIME_FRAC(NT), + & 1e9*GC_RTVMR, 1e9*OBS_RTVMR, DOFS, + & 1e9*TES(NT)%ERR(1) + + 301 FORMAT(A4,2x,A4,2x,A8, 2x,A8, 2x,A6,2x,A4,2x,A4,2x,A16, 2x, + & A12, 2x,A12, 2x,A7,2x,A8) + 302 FORMAT(I4,2x,I4,2x,F8.3,2x,F8.3,2x,I4,2x,I4,2x,I4,2x,F16.13,2x, + & F12.4,2x,F12.4,2x,F7.3,2x,F8.3) + + +! ! Calculate difference between modeled and observed profile +! ! Eliminate stratospheric forcing in this +! DO L = 1, LTES +! IF ( TROPP(I,J) < TES(NT)%PRES(L) ) THEN +! DIFF(L) = CH4_HAT(L) - LOG( TES(NT)%GC_CH4(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! !FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,L) * DIFF(L) +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO + + !IF ( NT == 600 ) THEN + ! print*,'DIFF = ', DIFF + ! print*,'FORCE = ',FORCE + ! print*,'NEW_COST = ',NEW_COST(NT) + !ENDIF +! ! dkh debug: compare profiles: +! print*, ' CH4_HAT, CH4_TES, CH4_GC [ppb]' +! WRITE(6,090) ( 1d9 * EXP(CH4_HAT(L)), +! & 1d9 * TES(NT)%CH4(L), +! & 1d9 * TES(NT)%GC_CH4(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, CH4_HAT, CH4_GC [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), CH4_HAT(L), +! & LOG(TES(NT)%GC_CH4(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! ENDIF +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + !kjw. We've now calculated: + ! 1) forcing ( 2 * S_{obs}^{-1} * DIFF = FORCE ) units of [lnvmr]^{-1} + ! 2) New contribution to cost function do to diff + ! DIFF * S_{obs}^{-1} * DIFF + ! This has all been done on the TES pressure grid + ! + ! At this point, we need to initialize the adjoint variable: STT_ADJ + ! Do so by applying the adjoint of all operators used to get + ! STT --> ln(vmr) for calculating ( F(x)-y ) + +! IF ( NT == 600 ) THEN +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! ENDIF +! 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + ! Adjoint of difference + GC_RTVMR_ADJ = DIFF_ADJ + + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(CH4_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(CH4_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(CH4_HAT(:))) + + + ! Adjoint of RTVMR Averaging + DO L=1,LTES + CH4_HAT_ADJ(L) = M_STAR(2,L) * GC_RTVMR_ADJ + ENDDO + + ! kjw debug + !IF ( NT == 600 ) THEN + ! print*,'CH4_HAT_ADJ = ',CH4_HAT_ADJ + !ENDIF + + ! Adjoint of ln(vmr) --> vmr + DO L=1,LTES + IF ( CH4_HAT_ADJ(L) /= 0.0 ) THEN + CH4_HAT_EXP_ADJ(L) = CH4_HAT_ADJ(L) * CH4_HAT_EXP(L) + ELSE + CH4_HAT_EXP_ADJ(L) = 0d0 + ENDIF + ENDDO + + ! kjw debug + !IF ( NT == 600 ) THEN + ! print*,'CH4_HAT_EXP_ADJ = ',CH4_HAT_EXP_ADJ + !ENDIF + +! DO L = 1, LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! CH4_HAT_ADJ(L+1) = GC_RTVMR_ADJ * Nmolec(L)/Totmolec +! ELSE +! CH4_HAT_ADJ(L+1) = 0d0 +! ENDIF +! ENDDO + + +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TROPP(I,J) < TES(NT)%PRES(L) ) THEN +! CH4_HAT_ADJ(L) = DIFF_ADJ(L) +! ELSE +! CH4_HAT_ADJ(L) = 0d0 +! ENDIF +! ENDDO + + ! adjoint of TES operator + DO L = 1, LTES + CH4_PERT_ADJ(L) = 0d0 + DO LL = 1, LTES + CH4_PERT_ADJ(L) = CH4_PERT_ADJ(L) + & + TES(NT)%AVG_KERNEL(L,LL) + & * CH4_HAT_EXP_ADJ(LL) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a (adjoint of natural log transform) + DO L = 1, LTES + ! fwd code: + !GC_CH4(L) = MAX(GC_CH4(L), 1d-10) + !CH4_PERT(L) = LOG(GC_CH4(L)) - LOG(TES(NT)%PRIOR(L)) + ! adj code: + IF ( GC_CH4(L) > 1d-10 ) THEN + GC_CH4_ADJ(L) = 1d0 / GC_CH4(L) * CH4_PERT_ADJ(L) + ELSE + GC_CH4_ADJ(L) = 1d0 / 1d-10 * CH4_PERT_ADJ(L) + ENDIF + ENDDO + +! ! dkh debug +! print*, 'CH4_HAT_ADJ, CH4_PERT_ADJ, GC_CH4_ADJ' +! WRITE(6,103) (CH4_HAT_ADJ(L), CH4_PERT_ADJ(L), GC_CH4_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_CH4_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_CH4_NATIVE_ADJ(L) = GC_CH4_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_CH4_ADJ(LL) + ENDDO + ENDDO + + ! kjw + ! Adjoint of interpolation leaves GC_CH4_NATIVE_ADJ with some zeros + ! in the lower troposphere. This occurs because the GC pres grid is + ! finer in lower troposphere than the TES grid. So, when interpolating + ! from GC --> TES, the contribution from some GC grid boxes to any TES + ! grid box is zero. Unfortunately, when we go back from TES to GC grid, + ! this means that some + + +! WRITE(114,112) ( GC_CH4_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! ! dkh debug +! print*, 'GC_CH4_NATIVE_ADJ 1 ' +! WRITE(6,104) (GC_CH4_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + + DO L = 1, LLPAR + + ! Adjoint of unit conversion + GC_CH4_NATIVE_ADJ(L) = ( GC_CH4_NATIVE_ADJ(L) * + & XNUMOL(1) / 6.022d23 ) / + & ( AD(I,J,L) * XNUMOLAIR / 6.022d23 ) + + + ! Just to make sure we're only forcing the troposphere + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + ! Pass adjoint back to adjoint tracer array + STT_ADJ(I,J,L,1) = + & STT_ADJ(I,J,L,1) + GC_CH4_NATIVE_ADJ(L) + + ENDIF + + ENDDO + + !kjw debug + !IF ( NT == 600 ) THEN + ! print*,'GC_CH4_NATIVE_ADJ = ',GC_CH4_NATIVE_ADJ + !ENDIF + !kjw debug + +!! ! dkh debug +! print*, 'GC_CH4_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_CH4_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_CH4(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%CH4(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( CH4_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_CH4_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(CH4_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_CH4_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * CH4_HAT(LL), LL=LTES,1,-1) +! WRITE(115,110) ( 1d9 * TES(NT)%GC_CH4(LL), LL=LTES,1,-1) + 110 FORMAT(F18.6,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + +! ----------------------------------------------------------------------- +! Use this section to test the adjoint of the TES_CH4 operator by +! slightly perturbing model [CH4] and recording resultant change +! in calculated contribution to the cost function. +! +! This routine will write the following information for each observation +! to rundir/diagadj/test_adjoint_obs.NN.m +! +! The adjoint of the observation operator has been tested and validated +! as of 7/20/10, kjw. +! +! IF ( NT .EQ. 600 ) THEN +! WRITE(116,210) ' L' , ' TROP', ' GC_PRES', +! & ' FD_POS', ' FD_NEG', ' FD_CEN', +! & ' ADJ', ' COST_POS', ' COST_NEG', +! & ' FD_POS/ADJ', ' FD_NEG/ADJ', ' FD_CEN/ADJ' +! PERT(:) = 1D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ, NT ) +! ori=.FALSE. +! ADJ_SAVE(:) = ADJ(:) +! print*, 'dch4: COST_FUNC_0 = ', COST_FUNC_0 +! WRITE(116,213) 'I ', I +! WRITE(116,213) 'J ', J +! WRITE(116,213) 'LTES ',TES(NT)%LTES(1) +! WRITE(116,212) 'GC_PSURF ', GC_PSURF +! WRITE(116,212) 'TES PSURF ',TES(NT)%PRES(1) +! WRITE(116,212) 'NEW_COST: ',NEW_COST(NT) +! WRITE(116,213) 'NT ', NT +! WRITE(116,212) 'COST_FUNC_0:',( COST_FUNC_0 ) +! WRITE(116,212) 'TES(NT).TIME',TES(NT)%TIME(1) +! DO L = 1, 47 +! PERT(:) = 1D0 +! PERT(L) = 1.1 +! COST_FUNC_1 = 0D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_1, PERT, ADJ, NT ) +! PERT(L) = 0.9 +! COST_FUNC_2 = 0D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_2, PERT, ADJ, NT ) +! FD_CEN(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +! FD_POS(L) = ( COST_FUNC_1 - COST_FUNC_0 ) / 0.1d0 +! FD_NEG(L) = ( COST_FUNC_0 - COST_FUNC_2 ) / 0.1d0 +! WRITE(116, 211) L, ITS_IN_THE_TROP(I,J,L), GC_PRES(L), +! & FD_POS(L), FD_NEG(L), +! & FD_CEN(L), ADJ_SAVE(L), +! & COST_FUNC_1, COST_FUNC_2, +! & FD_POS(L)/ADJ_SAVE(L), +! & FD_NEG(L)/ADJ_SAVE(L), +! & FD_CEN(L)/ADJ_SAVE(L) +! ENDDO +! WRITE(116,'(a)') '----------------------------------------------' +! +! 210 FORMAT(A4,2x,A6,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x,A12,2x, +! & A12,2x,A12,2x,A12,2x,A12,2x) +! 211 FORMAT(I4,2x,L6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6, +! & 2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6,2x,D12.6) +! 212 FORMAT(A12,F22.6) +! 213 FORMAT(A12,I4) +! 214 FORMAT(I4,2x,F18.6,2x,F18.6) +!! ----------------------------------------------------------------------- +! ENDIF ! IF ( NT .EQ. 600 ) + + + print*, ' - CALC_TES_CH4_FORCE: NEW_COST(NT) = ',NEW_COST(NT) + + +! ! kjw +! ! Calculate contribution to cost function for regions in my 9 box grid +! ! Here, we define regions +! reg = 0 +! IF ( LTES_PSO == .TRUE. ) THEN +! IF (( J-1 > JJPAR*2./3. ) .AND. ( I+1 < IIPAR/3. )) reg = 1 +! IF (( J-1 > JJPAR*2./3. ) .AND. ( I-1 > IIPAR*2./3.)) reg = 3 +! IF (( J-1 > JJPAR*2./3. ) .AND. ( reg == 0 ) ) reg = 2 +! IF (( J+1 < JJPAR/3. ) .AND. ( I+1 < IIPAR/3. )) reg = 7 +! IF (( J+1 < JJPAR/3. ) .AND. ( I-1 > IIPAR*2./3.)) reg = 9 +! IF (( J+1 < JJPAR/3. ) .AND. ( reg == 0 ) ) reg = 8 +! IF (( I+1 < IIPAR/3. ) .AND. ( reg == 0 ) ) reg = 4 +! IF (( I-1 > IIPAR*2./3. ) .AND. ( reg == 0 ) ) reg = 6 +! IF (( reg == 0 ) ) reg = 5 +! ENDIF ! ENDIF LTES_PSO == .TRUE. +! +! ! Assign value to proper region +! JJ_this(reg) = JJ_this(reg) + NEW_COST(NT) +! Jforce_this(reg) = Jforce_this(reg) + FORCE +! Jdiff_this(reg) = Jdiff_this(reg) + DIFF +! +! JJ(reg) = JJ(reg) + NEW_COST(NT) +! Jforce(reg) = Jforce(reg) + FORCE +! Jdiff(reg) = Jdiff(reg) + DIFF + + + ENDDO ! NT +!!$OMP END PARALLEL DO + + print*, ' - CALC_TES_CH4_FORCE: finished assimilating ' // + & 'data this hour.' + + print*,'NEW_COST(NTSTOP:NTSTART) = ', NEW_COST(NTSTOP:NTSTART) + print*,'SUM(NEW_COST(NTSTOP:NTSTART)) = ', + & SUM(NEW_COST(NTSTOP:NTSTART)) + print*,'NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + IF ( FIRST ) FIRST = .FALSE. + + +! ! Print information about JJ_this, Jforce_this, Jdiff_this +! ! Cost function info by region +! print*,'EYOEYOEYO, J info below' +! print*,'Year, month, day, hour, hours before end of simulation' +! print*,GET_YEAR(), GET_MONTH(), GET_DAY(), GET_HOUR(), +! & GET_TAUe() - GET_TAU() +! WRITE(6,820) 'JJ_this= ', JJ +! WRITE(6,820) 'Jforce_this= ', Jforce +! WRITE(6,820) 'Jdiff*1d9_this= ', Jdiff*1d9 +! 820 FORMAT(A18, 2x, 9F28.6 ) + + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution this hour = ', COST_FUNC - OLD_COST + + + ! Close Satellite diagnostic file + CLOSE( IU_FILE ) + + + ! kjw + ! Print Information about cost function and forcing according + ! to region defined by apriori. Print information added during + ! this call to CALC_TES_CH4_FORCE + ! kjw + + + + ! Return to calling program + END SUBROUTINE CALC_TES_CH4_FORCE + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_CH4_FORCE_FD( COST_FUNC_A, PERT, ADJ, NT ) +! +!****************************************************************************** +! Subroutine CALC_TES_CH4_FORCE_FD tests the adjoint of CALC_TES_CH4_FORCE +! (dkh, 05/05/10) +! +! Can be driven with: +! PERT(:) = 1D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +! ADJ_SAVE(:) = ADJ(:) +! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +! DO L = 1, 30 +! PERT(:) = 1D0 +! PERT(L) = 1.1 +! COST_FUNC = 0D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +! PERT(L) = 0.9 +! COST_FUNC = 0D0 +! CALL CALC_TES_CH4_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +! print*, 'do3: FD = ', FD(L), L +! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +! print*, 'do3: COST = ', COST_FUNC, L +! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +! ENDDO +! +! +! +! +! Arguments as Input/Output: +! =========================================================================== +! (1 ) COST_FUNC_A (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (1 ) Add more diagnostics. Now read and write doubled CH4 (dkh, 11/08/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : CH4_PROF_SAV + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : CSPEC, JLOP + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DAO_MOD, ONLY : TROPP + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR, XNUMOL + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE TRACER_MOD, ONLY : STT + USE LOGICAL_ADJ_MOD, ONLY : LTES_PSO + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC_A + INTEGER, INTENT(IN) :: NT + REAL*8, INTENT(IN) :: PERT(LLPAR) + REAL*8, INTENT(OUT) :: ADJ(LLPAR) + + ! Local variables + INTEGER :: NTSTART, NTSTOP + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: GC_CH4(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: CH4_HAT(MAXLEV) + REAL*8 :: CH4_HAT_EXP(MAXLEV) + REAL*8 :: CH4_PERT(MAXLEV) + REAL*8 :: FORCE + REAL*8 :: DIFF + REAL*8 :: NEW_COST!(MAXTES) + REAL*8 :: OLD_COST + !REAL*8, SAVE :: TIME_FRAC!(MAXTES) + !INTEGER,SAVE :: NTES + + REAL*8 :: GC_CH4_NATIVE_ADJ(LLPAR) + REAL*8 :: CH4_HAT_ADJ(MAXLEV) + REAL*8 :: CH4_HAT_EXP_ADJ(MAXLEV) + REAL*8 :: CH4_PERT_ADJ(MAXLEV) + REAL*8 :: GC_CH4_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ + REAL*4 :: S_obs_inv + REAL*8 :: GC_RTVMR + REAL*8 :: OBS_RTVMR + REAL*8 :: GC_RTVMR_ADJ + REAL*8 :: M_STAR(4,MAXLEV) + REAL*8 :: Pres_ln(MAXLEV) + REAL*8 :: Pedges_ln(MAXLEV) + REAL*8 :: Pedges(MAXLEV) + REAL*8 :: Pdiff(MAXLEV) + REAL*8 :: Nmolec(MAXLEV) + REAL*8 :: Totmolec + REAL*8 :: DIFF_onTES(MAXLEV) + + !LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + + !================================================================= + ! CALC_TES_CH4_FORCE_FD begins here! + !================================================================= + + !print*, ' - CALC_TES_CH4_FORCE_FD ' + + NEW_COST = 0D0 + + ! Calculate S_obs_inv + !S_obs_inv = 1. / ( LOG( ( 1800. + ERR_PPB ) / 1800. ) )**2 + S_obs_inv = 1. / ( 40.0d-9 ** 2 ) + + +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'force_adj_stuff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC_A +! +! ! Check if it is the last hour of a day +! IF ( GET_NHMS() == 230000 ) THEN +! +! ! Read the TES CH4 file for this day +! CALL READ_TES_CH4_OBS( GET_NYMD(), NTES ) +! +! ! If NTES = 0, it means there are no observations today. +! ! Return to calling procedure +! IF ( NTES == 0 ) THEN +! WRITE(6,*) ' No TES CH4 obs today. Returning 01 ... ' +! RETURN +! ENDIF +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +!! ENDIF +! +! ! If NTES = 0, it means there are no observations today. +! ! Return to calling procedure +! IF ( NTES == 0 ) THEN +! WRITE(6,*) ' No TES CH4 obs today. Returning 02 ... ' +! RETURN +! ENDIF +! +! +! ! Get the range of TES retrievals for the current hour +! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +! +! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +! +! print*, ' No matching TES CH4 obs for this hour' +! RETURN +! ENDIF +! +! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +! & TIME_FRAC(NTSTOP) +! print*, ' found record range: ', NTSTART, NTSTOP + +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_CH4, DIFF ) +!!!$OMP+PRIVATE( GC_CH4_NATIVE, CH4_PERT, CH4_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_CH4_NATIVE_ADJ, GC_CH4_ADJ ) +!!!$OMP+PRIVATE( CH4_PERT_ADJ, CH4_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 + + !print*, ' - CALC_TES_CH4_FORCE_FD: analyzing record ', NT + + ! For safety, initialize these up to LLTES + GC_CH4(:) = 0d0 + MAP(:,:) = 0d0 + CH4_HAT_ADJ(:) = 0d0 + FORCE = 0d0 + + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + !print*, 'I,J = ', I, J + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), TES(NT)%PRES(1) ) + + + ! Get CH4 values at native model resolution + !DO L = 1, LLPAR + + + !kjw. JLOP and CSPEC are variables in comode_mod.f, associated + ! with smvgear. For getting CH4 values at native model + ! resolution, write my own thing, it'll probably have to do + ! with using CH4 from STT when below tropopause, and using + ! the TES retrieval above the tropopause. Therefore, there + ! will be no adjoint forcing above the tropopause. + !kjw. + + !kjw + ! Get CH4 from restored STT array + ! Find out units of STT (I think it's [kg/box]). + ! If so, convert to [v/v] before next step + DO L=1,LLPAR + GC_CH4_NATIVE(L) = CHK_STT(I,J,L,1) * PERT(L) + ENDDO + + ! Unit Conversion + DO L=1,LLPAR + + ! Convert from [kg/box] --> [v/v] + ! Numerator = moles CH4/box + ! Denominator = moles air/box + GC_CH4_NATIVE(L) = (GC_CH4_NATIVE(L)*XNUMOL(1)/6.022d23 ) / + & ( AD(I,J,L) * XNUMOLAIR / 6.022d23 ) + ENDDO + !!!! Bypass unit conversion +!!! GC_CH4_NATIVE(:) = GC_CH4_NATIVE(:) + + ! Interpolate GC CH4 column to TES grid + DO LL = 1, LTES + GC_CH4(LL) = 0d0 + DO L = 1, LLPAR + GC_CH4(LL) = GC_CH4(LL) + & + MAP(L,LL) * GC_CH4_NATIVE(L) + ENDDO + ENDDO +!!! ! Bypass interpolation +!!! GC_CH4(1:47) = GC_CH4_NATIVE(:) +!!! + +! !kjw testing +! IF ( ori .EQ. .TRUE. ) THEN +! print*,'-------------------------' +! print*,'GC_CH4(13) = ',GC_CH4(13) +! ENDIF +! !kjw testing + + +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_CH4 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_CH4_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_CH4 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_CH4(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) + + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + ! x_m - x_a + DO L = 1, LTES + GC_CH4(L) = MAX(GC_CH4(L), 1d-10) + CH4_PERT(L) = LOG(GC_CH4(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + +! !kjw testing +! IF ( ori .EQ. .TRUE. ) THEN +! print*,'CH4_PERT(13) = ',CH4_PERT(13) +! ENDIF +! !kjw testing +!!! ! Bypass !x_m - x_a +!!! CH4_PERT(:) = GC_CH4(:) +!!! + + ! x_a + A_k * ( x_m - x_a ) + ! AVG_KERNEL indexing may look backwards because BPCH files storing AK + ! values use IDL column major indexing. + DO L = 1, LTES + CH4_HAT(L) = 0d0 + DO LL = 1, LTES + CH4_HAT(L) = CH4_HAT(L) + & + TES(NT)%AVG_KERNEL(LL,L) * CH4_PERT(LL) + ENDDO + CH4_HAT(L) = CH4_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO +!!! ! Bypass !x_a + A_k * ( x_m - x_a ) +!!! CH4_HAT(:) = CH4_PERT(:) +!!! + + +! !-------------------------------------------------------------- +! ! Calculate column average ln(vmr) weighted by # density of TES grid +! ! This operation is self adjoint. +! ! To get # density [molec / m^2], get pressure differences in grid. +! ! Get kg/m^2 of air in each box. (F=ma) dP=kg*g +! ! Get molec/m^2 air molec/m2 = kg/m2 * XNUMOLAIR +! ! TES pressure grid linear in ln(pres). Get pressure at edge of boxes +! !-------------------------------------------------------------- +! pres_ln(1:LTES)=LOG(TES(NT)%pres(1:LTES)) ! [hPa] --> ln([hPa]) +! Pedges_ln(1)=pres_ln(1) ! Bottom edge is surface pressure +! DO L=2,LTES-1 +! Pedges_ln(L) = ( pres_ln(L) + pres_ln(L+1) ) / 2. +! ENDDO +! Pedges=EXP(pedges_ln) ! ln([hPa]) --> [hPa] +! Pedges(LTES)=0 ! Top of atmosphere +! !print*,' kjw debug: TES pressure edges' +! !print*, Pedges +! +! ! Calculate pressure difference of each LTES-1 boxes +! DO L=1,LTES-1 +! Pdiff(L) = Pedges(L) - Pedges(L+1) +! ENDDO +! +! ! Calculate # molecules air in each LTES-1 obxes +! Pdiff(:) = 100 * Pdiff(:) ! [hPa] --> [Pa] +! Pdiff(:) = Pdiff(:) / 9.8 ! [hPa] --> [kg] +! Nmolec(:)= Pdiff(:) * XNUMOLAIR ! [kg] --> [molec] +! Totmolec = 0d0 +! DO L=1,LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! Totmolec = Totmolec + Nmolec(L) +! ENDIF +! ENDDO +! +! IF ( NT .EQ. 600 ) THEN +! !print*,' kjw debug:# molecules in column (should be ~2e29)' +! !print*, Totmolec +! ENDIF +! +! ! Calculate column average ln(vmr) weighted by # density of TES levels +! ! Only include levels with tropospheric air +! OBS_avg = 0d0 +! GC_avg = 0d0 +! DIFF_onTES(:) = 0d0 +! DIFF_onTES(1:LTES) = LOG(TES(NT)%GC_CH4(1:LTES)) - +! & CH4_HAT(1:LTES) +! DO L=1,LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! OBS_avg = OBS_avg + +! & LOG(TES(NT)%GC_CH4(L+1)) * Nmolec(L)/Totmolec +! GC_avg = GC_avg + +! & CH4_HAT(L+1) * Nmolec(L)/Totmolec +! ENDIF +! ENDDO + + + ! Transform from [ln(vmr)] --> [vmr] + CH4_HAT_EXP = EXP(CH4_HAT) + + ! Calculate RTln(VMR) for profiles. + CALL GET_RTVMR( NT, TES(NT)%GC_CH4, OBS_RTVMR, M_STAR ) + CALL GET_RTVMR( NT, CH4_HAT_EXP, GC_RTVMR, M_STAR ) + + + ! Retrieve RTVMR from TES structure for pseudo-observations + IF ( LTES_PSO ) THEN + OBS_RTVMR = 0d0 + OBS_RTVMR = TES(NT)%GC_CH4(67) + ENDIF + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! DIFF = model - obs. units: [ln(vmr)] / m^2 + DIFF = GC_RTVMR - OBS_RTVMR + + + ! Calculate DIFF^T * S_{obs}^{-1} * DIFF + FORCE = 0d0 + FORCE = 2 * DIFF * S_obs_inv + NEW_COST = 0.5d0 * DIFF * FORCE + + +! ! Calculate difference between modeled and observed profile +! ! Eliminate stratospheric forcing in this +! DO L = 1, LTES +! IF ( TROPP(I,J) < TES(NT)%PRES(L) ) THEN +! DIFF(L) = CH4_HAT(L) - LOG( TES(NT)%GC_CH4(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! ! Bypass DIFF +!!!! DIFF(:) = CH4_HAT(:) +! +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) *DIFF(LL) +! ENDDO +! NEW_COST = NEW_COST + 0.5d0 * DIFF(L) * FORCE(L) +! !NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO + +!!! !Bypass this part of adjoint +!!! DO L=1,LTES +!!! FORCE(L) = 0.5d0 +!!! NEW_COST=NEW_COST+ 0.5d0 * DIFF(L) +!!! ENDDO + + + +! ! dkh debug: compare profiles: +! print*, ' CH4_HAT, CH4_TES, CH4_GC [ppb]' +! WRITE(6,090) ( 1d9 * EXP(CH4_HAT(L)), +! & 1d9 * TES(NT)%CH4(L), +! & 1d9 * TES(NT)%GC_CH4(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, CH4_HAT, CH4_GC [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), CH4_HAT(L), +! & LOG(TES(NT)%GC_CH4(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- + + !kjw. We've now calculated: + ! 1) forcing ( 2 * S_{obs}^{-1} * DIFF = FORCE ) units of [lnvmr]^{-1} + ! 2) New contribution to cost function do to diff + ! DIFF * S_{obs}^{-1} * DIFF + ! This has all been done on the TES pressure grid + ! + ! At this point, we need to initialize the adjoint variable: STT_ADJ + ! Do so by applying the adjoint of all operators used to get + ! STT --> ln(vmr) for calculating ( F(x)-y ) + + ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is 2 * S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ = FORCE + + ! Adjoint of difference + GC_RTVMR_ADJ = DIFF_ADJ + + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(CH4_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(CH4_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(CH4_HAT(:))) + + +! ! Adjoint of Column Averaging +! DO L = 1, LTES-1 +! IF ( TROPP(I,J) < Pedges(L) ) THEN +! CH4_HAT_ADJ(L+1) = GC_avg_ADJ * Nmolec(L)/Totmolec +! ELSE +! CH4_HAT_ADJ(L+1) = 0d0 +! ENDIF +! ENDDO + + ! Adjoint of RTVMR Averaging + DO L=1,LTES + CH4_HAT_ADJ(L) = M_STAR(2,L) * GC_RTVMR_ADJ + ENDDO + + ! Adjoint of ln(vmr) --> vmr + DO L=1,LTES + IF ( CH4_HAT_ADJ(L) /= 0.0 ) THEN + CH4_HAT_EXP_ADJ(L) = CH4_HAT_ADJ(L) * CH4_HAT_EXP(L) + ELSE + CH4_HAT_EXP_ADJ(L) = 0d0 + ENDIF + ENDDO + +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TROPP(I,J) < TES(NT)%PRES(L) ) THEN +! CH4_HAT_ADJ(L) = DIFF_ADJ(L) +! ELSE +! CH4_HAT_ADJ(L) = 0d0 +! ENDIF +! ENDDO +!!! ! Bypass adjoint of difference +!!! CH4_HAT_ADJ(:) = DIFF_ADJ(:) + + + +!!! ! adjoint of TES operator + DO L = 1, LTES + CH4_PERT_ADJ(L) = 0d0 + DO LL = 1, LTES + CH4_PERT_ADJ(L) = CH4_PERT_ADJ(L) + & + TES(NT)%AVG_KERNEL(L,LL) + & * CH4_HAT_EXP_ADJ(LL) + ENDDO + ENDDO +!!! ! Bypass adjoint of TES operator +!!! CH4_PERT_ADJ(:) = CH4_HAT_ADJ(:) +!!! + + ! Adjoint of x_m - x_a + DO L = 1, LTES + ! fwd code: + !GC_CH4(L) = MAX(GC_CH4(L), 1d-10) + !CH4_PERT(L) = LOG(GC_CH4(L)) - LOG(TES(NT)%PRIOR(L)) + ! adj code: + IF ( GC_CH4(L) > 1d-10 ) THEN + GC_CH4_ADJ(L) = 1d0 / GC_CH4(L) * CH4_PERT_ADJ(L) + ELSE + GC_CH4_ADJ(L) = 1d0 / 1d-10 * CH4_PERT_ADJ(L) + ENDIF + ENDDO +!!! ! Bypass adjoint of x_m - x_a +!!! GC_CH4_ADJ(:) = CH4_PERT_ADJ(:) + + + + ! dkh debug +! print*, 'CH4_HAT_ADJ, CH4_PERT_ADJ, GC_CH4_ADJ' +! WRITE(6,103) (CH4_HAT_ADJ(L), CH4_PERT_ADJ(L), GC_CH4_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + +! ! adjoint of interpolation + DO L = 1, LLPAR + GC_CH4_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_CH4_NATIVE_ADJ(L) = GC_CH4_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_CH4_ADJ(LL) + ENDDO + ENDDO +!!! ! Bypass adjoint of interpolation +!!! GC_CH4_NATIVE_ADJ(:) = GC_CH4_ADJ(1:47) +!!! + + ! kjw + ! Adjoint of interpolation leaves GC_CH4_NATIVE_ADJ with some zeros + ! in the lower troposphere. This occurs because the GC pres grid is + ! finer in lower troposphere than the TES grid. So, when interpolating + ! from GC --> TES, the contribution from some GC grid boxes to any TES + ! grid box is zero. Unfortunately, when we go back from TES to GC grid, + ! this means that some + + +! WRITE(114,112) ( GC_CH4_NATIVE_ADJ(L), L=LLPAR,1,-1) + + ! dkh debug + !print*, 'GC_CH4_NATIVE_ADJ 1 ' + ! WRITE(6,104) (GC_CH4_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + + DO L = 1, LLPAR + + ! Adjoint of unit conversion + GC_CH4_NATIVE_ADJ(L) = ( GC_CH4_NATIVE_ADJ(L) * + & XNUMOL(1) / 6.022d23 ) / + & ( AD(I,J,L) * XNUMOLAIR / 6.022d23 ) + !!!! Bypass adjoint of unit conversion + !!!GC_CH4_NATIVE_ADJ(:) = GC_CH4_NATIVE_ADJ(:) + + ! Just to make sure we're only forcing the troposphere + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + ! Pass adjoint back to adjoint tracer array + STT_ADJ(I,J,L,1) = + & STT_ADJ(I,J,L,1) + GC_CH4_NATIVE_ADJ(L) + + ADJ(L) = GC_CH4_NATIVE_ADJ(L) * CHK_STT(I,J,L,1) + ELSE + ADJ(L) = 0 + ENDIF + + ENDDO + + +! ! dkh debug +! print*, 'GC_CH4_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_CH4_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_CH4(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%CH4(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( CH4_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_CH4_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(CH4_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_CH4_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_CH4(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! WRITE(116,212) TES(NT)%TIME(1) +! 212 FORMAT(F22.6) + + ! Update cost function + ! COST_FUNC = SUM( NEW_COST(NTSTART:NTSTOP)) + COST_FUNC_A = NEW_COST + + + ! Return to calling program + END SUBROUTINE CALC_TES_CH4_FORCE_FD + +!!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_PSEUDO_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine MAKE_PSEUDO_OBS populates TES%GC_CH4 with processed GC columns +! Processing consists of adding error and applying TES observation operator +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) YYYYMMDD (INTEGER) : Current model date +! +! Arguments as Output: +! ============================================================================ +! (0 ) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : EXPAND_DATE + USE FILE_MOD, ONLY : IU_FILE, IOERROR + USE DIRECTORY_MOD, ONLY : RUN_DIR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR, DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH, GET_DAY + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE TRANSFER_MOD, ONLY : TRANSFER_2D, TRANSFER_3D + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, EXPAND_NAME + + +# include "CMN_SIZE" ! Size params + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: YYYYMMDD + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: FILENAME_ROOT + CHARACTER(LEN=255) :: FILENAME_OBS + INTEGER :: IOS, NT, I, J, L + INTEGER :: IIJJ(2), LL, LTES + INTEGER :: DD, MM, YYYY + INTEGER :: HH, HH_last, HHMMSS + REAL*4 :: ARRAY2D(IIPAR,JJPAR,1) + REAL*4 :: ARRAY3D(IIPAR,JJPAR,LLPAR) + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: GC_CH4(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PRES(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_PSURF(IIPAR,JJPAR) + REAL*8 :: GC_PRES_this(LLPAR) + REAL*8 :: GC_CH4_NATIVE_this(LLPAR) + REAL*8 :: GC_CH4_this(MAXLEV) + REAL*8 :: CH4_PERT(MAXLEV) + REAL*8 :: CH4_HAT(MAXLEV) + REAL*8 :: GC_PSURF_this + REAL*8 :: XTAU + REAL*8 :: day_frac + REAL*8 :: GC_PSO_RTVMR + REAL*8 :: GC_PSO_RTVMR_werr + REAL*8 :: M_STAR(4,MAXLEV) + + + !================================================================= + ! MAKE_PSEUDO_OBS begins here! + !================================================================= + + ! ---------------------------------------------------------------- + ! Get Today's Error values + WRITE(6,'(a)') ' MAKE_PSEUDO_OBS - reading random errors' + + ! filename + FILENAME = TRIM( 'tes_ch4_random_YYYYMMDD.txt' ) + + ! Expand date tokens in filename + CALL EXPAND_DATE( FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + FILENAME = TRIM('/home/kjw/TES/data/V004/bpch/randoms/') // + & TRIM( FILENAME ) + + ! Open file + print*,'Opening: ', TRIM(FILENAME) + OPEN( IU_FILE, FILE=TRIM( FILENAME ), + & STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_rand_file:1') + + ! Read each line + DO NT=1,NTES+1 + READ( IU_FILE, '(F16.12)', IOSTAT=IOS ) TES(NT)%ERR(1) + IF ( NT .EQ. NTES+1 ) THEN + IF ( IOS < 0 ) THEN + WRITE(6,'(a)') 'Done reading random errors' + ELSE + WRITE(6,'(a)') 'Unexpected end. read_rand_file:2' + ENDIF + ENDIF + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + print*,'1TES(300)%ERR(1) = ',TES(300)%ERR(1) + + ! Errors have mean=0, stddev=1. Multiply by ERR_PPB (20-40) / 1d9 + print*,ERR_PPB + DO NT=1,NTES + TES(NT)%ERR(1) = TES(NT)%ERR(1) * ERR_PPB / 1.0d9 + ENDDO + print*,'2TES(300)%ERR(1) = ',TES(300)%ERR(1) + + + ! ---------------------------------------------------------------- + ! Get Today's GEOS-Chem columns + WRITE(6,'(a)') ' MAKE_PSEUDO_OBS - Reading GEOS-Chem observations' + + ! Set HH_last to -1 to guarantee opening file for 1st observation + HH_last = -1 + + ! Loop over each TES observation + DO NT=1,NTES + + print*, ' - MAKE_PSEUDO_OBS: for record ', NT + + ! Get date and hour of observation (round time) + YYYY = floor( ( YYYYMMDD * 1d-4 ) ) + MM = floor( ( YYYYMMDD - 1d4 * YYYY ) * 1d-2 ) + DD = floor( ( YYYYMMDD - 1d4 * YYYY - 1d2 * MM ) ) + day_frac = TES(NT)%TIME(1) - 1d4 * YYYY - + & 1d2 * MM - DD + HH = nint( 24. * day_frac ) + IF ( HH == 24 ) HH = 23 ! If last 1/2 hour of day, use HH=23 + HHMMSS = 1d4 * HH + + ! Open new obs file if necessary + IF ( HH /= HH_last ) THEN + + FILENAME_ROOT = TRIM( RUN_DIR ) + FILENAME_OBS = 'gctm.obs.YYYYMMDD.hhmm' + + print*,'TES(NT)%TIME(1) = ',TES(NT)%TIME(1) + print*,'GET_YEAR = ', GET_YEAR() + print*,'GET_MONTH = ', GET_MONTH() + print*,'GET_DAY = ', GET_DAY() + print*,'YYYY = ',YYYY + print*,'MM = ',MM + print*,'HH = ',HH + print*,'HHMMSS = ',HHMMSS + print*,'FILENAME_OBS = ',FILENAME_OBS + CALL EXPAND_DATE( FILENAME_OBS, YYYYMMDD, HHMMSS ) + FILENAME_OBS = TRIM( ADJTMP_DIR ) // + & TRIM( FILENAME_OBS ) + print*,'FILENAME_OBS = ', FILENAME_OBS + + ! Get Tau value for BPCH read + XTAU = GET_TAU0( MM, DD, YYYY, HH ) + + ! Get 3D array of GEOS-Chem values + print*,'Read observations' + GC_CH4(:,:,:) = 0d0 + ARRAY3D(:,:,:) = 0d0 + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, ARRAY3D, QUIET=.TRUE. ) + !CALL TRANSFER_3D( ARRAY3D(:,:,:), GC_CH4(:,:,:) ) + GC_CH4(:,:,:) = ARRAY3D(:,:,:) + + ! Get 3D array of GEOS-Chem pressure centers + print*,'Read pressure centers' + ARRAY3D(:,:,:) = 0d0 + GC_PRES(:,:,:) = 0d0 + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 2, + & XTAU, IIPAR, JJPAR, + & LLPAR, ARRAY3D, QUIET=.TRUE. ) + !CALL TRANSFER_3D( ARRAY3D(:,:,:), GC_PRES(:,:,:) ) + GC_PRES(:,:,:) = ARRAY3D(:,:,:) + + ! Get 2D array of GEOS-Chem surface pressure + print*,'Read surface pressure' + GC_PSURF(:,:) = 0d0 + ARRAY2D(:,:,1) = 0d0 + CALL READ_BPCH2( TRIM(FILENAME_OBS), 'IJ-OBS-$', 3, + & XTAU, IIPAR, JJPAR, + & 1, ARRAY2D, QUIET=.TRUE. ) + !CALL TRANSFER_2D( ARRAY2D(:,:,1), GC_PSURF(:,:) ) + GC_PSURF(:,:) = ARRAY2D(:,:,1) + + ENDIF + + ! RESET a few variables to be safe + I = 0 + J = 0 + GC_PRES_this(:) = 0d0 + GC_PSURF_this = 0d0 + CH4_HAT(:) = 0d0 + MAP(:,:) = 0d0 + GC_PSO_RTVMR = 0d0 + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES_this(L) = GC_PRES(I,J,L) + GC_CH4_NATIVE_this(L) = GC_CH4(I,J,L)! + TES(NT)%ERR(1) + ENDDO + + + ! Get GC surface pressure (mbar) + GC_PSURF_this = GC_PSURF(I,J) + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES_this(:), GC_PSURF_this, + & LTES, TES(NT)%PRES(1:LTES), TES(NT)%PRES(1) ) + + + IF ( NT == 600 ) THEN + !print*,'LTES = ',LTES + !print*,'LLPAR = ',LLPAR + !print*,'GC_PSURF = ',GC_PSURF_this + + !WRITE(6,'(a)') 'GEOS-Chem pressure grid' + !WRITE(6,'(F10.3)') ( GC_PRES_this(L), L=1,47 ) + + !WRITE(6,'(a)') 'TES pressure grid' + !WRITE(6,'(F10.3)') ( TES(NT)%PRES(L), L=1,65 ) + + WRITE(6,'(a)') '20th row of MAP matrix in MAKE_PSEUDO_OBS' + WRITE(6,'(5F8.5)') ( MAP(20:24,L) , L=65,1,-1) + ENDIF + + ! Interpolate GC CH4 column to TES grid + DO LL = 1, LTES + GC_CH4_this(LL) = 0d0 + DO L = 1, LLPAR + GC_CH4_this(LL) = GC_CH4_this(LL) + & + MAP(L,LL) * GC_CH4_NATIVE_this(L) + ENDDO + ENDDO + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_CH4_this(L) = MAX(GC_CH4_this(L), 1d-10) + CH4_PERT(L) = LOG(GC_CH4_this(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LTES + CH4_HAT(L) = 0d0 + DO LL = 1, LTES + CH4_HAT(L) = CH4_HAT(L) + & + TES(NT)%AVG_KERNEL(LL,L) * CH4_PERT(LL) + ENDDO + CH4_HAT(L) = CH4_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + ! Indexing of Averaging Kernel is seemingly backwards because + ! TES observation files processed in IDL, which is column major + + + ! Get RTVMR of GEOS-Chem column w/ TES obs operator applied + CALL GET_RTVMR( NT, EXP(CH4_HAT), GC_PSO_RTVMR, M_STAR ) + + ! Add random error w/ standard deviation = ERR_PPB to RTVMR + GC_PSO_RTVMR_werr = GC_PSO_RTVMR + TES(NT)%ERR(1) + + + ! Place pseudo-observation RTVMR [v/v] in TES structure + TES(NT)%GC_CH4(67) = GC_PSO_RTVMR_werr + + IF ( NT == 600 ) THEN + print*,'Error [v/v] = ', TES(NT)%ERR(1) + print*,'GC_PSO_RTVMR = ',GC_PSO_RTVMR + print*,'GC_PSO_RTVMR_werr = ',GC_PSO_RTVMR_werr + ENDIF + + ! Make this hour equal to last hour + HH_last = HH + HH = 0 + + +! ! Check GEOS-Chem, Error, and CH4_HAT for a given observation +! ! Success! kjw, 07/25/10 +! IF ( NT == 600 ) THEN +! ! Write values for one observation to check that it's right +! FILENAME = 'test_pseudo_obs.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! WRITE(IU_FILE,'(a4,i4)') 'I = ', I +! WRITE(IU_FILE,'(a4,i4)') 'J = ', J +! WRITE(IU_FILE,'(a12,F8.3)') 'TES PSURF = ', TES(NT)%PRES(1) +! WRITE(IU_FILE,'(a12,F8.3)') 'GC PSURF = ', GC_PSURF_this +! WRITE(IU_FILE,'(a10,F16.12)') 'ERR_PPB =',1d9*TES(NT)%ERR(1) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'GEOS-Chem CH4 Native' +! WRITE(IU_FILE,'(F16.8)') (1d9*GC_CH4(I,J,L), L=1,47) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'GEOS-Chem CH4 Native w Error' +! WRITE(IU_FILE,'(F16.8)') (1d9*GC_CH4_native_this(L),L=1,47) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'GEOS-Chem CH4 on TES' +! WRITE(IU_FILE,'(F16.8)') (1d9*GC_CH4_this(L), L=1,65) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'TES a priori' +! WRITE(IU_FILE,'(F16.8)') ( 1d9*TES(NT)%PRIOR(L), L=1,65 ) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'CH4 HAT' +! WRITE(IU_FILE,'(F24.12)') ( CH4_HAT(L), L=1,65 ) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'EXP( CH4 HAT )' +! WRITE(IU_FILE,'(F16.8)') ( 1d9*EXP(CH4_HAT(L)), L=1,65 ) +! WRITE(IU_FILE,'(a)') '-------------------------------------' +! WRITE(IU_FILE,'(a)') 'GC_CH4 HAT' +! WRITE(IU_FILE,'(F16.8)') ( 1d9*TES(NT)%GC_CH4(L), L=1,65 ) +! +! CLOSE(IU_FILE) +! ENDIF + + + ENDDO ! End looping over each observation + + + + + + ! Return to calling program + END SUBROUTINE MAKE_PSEUDO_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_GC_BIAS +! +!****************************************************************************** +! Subroutine CALC_TES_GC_BIAS calculates mean TES bias w.r.t. GEOS-Chem during +! the entire simulation period. Bias is then stored in module variable BIAS +! +! Arguments as Input: +! ============================================================================ +! (1 ) +! +! Arguments as Output: +! ============================================================================ +! (1 ) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TIME_BEHIND_ADJ + USE TIME_MOD, ONLY : EXPAND_DATE + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE BPCH2_MOD, ONLY : READ_BPCH2, GET_RES_EXT + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE GRID_MOD, ONLY : GET_IJ + USE FILE_MOD, ONLY : IU_FILE, IOERROR + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" + + ! Arguments + + ! Local Variables + LOGICAL :: file_exist + CHARACTER(LEN=255) :: TES_dir, READ_FILENAME + CHARACTER(LEN=255) :: PRS_ROOTNAME, PRS_FILENAME, CHK_FILENAME + INTEGER :: NTES, I, J, LTES, NHITS, hh + INTEGER :: NT, nday, N, L, ND49_NT, IOS + INTEGER :: nymd0, ND49_NTES, LL + INTEGER :: IIJJ(2) + INTEGER :: MATCHES(MAXTES) + INTEGER :: NTSTART, NTSTOP + REAL*8 :: GC_RTVMRt, OBS_RTVMRt + REAL*4 :: OBS_RTVMR_today(MAXTES) + REAL*4 :: GC_RTVMR_today(MAXTES) + REAL*4 :: OBS_RTVMR_tot(1000) + REAL*4 :: GC_RTVMR_tot(1000) + REAL*4 :: NOBS_tot(1000) + REAL*4 :: ARRAY0(1) + REAL*4 :: ARRAY1(MAXTES) + REAL*4 :: ND49_lat(MAXTES) + REAL*4 :: ND49_lon(MAXTES) + REAL*4 :: ND49_PSURF(MAXTES) + REAL*4 :: ARRAY2(MAXTES,LLPAR,1) + REAL*4 :: ND49_PCEN(MAXTES,LLPAR) + REAL*4 :: ND49_PEDGE(MAXTES,LLPAR) + REAL*4 :: ND49_kg_box(MAXTES,LLPAR) + REAL*8 :: tau0 + REAL*8 :: date0(2) + REAL*8 :: TIME_FRAC(MAXTES) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: GC_chk(IIPAR,JJPAR,LLPAR) + REAL*4 :: GC_ch4_kg(LLPAR) + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_CH4_NATIVE(LLPAR) + REAL*8 :: CH4_PERT(MAXLEV) + REAL*8 :: GC_CH4(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: M_STAR(4,MAXLEV) + REAL*8 :: CH4_HAT(MAXLEV) + REAL*8 :: CH4_HAT_EXP(MAXLEV) + REAL*4 :: TAUb, TAUe + REAL*8 :: BIAS_tot, N_tot + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL, NV + INTEGER :: IJLOOP + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! CALC_TES_GC_BIAS begins here! + !================================================================= + + ! TES observation root directory + TES_dir = '/home/kjw/TES/data/V004/bpch/' + + + print*,' CALC_TES_GC_BIAS' + print*,' current NYMD, NHMS = ',GET_NYMD(), GET_NHMS() + + + ! Set TAUb and TAUe + TAUb = GET_TAUb() + TAUe = GET_TAUe() + + ! Set some variables for first iteration of loop + tau0 = TAUe - 24d0 + nday = 1 + + ! Loop over every day in assimilation period + DO WHILE ( tau0 > TAUb ) + + ! Zero arrays to be safe + GC_RTVMR_today(:) = 0d0 + OBS_RTVMR_today(:) = 0d0 + + ! Get NYMD of the day + date0 = GET_TIME_BEHIND_ADJ( 1380 + (nday-1)*1440 ) + nymd0 = date0(1) + print*,'nymd0 = ',nymd0 + print*,'tau0 = ',tau0 + + ! Get filename of TES observations + READ_FILENAME = TRIM( 'tes_ch4_YYYYMMDD.bpch' ) + CALL EXPAND_DATE( READ_FILENAME, nymd0, 9999 ) + READ_FILENAME = TRIM( TES_dir ) // TRIM( READ_FILENAME ) + + ! Find whether observations exists on this day + INQUIRE( FILE=READ_FILENAME, exist=file_exist ) + + ! If the file exists, proceed. + IF ( file_exist ) THEN + + ! Read TES_CH4_OBS during the day + CALL READ_TES_CH4_OBS( nymd0, NTES ) + + ! TIME is YYYYMMDD.frac-of-day. + ! Subtract date and save just time frac + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - nymd0 + + ! Open ND49 file and find the entries we want + PRS_FILENAME = 'ND49_trim_' // GET_RES_EXT() // + & '_YYYYMMDD.bpch' + CALL EXPAND_DATE( PRS_FILENAME, nymd0, 9999 ) + PRS_ROOTNAME = '/home/kjw/GEOS-Chem/runs/ch4/TES/ND49_trim/' + PRS_FILENAME = TRIM( PRS_ROOTNAME) // TRIM( PRS_FILENAME ) + + + ! Get # of observations in this BPCH file + ! Read NTES from ND49 file + CALL READ_BPCH2( PRS_FILENAME, 'IJ-AVG-$', 1, + & tau0, 1, 1, + & 1, ARRAY0(1), QUIET=.TRUE. ) + ND49_NTES = INT( ARRAY0(1) ) + + + !================================================================= + ! Open binary punch file and read top-of-file header. + ! Do some error checking to make sure the file is the right format. + !================================================================= + CALL OPEN_BPCH2_FOR_READ( IU_FILE, PRS_FILENAME ) + + !================================================================= + ! Read data from the binary punch file + ! + ! NOTE: IOS < 0 is end-of-file, IOS > 0 is error condition + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR(IOS,IU_FILE, 'tes_ch4_mod:1') + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_FILE,'tes_ch4_mod:2') + + ! Zero Dummy array + ARRAY2(:,:,:) = 0d0 + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( ARRAY2(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_FILE,'tes_ch4_mod:3') + + + ! Test for a match + IF ( 'IJ-AVG-$' == TRIM( CATEGORY ) ) THEN + + ! Longitude + IF ( NTRACER == 3 ) THEN + WRITE(6,*) ' - Reading: Latitude ... ' + ND49_lat = ARRAY2(1:ND49_NTES,1,1) + + ! Latitude + ELSEIF ( NTRACER == 4 ) THEN + WRITE(6,*) ' - Reading: Longitude ... ' + ND49_lon = ARRAY2(1:ND49_NTES,1,1) + + + ! Surface Pressure + ELSEIF ( NTRACER == 7 ) THEN + WRITE(6,*) ' - Reading: PSURF ... ' + ND49_PSURF = ARRAY2(1:ND49_NTES,1,1) + + ! Pressure Centers + ELSEIF ( NTRACER == 10 ) THEN + WRITE(6,*) ' - Reading: Pressure ... ' + ND49_PCEN(:,:) = ARRAY2(1:ND49_NTES,1:LLPAR,1) + + ENDIF ! If tracer == # + + ENDIF ! If Category match + + ENDDO + CLOSE( IU_FILE ) + + + + ! Calculate Pressure edges from Pressure centers (approximate) + DO N=1,ND49_NTES + ND49_PEDGE(N,1) = ND49_PSURF(N) + DO L=2,LLPAR + ND49_PEDGE(N,L) = 0.5d0 * ( ND49_PCEN(N,L) + + & ND49_PCEN(N,(L-1)) ) + ENDDO + ENDDO + + ! Calculate kg air/box from Pressure edges + ND49_PEDGE(:,:) = ND49_PEDGE(:,:) * 1d2 ! [hPa] --> [Pa] + DO N=1,ND49_NTES + DO L=1,LLPAR-1 + ND49_kg_box(N,L) = (ND49_PEDGE(N,L) -ND49_PEDGE(N,(L+1))) + & / 9.81 + ENDDO + !ND49_kg_box(N,47) = ND49_PEDGE(N,47) / 9.81 + ND49_kg_box(N,LLPAR) = ND49_PEDGE(N,LLPAR) / 9.81 + ENDDO + + ! Convert + + + + ! Associate ND49_NTES information with TES(NT) information + ! Create array of indices of length = NTES. + ! It should have values ex. [1, 2, 5, 7, ... ], associating each + ! NTES with the matching index of ND49_NTES + nhits=1 ! nhits counts the # of matches we have. + ! nhits should = NTES when these loops finish + DO NT=1,NTES + DO ND49_NT=1,ND49_NTES + IF ( TES(NT)%LAT(1) == ND49_lat(ND49_NT) .AND. + & TES(NT)%LON(1) == ND49_lon(ND49_NT) ) THEN + MATCHES(NT) = ND49_NT + nhits=nhits + 1 + ENDIF + ENDDO + ENDDO + + + ! Loop over every hour in the day + DO hh=23,0,-1 + + ! Get NT range for this hour + CALL GET_NT_RANGE( NTES, hh*10000, TIME_FRAC, + & NTSTART, NTSTOP ) + + ! If we have observations during this hour, proceed + IF ( NTSTART /= 0 .OR. NTSTOP /= 0 ) THEN + + + ! Get GEOS-Chem CH4 values during this hour + !------------------------------------------------------ + CHK_FILENAME = 'gctm.chk.YYYYMMDD.hhmm' + CALL EXPAND_DATE( CHK_FILENAME, nymd0, hh*10000 ) + CHK_FILENAME = TRIM( ADJTMP_DIR ) // + & TRIM( CHK_FILENAME ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_FILE, CHK_FILENAME ) + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_FILE,'read_checkpt_file:7' ) + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST,JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_FILE,'read_checkpt_file:8' ) + + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_FILE,'read_checkpt_file:9' ) + + ! Convert from kg/box to [v/v] + DO J=1,JJPAR + DO I=1,IIPAR + DO L=1,LLPAR + GC_chk(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO + + ! Close file + CLOSE( IU_FILE ) + !------------------------------------------------------ + + + !!!!!! GCvmr = GCkg / 16d-3 / ( kg_air(I,J,L) / 29d-3 ) + + ! Loop over observations during this hour + DO NT = NTSTART, NTSTOP, -1 + + ! For safety, initialize these up to LLTES + GC_CH4_NATIVE(:) = 0d0 + GC_CH4(:) = 0d0 + MAP(:,:) = 0d0 + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), + & REAL(TES(NT)%LAT(1),4) ) + I = IIJJ(1) + J = IIJJ(2) + + ! Get GEOS-Chem CH4 in [v/v] from [kg/box] + GC_CH4_kg(:) = GC_chk(I,J,:) + DO L=1,LLPAR + GC_CH4_NATIVE(L) = GC_CH4_kg(L) * 29d-3 / 16d-3 / + & ( ND49_kg_box(MATCHES(NT),L) * GET_AREA_M2(J) ) + ENDDO +! IF (NT == 600) THEN +! print*,'GC_CH4_NATIVE(14) = ', GC_CH4_NATIVE(14) +! print*,'GC_CH4_kg(14) = ', GC_CH4_kg(14) +! print*,'ND49_kg_box(14) = ', +! & ND49_kg_box(MATCHES(NT),14) +! print*,'ND49_PEDGE(14) = ', +! & ND49_PEDGE(MATCHES(NT),14) +! ENDIF + + ! Get GEOS-Chem pressure levels + GC_PRES(:) = ND49_PCEN(MATCHES(NT),:) + GC_PSURF = ND49_PSURF(MATCHES(NT)) + + ! Calculate the interpolation weight matrix + + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), TES(NT)%PRES(1)) + + ! Interpolate GC CH4 column to TES grid + DO LL = 1, LTES + GC_CH4(LL) = 0d0 + DO L = 1, LLPAR + GC_CH4(LL) = GC_CH4(LL) + & + MAP(L,LL) * GC_CH4_NATIVE(L) + ENDDO + ENDDO + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_CH4(L) =MAX(GC_CH4(L), 1d-10) + CH4_PERT(L) =LOG(GC_CH4(L))-LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LTES + CH4_HAT(L) = 0d0 + DO LL = 1, LTES + CH4_HAT(L) = CH4_HAT(L) + & + TES(NT)%AVG_KERNEL(LL,L) * CH4_PERT(LL) + ENDDO + CH4_HAT(L) = CH4_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! Transform from [ln(vmr)] --> [ppb] + CH4_HAT_EXP = EXP(CH4_HAT) + + ! Calculate RTVMR for profiles. + CALL GET_RTVMR(NT,TES(NT)%CH4, OBS_RTVMRt, M_STAR) + CALL GET_RTVMR(NT,CH4_HAT_EXP, GC_RTVMRt, M_STAR) + + ! Save RTVMR values + GC_RTVMR_today(NT) = GC_RTVMRt * 1d9 + OBS_RTVMR_today(NT) = OBS_RTVMRt * 1d9 + + ENDDO! End looping over each obs during this hour + + ENDIF ! End if we have obs during this hour + ENDDO ! End looping over each hour during the day + + + ! If the file does not exist, say so and move to next day + ELSE + WRITE(6,*) ' - CALC_TES_GC_BIAS: no files today: ', + & TRIM( READ_FILENAME ) + ENDIF + + ! Average RTVMRs from the day + OBS_RTVMR_tot(nday) = SUM( OBS_RTVMR_today ) + GC_RTVMR_tot(nday) = SUM( GC_RTVMR_today ) + NOBS_tot(nday) = NTES + + + ! Increment Time counters + tau0 = tau0 - 24 + nday = nday + 1 + ENDDO + + + ! Calculate mean bias from OBS_RTVMR_tot and GC_RTVMR_tot + BIAS_tot = SUM( OBS_RTVMR_tot - GC_RTVMR_tot ) + N_tot = SUM( NOBS_tot ) + BIAS_PPB = BIAS_tot / N_tot + + + print*,' - CALC_TES_GC_BIAS: ' + print*,' GC_RTVMR_tot = ', SUM( GC_RTVMR_tot )/N_tot + print*,' OBS_RTVMR_tot = ', SUM( OBS_RTVMR_tot )/N_tot + print*,' Total # observations = ', N_tot + print*,' Mean Bias [ppb] = ', BIAS_PPB + print*,' We hope mean bias ~ 110 ppb' + + + ! Return to calling program + END SUBROUTINE CALC_TES_GC_BIAS + +!------------------------------------------------------------------------------ + + + SUBROUTINE GET_RTVMR( NT, VMR_IN, RTVMR_OUT, M_STAR ) +! +!****************************************************************************** +! Subroutine GET_RTVMR returns Representative Tropospheric Volume Mixing Ratio +! for a given column of ln(vmr). RTVMR is described in Payne et. al. 2009 +! +! Arguments as Input: +! ============================================================================ +! (1 ) NT (INTEGER) : TES observation # +! (2 ) VMR_IN (REAL) : CH4 column [ln(vmr)] from which to calculate RTVMR +! +! Arguments as Output: +! ============================================================================ +! (1 ) RTVMR (REAL) : RTVMR calculated from CH4 column +! (2 ) M_STAR (REAL) : Normalized Mapping Matrix +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + + ! Arguments + INTEGER, INTENT(IN) :: NT + REAL*8, INTENT(IN) :: VMR_IN(MAXLEV) + REAL*8, INTENT(OUT) :: RTVMR_OUT + REAL*8, INTENT(OUT) :: M_STAR(4,MAXLEV) + !INTEGER :: NT + !REAL*8 :: ln_VMR_IN(MAXLEV) + !REAL*8 :: RTVMR_OUT + + ! Local Variables + INTEGER :: L, LC, LTES + REAL*8 :: MAX_AK + REAL*8 :: FINE_GRID(MAXLEV) + REAL*8 :: COARSE_GRID(4) + REAL*8 :: VMR_COARSE(4) + REAL*8 :: AK_ROW(MAXLEV) + REAL*8 :: temp + + LOGICAL :: FOUND_2nd, FOUND_3rd + + + + !================================================================= + ! GET_RTVMR begins here! + !================================================================= + + ! Initialize and make necessary variables from arguments + + ! If we've found 2nd and 3rd elements of coarse grid + FOUND_2nd = .FALSE. + FOUND_3rd = .FALSE. + + ! To make coding cleaner + LTES = TES(NT)%LTES(1) + + ! Fine pressure grid + FINE_GRID(1:LTES) = TES(NT)%PRES(1:LTES) + + ! Construct Coarse Pressure grid + COARSE_GRID(1) = TES(NT)%PRES(1) ! Bottom level + COARSE_GRID(4) = TES(NT)%PRES(LTES) ! Top level + AK_ROW(1:LTES) = SUM( TES(NT)%AVG_KERNEL(1:LTES,1:LTES), 2 ) + + ! Find max of rows of AK below ~50hPa + MAX_AK = MAXVAL( AK_ROW(1:35) ) + IF (NT == 600) THEN + print*,'--------------------------------------------------' + print*,'NT = ', NT + print*,'MAX_AK',MAX_AK + print*,'AK_ROW',AK_ROW + print*,'--------------------------------------------------' + ENDIF + + DO L=LTES,1,-1 + ! First pressure level at which sum of rows of AK > 0.4 + IF ( AK_ROW(L) > 0.4 .AND. TES(NT)%PRES(L) > 30.0 .AND. + & FOUND_3rd == .FALSE. ) THEN + COARSE_GRID(3) = TES(NT)%PRES(L) + FOUND_3rd = .TRUE. + ENDIF + ! Pressure level at which rows of AK are maximum + IF ( AK_ROW(L) == MAX_AK .AND. FOUND_2nd == .FALSE. ) THEN + COARSE_GRID(2) = TES(NT)%PRES(L) + FOUND_2nd = .TRUE. + ENDIF + ENDDO + + + ! Now that we have fine and coarse grids, make mapping matrix + M_STAR = MAKE_RTVMR_MAP( NT, LTES, FINE_GRID, COARSE_GRID ) + +! !kjw debug +! IF ( NT == 600 ) THEN +! print*,'Checking AK_ROW' +! print*,AK_ROW +! print*,'Checking COARSE_GRID' +! print*,COARSE_GRID +! print*,'Checking M_STAR ... ' +! print*,'SUM of rows of M_STAR(4,LTES)' +! print*,SUM(M_STAR,2) +! print*,'Writing Out M_STAR' +! WRITE(6,546) (L,M_STAR(1,L),M_STAR(2,L),M_STAR(3,L), +! & M_STAR(4,L), L=1,MAXLEV) +! 546 FORMAT(i4, 2x, F10.8, 2x, F10.8, 2x, F10.8, 2x, F10.8) +! ENDIF + + + + ! Apply mapping matrix to CH4 column + DO LC=1,4 + temp = 0d0 + DO L=1,LTES + temp = temp + M_STAR(LC,L) * VMR_IN(L) + ENDDO + VMR_COARSE(LC) = temp + ENDDO + + ! RTVMR value is 2nd element of the coarse array + RTVMR_OUT = VMR_COARSE(2) + + + ! Return to calling program + END SUBROUTINE GET_RTVMR + +!------------------------------------------------------------------------------ + + FUNCTION MAKE_RTVMR_MAP( NT, LTES, FINE_GRID, COARSE_GRID ) + & RESULT( M_STAR ) +! +!****************************************************************************** +! Subroutine MAKE_RTVMR_MAP makes matrix to map 67 element TES grid to 4 +! element RTVMR grid. Adapted from from Mark Shephard and Vivienne +! Payne's retv_make_map_vhp.pro (acquired by kjw from Vivienne). +! +! Arguments as Input: +! ============================================================================ +! (1 ) NT (INTEGER) : # of TES observation +! (2 ) FINE_GRID (REAL) : Fine pressure grid from which to map VMR +! (3 ) COARSE_GRID (REAL) : Coarse pressure grid onto which we will map VMR +! +! Arguments as Output: +! ============================================================================ +! (1 ) M_STAR (REAL) : Normalized mapping matrix x_coarse = M* x_fine +! M* is pseudo-inverse of M, which maps coarse to fine grid + +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + + ! Arguments + !INTEGER, INTENT(IN) :: LTES + !REAL*8, INTENT(IN) :: FINE_GRID(MAXLEV) + !REAL*8, INTENT(IN) :: COARSE_GRID(4) + !REAL*8, INTENT(OUT) :: M_STAR(4,MAXLEV) + INTEGER :: LTES, NT + REAL*8 :: FINE_GRID(MAXLEV) + REAL*8 :: COARSE_GRID(4) + REAL*8 :: M_STAR(4,MAXLEV) + + ! Local Variables + INTEGER :: L, LC, IND, K + INTEGER :: FINE_INDS(4), FINE_INDS_SIX(6) + REAL*8 :: MAP_TEMP(4,MAXLEV) + REAL*8 :: MAP_NORM(4,MAXLEV) + REAL*8 :: sum_map(4) + REAL*8 :: xdelta_p, xcoeff + + !================================================================= + ! MAKE_RTVMR_MAP begins here! + !================================================================= + + + ! Initialize and get required values + MAP_TEMP(:,:) = 0d0 + MAP_NORM(:,:) = 0d0 + + + ! Find indices of fine grid which match coarse grid + FINE_INDS(:) = 0d0 + IND = 1 + DO L=1,LTES + IF ( FINE_GRID(L) == COARSE_GRID(IND) ) THEN + FINE_INDS(IND) = L + IND = IND + 1 + ENDIF + ENDDO + + ! Make 6-element array of indices + FINE_INDS_SIX(:) = 0d0 + FINE_INDS_SIX(1) = FINE_INDS(1) + FINE_INDS_SIX(2:5) = FINE_INDS(:) + FINE_INDS_SIX(6) = FINE_INDS(4) + + !kjw debug +! IF ( NT == 600 ) THEN +! print*,'Checking FINE_GRID' +! print*,FINE_GRID +! print*,'Checking FINE_INDS' +! print*,FINE_INDS +! print*,'Checking FINE_INDS_SIX' +! print*,FINE_INDS_SIX +! ENDIF + + + DO L=1,6 + IF ( FINE_INDS_SIX(L) == 0.0 ) THEN + print*,'kjw debug: indices of fine grid matches to coarse' + print*,FINE_INDS_SIX + print*,' doh, this is f***ed up. FINE_INDS(L) = 0. L = ',L + print*,COARSE_GRID + ENDIF + IF ( FINE_INDS_SIX(L) > 67.0 ) THEN + print*,'kjw debug: indices of fine grid matches to coarse' + print*,' doh, this is f***ed up. FINE_INDS(L) >67. L = ',L + print*,COARSE_GRID + ENDIF + ENDDO + + ! Populate mapping matrix + K = 1 + DO LC=1,4 + DO L=FINE_INDS_SIX(K),FINE_INDS_SIX(K+2) + + ! Bottom of profile is set a constant perturbation + IF ( FINE_GRID(L) > COARSE_GRID(LC) .AND. LC == 1 ) THEN + MAP_TEMP(LC,L) = 1.0d0 + ENDIF + + ! Bottom side of profile + IF ( LC /= 1 ) THEN + IF ( FINE_GRID(L) >= COARSE_GRID(LC) .AND. + & FINE_GRID(L) <= COARSE_GRID(LC-1) ) THEN + xdelta_p = LOG(COARSE_GRID(LC-1))-LOG(COARSE_GRID(LC)) + xcoeff = 1d0 - ( LOG(FINE_GRID(L)) - + & LOG(COARSE_GRID(LC)) ) / xdelta_p + MAP_TEMP(LC,L) = xcoeff + ENDIF + ENDIF + + ! Top side of profile + IF ( LC /= 4 ) THEN + IF ( FINE_GRID(L) <= COARSE_GRID(LC) .AND. + & FINE_GRID(L) >= COARSE_GRID(LC+1) ) THEN + xdelta_p = LOG(COARSE_GRID(LC))-LOG(COARSE_GRID(LC+1)) + xcoeff = 1d0 - ( -LOG(FINE_GRID(L)) + + & LOG(COARSE_GRID(LC)) ) / xdelta_p + MAP_TEMP(LC,L) = xcoeff + ENDIF + ENDIF + + ! Top of profile is set a constant perturbation + IF ( FINE_GRID(L) < COARSE_GRID(LC) .AND. LC == 4 ) THEN + MAP_TEMP(LC,L) = 1.0d0 + ENDIF + + ENDDO + + ! Increment Indices between which to fill + K = K + 1 + ENDDO + +! !kjw debug +! IF ( NT == 600 ) THEN +! print*,'Checking M_STAR ... ' +! print*,'SUM of rows of MAP_TEMP(4,LTES)' +! print*,SUM(MAP_TEMP,2) +! print*,'Writing Out MAP_TEMP' +! WRITE(6,547) (L,MAP_TEMP(1,L),MAP_TEMP(2,L),MAP_TEMP(3,L), +! & MAP_TEMP(4,L), L=1,MAXLEV) +! 547 FORMAT(i4, 2x, F10.8, 2x, F10.8, 2x, F10.8, 2x, F10.8) +! ENDIF + + ! Normalize Mapping Matrix + sum_map(:) = 0d0 + sum_map(:) = SUM( MAP_TEMP, 2 ) + sum_map(:) = 0d0 + DO LC=1,4 + sum_map(LC) = SUM( MAP_TEMP(LC,:) ) + IF (NT .EQ. 600) THEN + !print*,'Sum map',LC + !print*,sum_map(LC) + ENDIF + MAP_NORM(LC,:) = MAP_TEMP(LC,:) / sum_map(LC) + ENDDO + +! !kjw debug +! IF ( NT == 600 ) THEN +! print*,'Checking M_STAR ... ' +! print*,'SUM of rows of MAP_NORM(4,LTES)' +! print*,SUM(MAP_NORM,2) +! print*,'Writing Out MAP_NORM' +! WRITE(6,547) (L,MAP_NORM(1,L),MAP_NORM(2,L),MAP_NORM(3,L), +! & MAP_NORM(4,L), L=1,MAXLEV) +! ENDIF + + + ! Assign Map to output variable + M_STAR = MAP_NORM + + + ! Return to calling program + END FUNCTION MAKE_RTVMR_MAP + + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + + print*, ' GET_NT_RANGE for ', HHMMSS + print*, ' NTSAVE ', NTSAVE + print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + !kjw + ! shouldn't the line below be: + ! ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC/2d0 < GC_HH_FRAC ) THEN + ! (difference is dividing H1_FRAC by 2) + ! necessary to round to nearest half hour instead of full hour + !kjw + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP !kjw. this line is useless + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where TES pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(:,LTM) = 0D0 + HINTERPZ(LTM,LTM) = 1D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ + +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!!----------------------------------------------------------------------------- +! SUBROUTINE INIT_TES_CH4 +!! +!!***************************************************************************** +!! Subroutine INIT_TES_CH4 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! IIPAR, JJPAR +! +! ! Local variables +! INTEGER :: AS +! +! !================================================================= +! ! INIT_TES_CH4 begins here +! !================================================================= +! +! ! dkh debug +! print*, ' INIT_TES_CH4' +! +! ALLOCATE( CH4_SAVE( LLPAR, MAXTES ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH4_SAVE' ) +! CH4_SAVE = 0d0 +! +! +! TES( 1 )%NYMD = 20050704 +! TES( 2 )%NYMD = 20050704 +! TES( 3 )%NYMD = 20050704 +! TES( 4 )%NYMD = 20050704 +! TES( 5 )%NYMD = 20050704 +! TES( 6 )%NYMD = 20050704 +! TES( 7 )%NYMD = 20050704 +! TES( 8 )%NYMD = 20050704 +! TES( 9 )%NYMD = 20050705 +! TES( 10 )%NYMD = 20050705 +! TES( 11 )%NYMD = 20050705 +! TES( 12 )%NYMD = 20050705 +! TES( 13 )%NYMD = 20050705 +! TES( 14 )%NYMD = 20050705 +! TES( 15 )%NYMD = 20050705 +! TES( 16 )%NYMD = 20050705 +! TES( 17 )%NYMD = 20050705 +! TES( 18 )%NYMD = 20050710 +! TES( 19 )%NYMD = 20050710 +! TES( 20 )%NYMD = 20050710 +! TES( 21 )%NYMD = 20050710 +! TES( 22 )%NYMD = 20050710 +! TES( 23 )%NYMD = 20050710 +! TES( 24 )%NYMD = 20050710 +! TES( 25 )%NYMD = 20050710 +! TES( 26 )%NYMD = 20050710 +! TES( 27 )%NYMD = 20050711 +! TES( 28 )%NYMD = 20050711 +! TES( 29 )%NYMD = 20050711 +! TES( 30 )%NYMD = 20050711 +! TES( 31 )%NYMD = 20050712 +! TES( 32 )%NYMD = 20050712 +! TES( 33 )%NYMD = 20050712 +! TES( 34 )%NYMD = 20050712 +! TES( 35 )%NYMD = 20050712 +! TES( 36 )%NYMD = 20050712 +! TES( 37 )%NYMD = 20050712 +! TES( 38 )%NYMD = 20050712 +! TES( 39 )%NYMD = 20050713 +! TES( 40 )%NYMD = 20050713 +! TES( 41 )%NYMD = 20050713 +! TES( 42 )%NYMD = 20050713 +! TES( 43 )%NYMD = 20050713 +! TES( 44 )%NYMD = 20050713 +! TES( 45 )%NYMD = 20050713 +! TES( 46 )%NYMD = 20050713 +! TES( 47 )%NYMD = 20050713 +! TES( 48 )%NYMD = 20050714 +! TES( 49 )%NYMD = 20050714 +! TES( 50 )%NYMD = 20050714 +! TES( 51 )%NYMD = 20050714 +! TES( 52 )%NYMD = 20050714 +! TES( 53 )%NYMD = 20050714 +! TES( 54 )%NYMD = 20050714 +! TES( 55 )%NYMD = 20050714 +! TES( 56 )%NYMD = 20050715 +! TES( 57 )%NYMD = 20050715 +! TES( 58 )%NYMD = 20050715 +! TES( 59 )%NYMD = 20050715 +! TES( 60 )%NYMD = 20050715 +! TES( 61 )%NYMD = 20050715 +! TES( 62 )%NYMD = 20050715 +! TES( 63 )%NYMD = 20050715 +! TES( 64 )%NYMD = 20050715 +! TES( 65 )%NYMD = 20050716 +! TES( 66 )%NYMD = 20050717 +! TES( 67 )%NYMD = 20050717 +! TES( 68 )%NYMD = 20050717 +! TES( 69 )%NYMD = 20050717 +! TES( 70 )%NYMD = 20050717 +! TES( 71 )%NYMD = 20050717 +! TES( 72 )%NYMD = 20050717 +! TES( 73 )%NYMD = 20050717 +! TES( 74 )%NYMD = 20050717 +! TES( 75 )%NYMD = 20050718 +! TES( 76 )%NYMD = 20050718 +! TES( 77 )%NYMD = 20050718 +! TES( 78 )%NYMD = 20050718 +! TES( 79 )%NYMD = 20050719 +! TES( 80 )%NYMD = 20050719 +! TES( 81 )%NYMD = 20050719 +! TES( 82 )%NYMD = 20050719 +! TES( 83 )%NYMD = 20050719 +! TES( 84 )%NYMD = 20050719 +! TES( 85 )%NYMD = 20050719 +! TES( 86 )%NYMD = 20050719 +! TES( 87 )%NYMD = 20050719 +! +! TES( 1 )%NHMS = 202000 +! TES( 2 )%NHMS = 202100 +! TES( 3 )%NHMS = 202100 +! TES( 4 )%NHMS = 202100 +! TES( 5 )%NHMS = 202200 +! TES( 6 )%NHMS = 202300 +! TES( 7 )%NHMS = 202300 +! TES( 8 )%NHMS = 202400 +! TES( 9 )%NHMS = 082100 +! TES( 10 )%NHMS = 082100 +! TES( 11 )%NHMS = 082200 +! TES( 12 )%NHMS = 082200 +! TES( 13 )%NHMS = 082300 +! TES( 14 )%NHMS = 082300 +! TES( 15 )%NHMS = 082400 +! TES( 16 )%NHMS = 082400 +! TES( 17 )%NHMS = 082500 +! TES( 18 )%NHMS = 194300 +! TES( 19 )%NHMS = 194300 +! TES( 20 )%NHMS = 194400 +! TES( 21 )%NHMS = 194400 +! TES( 22 )%NHMS = 194500 +! TES( 23 )%NHMS = 194500 +! TES( 24 )%NHMS = 194600 +! TES( 25 )%NHMS = 194600 +! TES( 26 )%NHMS = 194700 +! TES( 27 )%NHMS = 092300 +! TES( 28 )%NHMS = 092300 +! TES( 29 )%NHMS = 092400 +! TES( 30 )%NHMS = 092400 +! TES( 31 )%NHMS = 193000 +! TES( 32 )%NHMS = 193100 +! TES( 33 )%NHMS = 193100 +! TES( 34 )%NHMS = 193200 +! TES( 35 )%NHMS = 193300 +! TES( 36 )%NHMS = 193300 +! TES( 37 )%NHMS = 193400 +! TES( 38 )CH4%NHMS = 193400 +! TES( 39 )%NHMS = 091000 +! TES( 40 )%NHMS = 091100 +! TES( 41 )%NHMS = 091100 +! TES( 42 )%NHMS = 091200 +! TES( 43 )%NHMS = 091200 +! TES( 44 )%NHMS = 091200 +! TES( 45 )%NHMS = 091300 +! TES( 46 )%NHMS = 091300 +! TES( 47 )%NHMS = 091400 +! TES( 48 )%NHMS = 191900 +! TES( 49 )%NHMS = 191900 +! TES( 50 )%NHMS = 191900 +! TES( 51 )%NHMS = 192000 +! TES( 52 )%NHMS = 192000 +! TES( 53 )%NHMS = 192100 +! TES( 54 )%NHMS = 192100 +! TES( 55 )%NHMS = 192200 +! TES( 56 )%NHMS = 085800 +! TES( 57 )%NHMS = 085800 +! TES( 58 )%NHMS = 085900 +! TES( 59 )%NHMS = 085900 +! TES( 60 )%NHMS = 090000 +! TES( 61 )%NHMS = 090000 +! TES( 62 )%NHMS = 090100 +! TES( 63 )%NHMS = 090100 +! TES( 64 )%NHMS = 090100 +! TES( 65 )%NHMS = 190900 +! TES( 66 )%NHMS = 084500 +! TES( 67 )%NHMS = 084600 +! TES( 68 )%NHMS = 084600 +! TES( 69 )%NHMS = 084700 +! TES( 70 )%NHMS = 084700 +! TES( 71 )%NHMS = 084800 +! TES( 72 )%NHMS = 084800 +! TES( 73 )%NHMS = 084900 +! TES( 74 )%NHMS = 084900 +! TES( 75 )%NHMS = 203200 +! TES( 76 )%NHMS = 203300 +! TES( 77 )%NHMS = 203300 +! TES( 78 )%NHMS = 203400 +! TES( 79 )%NHMS = 083300 +! TES( 80 )%NHMS = 083400 +! TES( 81 )%NHMS = 083400 +! TES( 82 )%NHMS = 083500 +! TES( 83 )%NHMS = 083500 +! TES( 84 )%NHMS = 083500 +! TES( 85 )%NHMS = 083600 +! TES( 86 )%NHMS = 083600 +! TES( 87 )%NHMS = 083700 +! +! TES( 1 )%LAT = 31.29 +! TES( 2 )%LAT = 33 +! TES( 3 )%LAT = 34.64 +! TES( 4 )%LAT = 36.2 +! TES( 5 )%LAT = 37.91 +! TES( 6 )%LAT = 41.1 +! TES( 7 )%LAT = 42.8 +! TES( 8 )%LAT = 44.43 +! TES( 9 )%LAT = 43.54 +! TES( 10 )%LAT = 41.84 +! TES( 11 )%LAT = 40.2 +! TES( 12 )%LAT = 38.65 +! TES( 13 )%LAT = 36.94 +! TES( 14 )%LAT = 35.3 +! TES( 15 )%LAT = 33.74 +! TES( 16 )%LAT = 32.03 +! TES( 17 )%LAT = 30.39 +! TES( 18 )%LAT = 31.28 +! TES( 19 )%LAT = 32.99 +! TES( 20 )%LAT = 34.63 +! TES( 21 )%LAT = 36.19 +! TES( 22 )%LAT = 37.9 +! TES( 23 )%LAT = 39.53 +! TES( 24 )%LAT = 41.09 +! TES( 25 )%LAT = 42.8 +! TES( 26 )%LAT = 44.42 +! TES( 27 )%LAT = 43.55 +! TES( 28 )%LAT = 41.85 +! TES( 29 )%LAT = 40.22 +! TES( 30 )%LAT = 38.66 +! TES( 31 )%LAT = 31.28 +! TES( 32 )%LAT = 32.99 +! TES( 33 )%LAT = 34.63 +! TES( 34 )%LAT = 36.19 +! TES( 35 )%LAT = 39.53 +! TES( 36 )%LAT = 41.09 +! TES( 37 )%LAT = 42.79 +! TES( 38 )%LAT = 44.42 +! TES( 39 )%LAT = 43.55 +! TES( 40 )%LAT = 41.85 +! TES( 41 )%LAT = 40.22 +! TES( 42 )%LAT = 38.66 +! TES( 43 )%LAT = 36.96 +! TES( 44 )%LAT = 35.32 +! TES( 45 )%LAT = 33.76 +! TES( 46 )%LAT = 32.04 +! TES( 47 )%LAT = 30.4 +! TES( 48 )%LAT = 32.99 +! TES( 49 )%LAT = 34.63 +! TES( 50 )%LAT = 36.2 +! TES( 51 )%LAT = 37.9 +! TES( 52 )%LAT = 39.54 +! TES( 53 )%LAT = 41.1 +! TES( 54 )%LAT = 42.8 +! TES( 55 )%LAT = 44.42 +! TES( 56 )%LAT = 43.55 +! TES( 57 )%LAT = 41.85 +! TES( 58 )%LAT = 40.22 +! TES( 59 )%LAT = 38.66 +! TES( 60 )%LAT = 36.95 +! TES( 61 )%LAT = 35.31 +! TES( 62 )%LAT = 33.75 +! TES( 63 )%LAT = 32.04 +! TES( 64 )%LAT = 30.4 +! TES( 65 )%LAT = 44.4 +! TES( 66 )%LAT = 43.59 +! TES( 67 )%LAT = 41.89 +! TES( 68 )%LAT = 40.26 +! TES( 69 )%LAT = 38.7 +! TES( 70 )%LAT = 37 +! TES( 71 )%LAT = 35.36 +! TES( 72 )%LAT = 33.8 +! TES( 73 )%LAT = 32.09 +! TES( 74 )%LAT = 30.45 +! TES( 75 )%LAT = 31.27 +! TES( 76 )%LAT = 32.98 +! TES( 77 )%LAT = 34.62 +! TES( 78 )%LAT = 36.18 +! TES( 79 )%LAT = 43.58 +! TES( 80 )%LAT = 41.88 +! TES( 81 )%LAT = 40.25 +! TES( 82 )%LAT = 38.69 +! TES( 83 )%LAT = 36.98 +! TES( 84 )%LAT = 35.34 +! TES( 85 )%LAT = 33.78 +! TES( 86 )%LAT = 32.07 +! TES( 87 )%LAT = 30.43 +! +! TES( 1 )%LON = -105.13 +! TES( 2 )%LON = -105.6 +! TES( 3 )%LON = -106.05 +! TES( 4 )%LON = -106.5 +! TES( 5 )%LON = -107 +! TES( 6 )%LON = -108 +! TES( 7 )%LON = -108.57 +! TES( 8 )%LON = -109.13 +! TES( 9 )%LON = -92.52 +! TES( 10 )%LON = -93.09 +! TES( 11 )%LON = -93.62 +! TES( 12 )%LON = -94.11 +! TES( 13 )%LON = -94.62 +! TES( 14 )%LON = -95.09 +! TES( 15 )%LON = -95.53 +! TES( 16 )%LON = -96 +! TES( 17 )%LON = -96.44 +! TES( 18 )%LON = -95.84 +! TES( 19 )%LON = -96.3 +! TES( 20 )%LON = -96.76 +! TES( 21 )%LON = -97.2 +! TES( 22 )%LON = -97.71 +! TES( 23 )%LON = -98.21 +! TES( 24 )%LON = -98.71 +! TES( 25 )%LON = -99.27 +! TES( 26 )%LON = -99.83 +! TES( 27 )%LON = -107.94 +! TES( 28 )%LON = -108.51 +! TES( 29 )%LON = -109.04 +! TES( 30 )%LON = -109.53 +! TES( 31 )%LON = -92.74 +! TES( 32 )%LON = -93.2 +! TES( 33 )%LON = -93.66 +! TES( 34 )%LON = -94.11 +! TES( 35 )%LON = -95.11 +! TES( 36 )%LON = -95.61 +! TES( 37 )%LON = -96.17 +! TES( 38 )%LON = -96.73 +! TES( 39 )%LON = -104.84 +! TES( 40 )%LON = -105.41 +! TES( 41 )%LON = -105.94 +! TES( 42 )%LON = -106.43 +! TES( 43 )%LON = -106.94 +! TES( 44 )%LON = -107.42 +! TES( 45 )%LON = -107.86 +! TES( 46 )%LON = -108.33 +! TES( 47 )%LON = -108.76 +! TES( 48 )%LON = -90.1 +! TES( 49 )%LON = -90.56 +! TES( 50 )%LON = -91.01 +! TES( 51 )%LON = -91.51 +! TES( 52 )%LON = -92.01 +! TES( 53 )%LON = -92.51 +! TES( 54 )%LON = -93.07 +! TES( 55 )%LON = -93.64 +! TES( 56 )%LON = -101.74 +! TES( 57 )%LON = -102.32 +! TES( 58 )%LON = -102.84 +! TES( 59 )%LON = -103.33 +! TES( 60 )%LON = -103.84 +! TES( 61 )%LON = -104.32 +! TES( 62 )%LON = -104.76 +! TES( 63 )%LON = -105.23 +! TES( 64 )%LON = -105.67 +! TES( 65 )%LON = -90.54 +! TES( 66 )%LON = -98.64 +! TES( 67 )%LON = -99.22 +! TES( 68 )%LON = -99.75 +! TES( 69 )%LON = -100.23 +! TES( 70 )%LON = -100.75 +! TES( 71 )%LON = -101.22 +! TES( 72 )%LON = -101.67 +! TES( 73 )%LON = -102.13 +! TES( 74 )%LON = -102.57 +! TES( 75 )%LON = -108.19 +! TES( 76 )%LON = -108.65 +! TES( 77 )%LON = -109.11 +! TES( 78 )%LON = -109.55 +! TES( 79 )%LON = -95.57 +! TES( 80 )%LON = -96.14 +! TES( 81 )%LON = -96.67 +! TES( 82 )%LON = -97.16 +! TES( 83 )%LON = -97.67 +! TES( 84 )%LON = -98.15 +! TES( 85 )%LON = -98.59 +! TES( 86 )%LON = -99.06 +! TES( 87 )%LON = -99.49 +! +! TES( 1 )%FILENAME = TRIM('retv_vars.02945_0457_002.cdf') +! TES( 2 )%FILENAME = TRIM('retv_vars.02945_0457_003.cdf') +! TES( 3 )%FILENAME = TRIM('retv_vars.02945_0457_004.cdf') +! TES( 4 )%FILENAME = TRIM('retv_vars.02945_0458_002.cdf') +! TES( 5 )%FILENAME = TRIM('retv_vars.02945_0458_003.cdf') +! TES( 6 )%FILENAME = TRIM('retv_vars.02945_0459_002.cdf') +! TES( 7 )%FILENAME = TRIM('retv_vars.02945_0459_003.cdf') +! TES( 8 )%FILENAME = TRIM('retv_vars.02945_0459_004.cdf') +! TES( 9 )%FILENAME = TRIM('retv_vars.02945_0982_002.cdf') +! TES( 10 )%FILENAME = TRIM('retv_vars.02945_0982_003.cdf') +! TES( 11 )%FILENAME = TRIM('retv_vars.02945_0982_004.cdf') +! TES( 12 )%FILENAME = TRIM('retv_vars.02945_0983_002.cdf') +! TES( 13 )%FILENAME = TRIM('retv_vars.02945_0983_003.cdf') +! TES( 14 )%FILENAME = TRIM('retv_vars.02945_0983_004.cdf') +! TES( 15 )%FILENAME = TRIM('retv_vars.02945_0984_002.cdf') +! TES( 16 )%FILENAME = TRIM('retv_vars.02945_0984_003.cdf') +! TES( 17 )%FILENAME = TRIM('retv_vars.02945_0984_004.cdf') +! TES( 18 )%FILENAME = TRIM('retv_vars.02956_0457_002.cdf') +! TES( 19 )%FILENAME = TRIM('retv_vars.02956_0457_003.cdf') +! TES( 20 )%FILENAME = TRIM('retv_vars.02956_0457_004.cdf') +! TES( 21 )%FILENAME = TRIM('retv_vars.02956_0458_002.cdf') +! TES( 22 )%FILENAME = TRIM('retv_vars.02956_0458_003.cdf') +! TES( 23 )%FILENAME = TRIM('retv_vars.02956_0458_004.cdf') +! TES( 24 )%FILENAME = TRIM('retv_vars.02956_0459_002.cdf') +! TES( 25 )%FILENAME = TRIM('retv_vars.02956_0459_003.cdf') +! TES( 26 )%FILENAME = TRIM('retv_vars.02956_0459_004.cdf') +! TES( 27 )%FILENAME = TRIM('retv_vars.02956_1054_002.cdf') +! TES( 28 )%FILENAME = TRIM('retv_vars.02956_1054_003.cdf') +! TES( 29 )%FILENAME = TRIM('retv_vars.02956_1054_004.cdf') +! TES( 30 )%FILENAME = TRIM('retv_vars.02956_1055_002.cdf') +! TES( 31 )%FILENAME = TRIM('retv_vars.02960_0457_002.cdf') +! TES( 32 )%FILENAME = TRIM('retv_vars.02960_0457_003.cdf') +! TES( 33 )%FILENAME = TRIM('retv_vars.02960_0457_004.cdf') +! TES( 34 )%FILENAME = TRIM('retv_vars.02960_0458_002.cdf') +! TES( 35 )%FILENAME = TRIM('retv_vars.02960_0458_004.cdf') +! TES( 36 )%FILENAME = TRIM('retv_vars.02960_0459_002.cdf') +! TES( 37 )%FILENAME = TRIM('retv_vars.02960_0459_003.cdf') +! TES( 38 )%FILENAME = TRIM('retv_vars.02960_0459_004.cdf') +! TES( 39 )%FILENAME = TRIM('retv_vars.02960_1054_002.cdf') +! TES( 40 )%FILENAME = TRIM('retv_vars.02960_1054_003.cdf') +! TES( 41 )%FILENAME = TRIM('retv_vars.02960_1054_004.cdf') +! TES( 42 )%FILENAME = TRIM('retv_vars.02960_1055_002.cdf') +! TES( 43 )%FILENAME = TRIM('retv_vars.02960_1055_003.cdf') +! TES( 44 )%FILENAME = TRIM('retv_vars.02960_1055_004.cdf') +! TES( 45 )%FILENAME = TRIM('retv_vars.02960_1056_002.cdf') +! TES( 46 )%FILENAME = TRIM('retv_vars.02960_1056_003.cdf') +! TES( 47 )%FILENAME = TRIM('retv_vars.02960_1056_004.cdf') +! TES( 48 )%FILENAME = TRIM('retv_vars.02963_0457_003.cdf') +! TES( 49 )%FILENAME = TRIM('retv_vars.02963_0457_004.cdf') +! TES( 50 )%FILENAME = TRIM('retv_vars.02963_0458_002.cdf') +! TES( 51 )%FILENAME = TRIM('retv_vars.02963_0458_003.cdf') +! TES( 52 )%FILENAME = TRIM('retv_vars.02963_0458_004.cdf') +! TES( 53 )%FILENAME = TRIM('retv_vars.02963_0459_002.cdf') +! TES( 54 )%FILENAME = TRIM('retv_vars.02963_0459_003.cdf') +! TES( 55 )%FILENAME = TRIM('retv_vars.02963_0459_004.cdf') +! TES( 56 )%FILENAME = TRIM('retv_vars.02963_1054_002.cdf') +! TES( 57 )%FILENAME = TRIM('retv_vars.02963_1054_003.cdf') +! TES( 58 )%FILENAME = TRIM('retv_vars.02963_1054_004.cdf') +! TES( 59 )%FILENAME = TRIM('retv_vars.02963_1055_002.cdf') +! TES( 60 )%FILENAME = TRIM('retv_vars.02963_1055_003.cdf') +! TES( 61 )%FILENAME = TRIM('retv_vars.02963_1055_004.cdf') +! TES( 62 )%FILENAME = TRIM('retv_vars.02963_1056_002.cdf') +! TES( 63 )%FILENAME = TRIM('retv_vars.02963_1056_003.cdf') +! TES( 64 )%FILENAME = TRIM('retv_vars.02963_1056_004.cdf') +! TES( 65 )%FILENAME = TRIM('retv_vars.02967_0459_004.cdf') +! TES( 66 )%FILENAME = TRIM('retv_vars.02967_1054_002.cdf') +! TES( 67 )%FILENAME = TRIM('retv_vars.02967_1054_003.cdf') +! TES( 68 )%FILENAME = TRIM('retv_vars.02967_1054_004.cdf') +! TES( 69 )%FILENAME = TRIM('retv_vars.02967_1055_002.cdf') +! TES( 70 )%FILENAME = TRIM('retv_vars.02967_1055_003.cdf') +! TES( 71 )%FILENAME = TRIM('retv_vars.02967_1055_004.cdf') +! TES( 72 )%FILENAME = TRIM('retv_vars.02967_1056_002.cdf') +! TES( 73 )%FILENAME = TRIM('retv_vars.02967_1056_003.cdf') +! TES( 74 )%FILENAME = TRIM('retv_vars.02967_1056_004.cdf') +! TES( 75 )%FILENAME = TRIM('retv_vars.02971_0457_002.cdf') +! TES( 76 )%FILENAME = TRIM('retv_vars.02971_0457_003.cdf') +! TES( 77 )%FILENAME = TRIM('retv_vars.02971_0457_004.cdf') +! TES( 78 )%FILENAME = TRIM('retv_vars.02971_0458_002.cdf') +! TES( 79 )%FILENAME = TRIM('retv_vars.02971_0982_002.cdf') +! TES( 80 )%FILENAME = TRIM('retv_vars.02971_0982_003.cdf') +! TES( 81 )%FILENAME = TRIM('retv_vars.02971_0982_004.cdf') +! TES( 82 )%FILENAME = TRIM('retv_vars.02971_0983_002.cdf') +! TES( 83 )%FILENAME = TRIM('retv_vars.02971_0983_003.cdf') +! TES( 84 )%FILENAME = TRIM('retv_vars.02971_0983_004.cdf') +! TES( 85 )%FILENAME = TRIM('retv_vars.02971_0984_002.cdf') +! TES( 86 )%FILENAME = TRIM('retv_vars.02971_0984_003.cdf') +! TES( 87 )%FILENAME = TRIM('retv_vars.02971_0984_004.cdf') +! +! ! Return to calling program +! END SUBROUTINE INIT_TES_CH4 +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CLEANUP_TES_CH4 +!! +!!***************************************************************************** +!! Subroutine CLEANUP_TES_CH4 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! +! IF ( ALLOCATED( CH4_SAVE ) ) DEALLOCATE( CH4_SAVE ) +! +! +! ! Return to calling program +! END SUBROUTINE CLEANUP_TES_CH4 +!!------------------------------------------------------------------------------ + + +!------------------------------------------------------------------------------ + +! SUBROUTINE GET_GC_PSEUDO_OBS( NTES ) +!! +!!****************************************************************************** +!! Subroutine GET_GC_PSEUDO_OBS replaces TES observatins in TES%CH4 with +!! pseudo-observations from a GEOS-Chem run with scaling factors = 1. +!! The GEOS-Chem profile is mapped to the TES pressure grid and processed with +!! the TES averaging kernel before being saved in TES%CH4 +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) LGC_TOP (TYPE) : Description [unit] +!! (2 ) GC_PRES (TYPE) : Description [unit] +!! (3 ) GC_SURFP(TYPE) : Description [unit] +!! (4 ) LTM_TOP (TYPE) : Description [unit] +!! (5 ) TM_PRES (TYPE) : Description [unit] +!! (6 ) TM_SURFP(TYPE) : Description [unit] +!! +!! Arguments as Output: +!! ============================================================================ +!! (1 ) HINTERPZ (TYPE) : Description [unit] +!! +!! NOTES: +!! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE TIME_MOD, ONLY : GET_NYMD, GET_TIME_BEHIND_ADJ +! USE PRESSURE_MOD, ONLY : GET_BP +! +! ! Arguments +! INTEGER :: NTES +! +! ! Local variables +! INTEGER :: YYYYMMDD +! CHARACTER(LEN=255) :: ROOT_FILENAME +! CHARACTER(LEN=255) :: READ_FILENAME +! +! !================================================================= +! ! GET_GC_PSEUDO_OBS begins here! +! !================================================================= +! +! +! ! Filename root +! res_str = +! ROOT_FILENAME = TRIM( '/home/kjw/GEOS-Chem/runs' // +! & '/ch4/TES/ND49_' // GET_RES_EXT() ) +! READ_FILENAME = TRIM( 'tsYYYYMMDD.bpch' ) +! +! +! ! Initialize tau_round_old +! tau_round_old = -1 +! +! ! Loop over all observations +! DO NT = NTES, 1, -1 +! +! ! Copy LTES to cleanup code +! LTES = TES(NT)%LTES(1) +! +! ! Get Tau value for this observation +! tau_this = GET_TAU() - 23 + 24d0 * TES(NT)%TIME(1) +! +! ! Round Tau value to nearest 3 hours to access ND49 files +! tau_round = 3*NINT( tau_this/3d0 ) +! +! ! If the rounded tau value is different than previous rounded tau, +! ! we need to read new datablock from ND49 file +! IF tau_round /= tau_round_old THEN +! +! ! If observation occurs after 01:30:00 AM (UTC) +! IF ( tau_this >= GET_TAU()-23+1.5 ) THEN +! YYYYMMDD = GET_NYMD() +! ! If observation occurs in the early morning (UTC) +! ENDIF ELSE +! DATE = GET_TIME_BEHIND_ADJ( 60*24 ) +! YYYYMMDD = DATE(1) +! ENDIF +! +! ! Expand date tokens in filename +! CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) +! +! ! Get Filename of GEOS-Chem output to read +! READ_FILENAME = TRIM( ROOT_FILENAME ) // TRIM( READ_FILENAME ) +! +! WRITE(6,*) ' - READ_GEOS-Chem_CH4_OBS: reading file: ', +! & READ_FILENAME +! +! ! Read data from BPCH file +! CALL READ_BPCH2( READ_FILENAME, 'IJ-AVG-$', 1, +! & tau_this, IGLOB, JGLOB, +! & LLPAR, ARRAY, QUIET=.TRUE.) +! CALL TRANSFER_3D( ARRAY(:,:,:), GC_CH4_NATIVE_3D(:,:,:) ) +! +! ENDIF +! +! ! Get GC column [ppb] --> [v/v] +! GC_CH4_NATIVE(:) = GC_CH4_NATIVE_3D(II,JJ,:) / 1d9 +! +! +! ! Get I,J indices of grid box corresponding to current TES scan +! IIJJ = GET_IJ( TES(NT)%LON(1), TES(NT)%LAT(1) ) +! II = IIJJ(1) +! JJ = IIJJ(2) +! +! +! ! Map GEOS-Chem column to TES pressure grid +! +! ! Reset variables to be safe +! MAP(:,:) = 0d0 +! GC_PRES(:) = 0d0 +! +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LTES) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LTES +! GC_CH4_onTES(LL) = 0d0 +! DO L = 1, LLPAR +! GC_CH4_onTES(LL) = GC_CH4_onTES(LL) +! & + MAP(L,LL) * GC_CH4_NATIVE(L) +! ENDDO +! ENDDO +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LTES +! GC_CH4_onTES(L) = MAX(GC_CH4_onTES(L), 1d-10) +! CH4_PERT_onTES(L) = LOG(GC_CH4_onTES(L)) - +! & LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! CH4_HAT_onTES(L) = 0d0 +! DO LL = 1, LTES +! CH4_HAT_onTES(L) = CH4_HAT_onTES(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * CH4_PERT_onTES(LL) +! ENDDO +! CH4_HAT_onTES(L) = CH4_HAT_onTES(L) +! & + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! ! Replace stratospheric values with real TES observations +! ! to prevent adjoint forcing of stratosphere +! DO L = 1, LTES +! IF TES(NT)%PRES(L) < TROPP(II,JJ) THEN +! CH4_HAT_onTES(L) = LOG( TES(NT)%CH4(L) ) +! ENDIF +! ENDDO +! +! +! ! Place GEOS-Chem column into the TES_CH4 structure +! TES(NT)%GC_CH4(:) = CH4_HAT_onTES(:) +! +! +! ENDDO ! End looping over each observation +! +! +! +! END SUBROUTINE GET_GC_PSEUDO_OBS +! +!!-------------------------------------------------------------------------- + + +! SUBROUTINE SVD(A,N,U,S,VT) +!! +!!****************************************************************************** +!! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +!! +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) A (REAL*8) : N x N matrix to decompose +!! (2 ) N (INTEGER) : N is dimension of A +!! +!! Arguments as Output: +!! ============================================================================ +!! (1 ) U (REAL*8) : Array of left singular vectors +!! (2 ) S (REAL*8) : Vector of singular values +!! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +!! +!! +!! NOTES: +!! +!! Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +!! The information and material ("Material") provided below is owned by Intel +!! Corporation or its suppliers or licensors, and title to such Material remains +!! with Intel Corporation or its suppliers or licensors. The Material contains +!! proprietary information of Intel or its suppliers and licensors. The Material +!! is protected by worldwide copyright laws and treaty provisions. No part of +!! the Material may be copied, reproduced, published, uploaded, posted, +!! transmitted, or distributed in any way without Intel's prior express written +!! permission. No license under any patent, copyright or other intellectual +!! property rights in the Material is granted to or conferred upon you, either +!! expressly, by implication, inducement, estoppel or otherwise. Any license +!! under such intellectual property rights must be express and approved by Intel +!! in writing. +!! ============================================================================= +!! +!! DGESVD Example. +!! ============== +!! +!! Program computes the singular value decomposition of a general +!! rectangular matrix A: +!! +!! 8.79 9.93 9.83 5.45 3.16 +!! 6.11 6.91 5.04 -0.27 7.98 +!! -9.15 -7.93 4.86 4.85 3.01 +!! 9.57 1.64 8.83 0.74 5.80 +!! -3.49 4.02 9.80 10.00 4.27 +!! 9.84 0.15 -8.99 -6.02 -5.31 +!! +!! Description. +!! ============ +!! +!! The routine computes the singular value decomposition (SVD) of a real +!! m-by-n matrix A, optionally computing the left and/or right singular +!! vectors. The SVD is written as +!! +!! A = U*SIGMA*VT +!! +!! where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +!! diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +!! is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +!! are the singular values of A; they are real and non-negative, and are +!! returned in descending order. The first min(m, n) columns of U and V are +!! the left and right singular vectors of A. +!! +!! Note that the routine returns VT, not V. +!! +!! Example Program Results. +!! ======================== +!! +!! DGESVD Example Program Results +!! +!! Singular values +!! 27.47 22.64 8.56 5.99 2.01 +!! +!! Left singular vectors (stored columnwise) +!! -0.59 0.26 0.36 0.31 0.23 +!! -0.40 0.24 -0.22 -0.75 -0.36 +!! -0.03 -0.60 -0.45 0.23 -0.31 +!! -0.43 0.24 -0.69 0.33 0.16 +!! -0.47 -0.35 0.39 0.16 -0.52 +!! 0.29 0.58 -0.02 0.38 -0.65 +!! +!! Right singular vectors (stored rowwise) +!! -0.25 -0.40 -0.69 -0.37 -0.41 +!! 0.81 0.36 -0.25 -0.37 -0.10 +!! -0.26 0.70 -0.22 0.39 -0.49 +!! 0.40 -0.45 0.25 0.43 -0.62 +!! -0.22 0.14 0.59 -0.63 -0.44 +!! ============================================================================= +!!****************************************************************************** +!! +! ! Arguements +! INTEGER,INTENT(IN) :: N +! REAL*8, INTENT(IN) :: A(N,N) +! REAL*8, INTENT(OUT) :: U(N,N) +! REAL*8, INTENT(OUT) :: S(N) +! REAL*8, INTENT(OUT) :: VT(N,N) +! +! ! Local variables +! INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 +! INTEGER :: INFO, LWORK +! DOUBLE PRECISION :: WORK( LWMAX ) +! +!! .. External Subroutines .. +! EXTERNAL :: DGESVD +! +!! .. Intrinsic Functions .. +! INTRINSIC :: INT, MIN +! +! !================================================================= +! ! SVD begins here! +! !================================================================= +! +!! .. Executable Statements .. +! !WRITE(*,*)'DGESVD Example Program Results' +!! +!! Query the optimal workspace. +!! +! LWORK = -1 +! CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, +! $ WORK, LWORK, INFO ) +! LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +!! +!! Compute SVD. +!! +! CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, +! $ WORK, LWORK, INFO ) +!! +!! Check for convergence. +!! +! IF( INFO.GT.0 ) THEN +! WRITE(*,*)'The algorithm computing SVD failed to converge.' +! STOP +! END IF +! +!! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +!!! +!!! Print singular values. +!!! +!! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!!! +!!! Print left singular vectors. +!!! +!! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +!! $ N, N, U, N ) +!!! +!!! Print right singular vectors. +!!! +!! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +!! $ N, N, VT, N ) +! +! ! Return to calling program +! END SUBROUTINE SVD +!!------------------------------------------------------------------------------ +! SUBROUTINE DGESVD_EXAMPLE +! +!! .. Parameters .. +! INTEGER M, N +! PARAMETER ( M = 6, N = 5 ) +! INTEGER LDA, LDU, LDVT +! PARAMETER ( LDA = M, LDU = M, LDVT = N ) +! INTEGER LWMAX +! PARAMETER ( LWMAX = 1000 ) +!! +!! .. Local Scalars .. +! INTEGER INFO, LWORK +!! +!! .. Local Arrays .. +! DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), +! $ WORK( LWMAX ) +! DATA A/ +! $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, +! $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, +! $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, +! $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, +! $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 +! $ / +!! +!! .. External Subroutines .. +! EXTERNAL DGESVD +! !EXTERNAL PRINT_MATRIX +!! +!! .. Intrinsic Functions .. +! INTRINSIC INT, MIN +!! +!! .. Executable Statements .. +! WRITE(*,*)'DGESVD Example Program Results' +!! +!! Query the optimal workspace. +!! +! LWORK = -1 +! CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, +! $ WORK, LWORK, INFO ) +! LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +!! +!! Compute SVD. +!! +! CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, +! $ WORK, LWORK, INFO ) +!! +!! Check for convergence. +!! +! IF( INFO.GT.0 ) THEN +! WRITE(*,*)'The algorithm computing SVD failed to converge.' +! STOP +! END IF +!! +!! Print singular values. +!! +!! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!! +!! Print left singular vectors. +!! +!! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +!! $ M, N, U, LDU ) +!! +!! Print right singular vectors. +!! +!! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +!! $ N, N, VT, LDVT ) +!! +!! +!! End of DGESVD Example. +! END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +! +! Auxiliary routine: printing a matrix. +! +! SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) +! CHARACTER*(*) DESC +! INTEGER M, N, LDA +! DOUBLE PRECISION A( LDA, * ) +! +! INTEGER I, J +! +! WRITE(*,*) +! WRITE(*,*) DESC +! DO I = 1, M +! WRITE(*,9998) ( A( I, J ), J = 1, N ) +! END DO +! +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) +! 9998 FORMAT( 11(:,1X,E14.8) ) +! RETURN +! +! END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + END MODULE TES_CH4_MOD diff --git a/code/obs_operators/tes_nh3_mod.f b/code/obs_operators/tes_nh3_mod.f new file mode 100644 index 0000000..ea896ea --- /dev/null +++ b/code/obs_operators/tes_nh3_mod.f @@ -0,0 +1,14435 @@ +!$Id: tes_nh3_mod.f,v 1.7 2011/02/23 00:08:48 daven Exp $(?) + MODULE TES_NH3_MOD + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: LLTES = 15 + INTEGER, PARAMETER :: NFOR = 30 + INTEGER, PARAMETER :: MAXTES = 3991 + LOGICAL, PARAMETER :: LTES_NIGHT = .FALSE. + + + ! Record to store data from each TES obs + TYPE TES_NH3_OBS + INTEGER :: NYMD + INTEGER :: NHMS + INTEGER :: LLNT + INTEGER :: QFLAG + INTEGER :: DFLAG + REAL*8 :: LAT + REAL*8 :: LON + REAL*8, DIMENSION(LLTES) :: NH3 + REAL*8, DIMENSION(LLTES,LLTES) :: AVG_KERNEL + REAL*8, DIMENSION(LLTES) :: PRES + REAL*8, DIMENSION(LLTES,LLTES) :: OER_INV + REAL*8, DIMENSION(LLTES) :: PRIOR + REAL*8, DIMENSION(LLTES,LLTES) :: AVK_VMR + REAL*8, DIMENSION(LLTES,LLTES) :: OEI_VMR + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: BLVMR + REAL*8, DIMENSION(LLTES) :: BLVMR_WGT + ENDTYPE TES_NH3_OBS + + TYPE(TES_NH3_OBS) :: TES(MAXTES) + + + + ! Allocatable variables + REAL*8, ALLOCATABLE :: NH3_SAVE(:,:) + + + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_NH3_OBS( NH3, AVG_KERNEL, PRES, + & OER_INV, FILENAME, LLNT, + & PRIOR, QFLAG, DFLAG, + & LAT, LON, BLVMR, + & BLVMR_WGT ) +! +!****************************************************************************** +! Subroutine READ_TES_NH3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (REAL*8) : TES observation filename to read +! +! Arguments as Output: +! ============================================================================ +! (1 ) NH3 (REAL*8) : Retrieval NH3 [ppmv] +! (2 ) AVG_KERNEL (REAL*8) : Retrieval averaging kernel [lnvmr/lnvmr] +! (3 ) PRES (REAL*8) : Retrieval pressure levels [mbar] +! (4 ) OER_INV (REAL*8) : TES retrieval error matrix inverse [((lnvmr))^-2] +! (5 ) LLNT (REAL*8) : TES retrieval number of levels +! (6 ) PRIOR (REAL*8) : TES retrieval prior [ppmv] +! (7 ) QFLAG (INTEGER) : TES retrieval quality flag +! (8 ) DFLAG (INTEGER) : TES retrieval diagnostic flag +! (9 ) LAT (REAL*8) : TES retrieval latitude +! (10) LON (REAL*8) : TES retrieval longitude +! (11) BLVMR (REAL*8) : TES retrieval BLVMR [ppmv] +! (12) BLVMR_WGT (REAL*8) : TES retrieval BLVMR mapping [lnblvr/lnppmv] +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add QFLAG and DFLAG (dkh, 11/06/09) +! (3 ) Add LAT and LON (dkh, 11/30/09) +! (4 ) Add BLVMR and BLVMR_WGT (dkh, 11/02/10) +! (5 ) Use averageing kernel in lnvmr (AVG_KERNEL) instead of vmr (AVK_VMR) +! (6 ) Use observation error cov in lnvmr (OER_INV) instead of lnvrm (OEI_VMR) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE LOGICAL_ADJ_MOD, ONLY : LTES_BLVMR + USE NETCDF + +# include "CMN_SIZE" + + ! Arguments + REAL*8, INTENT(OUT) :: NH3(LLTES) + REAL*8, INTENT(OUT) :: AVG_KERNEL(LLTES,LLTES) + !REAL*8 INTENT(OUT) :: AVK_VMR(LLTES,LLTES) + REAL*8, INTENT(OUT) :: PRES(LLTES) + !REAL*8, INTENT(OUT) :: OEI_VMR(LLTES,LLTES) + REAL*8, INTENT(OUT) :: OER_INV(LLTES,LLTES) + REAL*8, INTENT(OUT) :: PRIOR(LLTES) + INTEGER, INTENT(OUT) :: LLNT + INTEGER, INTENT(OUT) :: QFLAG + INTEGER, INTENT(OUT) :: DFLAG + REAL*8, INTENT(OUT) :: LAT + REAL*8, INTENT(OUT) :: LON + REAL*8, INTENT(OUT) :: BLVMR + REAL*8, INTENT(OUT) :: BLVMR_WGT(LLTES) + CHARACTER(LEN=255), INTENT(IN) :: FILENAME + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=5) :: TMP + REAL*8 :: BLVMR_TMP(3) + REAL*8 :: BLVMR_WGT_TMP(3,LLTES) + + ! netCDF id's + INTEGER :: FID, VARID, DIMID, ATTID + INTEGER :: NBL + + ! Loop indexes, and error handling. + INTEGER :: L, LL + + ! dkh debug + INTEGER :: dim_ids(10), n_dims + + !================================================================= + ! READ_TES_NH3_OBS begins here! + !================================================================= + + ! Initialize + NH3 = 0d0 + !AVK_VMR = 0d0 + AVG_KERNEL = 0d0 + PRES = 0d0 + !OEI_VMR = 0d0 + OER_INV = 0d0 + LLNT = 0 + PRIOR = 0d0 + BLVMR_WGT = 0d0 + BLVMR = -999d0 + + ! Construct complete filename + READ_FILENAME = TRIM( DATA_DIR ) // + & TRIM( '../TES_NH3/' ) // + & TRIM( 'tes_nh3_gs_July_2009_for_paper/' ) // + & TRIM( FILENAME ) + + WRITE(6,*) ' - READ_TES_NH3_OBS: reading file: ', READ_FILENAME + + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + ! READ number of retrievals, LLTES + CALL CHECK( NF90_INQ_DIMID ( FID, "nretv", DIMID ), 101 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID,DIMID, TMP, LLNT), 102 ) + + ! READ NH3 column, NH3 + CALL CHECK( NF90_INQ_VARID( FID, "xretv", VARID ), 1 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, NH3(1:LLNT) ), 2 ) + + ! READ averaging kernal, AVG_KERNEL + CALL CHECK( NF90_INQ_VARID( FID, "avg_kernel", VARID ), 3 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, + & AVG_KERNEL(1:LLNT,1:LLNT) ), 4 ) + + ! READ pressure levels, PRES + CALL CHECK( NF90_INQ_VARID( FID, "pressure", VARID ), 5 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, PRES(1:LLNT) ), 6 ) + + ! READ inverse observational error, OER_INV + ! (note: a priori error already subtracted from this term) + CALL CHECK( NF90_INQ_VARID( FID, "noise_error", VARID ), 7 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, + & OER_INV(1:LLNT,1:LLNT) ), 8 ) + + ! READ apriori NH3 column, PRIOR + CALL CHECK( NF90_INQ_VARID( FID, "xa", VARID ), 9 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, PRIOR(1:LLNT) ), 10 ) + + ! READ quality flag QFLAG + ! 1 = successful + ! 0 = failed. For reason why, see DFLAG. + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Quality_Flag", + & QFLAG ), 12 ) + + ! READ diagnostic flag DFLAG + ! 0 = converged, but DOFS < 0.5, though thermal contrast ok + ! -1 = converged, but DOFS < 0.5 & thermal contrast poor + ! -2 = did not converge + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Diagnostic_Flag", + & DFLAG ), 14 ) + + ! READ latitude LAT + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Latitude", + & LAT ), 15 ) + + ! READ longitude LON + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Longitude", + & LON ), 16 ) + + !! READ averaging kernal for vmr retv, AVK_VMR + !CALL CHECK( NF90_INQ_VARID( FID, "ak_vmr", VARID ), 17 ) + !CALL CHECK( NF90_GET_VAR ( FID, VARID, + !& AVK_VMR(1:LLNT,1:LLNT) ), 18 ) + +! ! READ inverse observational error, OEI_VMR, based on vmr retv +! CALL CHECK( NF90_INQ_VARID( FID, "h_vmr", VARID ), 19 ) +! CALL CHECK( NF90_GET_VAR ( FID, VARID, +! & OEI_VMR(1:LLNT,1:LLNT) ), 20 ) + + ! READ BLVMR only for good retrievals, fill othewise + IF ( QFLAG == 1 .and. DFLAG == 1 .and. LTES_BLVMR ) THEN + + ! dkh debug + print*, ' quality retv; look for BLVMR ' + + ! get NBL + CALL CHECK( NF90_INQ_DIMID ( FID, "nbl", DIMID ), 201 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID,DIMID, TMP, NBL), 212 ) + + ! Get BLVMR_TMP + CALL CHECK( NF90_INQ_VARID( FID, "blvmr", VARID ), 21 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, BLVMR_TMP(1:NBL) ), + & 222 ) + + ! READ BLVMR_WGT only if BLVMR not = -999 + IF ( BLVMR_TMP(1) > 0 ) THEN + + ! Get BLVMR_WGT_TMP + CALL CHECK( NF90_INQ_VARID( FID, "blvmr_wgt", VARID ), + & 232 ) + +! dkh debug +! CALL CHECK( NF90_INQUIRE_VARIABLE( FID,VARID, ndims = n_dims, +! & dimids = dim_ids ), 212 ) + + CALL CHECK( NF90_GET_VAR ( FID, VARID, + & BLVMR_WGT_TMP(1:NBL,1:LLNT) ), 333 ) + + ! It is possible to have multiple BLVMRs when DOF > 1.2. + + IF ( NBL == 1 ) THEN + + ! Keep only the first one. + BLVMR = BLVMR_TMP(1) + BLVMR_WGT(:) = BLVMR_WGT_TMP(1,:) + + ELSEIF ( NBL > 1 ) THEN + ! Keep the last one (dkh, 01/21/11) + BLVMR = BLVMR_TMP(NBL) + BLVMR_WGT(:) = BLVMR_WGT_TMP(NBL,:) + + ENDIF + + ELSE + + ! Fill value + BLVMR = -999D0 + + ENDIF + ELSE + + ! Fill value + BLVMR = -999D0 + BLVMR_WGT = 0d0 + + ENDIF + + ! Check the data. + DO L = 1, LLNT + print*, ' NH3 = ', NH3(L), L + ENDDO + + DO L = 1, LLNT + !print*, ' diag(AVG_KERNEL) = ', AVK_VMR(L,L) + print*, ' diag(AVG_KERNEL) = ', AVG_KERNEL(L,L) + ENDDO + + IF ( LTES_BLVMR ) print*, ' BLVMR = ', BLVMR + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + ! Return to calling program + END SUBROUTINE READ_TES_NH3_OBS +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_TES_NH3_OBS( FILENAME, BLVMR_GC, + & NH3_GC, NH3_HAT, LLNT ) + +! +!****************************************************************************** +! Subroutine MAKE_TES_NH3_OBS adds BLVMR_GC to the TES data file. (dkh, 11/02/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (REAL*8) : TES observation filename to read +! (2 ) BLVMR_GC (REAL*8) : Boundary layer volume mixing ration in GC [ppmv] +! (3 ) NH3_GC (REAL*8) : GEOS-Chem NH3 concentrations on TES grid [ppmv] +! (4 ) NH3_HAT (REAL*8) : GEOS-Chem NH3 after applying TES obs op [ppmv] +! (5 ) LLNT (INTEGER) : Number of TES levels for current retrieval +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + +# include "CMN_SIZE" + + ! Arguments + CHARACTER(LEN=255), INTENT(IN) :: FILENAME + REAL*8, INTENT(IN) :: BLVMR_GC + REAL*8, INTENT(IN) :: NH3_GC(LLTES) + REAL*8, INTENT(IN) :: NH3_HAT(LLTES) + INTEGER, INTENT(IN) :: LLNT + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=5) :: TMP + + ! netCDF id's + INTEGER :: FID, VARID, DIMID, ATTID + INTEGER :: VARID2, VARID3, DIMID2 + + ! Loop indexes, and error handling. + INTEGER :: L, LL + + !================================================================= + ! MAKE_TES_NH3_OBS begins here! + !================================================================= + + ! Construct complete filename + READ_FILENAME = TRIM( DATA_DIR ) // + & TRIM( '../TES_NH3/' ) // + & TRIM( 'tes_nh3_gs_July_2009_for_paper/' ) // + & TRIM( FILENAME ) + + WRITE(6,*) ' - MAKE_TES_NH3_OBS: reading file: ', READ_FILENAME + + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_WRITE, FID ), 0 ) + + ! READ nbl + CALL CHECK( NF90_INQ_DIMID ( FID, "nbl", DIMID ), 101 ) + + ! READ nretv + CALL CHECK( NF90_INQ_DIMID ( FID, "nretv", DIMID2 ), 102 ) + + ! Place file into define mode + CALL CHECK( NF90_REDEF( FID ), 1 ) + + ! define new BLVMR_GC variable + CALL CHECK( NF90_DEF_VAR( FID, "blvmr_gc", NF90_FLOAT, DIMID, + & VARID ), 2 ) + + ! also define new NH3_GC variable + CALL CHECK( NF90_DEF_VAR( FID, "nh3_gc", NF90_FLOAT, DIMID2, + & VARID2), 3 ) + + ! also define new NH3_HAT variable + CALL CHECK( NF90_DEF_VAR( FID, "nh3_hat", NF90_FLOAT, DIMID2, + & VARID3), 4 ) + + ! end define mode + CALL CHECK( NF90_ENDDEF( FID ), 5 ) + + ! put values in BLVMR_GC + CALL CHECK( NF90_PUT_VAR( FID, VARID, BLVMR_GC ), 6 ) + + ! put values in NH3_GC + CALL CHECK( NF90_PUT_VAR( FID, VARID2, NH3_GC(1:LLNT) ), 7 ) + + ! put values in NH3_HAT + CALL CHECK( NF90_PUT_VAR( FID, VARID3, NH3_HAT(1:LLNT) ), 8 ) + + ! close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + ! Return to calling program + END SUBROUTINE MAKE_TES_NH3_OBS +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_nh3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_NH3_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_NH3_FORCE calculates the adjoint forcing from the TES +! NH3 observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (1 ) Add more diagnostics. Now read and write doubled NH3 (dkh, 11/08/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT + USE DAO_MOD, ONLY : AD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE LOGICAL_ADJ_MOD, ONLY : LTES_BLVMR + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TRACERID_MOD, ONLY : IDTNH3 + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : TCVV + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LLNT + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_NH3_NATIVE(LLPAR) + REAL*8 :: GC_NH3(LLTES) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,LLTES) + REAL*8 :: NH3_HAT(LLTES) + REAL*8 :: NH3_PERT(LLTES) + REAL*8 :: FORCE(LLTES) + REAL*8 :: DIFF(LLTES) + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + + REAL*8 :: GC_NH3_NATIVE_DBL(LLPAR) + REAL*8 :: GC_NH3_DBL(LLTES) + REAL*8 :: NH3_HAT_DBL(LLTES) + REAL*8 :: NH3_PERT_DBL(LLTES) + + REAL*8 :: ADJ_GC_NH3_NATIVE(LLPAR) + REAL*8 :: ADJ_NH3_HAT(LLTES) + REAL*8 :: ADJ_NH3_PERT(LLTES) + REAL*8 :: ADJ_GC_NH3(LLTES) + REAL*8 :: ADJ_DIFF(LLTES) + REAL*8 :: BLVMR_GC + REAL*8 :: BLVMR_TC + REAL*8 :: TMP1 + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + + + !================================================================= + ! CALC_TES_NH3_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_NH3_FORCE ' + + NEW_COST = 0d0 + + !IF ( FIRST ) THEN + ! CALL READ_NH3_FILE( ) + ! FIRST = .FALSE. + !ENDIF + + ! Open files for output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_nh3_pert.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'adj_gc_nh3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_nh3_hat_dbl.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FIRST = .FALSE. + + ENDIF + + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Get range of TES observations the occur during the current hour + CALL GET_NT_RANGE( GET_NYMD(), GET_NHMS(), NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES NH3 obs for this hour' + RETURN + ENDIF + + ! Loop over TES observations (first do a sequential loop for + ! reading the data) + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_NH3_FORCE: reading record ', NT + + CALL READ_TES_NH3_OBS( TES(NT)%NH3(:), TES(NT)%AVG_KERNEL(:,:), + & TES(NT)%PRES(:), TES(NT)%OER_INV(:,:), + & TES(NT)%FILENAME, TES(NT)%LLNT, + & TES(NT)%PRIOR(:), TES(NT)%QFLAG, + & TES(NT)%DFLAG, + & TES(NT)%LAT, TES(NT)%LON, + & TES(NT)%BLVMR, TES(NT)%BLVMR_WGT(:) ) + + + print*, ' retrieved data for lat / lon : ', TES(NT)%LAT, + & TES(NT)%LON + + + ENDDO + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LLNT, IIJJ, I, J, L, LL ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_NH3, DIFF ) +!!$OMP+PRIVATE( GC_NH3_NATIVE, NH3_PERT, NH3_HAT, FORCE ) +!!$OMP+PRIVATE( ADJ_GC_NH3_NATIVE, ADJ_GC_NH3 ) +!!$OMP+PRIVATE( ADJ_NH3_PERT, ADJ_NH3_HAT ) +!!$OMP+PRIVATE( ADJ_DIFF ) + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_NH3_FORCE: analyzing record ', NT + + ! Skip spiky retrievals that look cloud contaminated + !IF ( NT == 415 .or. NT == 668 ) THEN + ! print*, ' SKIPPING record owing to cloud ', NT + ! CYCLE + !ENDIF + IF ( .not. LTES_NIGHT .and. TES(NT)%NHMS < 150000 ) THEN + print*, ' SKIPPING night time retrievals ', NT + CYCLE + ENDIF + + + ! Check quality of retrieval + IF ( TES(NT)%QFLAG .ne. 1 ) THEN + + IF ( TES(NT)%DFLAG .ne. 0 ) THEN + print*, ' SKIPPING record ', NT + print*, ' QFLAG, DFLAG = ', TES(NT)%QFLAG, TES(NT)%DFLAG + CYCLE + ELSE + + print*, ' QFLAG = 0 but DFLAG = 0 ' + + ENDIF + + ENDIF + + ! For safety, initialize these up to LLTES + GC_NH3(:) = 0d0 + MAP(:,:) = 0d0 + ADJ_NH3_HAT(:) = 0d0 + FORCE(:) = 0d0 + + + ! Copy LLNT to make coding a bit cleaner + LLNT = TES(NT)%LLNT + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON,4), REAL(TES(NT)%LAT,4) ) + I = IIJJ(1) + J = IIJJ(2) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LLNT) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LLNT, TES(NT)%PRES(1:LLNT), GC_PSURF ) + + + ! Get NH3 values at native model resolution + GC_NH3_NATIVE(:) = CHK_STT(I,J,:,IDTNH3) + + print*, 'I,J = ', I, J + + ! Convert from kg/box to ppm + GC_NH3_NATIVE(:) = GC_NH3_NATIVE(:) * TCVV(IDTNH3) + & / AD(I,J,:) * 1d6 + + NH3_SAVE(:,NT) = GC_NH3_NATIVE(:) + +! skip for real data +! ! Get NH3 values from doubled emissions run [ppmv] +! GC_NH3_NATIVE_DBL(:) +! & = GET_DOUBLED_NH3( GET_NYMD(), GET_NHMS(), +! & REAL(TES(NT)%LON,4), REAL(TES(NT)%LAT,4)) + + ! Interpolate GC NH3 column to TES grid + DO LL = 1, LLNT + GC_NH3(LL) = 0d0 + DO L = 1, LLPAR + GC_NH3(LL) = GC_NH3(LL) + & + MAP(L,LL) * GC_NH3_NATIVE(L) + ENDDO + ENDDO + + !print*, ' gc_nh3 =', gc_nh3(:) + +! skip for real data +! ! Interpolate doubled GC NH3 column to TES grid +! DO LL = 1, LLNT +! GC_NH3_DBL(LL) = 0d0 +! DO L = 1, LLPAR +! GC_NH3_DBL(LL) = GC_NH3_DBL(LL) +! & + MAP(L,LL) * GC_NH3_NATIVE_DBL(L) +! ENDDO +! ENDDO + + ! dkh debug: compare profiles: + print*, ' GC_PRES, GC_native_NH3 ' + WRITE(6,100) (GC_PRES(L), GC_NH3_NATIVE(L), + & L = LLPAR, 1, -1 ) + print*, ' TES_PRES, GC_NH3 ' + WRITE(6,100) (TES(NT)%PRES(LL), GC_NH3(LL), LL = LLNT, 1, -1 ) + 100 FORMAT(1X,F16.8,1X,F16.8) + + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = ln(x_a) + A_k ( ln(x_m) - ln(x_a) ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [ppmv] + ! x_m = GC modeled column [ppmv] + ! A_k = TES averaging kernel [lnvmr/lnvmr] + !-------------------------------------------------------------- + + ! fill + DO L = 1, LLNT + GC_NH3(L) = MAX(GC_NH3(L),0.00000001) + ENDDO + + ! x_m - x_a + DO L = 1, LLNT + NH3_PERT(L) = LOG(GC_NH3(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LLNT + NH3_HAT(L) = 0d0 + DO LL = 1, LLNT + NH3_HAT(L) = NH3_HAT(L) + & + TES(NT)%AVG_KERNEL(LL,L) * NH3_PERT(LL) +! & + TES(NT)%AVK_VMR(L,LL) * NH3_PERT(LL) + ENDDO + NH3_HAT(L) = NH3_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + +! skip for real data +! ! x_m - x_a for doubled +! DO L = 1, LLNT +! GC_NH3_DBL(L) = MAX(GC_NH3_DBL(L), 1d-10) +! NH3_PERT_DBL(L) = LOG(GC_NH3_DBL(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LLNT +! NH3_HAT_DBL(L) = 0d0 +! DO LL = 1, LLNT +! NH3_HAT_DBL(L) = NH3_HAT_DBL(L) +!! & + TES(NT)%AVG_KERNEL(L,LL) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * NH3_PERT_DBL(LL) +! ENDDO +! NH3_HAT_DBL(L) = NH3_HAT_DBL(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + DO L = 1, LLNT + DIFF(L) = NH3_HAT(L) - LOG( TES(NT)%NH3(L) ) + ENDDO + + ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + DO L = 1, LLNT + FORCE(L) = 0d0 + ! try using just the diagonal of OEI_VMR + !DO LL = 1, LLNT + ! FORCE(L) = FORCE(L) + TES(NT)%OEI_VMR(L,LL) * DIFF(LL) + !ENDDO + !FORCE(L) = TES(NT)%OEI_VMR(L,L) * DIFF(L) + ! try using diag and a minimum error of 0.01 ppb --> 1/0.00001^2 --> 1d10 + !IF ( TES(NT)%OEI_VMR(L,L) < 1d10 ) THEN + ! FORCE(L) = TES(NT)%OEI_VMR(L,L) * DIFF(L) + !ELSE + ! FORCE(L) = 1d10 * DIFF(L) + !ENDIF + + ! put a cap on the error, but use the entire matrix + DO LL = 1, LLNT + + ! Cap values + + IF ( MAXVAL(TES(NT)%NH3(:)) < 0.001 ) THEN + IF ( L == LL ) THEN + TES(NT)%OER_INV(L,LL) + & = MIN(0.5d0 , ABS( TES(NT)%OER_INV(L,LL) ) ) + ELSE + TMP1 + & = MIN(0.25d0, ABS( TES(NT)%OER_INV(L,LL) ) ) + + ! retain sign + TES(NT)%OER_INV(L,LL) + & = SIGN( TMP1, TES(NT)%OER_INV(L,LL) ) + ENDIF + ENDIF + + FORCE(L) = FORCE(L) + TES(NT)%OER_INV(L,LL) * DIFF(LL) + + ENDDO + + NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + ENDDO + + ! dkh debug: compare profiles: + print*, ' TES_PRIOR, NH3_HAT, NH3_TES in vmr' + WRITE(6,101) (TES(NT)%PRIOR(L), EXP(NH3_HAT(L)),TES(NT)%NH3(L), + & L, L = LLNT, 1, -1 ) + print*, ' TES_PRIOR, NH3_HAT, NH3_TES in lnvmr' + WRITE(6,101) (LOG(TES(NT)%PRIOR(L)), NH3_HAT(L), + & LOG(TES(NT)%NH3(L)), L, L = LLNT, 1, -1 ) + 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1x,i3) + + !-------------------------------------------------------------- + ! Calculate BLVMR_GC and save to the data file + !-------------------------------------------------------------- + + ! Only do this for records which have a BLVMR + IF( LTES_BLVMR .and. TES(NT)%BLVMR > 0 ) THEN + + BLVMR_GC = 0d0 + BLVMR_TC = 0d0 + + DO L = 1, LLNT + + BLVMR_GC = BLVMR_GC + & + TES(NT)%BLVMR_WGT(L) + & * NH3_HAT(L) + + BLVMR_TC = BLVMR_TC + & + TES(NT)%BLVMR_WGT(L) + & * TES(NT)%NH3(L) + ENDDO + + BLVMR_GC = EXP( BLVMR_GC ) + BLVMR_TC = EXP( BLVMR_TC ) + + ! Append to data file + CALL MAKE_TES_NH3_OBS( TES(NT)%FILENAME, BLVMR_GC, + & GC_NH3, EXP(NH3_HAT(:)), + & LLNT ) + + print*, ' BLVMRs = ', TES(NT)%BLVMR, BLVMR_GC, BLVMR_TC, NT + + ENDIF + + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug + print*, 'DIFF , FORCE, diag OEI ' + WRITE(6,102) (DIFF(L), FORCE(L), TES(NT)%OER_INV(L,L), + & L = LLNT, 1, -1 ) + 102 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + ADJ_DIFF(:) = FORCE(:) + + ! Adjoint of difference + DO L = 1, LLNT + ADJ_NH3_HAT(L) = ADJ_DIFF(L) + ENDDO + + ! adjoint of TES operator + DO L = 1, LLNT + ADJ_NH3_PERT(L) = 0d0 + DO LL = 1, LLNT + ADJ_NH3_PERT(L) = ADJ_NH3_PERT(L) + & + TES(NT)%AVG_KERNEL(L,LL) + & * ADJ_NH3_HAT(LL) + + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO L = 1, LLNT + ! fwd code: + !NH3_PERT(L) = LOG(GC_NH3(L)) - LOG(TES(NT)%PRIOR(L))) + ! adj code: + ADJ_GC_NH3(L) = ADJ_NH3_PERT(L) / GC_NH3(L) + ENDDO + + ! dkh debug + print*, 'ADJ_NH3_HAT, ADJ_NH3_PERT, ADJ_GC_NH3 ' + WRITE(6,103) (ADJ_NH3_HAT(L), ADJ_NH3_PERT(L), ADJ_GC_NH3(L), + & L = LLNT, 1, -1 ) + 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + ADJ_GC_NH3_NATIVE(L) = 0d0 + DO LL = 1, LLNT + ADJ_GC_NH3_NATIVE(L) = ADJ_GC_NH3_NATIVE(L) + & + MAP(L,LL) * ADJ_GC_NH3(LL) + ENDDO + ENDDO + + ! Adjoint of unit conversion + ADJ_GC_NH3_NATIVE(:) = ADJ_GC_NH3_NATIVE(:) * TCVV(IDTNH3) + & / AD(I,J,:) * 1d6 + + ! Pass adjoint back to adjoint tracer array + STT_ADJ(I,J,:,IDTNH3) = STT_ADJ(I,J,:,IDTNH3) + & + ADJ_GC_NH3_NATIVE(:) + + ! dkh debug + print*, ' adj_stt force = ', ADJ_GC_NH3_NATIVE(:) + + ! dkh debug + print*, 'ADJ_GC_NH3_NATIVE, ADJ_GC_NH3_NATIVE conv, ADJ_STT ' + WRITE(6,104) (ADJ_GC_NH3_NATIVE(L) * AD(I,J,L) + & / 1d6 / TCVV(IDTNH3), + & ADJ_GC_NH3_NATIVE(L), STT_ADJ(I,J,L,IDTNH3), + & L = LLPAR, 1, -1 ) + 104 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + + WRITE(101,112) ( TES(NT)%PRES(LL), LL=LLNT,1,-1) + WRITE(102,112) ( GC_NH3(LL), LL=LLNT,1,-1) + WRITE(103,112) ( TES(NT)%NH3(LL), LL=LLNT,1,-1) + WRITE(104,112) ( TES(NT)%PRIOR(LL), LL=LLNT,1,-1) + WRITE(105,112) ( DIFF(LL), LL=LLNT,1,-1) + WRITE(106,112) ( FORCE(LL), LL=LLNT,1,-1) + WRITE(107,111) NT, LLNT + WRITE(108,112) ( ADJ_NH3_PERT(LL), LL=LLNT,1,-1) + WRITE(109,112) ( ADJ_GC_NH3(LL), LL=LLNT,1,-1) + WRITE(110,112) ( EXP(NH3_HAT(LL)), LL=LLNT,1,-1) + ! skip for real data + !WRITE(111,110) ( EXP(NH3_HAT_DBL(LL)), LL=LLNT,1,-1) + 110 FORMAT(F16.8,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + + + ENDDO ! NT +!!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution = ', COST_FUNC - OLD_COST + + + + ! dkh debug + !IF ( NTSTOP == 1 ) THEN + ! CALL MAKE_NH3_FILE( ) + !ENDIF + + ! Return to calling program + END SUBROUTINE CALC_TES_NH3_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_NH3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine to test CALC_TES_NH3_FORCE (dkh, 09/30/10). +!! +!! It has a few changes from the original, noted with 'for FD test' +!! +!! Call from CALC_FORCE_FOR_OBS: +!! USE TES_NH3_MOD, ONLY : CALC_TES_NH3_FORCE_FD +!!... +!! ! for FD test +!! REAL*8 :: COST_FUNC_0 +!! REAL*8 :: COST_FUNC_1 +!! REAL*8 :: COST_FUNC_2 +!! REAL*8 :: PERT(LLPAR) +!! REAL*8 :: ADJ(LLPAR) +!! REAL*8 :: FD(LLPAR) +!! REAL*8 :: ADJ_SAVE(LLPAR) +!!... +!! PERT(:) = 1D0 +!! CALL CALC_TES_NH3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, LLPAR +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_NH3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_NH3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC_2, COST_FUNC_1, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE DAO_MOD, ONLY : AD +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TRACERID_MOD, ONLY : IDTNH3 +! USE TRACER_MOD, ONLY : STT +! USE TRACER_MOD, ONLY : TCVV +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! ! for FD test +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LLNT +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_NH3_NATIVE(LLPAR) +! REAL*8 :: GC_NH3(LLTES) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,LLTES) +! REAL*8 :: NH3_HAT(LLTES) +! REAL*8 :: NH3_PERT(LLTES) +! REAL*8 :: FORCE(LLTES) +! REAL*8 :: DIFF(LLTES) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! +! REAL*8 :: GC_NH3_NATIVE_DBL(LLPAR) +! REAL*8 :: GC_NH3_DBL(LLTES) +! REAL*8 :: NH3_HAT_DBL(LLTES) +! REAL*8 :: NH3_PERT_DBL(LLTES) +! +! REAL*8 :: ADJ_GC_NH3_NATIVE(LLPAR) +! REAL*8 :: ADJ_NH3_HAT(LLTES) +! REAL*8 :: ADJ_NH3_PERT(LLTES) +! REAL*8 :: ADJ_GC_NH3(LLTES) +! REAL*8 :: ADJ_DIFF(LLTES) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_NH3_FORCE begins here! +! !================================================================= +! +! print*, ' - CALC_TES_NH3_FORCE ' +! +! NEW_COST = 0d0 +! +! !IF ( FIRST ) THEN +! ! CALL READ_NH3_FILE( ) +! ! FIRST = .FALSE. +! !ENDIF +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_nh3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_nh3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'adj_nh3_pert.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'adj_gc_nh3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_nh3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_nh3_hat_dbl.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! !for FD test: move this to later +!! FIRST = .FALSE. +! +! +! ENDIF +! +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Get range of TES observations the occur during the current hour +! ! for FD test +!! CALL GET_NT_RANGE( GET_NYMD(), GET_NHMS(), NTSTART, NTSTOP ) +!! +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES NH3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! ! Loop over TES observations (first do a sequential loop for +!! ! reading the data) +!! DO NT = NTSTART, NTSTOP, -1 +! NTSTART = 1 +! NTSTOP = 1 +! NT = 1 +! IF ( FIRST ) THEN +! +! print*, ' - CALC_TES_NH3_FORCE: reading record ', NT +! +! CALL READ_TES_NH3_OBS( TES(NT)%NH3(:), TES(NT)%AVK_VMR(:,:), +! & TES(NT)%PRES(:), TES(NT)%OEI_VMR(:,:), +! & TES(NT)%FILENAME, TES(NT)%LLNT, +! & TES(NT)%PRIOR(:), TES(NT)%QFLAG, +! & TES(NT)%DFLAG, +! & TES(NT)%LAT, TES(NT)%LON ) +! +! +! print*, ' retrieved data for lat / lon : ', TES(NT)%LAT, +! & TES(NT)%LON +! +! +! ! for FD test +!! ENDDO +! FIRST = .FALSE. +! ENDIF +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LLNT, IIJJ, I, J, L, LL ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_NH3, DIFF ) +!!!$OMP+PRIVATE( GC_NH3_NATIVE, NH3_PERT, NH3_HAT, FORCE ) +!!!$OMP+PRIVATE( ADJ_GC_NH3_NATIVE, ADJ_GC_NH3 ) +!!!$OMP+PRIVATE( ADJ_NH3_PERT, ADJ_NH3_HAT ) +!!!$OMP+PRIVATE( ADJ_DIFF ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_NH3_FORCE: analyzing record ', NT +! +! ! Skip spiky retrievals that look cloud contaminated +! IF ( NT == 415 .or. NT == 668 ) THEN +! print*, ' SKIPPING record owing to cloud ', NT +! CYCLE +! ENDIF +! +! ! Check quality of retrieval +! IF ( TES(NT)%QFLAG .ne. 1 ) THEN +! +! IF ( TES(NT)%DFLAG .ne. 0 ) THEN +! print*, ' SKIPPING record ', NT +! print*, ' QFLAG, DFLAG = ', TES(NT)%QFLAG, TES(NT)%DFLAG +! CYCLE +! ELSE +! +! print*, ' QFLAG = 0 but DFLAG = 0 ' +! +! ENDIF +! +! ENDIF +! +! ! For safety, initialize these up to LLTES +! GC_NH3(:) = 0d0 +! MAP(:,:) = 0d0 +! ADJ_NH3_HAT(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LLNT to make coding a bit cleaner +! LLNT = TES(NT)%LLNT +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON,4), REAL(TES(NT)%LAT,4) ) +! I = IIJJ(1) +! J = IIJJ(2) +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LLNT) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LLNT, TES(NT)%PRES(1:LLNT), GC_PSURF ) +! +! +! ! Get NH3 values at native model resolution +! ! for FD test +! !GC_NH3_NATIVE(:) = CHK_STT(I,J,:,IDTNH3) +! GC_NH3_NATIVE(:) = CHK_STT(I,J,:,IDTNH3) * PERT(:) +! +! print*, 'I,J = ', I, J +! +! ! Convert from kg/box to ppm +! GC_NH3_NATIVE(:) = GC_NH3_NATIVE(:) * TCVV(IDTNH3) +! & / AD(I,J,:) * 1d6 +! +! NH3_SAVE(:,NT) = GC_NH3_NATIVE(:) +! +!! skip for real data +!! ! Get NH3 values from doubled emissions run [ppmv] +!! GC_NH3_NATIVE_DBL(:) +!! & = GET_DOUBLED_NH3( GET_NYMD(), GET_NHMS(), +!! & REAL(TES(NT)%LON,4), REAL(TES(NT)%LAT,4)) +! +! ! Interpolate GC NH3 column to TES grid +! DO LL = 1, LLNT +! GC_NH3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_NH3(LL) = GC_NH3(LL) +! & + MAP(L,LL) * GC_NH3_NATIVE(L) +! ENDDO +! ENDDO +! +! print*, ' gc_nh3 =', gc_nh3(:) +! +!! skip for real data +!! ! Interpolate doubled GC NH3 column to TES grid +!! DO LL = 1, LLNT +!! GC_NH3_DBL(LL) = 0d0 +!! DO L = 1, LLPAR +!! GC_NH3_DBL(LL) = GC_NH3_DBL(LL) +!! & + MAP(L,LL) * GC_NH3_NATIVE_DBL(L) +!! ENDDO +!! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_NH3 ' +! WRITE(6,100) (GC_PRES(L), GC_NH3_NATIVE(L), +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_NH3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), GC_NH3(LL), LL = LLNT, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [ppmv] +! ! x_a = TES apriori column [ppmv] +! ! x_m = GC modeled column [ppmv] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LLNT +! NH3_PERT(L) = GC_NH3(L) - TES(NT)%PRIOR(L) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LLNT +! NH3_HAT(L) = 0d0 +! DO LL = 1, LLNT +! NH3_HAT(L) = NH3_HAT(L) +! & + TES(NT)%AVK_VMR(LL,L) * NH3_PERT(LL) +!! & + TES(NT)%AVK_VMR(L,LL) * NH3_PERT(LL) +! ENDDO +! NH3_HAT(L) = NH3_HAT(L) + TES(NT)%PRIOR(L) +! ENDDO +! +!! skip for real data +!! ! x_m - x_a for doubled +!! DO L = 1, LLNT +!! GC_NH3_DBL(L) = MAX(GC_NH3_DBL(L), 1d-10) +!! NH3_PERT_DBL(L) = LOG(GC_NH3_DBL(L)) - LOG(TES(NT)%PRIOR(L)) +!! ENDDO +!! +!! ! x_a + A_k * ( x_m - x_a ) +!! DO L = 1, LLNT +!! NH3_HAT_DBL(L) = 0d0 +!! DO LL = 1, LLNT +!! NH3_HAT_DBL(L) = NH3_HAT_DBL(L) +!!! & + TES(NT)%AVG_KERNEL(L,LL) +!! & + TES(NT)%AVG_KERNEL(LL,L) +!! & * NH3_PERT_DBL(LL) +!! ENDDO +!! NH3_HAT_DBL(L) = NH3_HAT_DBL(L) + LOG(TES(NT)%PRIOR(L)) +!! ENDDO +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LLNT +! DIFF(L) = NH3_HAT(L) - TES(NT)%NH3(L) +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LLNT +! FORCE(L) = 0d0 +! ! try using just the diagonal of OEI_VMR +! !DO LL = 1, LLNT +! ! FORCE(L) = FORCE(L) + TES(NT)%OEI_VMR(L,LL) * DIFF(LL) +! !ENDDO +! !FORCE(L) = TES(NT)%OEI_VMR(L,L) * DIFF(L) +! ! try using diag and a minimum error of 0.01 ppb --> 1/0.00001^2 --> 1d10 +! IF ( TES(NT)%OEI_VMR(L,L) < 1d10 ) THEN +! FORCE(L) = TES(NT)%OEI_VMR(L,L) * DIFF(L) +! ELSE +! FORCE(L) = 1d10 * DIFF(L) +! ENDIF +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, NH3_HAT, NH3_TES in vmr' +! WRITE(6,101) (TES(NT)%PRIOR(L), NH3_HAT(L),TES(NT)%NH3(L), +! & L, L = LLNT, 1, -1 ) +! print*, ' TES_PRIOR, NH3_HAT, NH3_TES in lnvmr' +!! WRITE(6,101) (LOG(TES(NT)%PRIOR(L)), NH3_HAT(L), +!! & LOG(TES(NT)%NH3(L)), L, L = LLNT, 1, -1 ) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE, diag OEI ' +! WRITE(6,102) (DIFF(L), FORCE(L), TES(NT)%OEI_VMR(L,L), +! & L = LLNT, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! ADJ_DIFF(:) = FORCE(:) +! +! ! Adjoint of difference +! DO L = 1, LLNT +! ADJ_NH3_HAT(L) = ADJ_DIFF(L) +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LLNT +! ADJ_NH3_PERT(L) = 0d0 +! DO LL = 1, LLNT +! ADJ_NH3_PERT(L) = ADJ_NH3_PERT(L) +! & + TES(NT)%AVK_VMR(L,LL) +!! & + TES(NT)%AVK_VMR(LL,L) +! & * ADJ_NH3_HAT(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LLNT +! ! fwd code: +! !NH3_PERT(L) = GC_NH3(L) - TES(NT)%PRIOR(L)) +! ! adj code: +! ADJ_GC_NH3(L) = ADJ_NH3_PERT(L) +! ENDDO +! +! ! dkh debug +! print*, 'ADJ_NH3_HAT, ADJ_NH3_PERT, ADJ_GC_NH3 ' +! WRITE(6,103) (ADJ_NH3_HAT(L), ADJ_NH3_PERT(L), ADJ_GC_NH3(L), +! & L = LLNT, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! ADJ_GC_NH3_NATIVE(L) = 0d0 +! DO LL = 1, LLNT +! ADJ_GC_NH3_NATIVE(L) = ADJ_GC_NH3_NATIVE(L) +! & + MAP(L,LL) * ADJ_GC_NH3(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of unit conversion +! ADJ_GC_NH3_NATIVE(:) = ADJ_GC_NH3_NATIVE(:) * TCVV(IDTNH3) +! & / AD(I,J,:) * 1d6 +! +! ! Pass adjoint back to adjoint tracer array +! STT_ADJ(I,J,:,IDTNH3) = STT_ADJ(I,J,:,IDTNH3) +! & + ADJ_GC_NH3_NATIVE(:) +! +! ! for FD test +! ADJ(:) = ADJ_GC_NH3_NATIVE(:) * CHK_STT(I,J,:,IDTNH3) +! +! ! dkh debug +! print*, ' adj_stt force = ', ADJ_GC_NH3_NATIVE(:) +! +! ! dkh debug +! print*, 'ADJ_GC_NH3_NATIVE, ADJ_GC_NH3_NATIVE conv, ADJ_STT ' +! WRITE(6,104) (ADJ_GC_NH3_NATIVE(L) * AD(I,J,L) +! & / 1d6 / TCVV(IDTNH3), +! & ADJ_GC_NH3_NATIVE(L), STT_ADJ(I,J,L,IDTNH3), +! & L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! +! WRITE(101,112) ( TES(NT)%PRES(LL), LL=LLNT,1,-1) +! WRITE(102,112) ( GC_NH3(LL), LL=LLNT,1,-1) +! WRITE(103,112) ( TES(NT)%NH3(LL), LL=LLNT,1,-1) +! WRITE(104,112) ( TES(NT)%PRIOR(LL), LL=LLNT,1,-1) +! WRITE(105,112) ( DIFF(LL), LL=LLNT,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LLNT,1,-1) +! WRITE(107,111) NT, LLNT +! WRITE(108,112) ( ADJ_NH3_PERT(LL), LL=LLNT,1,-1) +! WRITE(109,112) ( ADJ_GC_NH3(LL), LL=LLNT,1,-1) +! WRITE(110,112) ( NH3_HAT(LL), LL=LLNT,1,-1) +! ! skip for real data +! !WRITE(111,110) ( EXP(NH3_HAT_DBL(LL)), LL=LLNT,1,-1) +! 110 FORMAT(F16.8,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! ! for FD test +! !COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! dkh debug +! !IF ( NTSTOP == 1 ) THEN +! ! CALL MAKE_NH3_FILE( ) +! !ENDIF +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_NH3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( GCNYMD, GCNHMS, NTSTART, NTSTOP ) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) GCNYMD (INTEGER) : Current model YYYYMMDD +! (2 ) GCNHMS (INTEGER) : Current model HHMMSS +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + INTEGER, INTENT(IN) :: GCNYMD + INTEGER, INTENT(IN) :: GCNHMS + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE = MAXTES + !INTEGER, SAVE :: NTSAVE = 148 + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + print*, ' GET_NT_RANGE ', GCNYMD, GCNHMS + print*, ' NTSAVE ', NTSAVE + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TES(NTSAVE)%NYMD < GCNYMD ) THEN + + + print*, 'No records reached yet' + RETURN + + ! Model day matches day of existing records + ELSEIF ( TES(NTSAVE)%NYMD == GCNYMD ) THEN + + print*,' Model day matches day of existing records' + IF ( TES(NTSAVE)%NHMS + 7000 < GCNHMS ) THEN + + ! No records reached yet + print*, 'But no records reached yet' + RETURN + + ! Model hour (+/- 30 min) matches existing records + ELSEIF ( TES(NTSAVE)%NHMS + 7000 >= GCNHMS ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TES%NYMD, TES%NHMS ', + & TES(NTSTART)%NYMD, TES(NTSTART)%NHMS, NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TES(NTEST)%NHMS + 7000 < GCNHMS ) THEN + + print*, ' Testing : TES%NYMD, TES%NHMS ', + & TES(NTEST)%NYMD, TES(NTEST)%NHMS, NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When test day is earlier than the model day and the + ! hour is less than 23:30, the stopping record has been passed. + ELSEIF ( TES(NTEST)%NYMD < GCNYMD .and. + & TES(NTEST)%NHMS < 233000 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ENDIF + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where the lowest TES level pressure is lower than the + ! lowest GC layer pressure. In this case, just 1:1 map. + + ! Bug fix: a more general version allows for multiples TES pressure + ! levels to exist below the lowest GC pressure. (dm, dkh, 09/30/10) + ! OLD code: + !IF ( TM_PRESC(1) > GC_PRESC(1) ) THEN + ! HINTERPZ(1,1) = 1D0 + ! HINTERPZ(2:LGC_TOP,1) = 0D0 + !ENDIF + ! New code: + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(1,LTM) = 1D0 + HINTERPZ(2:LGC_TOP,LTM) = 0D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!------------------------------------------------------------------------------ + SUBROUTINE MAKE_NH3_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_NH3_FILE saves NH3 profiles that correspond to time and +! place of TES NH3 obs. (dkh, 03/01/09) +! +! Module variables as Input: +! ============================================================================ +! (1 ) NH3_SAVE (REAL*8) : NH3 profiles [ppmv] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J, I0, J0, L, NT + CHARACTER(LEN=120) :: FILENAME + REAL*4 :: DAT(1,LLPAR,MAXTES) + INTEGER, PARAMETER :: IUN = 88 + + ! For binary punch file, version 2.0 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + !================================================================= + ! MAKE_NH3_FILE begins here! + !================================================================= + + FILENAME = TRIM( 'nh3.bpch' ) + + ! Append data directory prefix + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'NH3 profile ' + CATEGORY = 'IJ-AVE-$' + LONRES = DISIZE + LATRES = DJSIZE + UNIT = 'ppmv' + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_NH3_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) + + ! Temporarily store data in DAT as REAL4 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( NT ) + DO NT = 1, MAXTES + + DAT(1,:,NT) = REAL(NH3_SAVE(:,NT)) + + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, 1d0, 1d0, RESERVED, + & 1, LLPAR, MAXTES, I0+1, + & J0+1, 1, DAT ) + + ! Close file + CLOSE( IUN ) + + print*, ' NH3_SAVE sum write = ', SUM(NH3_SAVE(:,:)) + + ! Return to calling program + END SUBROUTINE MAKE_NH3_FILE + +!------------------------------------------------------------------------------ + SUBROUTINE READ_NH3_FILE( ) +! +!****************************************************************************** +! Subroutine READ_NH3_FILE reads the GC modeled NH3 profiles that correspond +! to the TES NH3 times and locations. (dkh, 03/01/09) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + REAL*4 :: DAT(1,LLPAR,MAXTES) + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_USA_MASK begins here! + !================================================================= + + ! File name + FILENAME = TRIM( ADJTMP_DIR ) // + & 'nh3.bpch' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_NH3_FILE: Reading ', a ) + + + ! USA mask is stored in the bpch file as #2 + CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, + & 1d0, 1, LLPAR, + & MAXTES, DAT, QUIET=.TRUE. ) + + ! Cast to REAL*8 + NH3_SAVE(:,:) = DAT(1,:,:) + + print*, ' NH3_SAVE sum read = ', SUM(NH3_SAVE(:,:)) + + ! Return to calling program + END SUBROUTINE READ_NH3_FILE + +!----------------------------------------------------------------------------- + FUNCTION GET_DOUBLED_NH3( NYMD, NHMS, LON, LAT ) RESULT( NH3_DBL ) +! +!****************************************************************************** +! Subroutine GET_DOUBLED_NH3 reads and returns the nh3 profiles from +! model run with doubled emissions. (dkh, 11/08/09) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE GRID_MOD, ONLY : GET_IJ + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_TAU + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER :: NYMD, NHMS + REAL*4 :: LON, LAT + + ! Function arg + REAL*8 :: NH3_DBL(LLPAR) + + ! Local variables + REAL*4 :: DAT(144,91,20) + CHARACTER(LEN=255) :: FILENAME + INTEGER :: IIJJ(2) + + !================================================================= + ! GET_DOUBLED_NH3 begins here! + !================================================================= + + ! filename + FILENAME = 'nh3.YYYYMMDD.hhmm' + + ! Expand filename + CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) + + ! Full path to file + FILENAME = TRIM( DATA_DIR ) // + & 'doubled_nh3/' // + & TRIM( FILENAME ) // + & TRIM( '00' ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - GET_DOUBLED_NH3: Reading ', a ) + + ! dkh debug + print*, ' GET_TAU() = ', GET_TAU() + + ! Get data + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, + & GET_TAU(), 144, 91, + & 20, DAT, QUIET=.FALSE. ) + + ! Now use GET_IJ in grid_mod.f (dkh, 02/16/11) + !IIJJ = GET_IJ_2x25( LON, LAT ) + IIJJ = GET_IJ( LON, LAT ) + + + print*, ' found doubled in I/J = ', IIJJ + + ! just the column for the present location, and convert ppb to ppm + NH3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 + NH3_DBL(21:LLPAR) = 0d0 + + print*, ' NH3_DBL = ', NH3_DBL + + ! Return to calling program + END FUNCTION GET_DOUBLED_NH3 + +! Now we use GET_IJ in grid_mod.f (dkh, 02/16/11) +!!------------------------------------------------------------------------------ +! FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) +! +!! +!!****************************************************************************** +!! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +!! LON, LAT coord. (dkh, 11/08/09) +!! +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) LON (REAL*8) : Longitude [degrees] +!! (2 ) LAT (REAL*8) : Latitude [degrees] +!! +!! Function result +!! ============================================================================ +!! (1 ) IIJJ(1) (INTEGER) : Long index [none] +!! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ERROR_MOD, ONLY : ERROR_STOP +! +! ! Arguments +! REAL*4 :: LAT, LON +! +! ! Return +! INTEGER :: I, J, IIJJ(2) +! +! ! Local variables +! REAL*8 :: TLON, TLAT, DLON, DLAT +! REAL*8, PARAMETER :: DISIZE = 2.5d0 +! REAL*8, PARAMETER :: DJSIZE = 2.0d0 +! INTEGER, PARAMETER :: IIMAX = 144 +! INTEGER, PARAMETER :: JJMAX = 91 +! +! +! !================================================================= +! ! GET_IJ_2x25 begins here! +! !================================================================= +! +! TLON = 180d0 + LON + DISIZE +! TLAT = 90d0 + LAT + DJSIZE +! +! I = TLON / DISIZE +! J = TLAT / DJSIZE +! +! +! IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN +! I = I + 1 +! ENDIF +! +! IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN +! J = J + 1 +! ENDIF +! +! +! ! Longitude wraps around +! !IF ( I == 73 ) I = 1 +! IF ( I == ( IIMAX + 1 ) ) I = 1 +! +! ! Check for impossible values +! IF ( I > IIMAX .or. J > JJMAX .or. +! & I < 1 .or. J < 1 ) THEN +! CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') +! ENDIF +! +! IIJJ(1) = I +! IIJJ(2) = J +! +! ! Return to calling program +! END FUNCTION GET_IJ_2x25 +! +!!----------------------------------------------------------------------------- + + SUBROUTINE READ_TES_BLVMR( FILENAME, LAT, LON, + & BLVMR, BLVMR_GC ) +! +!****************************************************************************** +! Subroutine READ_TES_BLVMR reads the BLVMR values in a TES netcdf file. +! (dkh, 01/20/11) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (REAL*8) : TES observation filename to read +! +! Arguments as Output: +! ============================================================================ +! (1 ) LAT (REAL*8) : TES retrieval latitude +! (2 ) LON (REAL*8) : TES retrieval longitude +! (3 ) BLVMR (REAL*8) : TES retrieval BLVMR [ppmv] +! (4 ) BLVMR_GC (REAL*8) : GEOS-Chem BLVMR [ppmv] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + +# include "CMN_SIZE" + + ! Arguments + CHARACTER(LEN=255), INTENT(IN) :: FILENAME + REAL*8, INTENT(OUT) :: LAT + REAL*8, INTENT(OUT) :: LON + REAL*8, INTENT(OUT) :: BLVMR + REAL*8, INTENT(OUT) :: BLVMR_GC + + ! Local variables + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=5) :: TMP + REAL*8 :: BLVMR_TMP(3) + REAL*8 :: BLVMR_GC_TMP(3) + INTEGER :: QFLAG + INTEGER :: DFLAG + + ! netCDF id's + INTEGER :: FID, VARID, DIMID, ATTID + INTEGER :: NBL + + ! Loop indexes, and error handling. + INTEGER :: L, LL + + ! dkh debug + INTEGER :: dim_ids(10), n_dims + + !================================================================= + ! READ_TES_BLVMR begins here! + !================================================================= + + ! Initialize + BLVMR_GC = -999d0 + BLVMR = -999d0 + + ! Construct complete filename + READ_FILENAME = TRIM( DATA_DIR ) // + & TRIM( '../TES_NH3/' ) // + & TRIM( 'tes_nh3_gs_January_2006_for_paper/' ) // + & TRIM( FILENAME ) + + WRITE(6,*) ' - READ_TES_NH3_OBS: reading file: ', READ_FILENAME + + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + ! READ quality flag QFLAG + ! 1 = successful + ! 0 = failed. For reason why, see DFLAG. + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Quality_Flag", + & QFLAG ), 12 ) + + ! READ diagnostic flag DFLAG + ! 0 = converged, but DOFS < 0.5, though thermal contrast ok + ! -1 = converged, but DOFS < 0.5 & thermal contrast poor + ! -2 = did not converge + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Diagnostic_Flag", + & DFLAG ), 14 ) + + ! READ latitude LAT + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Latitude", + & LAT ), 15 ) + + ! READ longitude LON + CALL CHECK( NF90_GET_ATT( FID, NF90_GLOBAL, "Longitude", + & LON ), 16 ) + + ! READ BLVMR only for good retrievals, fill othewise + IF ( QFLAG == 1 .and. DFLAG == 1 ) THEN + + ! dkh debug + print*, ' quality retv; look for BLVMR ' + + ! get NBL + CALL CHECK( NF90_INQ_DIMID ( FID, "nbl", DIMID ), 201 ) + CALL CHECK( NF90_INQUIRE_DIMENSION( FID,DIMID, TMP, NBL), 212 ) + + ! Get BLVMR_TMP + CALL CHECK( NF90_INQ_VARID( FID, "blvmr", VARID ), 21 ) + CALL CHECK( NF90_GET_VAR ( FID, VARID, BLVMR_TMP(1:NBL) ), + & 222 ) + + ! READ BLVMR_GC only if BLVMR not = -999 + IF ( BLVMR_TMP(1) > 0 ) THEN + + ! Get BLVMR_GC + CALL CHECK( NF90_INQ_VARID( FID, "blvmr_gc", VARID ), + & 232 ) + + CALL CHECK( NF90_GET_VAR ( FID, VARID, + & BLVMR_GC_TMP(1:NBL) ), 333 ) + + ! It is possible to have two BLVMRs when DOF > 1.2. + IF ( NBL == 1 ) THEN + + ! Keep only the first one. + BLVMR = BLVMR_TMP(1) + + ELSEIF ( NBL > 1 ) THEN + ! Keep the last one (dkh, 01/21/11) + BLVMR = BLVMR_TMP(NBL) + + ENDIF + + + ELSE + + ! Fill value + BLVMR = -999D0 + BLVMR_GC = -999D0 + + ENDIF + ELSE + + ! Fill value + BLVMR = -999D0 + BLVMR_GC = -999D0 + + ENDIF + + print*, ' BLVMR = ', BLVMR, BLVMR_GC, LAT, LON, FILENAME + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + ! Return to calling program + END SUBROUTINE READ_TES_BLVMR +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_TES_BLVMR( ) +! +!****************************************************************************** +! Subroutine MAKE_TES_BLVMR makes a binary punch file out of BLVMR values +! (dkh, 01/20/11) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_IJ, GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : GET_TAU + +# include "CMN_SIZE" + + ! Arguments + + ! Local variables + INTEGER :: I, J, I0, J0, IIJJ(2), NTES + CHARACTER(LEN=120) :: WRITE_FILENAME + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: BLVMR_BAR(IIPAR,JJPAR), BLVMR_GC_BAR(IIPAR,JJPAR) + REAL*8 :: DELTA_BLVMR, DELTA_BLVMR_GC + INTEGER :: N(IIPAR,JJPAR) + + ! For binary punch file, version 2.0 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + INTEGER :: IU_BPCH + + ! Variables read from file + REAL*8 :: LAT, LON + REAL*8 :: BLVMR + REAL*8 :: BLVMR_GC + + !================================================================= + ! MAKE_TES_BLVMR begins here! + !================================================================= + BLVMR_BAR(:,:) = 0d0 + BLVMR_GC_BAR(:,:) = 0d0 + N(:,:) = 0d0 + + + DO NTES = 1, MAXTES + + FILENAME = TES(NTES)%FILENAME + + WRITE(6,*) ' MAKE_TES_BLVMR: reading file: ', FILENAME, NTES + + CALL READ_TES_BLVMR( FILENAME, LAT, LON, BLVMR, BLVMR_GC ) + + ! dkh debug + print*, ' LAT = ', LAT + print*, ' LON = ', LON + print*, ' BLVMR = ', BLVMR + print*, ' BLVMR_GC = ', BLVMR_GC + + ! Quality check + IF ( + & BLVMR < 0 .or. + & BLVMR_GC < 0 ) CYCLE + + ! Get grid box + IIJJ = GET_IJ( REAL(LON,4), REAL(LAT,4)) + I = IIJJ(1) + J = IIJJ(2) + + ! Update local count + N(I,J) = N(I,J) + 1 + + ! Update mean + DELTA_BLVMR = BLVMR - BLVMR_BAR(I,J) + DELTA_BLVMR_GC = BLVMR_GC - BLVMR_GC_BAR(I,J) + + BLVMR_BAR(I,J) = BLVMR_BAR(I,J) + DELTA_BLVMR /N(I,J) + BLVMR_GC_BAR(I,J) = BLVMR_GC_BAR(I,J) + DELTA_BLVMR_GC /N(I,J) + + ENDDO + + WRITE(6,*) 'Done reading TES data files ' + WRITE(6,*) 'Number of good data points found: ', SUM(N(:,:)) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'BLVMR data file ' + CATEGORY = 'BLVMR' + LONRES = DISIZE + LATRES = DJSIZE + UNIT = 'ppm' + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the file for output -- binary punch format + !================================================================= + + ! Add ADJ_DIR prefix to filename + WRITE_FILENAME = TRIM( 'blvmr.bpch' ) + + WRITE( 6, 100 ) TRIM( WRITE_FILENAME ) + 100 FORMAT( ' - MAKE_TES_BLVMR: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_BPCH, WRITE_FILENAME, TITLE ) + + CALL BPCH2( IU_BPCH, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, REAL(BLVMR_BAR,4) ) + + CALL BPCH2( IU_BPCH, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, REAL(BLVMR_GC_BAR,4) ) + + + ! Close file + CLOSE( IU_BPCH ) + + ! Return to calling program + END SUBROUTINE MAKE_TES_BLVMR + +!------------------------------------------------------------------------------ + SUBROUTINE INIT_TES_NH3 +! +!***************************************************************************** +! Subroutine INIT_TES_NH3 deallocates all module arrays. (dkh, 02/15/09) +! +! NOTES: +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! IIPAR, JJPAR + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_TES_NH3 begins here + !================================================================= + + ! dkh debug + print*, ' INIT_TES_NH3' + + ALLOCATE( NH3_SAVE( LLPAR, MAXTES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NH3_SAVE' ) + NH3_SAVE = 0d0 + + ! tes_nh3_gs_July_2009_for_paper + TES(1)%NYMD = 20090701 + TES(2)%NYMD = 20090701 + TES(3)%NYMD = 20090701 + TES(4)%NYMD = 20090701 + TES(5)%NYMD = 20090701 + TES(6)%NYMD = 20090701 + TES(7)%NYMD = 20090701 + TES(8)%NYMD = 20090701 + TES(9)%NYMD = 20090701 + TES(10)%NYMD = 20090701 + TES(11)%NYMD = 20090701 + TES(12)%NYMD = 20090701 + TES(13)%NYMD = 20090701 + TES(14)%NYMD = 20090701 + TES(15)%NYMD = 20090701 + TES(16)%NYMD = 20090701 + TES(17)%NYMD = 20090701 + TES(18)%NYMD = 20090701 + TES(19)%NYMD = 20090701 + TES(20)%NYMD = 20090701 + TES(21)%NYMD = 20090701 + TES(22)%NYMD = 20090701 + TES(23)%NYMD = 20090701 + TES(24)%NYMD = 20090701 + TES(25)%NYMD = 20090701 + TES(26)%NYMD = 20090701 + TES(27)%NYMD = 20090701 + TES(28)%NYMD = 20090701 + TES(29)%NYMD = 20090701 + TES(30)%NYMD = 20090701 + TES(31)%NYMD = 20090701 + TES(32)%NYMD = 20090701 + TES(33)%NYMD = 20090701 + TES(34)%NYMD = 20090701 + TES(35)%NYMD = 20090701 + TES(36)%NYMD = 20090701 + TES(37)%NYMD = 20090701 + TES(38)%NYMD = 20090701 + TES(39)%NYMD = 20090701 + TES(40)%NYMD = 20090701 + TES(41)%NYMD = 20090701 + TES(42)%NYMD = 20090701 + TES(43)%NYMD = 20090701 + TES(44)%NYMD = 20090701 + TES(45)%NYMD = 20090701 + TES(46)%NYMD = 20090701 + TES(47)%NYMD = 20090701 + TES(48)%NYMD = 20090701 + TES(49)%NYMD = 20090701 + TES(50)%NYMD = 20090701 + TES(51)%NYMD = 20090701 + TES(52)%NYMD = 20090701 + TES(53)%NYMD = 20090701 + TES(54)%NYMD = 20090701 + TES(55)%NYMD = 20090701 + TES(56)%NYMD = 20090701 + TES(57)%NYMD = 20090701 + TES(58)%NYMD = 20090701 + TES(59)%NYMD = 20090701 + TES(60)%NYMD = 20090701 + TES(61)%NYMD = 20090701 + TES(62)%NYMD = 20090701 + TES(63)%NYMD = 20090701 + TES(64)%NYMD = 20090701 + TES(65)%NYMD = 20090701 + TES(66)%NYMD = 20090701 + TES(67)%NYMD = 20090701 + TES(68)%NYMD = 20090701 + TES(69)%NYMD = 20090701 + TES(70)%NYMD = 20090701 + TES(71)%NYMD = 20090701 + TES(72)%NYMD = 20090701 + TES(73)%NYMD = 20090701 + TES(74)%NYMD = 20090701 + TES(75)%NYMD = 20090701 + TES(76)%NYMD = 20090701 + TES(77)%NYMD = 20090701 + TES(78)%NYMD = 20090701 + TES(79)%NYMD = 20090701 + TES(80)%NYMD = 20090701 + TES(81)%NYMD = 20090701 + TES(82)%NYMD = 20090701 + TES(83)%NYMD = 20090701 + TES(84)%NYMD = 20090701 + TES(85)%NYMD = 20090701 + TES(86)%NYMD = 20090701 + TES(87)%NYMD = 20090701 + TES(88)%NYMD = 20090701 + TES(89)%NYMD = 20090701 + TES(90)%NYMD = 20090701 + TES(91)%NYMD = 20090701 + TES(92)%NYMD = 20090701 + TES(93)%NYMD = 20090701 + TES(94)%NYMD = 20090701 + TES(95)%NYMD = 20090701 + TES(96)%NYMD = 20090701 + TES(97)%NYMD = 20090701 + TES(98)%NYMD = 20090701 + TES(99)%NYMD = 20090701 + TES(100)%NYMD = 20090701 + TES(101)%NYMD = 20090701 + TES(102)%NYMD = 20090701 + TES(103)%NYMD = 20090701 + TES(104)%NYMD = 20090701 + TES(105)%NYMD = 20090701 + TES(106)%NYMD = 20090701 + TES(107)%NYMD = 20090701 + TES(108)%NYMD = 20090701 + TES(109)%NYMD = 20090701 + TES(110)%NYMD = 20090701 + TES(111)%NYMD = 20090701 + TES(112)%NYMD = 20090701 + TES(113)%NYMD = 20090701 + TES(114)%NYMD = 20090701 + TES(115)%NYMD = 20090701 + TES(116)%NYMD = 20090701 + TES(117)%NYMD = 20090701 + TES(118)%NYMD = 20090701 + TES(119)%NYMD = 20090701 + TES(120)%NYMD = 20090701 + TES(121)%NYMD = 20090701 + TES(122)%NYMD = 20090701 + TES(123)%NYMD = 20090701 + TES(124)%NYMD = 20090701 + TES(125)%NYMD = 20090701 + TES(126)%NYMD = 20090701 + TES(127)%NYMD = 20090701 + TES(128)%NYMD = 20090701 + TES(129)%NYMD = 20090701 + TES(130)%NYMD = 20090701 + TES(131)%NYMD = 20090701 + TES(132)%NYMD = 20090701 + TES(133)%NYMD = 20090701 + TES(134)%NYMD = 20090701 + TES(135)%NYMD = 20090701 + TES(136)%NYMD = 20090701 + TES(137)%NYMD = 20090701 + TES(138)%NYMD = 20090701 + TES(139)%NYMD = 20090701 + TES(140)%NYMD = 20090701 + TES(141)%NYMD = 20090701 + TES(142)%NYMD = 20090701 + TES(143)%NYMD = 20090701 + TES(144)%NYMD = 20090701 + TES(145)%NYMD = 20090701 + TES(146)%NYMD = 20090701 + TES(147)%NYMD = 20090701 + TES(148)%NYMD = 20090701 + TES(149)%NYMD = 20090702 + TES(150)%NYMD = 20090702 + TES(151)%NYMD = 20090702 + TES(152)%NYMD = 20090702 + TES(153)%NYMD = 20090702 + TES(154)%NYMD = 20090702 + TES(155)%NYMD = 20090702 + TES(156)%NYMD = 20090702 + TES(157)%NYMD = 20090702 + TES(158)%NYMD = 20090702 + TES(159)%NYMD = 20090702 + TES(160)%NYMD = 20090702 + TES(161)%NYMD = 20090702 + TES(162)%NYMD = 20090702 + TES(163)%NYMD = 20090702 + TES(164)%NYMD = 20090702 + TES(165)%NYMD = 20090702 + TES(166)%NYMD = 20090702 + TES(167)%NYMD = 20090702 + TES(168)%NYMD = 20090702 + TES(169)%NYMD = 20090702 + TES(170)%NYMD = 20090702 + TES(171)%NYMD = 20090702 + TES(172)%NYMD = 20090702 + TES(173)%NYMD = 20090702 + TES(174)%NYMD = 20090702 + TES(175)%NYMD = 20090702 + TES(176)%NYMD = 20090702 + TES(177)%NYMD = 20090702 + TES(178)%NYMD = 20090702 + TES(179)%NYMD = 20090702 + TES(180)%NYMD = 20090702 + TES(181)%NYMD = 20090702 + TES(182)%NYMD = 20090702 + TES(183)%NYMD = 20090702 + TES(184)%NYMD = 20090702 + TES(185)%NYMD = 20090702 + TES(186)%NYMD = 20090702 + TES(187)%NYMD = 20090702 + TES(188)%NYMD = 20090702 + TES(189)%NYMD = 20090702 + TES(190)%NYMD = 20090702 + TES(191)%NYMD = 20090702 + TES(192)%NYMD = 20090702 + TES(193)%NYMD = 20090702 + TES(194)%NYMD = 20090702 + TES(195)%NYMD = 20090702 + TES(196)%NYMD = 20090702 + TES(197)%NYMD = 20090702 + TES(198)%NYMD = 20090702 + TES(199)%NYMD = 20090702 + TES(200)%NYMD = 20090702 + TES(201)%NYMD = 20090702 + TES(202)%NYMD = 20090702 + TES(203)%NYMD = 20090702 + TES(204)%NYMD = 20090702 + TES(205)%NYMD = 20090702 + TES(206)%NYMD = 20090702 + TES(207)%NYMD = 20090702 + TES(208)%NYMD = 20090702 + TES(209)%NYMD = 20090702 + TES(210)%NYMD = 20090702 + TES(211)%NYMD = 20090702 + TES(212)%NYMD = 20090702 + TES(213)%NYMD = 20090702 + TES(214)%NYMD = 20090702 + TES(215)%NYMD = 20090702 + TES(216)%NYMD = 20090702 + TES(217)%NYMD = 20090702 + TES(218)%NYMD = 20090702 + TES(219)%NYMD = 20090702 + TES(220)%NYMD = 20090702 + TES(221)%NYMD = 20090702 + TES(222)%NYMD = 20090702 + TES(223)%NYMD = 20090702 + TES(224)%NYMD = 20090702 + TES(225)%NYMD = 20090702 + TES(226)%NYMD = 20090702 + TES(227)%NYMD = 20090702 + TES(228)%NYMD = 20090702 + TES(229)%NYMD = 20090702 + TES(230)%NYMD = 20090702 + TES(231)%NYMD = 20090702 + TES(232)%NYMD = 20090702 + TES(233)%NYMD = 20090702 + TES(234)%NYMD = 20090702 + TES(235)%NYMD = 20090702 + TES(236)%NYMD = 20090702 + TES(237)%NYMD = 20090702 + TES(238)%NYMD = 20090702 + TES(239)%NYMD = 20090702 + TES(240)%NYMD = 20090702 + TES(241)%NYMD = 20090702 + TES(242)%NYMD = 20090702 + TES(243)%NYMD = 20090702 + TES(244)%NYMD = 20090702 + TES(245)%NYMD = 20090702 + TES(246)%NYMD = 20090702 + TES(247)%NYMD = 20090702 + TES(248)%NYMD = 20090702 + TES(249)%NYMD = 20090702 + TES(250)%NYMD = 20090702 + TES(251)%NYMD = 20090702 + TES(252)%NYMD = 20090702 + TES(253)%NYMD = 20090702 + TES(254)%NYMD = 20090702 + TES(255)%NYMD = 20090702 + TES(256)%NYMD = 20090702 + TES(257)%NYMD = 20090702 + TES(258)%NYMD = 20090702 + TES(259)%NYMD = 20090702 + TES(260)%NYMD = 20090702 + TES(261)%NYMD = 20090702 + TES(262)%NYMD = 20090702 + TES(263)%NYMD = 20090702 + TES(264)%NYMD = 20090702 + TES(265)%NYMD = 20090702 + TES(266)%NYMD = 20090702 + TES(267)%NYMD = 20090702 + TES(268)%NYMD = 20090702 + TES(269)%NYMD = 20090702 + TES(270)%NYMD = 20090702 + TES(271)%NYMD = 20090702 + TES(272)%NYMD = 20090702 + TES(273)%NYMD = 20090702 + TES(274)%NYMD = 20090703 + TES(275)%NYMD = 20090703 + TES(276)%NYMD = 20090703 + TES(277)%NYMD = 20090703 + TES(278)%NYMD = 20090703 + TES(279)%NYMD = 20090703 + TES(280)%NYMD = 20090703 + TES(281)%NYMD = 20090703 + TES(282)%NYMD = 20090703 + TES(283)%NYMD = 20090703 + TES(284)%NYMD = 20090703 + TES(285)%NYMD = 20090703 + TES(286)%NYMD = 20090703 + TES(287)%NYMD = 20090703 + TES(288)%NYMD = 20090703 + TES(289)%NYMD = 20090703 + TES(290)%NYMD = 20090703 + TES(291)%NYMD = 20090703 + TES(292)%NYMD = 20090703 + TES(293)%NYMD = 20090703 + TES(294)%NYMD = 20090703 + TES(295)%NYMD = 20090703 + TES(296)%NYMD = 20090703 + TES(297)%NYMD = 20090703 + TES(298)%NYMD = 20090703 + TES(299)%NYMD = 20090703 + TES(300)%NYMD = 20090703 + TES(301)%NYMD = 20090703 + TES(302)%NYMD = 20090703 + TES(303)%NYMD = 20090703 + TES(304)%NYMD = 20090703 + TES(305)%NYMD = 20090703 + TES(306)%NYMD = 20090703 + TES(307)%NYMD = 20090703 + TES(308)%NYMD = 20090703 + TES(309)%NYMD = 20090703 + TES(310)%NYMD = 20090703 + TES(311)%NYMD = 20090703 + TES(312)%NYMD = 20090703 + TES(313)%NYMD = 20090703 + TES(314)%NYMD = 20090703 + TES(315)%NYMD = 20090703 + TES(316)%NYMD = 20090703 + TES(317)%NYMD = 20090703 + TES(318)%NYMD = 20090703 + TES(319)%NYMD = 20090703 + TES(320)%NYMD = 20090703 + TES(321)%NYMD = 20090703 + TES(322)%NYMD = 20090703 + TES(323)%NYMD = 20090703 + TES(324)%NYMD = 20090703 + TES(325)%NYMD = 20090703 + TES(326)%NYMD = 20090703 + TES(327)%NYMD = 20090703 + TES(328)%NYMD = 20090703 + TES(329)%NYMD = 20090703 + TES(330)%NYMD = 20090703 + TES(331)%NYMD = 20090703 + TES(332)%NYMD = 20090703 + TES(333)%NYMD = 20090703 + TES(334)%NYMD = 20090703 + TES(335)%NYMD = 20090703 + TES(336)%NYMD = 20090703 + TES(337)%NYMD = 20090703 + TES(338)%NYMD = 20090703 + TES(339)%NYMD = 20090703 + TES(340)%NYMD = 20090703 + TES(341)%NYMD = 20090703 + TES(342)%NYMD = 20090703 + TES(343)%NYMD = 20090703 + TES(344)%NYMD = 20090703 + TES(345)%NYMD = 20090703 + TES(346)%NYMD = 20090703 + TES(347)%NYMD = 20090703 + TES(348)%NYMD = 20090703 + TES(349)%NYMD = 20090703 + TES(350)%NYMD = 20090703 + TES(351)%NYMD = 20090703 + TES(352)%NYMD = 20090703 + TES(353)%NYMD = 20090703 + TES(354)%NYMD = 20090703 + TES(355)%NYMD = 20090703 + TES(356)%NYMD = 20090703 + TES(357)%NYMD = 20090703 + TES(358)%NYMD = 20090703 + TES(359)%NYMD = 20090703 + TES(360)%NYMD = 20090703 + TES(361)%NYMD = 20090703 + TES(362)%NYMD = 20090703 + TES(363)%NYMD = 20090703 + TES(364)%NYMD = 20090703 + TES(365)%NYMD = 20090703 + TES(366)%NYMD = 20090703 + TES(367)%NYMD = 20090703 + TES(368)%NYMD = 20090703 + TES(369)%NYMD = 20090703 + TES(370)%NYMD = 20090703 + TES(371)%NYMD = 20090703 + TES(372)%NYMD = 20090703 + TES(373)%NYMD = 20090703 + TES(374)%NYMD = 20090703 + TES(375)%NYMD = 20090703 + TES(376)%NYMD = 20090703 + TES(377)%NYMD = 20090703 + TES(378)%NYMD = 20090703 + TES(379)%NYMD = 20090703 + TES(380)%NYMD = 20090703 + TES(381)%NYMD = 20090703 + TES(382)%NYMD = 20090703 + TES(383)%NYMD = 20090703 + TES(384)%NYMD = 20090703 + TES(385)%NYMD = 20090703 + TES(386)%NYMD = 20090703 + TES(387)%NYMD = 20090703 + TES(388)%NYMD = 20090703 + TES(389)%NYMD = 20090703 + TES(390)%NYMD = 20090703 + TES(391)%NYMD = 20090703 + TES(392)%NYMD = 20090703 + TES(393)%NYMD = 20090703 + TES(394)%NYMD = 20090703 + TES(395)%NYMD = 20090703 + TES(396)%NYMD = 20090703 + TES(397)%NYMD = 20090703 + TES(398)%NYMD = 20090703 + TES(399)%NYMD = 20090703 + TES(400)%NYMD = 20090703 + TES(401)%NYMD = 20090703 + TES(402)%NYMD = 20090703 + TES(403)%NYMD = 20090703 + TES(404)%NYMD = 20090703 + TES(405)%NYMD = 20090703 + TES(406)%NYMD = 20090703 + TES(407)%NYMD = 20090703 + TES(408)%NYMD = 20090703 + TES(409)%NYMD = 20090704 + TES(410)%NYMD = 20090704 + TES(411)%NYMD = 20090704 + TES(412)%NYMD = 20090704 + TES(413)%NYMD = 20090704 + TES(414)%NYMD = 20090704 + TES(415)%NYMD = 20090704 + TES(416)%NYMD = 20090704 + TES(417)%NYMD = 20090704 + TES(418)%NYMD = 20090704 + TES(419)%NYMD = 20090704 + TES(420)%NYMD = 20090704 + TES(421)%NYMD = 20090704 + TES(422)%NYMD = 20090704 + TES(423)%NYMD = 20090704 + TES(424)%NYMD = 20090704 + TES(425)%NYMD = 20090704 + TES(426)%NYMD = 20090704 + TES(427)%NYMD = 20090704 + TES(428)%NYMD = 20090704 + TES(429)%NYMD = 20090704 + TES(430)%NYMD = 20090704 + TES(431)%NYMD = 20090704 + TES(432)%NYMD = 20090704 + TES(433)%NYMD = 20090704 + TES(434)%NYMD = 20090704 + TES(435)%NYMD = 20090704 + TES(436)%NYMD = 20090704 + TES(437)%NYMD = 20090704 + TES(438)%NYMD = 20090704 + TES(439)%NYMD = 20090704 + TES(440)%NYMD = 20090704 + TES(441)%NYMD = 20090704 + TES(442)%NYMD = 20090704 + TES(443)%NYMD = 20090704 + TES(444)%NYMD = 20090704 + TES(445)%NYMD = 20090704 + TES(446)%NYMD = 20090704 + TES(447)%NYMD = 20090704 + TES(448)%NYMD = 20090704 + TES(449)%NYMD = 20090704 + TES(450)%NYMD = 20090704 + TES(451)%NYMD = 20090704 + TES(452)%NYMD = 20090704 + TES(453)%NYMD = 20090704 + TES(454)%NYMD = 20090704 + TES(455)%NYMD = 20090704 + TES(456)%NYMD = 20090704 + TES(457)%NYMD = 20090704 + TES(458)%NYMD = 20090704 + TES(459)%NYMD = 20090704 + TES(460)%NYMD = 20090704 + TES(461)%NYMD = 20090704 + TES(462)%NYMD = 20090704 + TES(463)%NYMD = 20090704 + TES(464)%NYMD = 20090704 + TES(465)%NYMD = 20090704 + TES(466)%NYMD = 20090704 + TES(467)%NYMD = 20090704 + TES(468)%NYMD = 20090704 + TES(469)%NYMD = 20090704 + TES(470)%NYMD = 20090704 + TES(471)%NYMD = 20090704 + TES(472)%NYMD = 20090704 + TES(473)%NYMD = 20090704 + TES(474)%NYMD = 20090704 + TES(475)%NYMD = 20090704 + TES(476)%NYMD = 20090704 + TES(477)%NYMD = 20090704 + TES(478)%NYMD = 20090704 + TES(479)%NYMD = 20090704 + TES(480)%NYMD = 20090704 + TES(481)%NYMD = 20090704 + TES(482)%NYMD = 20090704 + TES(483)%NYMD = 20090704 + TES(484)%NYMD = 20090704 + TES(485)%NYMD = 20090704 + TES(486)%NYMD = 20090704 + TES(487)%NYMD = 20090704 + TES(488)%NYMD = 20090704 + TES(489)%NYMD = 20090704 + TES(490)%NYMD = 20090704 + TES(491)%NYMD = 20090704 + TES(492)%NYMD = 20090704 + TES(493)%NYMD = 20090704 + TES(494)%NYMD = 20090704 + TES(495)%NYMD = 20090704 + TES(496)%NYMD = 20090704 + TES(497)%NYMD = 20090704 + TES(498)%NYMD = 20090704 + TES(499)%NYMD = 20090704 + TES(500)%NYMD = 20090704 + TES(501)%NYMD = 20090704 + TES(502)%NYMD = 20090704 + TES(503)%NYMD = 20090704 + TES(504)%NYMD = 20090704 + TES(505)%NYMD = 20090704 + TES(506)%NYMD = 20090704 + TES(507)%NYMD = 20090704 + TES(508)%NYMD = 20090704 + TES(509)%NYMD = 20090704 + TES(510)%NYMD = 20090704 + TES(511)%NYMD = 20090704 + TES(512)%NYMD = 20090704 + TES(513)%NYMD = 20090704 + TES(514)%NYMD = 20090704 + TES(515)%NYMD = 20090704 + TES(516)%NYMD = 20090704 + TES(517)%NYMD = 20090704 + TES(518)%NYMD = 20090705 + TES(519)%NYMD = 20090705 + TES(520)%NYMD = 20090705 + TES(521)%NYMD = 20090705 + TES(522)%NYMD = 20090705 + TES(523)%NYMD = 20090705 + TES(524)%NYMD = 20090705 + TES(525)%NYMD = 20090705 + TES(526)%NYMD = 20090705 + TES(527)%NYMD = 20090705 + TES(528)%NYMD = 20090705 + TES(529)%NYMD = 20090705 + TES(530)%NYMD = 20090705 + TES(531)%NYMD = 20090705 + TES(532)%NYMD = 20090705 + TES(533)%NYMD = 20090705 + TES(534)%NYMD = 20090705 + TES(535)%NYMD = 20090705 + TES(536)%NYMD = 20090705 + TES(537)%NYMD = 20090705 + TES(538)%NYMD = 20090705 + TES(539)%NYMD = 20090705 + TES(540)%NYMD = 20090705 + TES(541)%NYMD = 20090705 + TES(542)%NYMD = 20090705 + TES(543)%NYMD = 20090705 + TES(544)%NYMD = 20090705 + TES(545)%NYMD = 20090705 + TES(546)%NYMD = 20090705 + TES(547)%NYMD = 20090705 + TES(548)%NYMD = 20090705 + TES(549)%NYMD = 20090705 + TES(550)%NYMD = 20090705 + TES(551)%NYMD = 20090705 + TES(552)%NYMD = 20090705 + TES(553)%NYMD = 20090705 + TES(554)%NYMD = 20090705 + TES(555)%NYMD = 20090705 + TES(556)%NYMD = 20090705 + TES(557)%NYMD = 20090705 + TES(558)%NYMD = 20090705 + TES(559)%NYMD = 20090705 + TES(560)%NYMD = 20090705 + TES(561)%NYMD = 20090705 + TES(562)%NYMD = 20090705 + TES(563)%NYMD = 20090705 + TES(564)%NYMD = 20090705 + TES(565)%NYMD = 20090705 + TES(566)%NYMD = 20090705 + TES(567)%NYMD = 20090705 + TES(568)%NYMD = 20090705 + TES(569)%NYMD = 20090705 + TES(570)%NYMD = 20090705 + TES(571)%NYMD = 20090705 + TES(572)%NYMD = 20090705 + TES(573)%NYMD = 20090705 + TES(574)%NYMD = 20090705 + TES(575)%NYMD = 20090705 + TES(576)%NYMD = 20090705 + TES(577)%NYMD = 20090705 + TES(578)%NYMD = 20090705 + TES(579)%NYMD = 20090705 + TES(580)%NYMD = 20090705 + TES(581)%NYMD = 20090705 + TES(582)%NYMD = 20090705 + TES(583)%NYMD = 20090705 + TES(584)%NYMD = 20090705 + TES(585)%NYMD = 20090705 + TES(586)%NYMD = 20090705 + TES(587)%NYMD = 20090705 + TES(588)%NYMD = 20090705 + TES(589)%NYMD = 20090705 + TES(590)%NYMD = 20090705 + TES(591)%NYMD = 20090705 + TES(592)%NYMD = 20090705 + TES(593)%NYMD = 20090705 + TES(594)%NYMD = 20090705 + TES(595)%NYMD = 20090705 + TES(596)%NYMD = 20090705 + TES(597)%NYMD = 20090705 + TES(598)%NYMD = 20090705 + TES(599)%NYMD = 20090705 + TES(600)%NYMD = 20090705 + TES(601)%NYMD = 20090705 + TES(602)%NYMD = 20090705 + TES(603)%NYMD = 20090705 + TES(604)%NYMD = 20090705 + TES(605)%NYMD = 20090705 + TES(606)%NYMD = 20090705 + TES(607)%NYMD = 20090705 + TES(608)%NYMD = 20090705 + TES(609)%NYMD = 20090705 + TES(610)%NYMD = 20090705 + TES(611)%NYMD = 20090705 + TES(612)%NYMD = 20090705 + TES(613)%NYMD = 20090705 + TES(614)%NYMD = 20090705 + TES(615)%NYMD = 20090705 + TES(616)%NYMD = 20090705 + TES(617)%NYMD = 20090705 + TES(618)%NYMD = 20090705 + TES(619)%NYMD = 20090705 + TES(620)%NYMD = 20090705 + TES(621)%NYMD = 20090705 + TES(622)%NYMD = 20090705 + TES(623)%NYMD = 20090705 + TES(624)%NYMD = 20090705 + TES(625)%NYMD = 20090705 + TES(626)%NYMD = 20090705 + TES(627)%NYMD = 20090705 + TES(628)%NYMD = 20090705 + TES(629)%NYMD = 20090705 + TES(630)%NYMD = 20090705 + TES(631)%NYMD = 20090705 + TES(632)%NYMD = 20090705 + TES(633)%NYMD = 20090705 + TES(634)%NYMD = 20090705 + TES(635)%NYMD = 20090705 + TES(636)%NYMD = 20090705 + TES(637)%NYMD = 20090705 + TES(638)%NYMD = 20090705 + TES(639)%NYMD = 20090705 + TES(640)%NYMD = 20090705 + TES(641)%NYMD = 20090705 + TES(642)%NYMD = 20090705 + TES(643)%NYMD = 20090705 + TES(644)%NYMD = 20090705 + TES(645)%NYMD = 20090705 + TES(646)%NYMD = 20090705 + TES(647)%NYMD = 20090705 + TES(648)%NYMD = 20090705 + TES(649)%NYMD = 20090705 + TES(650)%NYMD = 20090705 + TES(651)%NYMD = 20090705 + TES(652)%NYMD = 20090705 + TES(653)%NYMD = 20090705 + TES(654)%NYMD = 20090705 + TES(655)%NYMD = 20090705 + TES(656)%NYMD = 20090705 + TES(657)%NYMD = 20090705 + TES(658)%NYMD = 20090705 + TES(659)%NYMD = 20090705 + TES(660)%NYMD = 20090705 + TES(661)%NYMD = 20090705 + TES(662)%NYMD = 20090705 + TES(663)%NYMD = 20090705 + TES(664)%NYMD = 20090705 + TES(665)%NYMD = 20090705 + TES(666)%NYMD = 20090705 + TES(667)%NYMD = 20090705 + TES(668)%NYMD = 20090705 + TES(669)%NYMD = 20090705 + TES(670)%NYMD = 20090705 + TES(671)%NYMD = 20090705 + TES(672)%NYMD = 20090705 + TES(673)%NYMD = 20090705 + TES(674)%NYMD = 20090705 + TES(675)%NYMD = 20090705 + TES(676)%NYMD = 20090705 + TES(677)%NYMD = 20090706 + TES(678)%NYMD = 20090706 + TES(679)%NYMD = 20090706 + TES(680)%NYMD = 20090706 + TES(681)%NYMD = 20090706 + TES(682)%NYMD = 20090706 + TES(683)%NYMD = 20090706 + TES(684)%NYMD = 20090706 + TES(685)%NYMD = 20090706 + TES(686)%NYMD = 20090706 + TES(687)%NYMD = 20090706 + TES(688)%NYMD = 20090706 + TES(689)%NYMD = 20090706 + TES(690)%NYMD = 20090706 + TES(691)%NYMD = 20090706 + TES(692)%NYMD = 20090706 + TES(693)%NYMD = 20090706 + TES(694)%NYMD = 20090706 + TES(695)%NYMD = 20090706 + TES(696)%NYMD = 20090706 + TES(697)%NYMD = 20090706 + TES(698)%NYMD = 20090706 + TES(699)%NYMD = 20090706 + TES(700)%NYMD = 20090706 + TES(701)%NYMD = 20090706 + TES(702)%NYMD = 20090706 + TES(703)%NYMD = 20090706 + TES(704)%NYMD = 20090706 + TES(705)%NYMD = 20090706 + TES(706)%NYMD = 20090706 + TES(707)%NYMD = 20090706 + TES(708)%NYMD = 20090706 + TES(709)%NYMD = 20090706 + TES(710)%NYMD = 20090706 + TES(711)%NYMD = 20090706 + TES(712)%NYMD = 20090706 + TES(713)%NYMD = 20090706 + TES(714)%NYMD = 20090706 + TES(715)%NYMD = 20090706 + TES(716)%NYMD = 20090706 + TES(717)%NYMD = 20090706 + TES(718)%NYMD = 20090706 + TES(719)%NYMD = 20090706 + TES(720)%NYMD = 20090706 + TES(721)%NYMD = 20090706 + TES(722)%NYMD = 20090706 + TES(723)%NYMD = 20090706 + TES(724)%NYMD = 20090706 + TES(725)%NYMD = 20090706 + TES(726)%NYMD = 20090706 + TES(727)%NYMD = 20090706 + TES(728)%NYMD = 20090706 + TES(729)%NYMD = 20090706 + TES(730)%NYMD = 20090706 + TES(731)%NYMD = 20090706 + TES(732)%NYMD = 20090706 + TES(733)%NYMD = 20090706 + TES(734)%NYMD = 20090706 + TES(735)%NYMD = 20090706 + TES(736)%NYMD = 20090706 + TES(737)%NYMD = 20090706 + TES(738)%NYMD = 20090706 + TES(739)%NYMD = 20090706 + TES(740)%NYMD = 20090706 + TES(741)%NYMD = 20090706 + TES(742)%NYMD = 20090706 + TES(743)%NYMD = 20090706 + TES(744)%NYMD = 20090706 + TES(745)%NYMD = 20090706 + TES(746)%NYMD = 20090706 + TES(747)%NYMD = 20090706 + TES(748)%NYMD = 20090706 + TES(749)%NYMD = 20090706 + TES(750)%NYMD = 20090706 + TES(751)%NYMD = 20090706 + TES(752)%NYMD = 20090706 + TES(753)%NYMD = 20090706 + TES(754)%NYMD = 20090706 + TES(755)%NYMD = 20090706 + TES(756)%NYMD = 20090706 + TES(757)%NYMD = 20090706 + TES(758)%NYMD = 20090706 + TES(759)%NYMD = 20090706 + TES(760)%NYMD = 20090706 + TES(761)%NYMD = 20090706 + TES(762)%NYMD = 20090706 + TES(763)%NYMD = 20090706 + TES(764)%NYMD = 20090706 + TES(765)%NYMD = 20090706 + TES(766)%NYMD = 20090706 + TES(767)%NYMD = 20090706 + TES(768)%NYMD = 20090706 + TES(769)%NYMD = 20090706 + TES(770)%NYMD = 20090706 + TES(771)%NYMD = 20090706 + TES(772)%NYMD = 20090706 + TES(773)%NYMD = 20090706 + TES(774)%NYMD = 20090706 + TES(775)%NYMD = 20090706 + TES(776)%NYMD = 20090706 + TES(777)%NYMD = 20090706 + TES(778)%NYMD = 20090706 + TES(779)%NYMD = 20090706 + TES(780)%NYMD = 20090706 + TES(781)%NYMD = 20090706 + TES(782)%NYMD = 20090706 + TES(783)%NYMD = 20090706 + TES(784)%NYMD = 20090706 + TES(785)%NYMD = 20090706 + TES(786)%NYMD = 20090706 + TES(787)%NYMD = 20090706 + TES(788)%NYMD = 20090706 + TES(789)%NYMD = 20090706 + TES(790)%NYMD = 20090706 + TES(791)%NYMD = 20090706 + TES(792)%NYMD = 20090706 + TES(793)%NYMD = 20090706 + TES(794)%NYMD = 20090706 + TES(795)%NYMD = 20090706 + TES(796)%NYMD = 20090706 + TES(797)%NYMD = 20090706 + TES(798)%NYMD = 20090706 + TES(799)%NYMD = 20090706 + TES(800)%NYMD = 20090706 + TES(801)%NYMD = 20090706 + TES(802)%NYMD = 20090706 + TES(803)%NYMD = 20090706 + TES(804)%NYMD = 20090709 + TES(805)%NYMD = 20090709 + TES(806)%NYMD = 20090709 + TES(807)%NYMD = 20090709 + TES(808)%NYMD = 20090709 + TES(809)%NYMD = 20090709 + TES(810)%NYMD = 20090709 + TES(811)%NYMD = 20090709 + TES(812)%NYMD = 20090709 + TES(813)%NYMD = 20090709 + TES(814)%NYMD = 20090709 + TES(815)%NYMD = 20090709 + TES(816)%NYMD = 20090709 + TES(817)%NYMD = 20090709 + TES(818)%NYMD = 20090709 + TES(819)%NYMD = 20090709 + TES(820)%NYMD = 20090709 + TES(821)%NYMD = 20090709 + TES(822)%NYMD = 20090709 + TES(823)%NYMD = 20090709 + TES(824)%NYMD = 20090709 + TES(825)%NYMD = 20090709 + TES(826)%NYMD = 20090709 + TES(827)%NYMD = 20090709 + TES(828)%NYMD = 20090709 + TES(829)%NYMD = 20090709 + TES(830)%NYMD = 20090709 + TES(831)%NYMD = 20090709 + TES(832)%NYMD = 20090709 + TES(833)%NYMD = 20090709 + TES(834)%NYMD = 20090709 + TES(835)%NYMD = 20090709 + TES(836)%NYMD = 20090709 + TES(837)%NYMD = 20090709 + TES(838)%NYMD = 20090709 + TES(839)%NYMD = 20090709 + TES(840)%NYMD = 20090709 + TES(841)%NYMD = 20090709 + TES(842)%NYMD = 20090709 + TES(843)%NYMD = 20090709 + TES(844)%NYMD = 20090709 + TES(845)%NYMD = 20090709 + TES(846)%NYMD = 20090709 + TES(847)%NYMD = 20090709 + TES(848)%NYMD = 20090709 + TES(849)%NYMD = 20090709 + TES(850)%NYMD = 20090709 + TES(851)%NYMD = 20090709 + TES(852)%NYMD = 20090709 + TES(853)%NYMD = 20090709 + TES(854)%NYMD = 20090709 + TES(855)%NYMD = 20090709 + TES(856)%NYMD = 20090709 + TES(857)%NYMD = 20090709 + TES(858)%NYMD = 20090709 + TES(859)%NYMD = 20090709 + TES(860)%NYMD = 20090709 + TES(861)%NYMD = 20090709 + TES(862)%NYMD = 20090709 + TES(863)%NYMD = 20090709 + TES(864)%NYMD = 20090709 + TES(865)%NYMD = 20090709 + TES(866)%NYMD = 20090709 + TES(867)%NYMD = 20090709 + TES(868)%NYMD = 20090709 + TES(869)%NYMD = 20090709 + TES(870)%NYMD = 20090709 + TES(871)%NYMD = 20090709 + TES(872)%NYMD = 20090709 + TES(873)%NYMD = 20090709 + TES(874)%NYMD = 20090709 + TES(875)%NYMD = 20090709 + TES(876)%NYMD = 20090709 + TES(877)%NYMD = 20090709 + TES(878)%NYMD = 20090709 + TES(879)%NYMD = 20090709 + TES(880)%NYMD = 20090709 + TES(881)%NYMD = 20090709 + TES(882)%NYMD = 20090709 + TES(883)%NYMD = 20090709 + TES(884)%NYMD = 20090709 + TES(885)%NYMD = 20090709 + TES(886)%NYMD = 20090709 + TES(887)%NYMD = 20090709 + TES(888)%NYMD = 20090709 + TES(889)%NYMD = 20090709 + TES(890)%NYMD = 20090709 + TES(891)%NYMD = 20090709 + TES(892)%NYMD = 20090709 + TES(893)%NYMD = 20090709 + TES(894)%NYMD = 20090709 + TES(895)%NYMD = 20090709 + TES(896)%NYMD = 20090709 + TES(897)%NYMD = 20090709 + TES(898)%NYMD = 20090709 + TES(899)%NYMD = 20090709 + TES(900)%NYMD = 20090709 + TES(901)%NYMD = 20090709 + TES(902)%NYMD = 20090709 + TES(903)%NYMD = 20090709 + TES(904)%NYMD = 20090709 + TES(905)%NYMD = 20090709 + TES(906)%NYMD = 20090709 + TES(907)%NYMD = 20090709 + TES(908)%NYMD = 20090709 + TES(909)%NYMD = 20090709 + TES(910)%NYMD = 20090709 + TES(911)%NYMD = 20090709 + TES(912)%NYMD = 20090709 + TES(913)%NYMD = 20090709 + TES(914)%NYMD = 20090709 + TES(915)%NYMD = 20090709 + TES(916)%NYMD = 20090709 + TES(917)%NYMD = 20090709 + TES(918)%NYMD = 20090709 + TES(919)%NYMD = 20090709 + TES(920)%NYMD = 20090709 + TES(921)%NYMD = 20090709 + TES(922)%NYMD = 20090709 + TES(923)%NYMD = 20090709 + TES(924)%NYMD = 20090709 + TES(925)%NYMD = 20090709 + TES(926)%NYMD = 20090709 + TES(927)%NYMD = 20090709 + TES(928)%NYMD = 20090709 + TES(929)%NYMD = 20090709 + TES(930)%NYMD = 20090709 + TES(931)%NYMD = 20090709 + TES(932)%NYMD = 20090709 + TES(933)%NYMD = 20090709 + TES(934)%NYMD = 20090709 + TES(935)%NYMD = 20090709 + TES(936)%NYMD = 20090709 + TES(937)%NYMD = 20090709 + TES(938)%NYMD = 20090709 + TES(939)%NYMD = 20090709 + TES(940)%NYMD = 20090709 + TES(941)%NYMD = 20090709 + TES(942)%NYMD = 20090709 + TES(943)%NYMD = 20090709 + TES(944)%NYMD = 20090709 + TES(945)%NYMD = 20090709 + TES(946)%NYMD = 20090709 + TES(947)%NYMD = 20090709 + TES(948)%NYMD = 20090709 + TES(949)%NYMD = 20090709 + TES(950)%NYMD = 20090709 + TES(951)%NYMD = 20090709 + TES(952)%NYMD = 20090710 + TES(953)%NYMD = 20090710 + TES(954)%NYMD = 20090710 + TES(955)%NYMD = 20090710 + TES(956)%NYMD = 20090710 + TES(957)%NYMD = 20090710 + TES(958)%NYMD = 20090710 + TES(959)%NYMD = 20090710 + TES(960)%NYMD = 20090710 + TES(961)%NYMD = 20090710 + TES(962)%NYMD = 20090710 + TES(963)%NYMD = 20090710 + TES(964)%NYMD = 20090710 + TES(965)%NYMD = 20090710 + TES(966)%NYMD = 20090710 + TES(967)%NYMD = 20090710 + TES(968)%NYMD = 20090710 + TES(969)%NYMD = 20090710 + TES(970)%NYMD = 20090710 + TES(971)%NYMD = 20090710 + TES(972)%NYMD = 20090710 + TES(973)%NYMD = 20090710 + TES(974)%NYMD = 20090710 + TES(975)%NYMD = 20090710 + TES(976)%NYMD = 20090710 + TES(977)%NYMD = 20090710 + TES(978)%NYMD = 20090710 + TES(979)%NYMD = 20090710 + TES(980)%NYMD = 20090710 + TES(981)%NYMD = 20090710 + TES(982)%NYMD = 20090710 + TES(983)%NYMD = 20090710 + TES(984)%NYMD = 20090710 + TES(985)%NYMD = 20090710 + TES(986)%NYMD = 20090710 + TES(987)%NYMD = 20090710 + TES(988)%NYMD = 20090710 + TES(989)%NYMD = 20090710 + TES(990)%NYMD = 20090710 + TES(991)%NYMD = 20090710 + TES(992)%NYMD = 20090710 + TES(993)%NYMD = 20090710 + TES(994)%NYMD = 20090710 + TES(995)%NYMD = 20090710 + TES(996)%NYMD = 20090710 + TES(997)%NYMD = 20090710 + TES(998)%NYMD = 20090710 + TES(999)%NYMD = 20090710 + TES(1000)%NYMD = 20090710 + TES(1001)%NYMD = 20090710 + TES(1002)%NYMD = 20090710 + TES(1003)%NYMD = 20090710 + TES(1004)%NYMD = 20090710 + TES(1005)%NYMD = 20090710 + TES(1006)%NYMD = 20090710 + TES(1007)%NYMD = 20090710 + TES(1008)%NYMD = 20090710 + TES(1009)%NYMD = 20090710 + TES(1010)%NYMD = 20090710 + TES(1011)%NYMD = 20090710 + TES(1012)%NYMD = 20090710 + TES(1013)%NYMD = 20090710 + TES(1014)%NYMD = 20090710 + TES(1015)%NYMD = 20090710 + TES(1016)%NYMD = 20090710 + TES(1017)%NYMD = 20090710 + TES(1018)%NYMD = 20090710 + TES(1019)%NYMD = 20090710 + TES(1020)%NYMD = 20090710 + TES(1021)%NYMD = 20090710 + TES(1022)%NYMD = 20090710 + TES(1023)%NYMD = 20090710 + TES(1024)%NYMD = 20090710 + TES(1025)%NYMD = 20090710 + TES(1026)%NYMD = 20090710 + TES(1027)%NYMD = 20090710 + TES(1028)%NYMD = 20090710 + TES(1029)%NYMD = 20090710 + TES(1030)%NYMD = 20090710 + TES(1031)%NYMD = 20090710 + TES(1032)%NYMD = 20090710 + TES(1033)%NYMD = 20090710 + TES(1034)%NYMD = 20090710 + TES(1035)%NYMD = 20090710 + TES(1036)%NYMD = 20090710 + TES(1037)%NYMD = 20090710 + TES(1038)%NYMD = 20090710 + TES(1039)%NYMD = 20090710 + TES(1040)%NYMD = 20090710 + TES(1041)%NYMD = 20090710 + TES(1042)%NYMD = 20090710 + TES(1043)%NYMD = 20090710 + TES(1044)%NYMD = 20090710 + TES(1045)%NYMD = 20090710 + TES(1046)%NYMD = 20090710 + TES(1047)%NYMD = 20090710 + TES(1048)%NYMD = 20090710 + TES(1049)%NYMD = 20090710 + TES(1050)%NYMD = 20090710 + TES(1051)%NYMD = 20090710 + TES(1052)%NYMD = 20090710 + TES(1053)%NYMD = 20090710 + TES(1054)%NYMD = 20090710 + TES(1055)%NYMD = 20090710 + TES(1056)%NYMD = 20090710 + TES(1057)%NYMD = 20090710 + TES(1058)%NYMD = 20090710 + TES(1059)%NYMD = 20090710 + TES(1060)%NYMD = 20090710 + TES(1061)%NYMD = 20090710 + TES(1062)%NYMD = 20090710 + TES(1063)%NYMD = 20090710 + TES(1064)%NYMD = 20090710 + TES(1065)%NYMD = 20090710 + TES(1066)%NYMD = 20090710 + TES(1067)%NYMD = 20090710 + TES(1068)%NYMD = 20090710 + TES(1069)%NYMD = 20090710 + TES(1070)%NYMD = 20090710 + TES(1071)%NYMD = 20090710 + TES(1072)%NYMD = 20090710 + TES(1073)%NYMD = 20090710 + TES(1074)%NYMD = 20090710 + TES(1075)%NYMD = 20090710 + TES(1076)%NYMD = 20090710 + TES(1077)%NYMD = 20090710 + TES(1078)%NYMD = 20090710 + TES(1079)%NYMD = 20090710 + TES(1080)%NYMD = 20090710 + TES(1081)%NYMD = 20090710 + TES(1082)%NYMD = 20090710 + TES(1083)%NYMD = 20090710 + TES(1084)%NYMD = 20090710 + TES(1085)%NYMD = 20090710 + TES(1086)%NYMD = 20090710 + TES(1087)%NYMD = 20090710 + TES(1088)%NYMD = 20090710 + TES(1089)%NYMD = 20090710 + TES(1090)%NYMD = 20090710 + TES(1091)%NYMD = 20090711 + TES(1092)%NYMD = 20090711 + TES(1093)%NYMD = 20090711 + TES(1094)%NYMD = 20090711 + TES(1095)%NYMD = 20090711 + TES(1096)%NYMD = 20090711 + TES(1097)%NYMD = 20090711 + TES(1098)%NYMD = 20090711 + TES(1099)%NYMD = 20090711 + TES(1100)%NYMD = 20090711 + TES(1101)%NYMD = 20090711 + TES(1102)%NYMD = 20090711 + TES(1103)%NYMD = 20090711 + TES(1104)%NYMD = 20090711 + TES(1105)%NYMD = 20090711 + TES(1106)%NYMD = 20090711 + TES(1107)%NYMD = 20090711 + TES(1108)%NYMD = 20090711 + TES(1109)%NYMD = 20090711 + TES(1110)%NYMD = 20090711 + TES(1111)%NYMD = 20090711 + TES(1112)%NYMD = 20090711 + TES(1113)%NYMD = 20090711 + TES(1114)%NYMD = 20090711 + TES(1115)%NYMD = 20090711 + TES(1116)%NYMD = 20090711 + TES(1117)%NYMD = 20090711 + TES(1118)%NYMD = 20090711 + TES(1119)%NYMD = 20090711 + TES(1120)%NYMD = 20090711 + TES(1121)%NYMD = 20090711 + TES(1122)%NYMD = 20090711 + TES(1123)%NYMD = 20090711 + TES(1124)%NYMD = 20090711 + TES(1125)%NYMD = 20090711 + TES(1126)%NYMD = 20090711 + TES(1127)%NYMD = 20090711 + TES(1128)%NYMD = 20090711 + TES(1129)%NYMD = 20090711 + TES(1130)%NYMD = 20090711 + TES(1131)%NYMD = 20090711 + TES(1132)%NYMD = 20090711 + TES(1133)%NYMD = 20090711 + TES(1134)%NYMD = 20090711 + TES(1135)%NYMD = 20090711 + TES(1136)%NYMD = 20090711 + TES(1137)%NYMD = 20090711 + TES(1138)%NYMD = 20090711 + TES(1139)%NYMD = 20090711 + TES(1140)%NYMD = 20090711 + TES(1141)%NYMD = 20090711 + TES(1142)%NYMD = 20090711 + TES(1143)%NYMD = 20090711 + TES(1144)%NYMD = 20090711 + TES(1145)%NYMD = 20090711 + TES(1146)%NYMD = 20090711 + TES(1147)%NYMD = 20090711 + TES(1148)%NYMD = 20090711 + TES(1149)%NYMD = 20090711 + TES(1150)%NYMD = 20090711 + TES(1151)%NYMD = 20090711 + TES(1152)%NYMD = 20090711 + TES(1153)%NYMD = 20090711 + TES(1154)%NYMD = 20090711 + TES(1155)%NYMD = 20090711 + TES(1156)%NYMD = 20090711 + TES(1157)%NYMD = 20090711 + TES(1158)%NYMD = 20090711 + TES(1159)%NYMD = 20090711 + TES(1160)%NYMD = 20090711 + TES(1161)%NYMD = 20090711 + TES(1162)%NYMD = 20090711 + TES(1163)%NYMD = 20090711 + TES(1164)%NYMD = 20090711 + TES(1165)%NYMD = 20090711 + TES(1166)%NYMD = 20090711 + TES(1167)%NYMD = 20090711 + TES(1168)%NYMD = 20090711 + TES(1169)%NYMD = 20090711 + TES(1170)%NYMD = 20090711 + TES(1171)%NYMD = 20090711 + TES(1172)%NYMD = 20090711 + TES(1173)%NYMD = 20090711 + TES(1174)%NYMD = 20090711 + TES(1175)%NYMD = 20090711 + TES(1176)%NYMD = 20090711 + TES(1177)%NYMD = 20090711 + TES(1178)%NYMD = 20090711 + TES(1179)%NYMD = 20090711 + TES(1180)%NYMD = 20090711 + TES(1181)%NYMD = 20090711 + TES(1182)%NYMD = 20090711 + TES(1183)%NYMD = 20090711 + TES(1184)%NYMD = 20090711 + TES(1185)%NYMD = 20090711 + TES(1186)%NYMD = 20090711 + TES(1187)%NYMD = 20090711 + TES(1188)%NYMD = 20090711 + TES(1189)%NYMD = 20090711 + TES(1190)%NYMD = 20090711 + TES(1191)%NYMD = 20090711 + TES(1192)%NYMD = 20090711 + TES(1193)%NYMD = 20090711 + TES(1194)%NYMD = 20090711 + TES(1195)%NYMD = 20090711 + TES(1196)%NYMD = 20090711 + TES(1197)%NYMD = 20090711 + TES(1198)%NYMD = 20090711 + TES(1199)%NYMD = 20090711 + TES(1200)%NYMD = 20090711 + TES(1201)%NYMD = 20090711 + TES(1202)%NYMD = 20090711 + TES(1203)%NYMD = 20090711 + TES(1204)%NYMD = 20090711 + TES(1205)%NYMD = 20090711 + TES(1206)%NYMD = 20090711 + TES(1207)%NYMD = 20090711 + TES(1208)%NYMD = 20090711 + TES(1209)%NYMD = 20090711 + TES(1210)%NYMD = 20090711 + TES(1211)%NYMD = 20090711 + TES(1212)%NYMD = 20090711 + TES(1213)%NYMD = 20090711 + TES(1214)%NYMD = 20090711 + TES(1215)%NYMD = 20090711 + TES(1216)%NYMD = 20090711 + TES(1217)%NYMD = 20090711 + TES(1218)%NYMD = 20090711 + TES(1219)%NYMD = 20090711 + TES(1220)%NYMD = 20090711 + TES(1221)%NYMD = 20090711 + TES(1222)%NYMD = 20090711 + TES(1223)%NYMD = 20090711 + TES(1224)%NYMD = 20090711 + TES(1225)%NYMD = 20090711 + TES(1226)%NYMD = 20090711 + TES(1227)%NYMD = 20090711 + TES(1228)%NYMD = 20090711 + TES(1229)%NYMD = 20090711 + TES(1230)%NYMD = 20090711 + TES(1231)%NYMD = 20090711 + TES(1232)%NYMD = 20090711 + TES(1233)%NYMD = 20090711 + TES(1234)%NYMD = 20090711 + TES(1235)%NYMD = 20090711 + TES(1236)%NYMD = 20090711 + TES(1237)%NYMD = 20090711 + TES(1238)%NYMD = 20090711 + TES(1239)%NYMD = 20090711 + TES(1240)%NYMD = 20090711 + TES(1241)%NYMD = 20090711 + TES(1242)%NYMD = 20090711 + TES(1243)%NYMD = 20090711 + TES(1244)%NYMD = 20090711 + TES(1245)%NYMD = 20090711 + TES(1246)%NYMD = 20090711 + TES(1247)%NYMD = 20090712 + TES(1248)%NYMD = 20090712 + TES(1249)%NYMD = 20090712 + TES(1250)%NYMD = 20090712 + TES(1251)%NYMD = 20090712 + TES(1252)%NYMD = 20090712 + TES(1253)%NYMD = 20090712 + TES(1254)%NYMD = 20090712 + TES(1255)%NYMD = 20090712 + TES(1256)%NYMD = 20090712 + TES(1257)%NYMD = 20090712 + TES(1258)%NYMD = 20090712 + TES(1259)%NYMD = 20090712 + TES(1260)%NYMD = 20090712 + TES(1261)%NYMD = 20090712 + TES(1262)%NYMD = 20090712 + TES(1263)%NYMD = 20090712 + TES(1264)%NYMD = 20090712 + TES(1265)%NYMD = 20090712 + TES(1266)%NYMD = 20090712 + TES(1267)%NYMD = 20090712 + TES(1268)%NYMD = 20090712 + TES(1269)%NYMD = 20090712 + TES(1270)%NYMD = 20090712 + TES(1271)%NYMD = 20090712 + TES(1272)%NYMD = 20090712 + TES(1273)%NYMD = 20090712 + TES(1274)%NYMD = 20090712 + TES(1275)%NYMD = 20090712 + TES(1276)%NYMD = 20090712 + TES(1277)%NYMD = 20090712 + TES(1278)%NYMD = 20090712 + TES(1279)%NYMD = 20090712 + TES(1280)%NYMD = 20090712 + TES(1281)%NYMD = 20090712 + TES(1282)%NYMD = 20090712 + TES(1283)%NYMD = 20090712 + TES(1284)%NYMD = 20090712 + TES(1285)%NYMD = 20090712 + TES(1286)%NYMD = 20090712 + TES(1287)%NYMD = 20090712 + TES(1288)%NYMD = 20090712 + TES(1289)%NYMD = 20090712 + TES(1290)%NYMD = 20090712 + TES(1291)%NYMD = 20090712 + TES(1292)%NYMD = 20090712 + TES(1293)%NYMD = 20090712 + TES(1294)%NYMD = 20090712 + TES(1295)%NYMD = 20090712 + TES(1296)%NYMD = 20090712 + TES(1297)%NYMD = 20090712 + TES(1298)%NYMD = 20090712 + TES(1299)%NYMD = 20090712 + TES(1300)%NYMD = 20090712 + TES(1301)%NYMD = 20090712 + TES(1302)%NYMD = 20090712 + TES(1303)%NYMD = 20090712 + TES(1304)%NYMD = 20090712 + TES(1305)%NYMD = 20090712 + TES(1306)%NYMD = 20090712 + TES(1307)%NYMD = 20090712 + TES(1308)%NYMD = 20090712 + TES(1309)%NYMD = 20090712 + TES(1310)%NYMD = 20090712 + TES(1311)%NYMD = 20090712 + TES(1312)%NYMD = 20090712 + TES(1313)%NYMD = 20090712 + TES(1314)%NYMD = 20090712 + TES(1315)%NYMD = 20090712 + TES(1316)%NYMD = 20090712 + TES(1317)%NYMD = 20090712 + TES(1318)%NYMD = 20090712 + TES(1319)%NYMD = 20090712 + TES(1320)%NYMD = 20090712 + TES(1321)%NYMD = 20090712 + TES(1322)%NYMD = 20090712 + TES(1323)%NYMD = 20090712 + TES(1324)%NYMD = 20090712 + TES(1325)%NYMD = 20090712 + TES(1326)%NYMD = 20090712 + TES(1327)%NYMD = 20090712 + TES(1328)%NYMD = 20090712 + TES(1329)%NYMD = 20090712 + TES(1330)%NYMD = 20090712 + TES(1331)%NYMD = 20090712 + TES(1332)%NYMD = 20090712 + TES(1333)%NYMD = 20090712 + TES(1334)%NYMD = 20090712 + TES(1335)%NYMD = 20090712 + TES(1336)%NYMD = 20090712 + TES(1337)%NYMD = 20090712 + TES(1338)%NYMD = 20090712 + TES(1339)%NYMD = 20090712 + TES(1340)%NYMD = 20090712 + TES(1341)%NYMD = 20090712 + TES(1342)%NYMD = 20090712 + TES(1343)%NYMD = 20090712 + TES(1344)%NYMD = 20090712 + TES(1345)%NYMD = 20090712 + TES(1346)%NYMD = 20090712 + TES(1347)%NYMD = 20090712 + TES(1348)%NYMD = 20090712 + TES(1349)%NYMD = 20090712 + TES(1350)%NYMD = 20090712 + TES(1351)%NYMD = 20090712 + TES(1352)%NYMD = 20090712 + TES(1353)%NYMD = 20090712 + TES(1354)%NYMD = 20090712 + TES(1355)%NYMD = 20090712 + TES(1356)%NYMD = 20090712 + TES(1357)%NYMD = 20090712 + TES(1358)%NYMD = 20090712 + TES(1359)%NYMD = 20090712 + TES(1360)%NYMD = 20090712 + TES(1361)%NYMD = 20090712 + TES(1362)%NYMD = 20090712 + TES(1363)%NYMD = 20090712 + TES(1364)%NYMD = 20090712 + TES(1365)%NYMD = 20090712 + TES(1366)%NYMD = 20090712 + TES(1367)%NYMD = 20090712 + TES(1368)%NYMD = 20090712 + TES(1369)%NYMD = 20090712 + TES(1370)%NYMD = 20090712 + TES(1371)%NYMD = 20090712 + TES(1372)%NYMD = 20090712 + TES(1373)%NYMD = 20090713 + TES(1374)%NYMD = 20090713 + TES(1375)%NYMD = 20090713 + TES(1376)%NYMD = 20090713 + TES(1377)%NYMD = 20090713 + TES(1378)%NYMD = 20090713 + TES(1379)%NYMD = 20090713 + TES(1380)%NYMD = 20090713 + TES(1381)%NYMD = 20090713 + TES(1382)%NYMD = 20090713 + TES(1383)%NYMD = 20090713 + TES(1384)%NYMD = 20090713 + TES(1385)%NYMD = 20090713 + TES(1386)%NYMD = 20090713 + TES(1387)%NYMD = 20090713 + TES(1388)%NYMD = 20090713 + TES(1389)%NYMD = 20090713 + TES(1390)%NYMD = 20090713 + TES(1391)%NYMD = 20090713 + TES(1392)%NYMD = 20090713 + TES(1393)%NYMD = 20090713 + TES(1394)%NYMD = 20090713 + TES(1395)%NYMD = 20090713 + TES(1396)%NYMD = 20090713 + TES(1397)%NYMD = 20090713 + TES(1398)%NYMD = 20090713 + TES(1399)%NYMD = 20090713 + TES(1400)%NYMD = 20090713 + TES(1401)%NYMD = 20090713 + TES(1402)%NYMD = 20090713 + TES(1403)%NYMD = 20090713 + TES(1404)%NYMD = 20090713 + TES(1405)%NYMD = 20090713 + TES(1406)%NYMD = 20090713 + TES(1407)%NYMD = 20090713 + TES(1408)%NYMD = 20090713 + TES(1409)%NYMD = 20090713 + TES(1410)%NYMD = 20090713 + TES(1411)%NYMD = 20090713 + TES(1412)%NYMD = 20090713 + TES(1413)%NYMD = 20090713 + TES(1414)%NYMD = 20090713 + TES(1415)%NYMD = 20090713 + TES(1416)%NYMD = 20090713 + TES(1417)%NYMD = 20090713 + TES(1418)%NYMD = 20090713 + TES(1419)%NYMD = 20090713 + TES(1420)%NYMD = 20090713 + TES(1421)%NYMD = 20090713 + TES(1422)%NYMD = 20090713 + TES(1423)%NYMD = 20090713 + TES(1424)%NYMD = 20090713 + TES(1425)%NYMD = 20090713 + TES(1426)%NYMD = 20090713 + TES(1427)%NYMD = 20090713 + TES(1428)%NYMD = 20090713 + TES(1429)%NYMD = 20090713 + TES(1430)%NYMD = 20090713 + TES(1431)%NYMD = 20090713 + TES(1432)%NYMD = 20090713 + TES(1433)%NYMD = 20090713 + TES(1434)%NYMD = 20090713 + TES(1435)%NYMD = 20090713 + TES(1436)%NYMD = 20090713 + TES(1437)%NYMD = 20090713 + TES(1438)%NYMD = 20090713 + TES(1439)%NYMD = 20090713 + TES(1440)%NYMD = 20090713 + TES(1441)%NYMD = 20090713 + TES(1442)%NYMD = 20090713 + TES(1443)%NYMD = 20090713 + TES(1444)%NYMD = 20090713 + TES(1445)%NYMD = 20090713 + TES(1446)%NYMD = 20090713 + TES(1447)%NYMD = 20090713 + TES(1448)%NYMD = 20090713 + TES(1449)%NYMD = 20090713 + TES(1450)%NYMD = 20090713 + TES(1451)%NYMD = 20090713 + TES(1452)%NYMD = 20090713 + TES(1453)%NYMD = 20090713 + TES(1454)%NYMD = 20090713 + TES(1455)%NYMD = 20090713 + TES(1456)%NYMD = 20090713 + TES(1457)%NYMD = 20090713 + TES(1458)%NYMD = 20090713 + TES(1459)%NYMD = 20090713 + TES(1460)%NYMD = 20090713 + TES(1461)%NYMD = 20090713 + TES(1462)%NYMD = 20090713 + TES(1463)%NYMD = 20090713 + TES(1464)%NYMD = 20090713 + TES(1465)%NYMD = 20090713 + TES(1466)%NYMD = 20090713 + TES(1467)%NYMD = 20090713 + TES(1468)%NYMD = 20090713 + TES(1469)%NYMD = 20090713 + TES(1470)%NYMD = 20090713 + TES(1471)%NYMD = 20090713 + TES(1472)%NYMD = 20090713 + TES(1473)%NYMD = 20090713 + TES(1474)%NYMD = 20090713 + TES(1475)%NYMD = 20090713 + TES(1476)%NYMD = 20090713 + TES(1477)%NYMD = 20090713 + TES(1478)%NYMD = 20090713 + TES(1479)%NYMD = 20090713 + TES(1480)%NYMD = 20090713 + TES(1481)%NYMD = 20090713 + TES(1482)%NYMD = 20090713 + TES(1483)%NYMD = 20090713 + TES(1484)%NYMD = 20090713 + TES(1485)%NYMD = 20090713 + TES(1486)%NYMD = 20090713 + TES(1487)%NYMD = 20090713 + TES(1488)%NYMD = 20090713 + TES(1489)%NYMD = 20090713 + TES(1490)%NYMD = 20090713 + TES(1491)%NYMD = 20090713 + TES(1492)%NYMD = 20090713 + TES(1493)%NYMD = 20090713 + TES(1494)%NYMD = 20090713 + TES(1495)%NYMD = 20090713 + TES(1496)%NYMD = 20090713 + TES(1497)%NYMD = 20090713 + TES(1498)%NYMD = 20090713 + TES(1499)%NYMD = 20090713 + TES(1500)%NYMD = 20090713 + TES(1501)%NYMD = 20090713 + TES(1502)%NYMD = 20090713 + TES(1503)%NYMD = 20090713 + TES(1504)%NYMD = 20090714 + TES(1505)%NYMD = 20090714 + TES(1506)%NYMD = 20090714 + TES(1507)%NYMD = 20090714 + TES(1508)%NYMD = 20090714 + TES(1509)%NYMD = 20090714 + TES(1510)%NYMD = 20090714 + TES(1511)%NYMD = 20090714 + TES(1512)%NYMD = 20090714 + TES(1513)%NYMD = 20090714 + TES(1514)%NYMD = 20090714 + TES(1515)%NYMD = 20090714 + TES(1516)%NYMD = 20090714 + TES(1517)%NYMD = 20090714 + TES(1518)%NYMD = 20090714 + TES(1519)%NYMD = 20090714 + TES(1520)%NYMD = 20090714 + TES(1521)%NYMD = 20090714 + TES(1522)%NYMD = 20090714 + TES(1523)%NYMD = 20090714 + TES(1524)%NYMD = 20090714 + TES(1525)%NYMD = 20090714 + TES(1526)%NYMD = 20090714 + TES(1527)%NYMD = 20090714 + TES(1528)%NYMD = 20090714 + TES(1529)%NYMD = 20090714 + TES(1530)%NYMD = 20090714 + TES(1531)%NYMD = 20090714 + TES(1532)%NYMD = 20090714 + TES(1533)%NYMD = 20090714 + TES(1534)%NYMD = 20090714 + TES(1535)%NYMD = 20090714 + TES(1536)%NYMD = 20090714 + TES(1537)%NYMD = 20090714 + TES(1538)%NYMD = 20090714 + TES(1539)%NYMD = 20090714 + TES(1540)%NYMD = 20090714 + TES(1541)%NYMD = 20090714 + TES(1542)%NYMD = 20090714 + TES(1543)%NYMD = 20090714 + TES(1544)%NYMD = 20090714 + TES(1545)%NYMD = 20090714 + TES(1546)%NYMD = 20090714 + TES(1547)%NYMD = 20090714 + TES(1548)%NYMD = 20090714 + TES(1549)%NYMD = 20090714 + TES(1550)%NYMD = 20090714 + TES(1551)%NYMD = 20090714 + TES(1552)%NYMD = 20090714 + TES(1553)%NYMD = 20090714 + TES(1554)%NYMD = 20090714 + TES(1555)%NYMD = 20090714 + TES(1556)%NYMD = 20090714 + TES(1557)%NYMD = 20090714 + TES(1558)%NYMD = 20090714 + TES(1559)%NYMD = 20090714 + TES(1560)%NYMD = 20090714 + TES(1561)%NYMD = 20090714 + TES(1562)%NYMD = 20090714 + TES(1563)%NYMD = 20090714 + TES(1564)%NYMD = 20090714 + TES(1565)%NYMD = 20090714 + TES(1566)%NYMD = 20090714 + TES(1567)%NYMD = 20090714 + TES(1568)%NYMD = 20090714 + TES(1569)%NYMD = 20090714 + TES(1570)%NYMD = 20090714 + TES(1571)%NYMD = 20090714 + TES(1572)%NYMD = 20090714 + TES(1573)%NYMD = 20090714 + TES(1574)%NYMD = 20090714 + TES(1575)%NYMD = 20090714 + TES(1576)%NYMD = 20090714 + TES(1577)%NYMD = 20090714 + TES(1578)%NYMD = 20090714 + TES(1579)%NYMD = 20090714 + TES(1580)%NYMD = 20090714 + TES(1581)%NYMD = 20090714 + TES(1582)%NYMD = 20090714 + TES(1583)%NYMD = 20090714 + TES(1584)%NYMD = 20090714 + TES(1585)%NYMD = 20090714 + TES(1586)%NYMD = 20090714 + TES(1587)%NYMD = 20090714 + TES(1588)%NYMD = 20090714 + TES(1589)%NYMD = 20090714 + TES(1590)%NYMD = 20090714 + TES(1591)%NYMD = 20090714 + TES(1592)%NYMD = 20090714 + TES(1593)%NYMD = 20090714 + TES(1594)%NYMD = 20090714 + TES(1595)%NYMD = 20090714 + TES(1596)%NYMD = 20090714 + TES(1597)%NYMD = 20090714 + TES(1598)%NYMD = 20090714 + TES(1599)%NYMD = 20090714 + TES(1600)%NYMD = 20090714 + TES(1601)%NYMD = 20090714 + TES(1602)%NYMD = 20090714 + TES(1603)%NYMD = 20090714 + TES(1604)%NYMD = 20090714 + TES(1605)%NYMD = 20090714 + TES(1606)%NYMD = 20090714 + TES(1607)%NYMD = 20090714 + TES(1608)%NYMD = 20090714 + TES(1609)%NYMD = 20090714 + TES(1610)%NYMD = 20090714 + TES(1611)%NYMD = 20090714 + TES(1612)%NYMD = 20090714 + TES(1613)%NYMD = 20090714 + TES(1614)%NYMD = 20090714 + TES(1615)%NYMD = 20090714 + TES(1616)%NYMD = 20090714 + TES(1617)%NYMD = 20090714 + TES(1618)%NYMD = 20090714 + TES(1619)%NYMD = 20090714 + TES(1620)%NYMD = 20090714 + TES(1621)%NYMD = 20090714 + TES(1622)%NYMD = 20090714 + TES(1623)%NYMD = 20090714 + TES(1624)%NYMD = 20090714 + TES(1625)%NYMD = 20090714 + TES(1626)%NYMD = 20090714 + TES(1627)%NYMD = 20090714 + TES(1628)%NYMD = 20090714 + TES(1629)%NYMD = 20090714 + TES(1630)%NYMD = 20090714 + TES(1631)%NYMD = 20090714 + TES(1632)%NYMD = 20090714 + TES(1633)%NYMD = 20090714 + TES(1634)%NYMD = 20090714 + TES(1635)%NYMD = 20090714 + TES(1636)%NYMD = 20090714 + TES(1637)%NYMD = 20090714 + TES(1638)%NYMD = 20090714 + TES(1639)%NYMD = 20090714 + TES(1640)%NYMD = 20090714 + TES(1641)%NYMD = 20090714 + TES(1642)%NYMD = 20090714 + TES(1643)%NYMD = 20090715 + TES(1644)%NYMD = 20090715 + TES(1645)%NYMD = 20090715 + TES(1646)%NYMD = 20090715 + TES(1647)%NYMD = 20090715 + TES(1648)%NYMD = 20090715 + TES(1649)%NYMD = 20090715 + TES(1650)%NYMD = 20090715 + TES(1651)%NYMD = 20090715 + TES(1652)%NYMD = 20090715 + TES(1653)%NYMD = 20090715 + TES(1654)%NYMD = 20090715 + TES(1655)%NYMD = 20090715 + TES(1656)%NYMD = 20090715 + TES(1657)%NYMD = 20090715 + TES(1658)%NYMD = 20090715 + TES(1659)%NYMD = 20090715 + TES(1660)%NYMD = 20090715 + TES(1661)%NYMD = 20090715 + TES(1662)%NYMD = 20090715 + TES(1663)%NYMD = 20090715 + TES(1664)%NYMD = 20090715 + TES(1665)%NYMD = 20090715 + TES(1666)%NYMD = 20090715 + TES(1667)%NYMD = 20090715 + TES(1668)%NYMD = 20090715 + TES(1669)%NYMD = 20090715 + TES(1670)%NYMD = 20090715 + TES(1671)%NYMD = 20090715 + TES(1672)%NYMD = 20090715 + TES(1673)%NYMD = 20090715 + TES(1674)%NYMD = 20090715 + TES(1675)%NYMD = 20090715 + TES(1676)%NYMD = 20090715 + TES(1677)%NYMD = 20090715 + TES(1678)%NYMD = 20090715 + TES(1679)%NYMD = 20090715 + TES(1680)%NYMD = 20090715 + TES(1681)%NYMD = 20090715 + TES(1682)%NYMD = 20090715 + TES(1683)%NYMD = 20090715 + TES(1684)%NYMD = 20090715 + TES(1685)%NYMD = 20090715 + TES(1686)%NYMD = 20090715 + TES(1687)%NYMD = 20090715 + TES(1688)%NYMD = 20090715 + TES(1689)%NYMD = 20090715 + TES(1690)%NYMD = 20090715 + TES(1691)%NYMD = 20090715 + TES(1692)%NYMD = 20090715 + TES(1693)%NYMD = 20090715 + TES(1694)%NYMD = 20090715 + TES(1695)%NYMD = 20090715 + TES(1696)%NYMD = 20090715 + TES(1697)%NYMD = 20090715 + TES(1698)%NYMD = 20090715 + TES(1699)%NYMD = 20090715 + TES(1700)%NYMD = 20090715 + TES(1701)%NYMD = 20090715 + TES(1702)%NYMD = 20090715 + TES(1703)%NYMD = 20090715 + TES(1704)%NYMD = 20090715 + TES(1705)%NYMD = 20090715 + TES(1706)%NYMD = 20090715 + TES(1707)%NYMD = 20090715 + TES(1708)%NYMD = 20090715 + TES(1709)%NYMD = 20090715 + TES(1710)%NYMD = 20090715 + TES(1711)%NYMD = 20090715 + TES(1712)%NYMD = 20090715 + TES(1713)%NYMD = 20090715 + TES(1714)%NYMD = 20090715 + TES(1715)%NYMD = 20090715 + TES(1716)%NYMD = 20090715 + TES(1717)%NYMD = 20090715 + TES(1718)%NYMD = 20090715 + TES(1719)%NYMD = 20090715 + TES(1720)%NYMD = 20090715 + TES(1721)%NYMD = 20090715 + TES(1722)%NYMD = 20090715 + TES(1723)%NYMD = 20090715 + TES(1724)%NYMD = 20090715 + TES(1725)%NYMD = 20090715 + TES(1726)%NYMD = 20090715 + TES(1727)%NYMD = 20090715 + TES(1728)%NYMD = 20090715 + TES(1729)%NYMD = 20090715 + TES(1730)%NYMD = 20090715 + TES(1731)%NYMD = 20090715 + TES(1732)%NYMD = 20090715 + TES(1733)%NYMD = 20090715 + TES(1734)%NYMD = 20090715 + TES(1735)%NYMD = 20090715 + TES(1736)%NYMD = 20090715 + TES(1737)%NYMD = 20090715 + TES(1738)%NYMD = 20090715 + TES(1739)%NYMD = 20090715 + TES(1740)%NYMD = 20090715 + TES(1741)%NYMD = 20090715 + TES(1742)%NYMD = 20090715 + TES(1743)%NYMD = 20090715 + TES(1744)%NYMD = 20090715 + TES(1745)%NYMD = 20090715 + TES(1746)%NYMD = 20090715 + TES(1747)%NYMD = 20090715 + TES(1748)%NYMD = 20090715 + TES(1749)%NYMD = 20090715 + TES(1750)%NYMD = 20090715 + TES(1751)%NYMD = 20090715 + TES(1752)%NYMD = 20090715 + TES(1753)%NYMD = 20090715 + TES(1754)%NYMD = 20090715 + TES(1755)%NYMD = 20090715 + TES(1756)%NYMD = 20090715 + TES(1757)%NYMD = 20090715 + TES(1758)%NYMD = 20090715 + TES(1759)%NYMD = 20090715 + TES(1760)%NYMD = 20090715 + TES(1761)%NYMD = 20090715 + TES(1762)%NYMD = 20090715 + TES(1763)%NYMD = 20090715 + TES(1764)%NYMD = 20090715 + TES(1765)%NYMD = 20090715 + TES(1766)%NYMD = 20090715 + TES(1767)%NYMD = 20090715 + TES(1768)%NYMD = 20090715 + TES(1769)%NYMD = 20090715 + TES(1770)%NYMD = 20090715 + TES(1771)%NYMD = 20090715 + TES(1772)%NYMD = 20090715 + TES(1773)%NYMD = 20090715 + TES(1774)%NYMD = 20090715 + TES(1775)%NYMD = 20090715 + TES(1776)%NYMD = 20090715 + TES(1777)%NYMD = 20090715 + TES(1778)%NYMD = 20090715 + TES(1779)%NYMD = 20090715 + TES(1780)%NYMD = 20090715 + TES(1781)%NYMD = 20090715 + TES(1782)%NYMD = 20090715 + TES(1783)%NYMD = 20090715 + TES(1784)%NYMD = 20090715 + TES(1785)%NYMD = 20090716 + TES(1786)%NYMD = 20090716 + TES(1787)%NYMD = 20090716 + TES(1788)%NYMD = 20090716 + TES(1789)%NYMD = 20090716 + TES(1790)%NYMD = 20090716 + TES(1791)%NYMD = 20090716 + TES(1792)%NYMD = 20090716 + TES(1793)%NYMD = 20090716 + TES(1794)%NYMD = 20090716 + TES(1795)%NYMD = 20090716 + TES(1796)%NYMD = 20090716 + TES(1797)%NYMD = 20090716 + TES(1798)%NYMD = 20090716 + TES(1799)%NYMD = 20090716 + TES(1800)%NYMD = 20090716 + TES(1801)%NYMD = 20090716 + TES(1802)%NYMD = 20090716 + TES(1803)%NYMD = 20090716 + TES(1804)%NYMD = 20090716 + TES(1805)%NYMD = 20090716 + TES(1806)%NYMD = 20090716 + TES(1807)%NYMD = 20090716 + TES(1808)%NYMD = 20090716 + TES(1809)%NYMD = 20090716 + TES(1810)%NYMD = 20090716 + TES(1811)%NYMD = 20090716 + TES(1812)%NYMD = 20090716 + TES(1813)%NYMD = 20090716 + TES(1814)%NYMD = 20090716 + TES(1815)%NYMD = 20090716 + TES(1816)%NYMD = 20090716 + TES(1817)%NYMD = 20090716 + TES(1818)%NYMD = 20090716 + TES(1819)%NYMD = 20090716 + TES(1820)%NYMD = 20090716 + TES(1821)%NYMD = 20090716 + TES(1822)%NYMD = 20090716 + TES(1823)%NYMD = 20090716 + TES(1824)%NYMD = 20090716 + TES(1825)%NYMD = 20090716 + TES(1826)%NYMD = 20090716 + TES(1827)%NYMD = 20090716 + TES(1828)%NYMD = 20090716 + TES(1829)%NYMD = 20090716 + TES(1830)%NYMD = 20090716 + TES(1831)%NYMD = 20090716 + TES(1832)%NYMD = 20090716 + TES(1833)%NYMD = 20090716 + TES(1834)%NYMD = 20090716 + TES(1835)%NYMD = 20090716 + TES(1836)%NYMD = 20090716 + TES(1837)%NYMD = 20090716 + TES(1838)%NYMD = 20090716 + TES(1839)%NYMD = 20090716 + TES(1840)%NYMD = 20090716 + TES(1841)%NYMD = 20090716 + TES(1842)%NYMD = 20090716 + TES(1843)%NYMD = 20090716 + TES(1844)%NYMD = 20090716 + TES(1845)%NYMD = 20090716 + TES(1846)%NYMD = 20090716 + TES(1847)%NYMD = 20090716 + TES(1848)%NYMD = 20090716 + TES(1849)%NYMD = 20090716 + TES(1850)%NYMD = 20090716 + TES(1851)%NYMD = 20090716 + TES(1852)%NYMD = 20090716 + TES(1853)%NYMD = 20090716 + TES(1854)%NYMD = 20090716 + TES(1855)%NYMD = 20090716 + TES(1856)%NYMD = 20090716 + TES(1857)%NYMD = 20090716 + TES(1858)%NYMD = 20090716 + TES(1859)%NYMD = 20090716 + TES(1860)%NYMD = 20090716 + TES(1861)%NYMD = 20090716 + TES(1862)%NYMD = 20090716 + TES(1863)%NYMD = 20090716 + TES(1864)%NYMD = 20090716 + TES(1865)%NYMD = 20090716 + TES(1866)%NYMD = 20090716 + TES(1867)%NYMD = 20090716 + TES(1868)%NYMD = 20090716 + TES(1869)%NYMD = 20090716 + TES(1870)%NYMD = 20090716 + TES(1871)%NYMD = 20090716 + TES(1872)%NYMD = 20090716 + TES(1873)%NYMD = 20090716 + TES(1874)%NYMD = 20090716 + TES(1875)%NYMD = 20090716 + TES(1876)%NYMD = 20090716 + TES(1877)%NYMD = 20090716 + TES(1878)%NYMD = 20090716 + TES(1879)%NYMD = 20090716 + TES(1880)%NYMD = 20090716 + TES(1881)%NYMD = 20090716 + TES(1882)%NYMD = 20090716 + TES(1883)%NYMD = 20090716 + TES(1884)%NYMD = 20090716 + TES(1885)%NYMD = 20090716 + TES(1886)%NYMD = 20090716 + TES(1887)%NYMD = 20090716 + TES(1888)%NYMD = 20090716 + TES(1889)%NYMD = 20090716 + TES(1890)%NYMD = 20090716 + TES(1891)%NYMD = 20090716 + TES(1892)%NYMD = 20090716 + TES(1893)%NYMD = 20090716 + TES(1894)%NYMD = 20090716 + TES(1895)%NYMD = 20090716 + TES(1896)%NYMD = 20090716 + TES(1897)%NYMD = 20090716 + TES(1898)%NYMD = 20090716 + TES(1899)%NYMD = 20090716 + TES(1900)%NYMD = 20090716 + TES(1901)%NYMD = 20090716 + TES(1902)%NYMD = 20090716 + TES(1903)%NYMD = 20090716 + TES(1904)%NYMD = 20090716 + TES(1905)%NYMD = 20090716 + TES(1906)%NYMD = 20090716 + TES(1907)%NYMD = 20090716 + TES(1908)%NYMD = 20090716 + TES(1909)%NYMD = 20090716 + TES(1910)%NYMD = 20090716 + TES(1911)%NYMD = 20090716 + TES(1912)%NYMD = 20090716 + TES(1913)%NYMD = 20090716 + TES(1914)%NYMD = 20090716 + TES(1915)%NYMD = 20090716 + TES(1916)%NYMD = 20090716 + TES(1917)%NYMD = 20090716 + TES(1918)%NYMD = 20090716 + TES(1919)%NYMD = 20090716 + TES(1920)%NYMD = 20090716 + TES(1921)%NYMD = 20090716 + TES(1922)%NYMD = 20090716 + TES(1923)%NYMD = 20090716 + TES(1924)%NYMD = 20090716 + TES(1925)%NYMD = 20090716 + TES(1926)%NYMD = 20090717 + TES(1927)%NYMD = 20090717 + TES(1928)%NYMD = 20090717 + TES(1929)%NYMD = 20090717 + TES(1930)%NYMD = 20090717 + TES(1931)%NYMD = 20090717 + TES(1932)%NYMD = 20090717 + TES(1933)%NYMD = 20090717 + TES(1934)%NYMD = 20090717 + TES(1935)%NYMD = 20090717 + TES(1936)%NYMD = 20090717 + TES(1937)%NYMD = 20090717 + TES(1938)%NYMD = 20090717 + TES(1939)%NYMD = 20090717 + TES(1940)%NYMD = 20090717 + TES(1941)%NYMD = 20090717 + TES(1942)%NYMD = 20090717 + TES(1943)%NYMD = 20090717 + TES(1944)%NYMD = 20090717 + TES(1945)%NYMD = 20090717 + TES(1946)%NYMD = 20090717 + TES(1947)%NYMD = 20090717 + TES(1948)%NYMD = 20090717 + TES(1949)%NYMD = 20090717 + TES(1950)%NYMD = 20090717 + TES(1951)%NYMD = 20090717 + TES(1952)%NYMD = 20090717 + TES(1953)%NYMD = 20090717 + TES(1954)%NYMD = 20090717 + TES(1955)%NYMD = 20090717 + TES(1956)%NYMD = 20090717 + TES(1957)%NYMD = 20090717 + TES(1958)%NYMD = 20090717 + TES(1959)%NYMD = 20090717 + TES(1960)%NYMD = 20090717 + TES(1961)%NYMD = 20090717 + TES(1962)%NYMD = 20090717 + TES(1963)%NYMD = 20090717 + TES(1964)%NYMD = 20090717 + TES(1965)%NYMD = 20090717 + TES(1966)%NYMD = 20090717 + TES(1967)%NYMD = 20090717 + TES(1968)%NYMD = 20090717 + TES(1969)%NYMD = 20090717 + TES(1970)%NYMD = 20090717 + TES(1971)%NYMD = 20090717 + TES(1972)%NYMD = 20090717 + TES(1973)%NYMD = 20090717 + TES(1974)%NYMD = 20090717 + TES(1975)%NYMD = 20090717 + TES(1976)%NYMD = 20090717 + TES(1977)%NYMD = 20090717 + TES(1978)%NYMD = 20090717 + TES(1979)%NYMD = 20090717 + TES(1980)%NYMD = 20090717 + TES(1981)%NYMD = 20090717 + TES(1982)%NYMD = 20090717 + TES(1983)%NYMD = 20090717 + TES(1984)%NYMD = 20090717 + TES(1985)%NYMD = 20090717 + TES(1986)%NYMD = 20090717 + TES(1987)%NYMD = 20090717 + TES(1988)%NYMD = 20090717 + TES(1989)%NYMD = 20090717 + TES(1990)%NYMD = 20090717 + TES(1991)%NYMD = 20090717 + TES(1992)%NYMD = 20090717 + TES(1993)%NYMD = 20090717 + TES(1994)%NYMD = 20090717 + TES(1995)%NYMD = 20090717 + TES(1996)%NYMD = 20090717 + TES(1997)%NYMD = 20090717 + TES(1998)%NYMD = 20090717 + TES(1999)%NYMD = 20090717 + TES(2000)%NYMD = 20090717 + TES(2001)%NYMD = 20090717 + TES(2002)%NYMD = 20090717 + TES(2003)%NYMD = 20090717 + TES(2004)%NYMD = 20090717 + TES(2005)%NYMD = 20090717 + TES(2006)%NYMD = 20090717 + TES(2007)%NYMD = 20090717 + TES(2008)%NYMD = 20090717 + TES(2009)%NYMD = 20090717 + TES(2010)%NYMD = 20090717 + TES(2011)%NYMD = 20090717 + TES(2012)%NYMD = 20090717 + TES(2013)%NYMD = 20090717 + TES(2014)%NYMD = 20090717 + TES(2015)%NYMD = 20090717 + TES(2016)%NYMD = 20090717 + TES(2017)%NYMD = 20090717 + TES(2018)%NYMD = 20090717 + TES(2019)%NYMD = 20090717 + TES(2020)%NYMD = 20090717 + TES(2021)%NYMD = 20090717 + TES(2022)%NYMD = 20090717 + TES(2023)%NYMD = 20090717 + TES(2024)%NYMD = 20090717 + TES(2025)%NYMD = 20090717 + TES(2026)%NYMD = 20090717 + TES(2027)%NYMD = 20090717 + TES(2028)%NYMD = 20090717 + TES(2029)%NYMD = 20090717 + TES(2030)%NYMD = 20090717 + TES(2031)%NYMD = 20090717 + TES(2032)%NYMD = 20090717 + TES(2033)%NYMD = 20090717 + TES(2034)%NYMD = 20090717 + TES(2035)%NYMD = 20090717 + TES(2036)%NYMD = 20090717 + TES(2037)%NYMD = 20090717 + TES(2038)%NYMD = 20090717 + TES(2039)%NYMD = 20090717 + TES(2040)%NYMD = 20090717 + TES(2041)%NYMD = 20090717 + TES(2042)%NYMD = 20090717 + TES(2043)%NYMD = 20090717 + TES(2044)%NYMD = 20090717 + TES(2045)%NYMD = 20090717 + TES(2046)%NYMD = 20090717 + TES(2047)%NYMD = 20090717 + TES(2048)%NYMD = 20090717 + TES(2049)%NYMD = 20090717 + TES(2050)%NYMD = 20090717 + TES(2051)%NYMD = 20090717 + TES(2052)%NYMD = 20090717 + TES(2053)%NYMD = 20090717 + TES(2054)%NYMD = 20090717 + TES(2055)%NYMD = 20090717 + TES(2056)%NYMD = 20090717 + TES(2057)%NYMD = 20090717 + TES(2058)%NYMD = 20090717 + TES(2059)%NYMD = 20090717 + TES(2060)%NYMD = 20090717 + TES(2061)%NYMD = 20090717 + TES(2062)%NYMD = 20090717 + TES(2063)%NYMD = 20090717 + TES(2064)%NYMD = 20090717 + TES(2065)%NYMD = 20090717 + TES(2066)%NYMD = 20090717 + TES(2067)%NYMD = 20090717 + TES(2068)%NYMD = 20090717 + TES(2069)%NYMD = 20090717 + TES(2070)%NYMD = 20090717 + TES(2071)%NYMD = 20090717 + TES(2072)%NYMD = 20090717 + TES(2073)%NYMD = 20090718 + TES(2074)%NYMD = 20090718 + TES(2075)%NYMD = 20090718 + TES(2076)%NYMD = 20090718 + TES(2077)%NYMD = 20090718 + TES(2078)%NYMD = 20090718 + TES(2079)%NYMD = 20090718 + TES(2080)%NYMD = 20090718 + TES(2081)%NYMD = 20090718 + TES(2082)%NYMD = 20090718 + TES(2083)%NYMD = 20090718 + TES(2084)%NYMD = 20090718 + TES(2085)%NYMD = 20090718 + TES(2086)%NYMD = 20090718 + TES(2087)%NYMD = 20090718 + TES(2088)%NYMD = 20090718 + TES(2089)%NYMD = 20090718 + TES(2090)%NYMD = 20090718 + TES(2091)%NYMD = 20090718 + TES(2092)%NYMD = 20090718 + TES(2093)%NYMD = 20090718 + TES(2094)%NYMD = 20090718 + TES(2095)%NYMD = 20090718 + TES(2096)%NYMD = 20090718 + TES(2097)%NYMD = 20090718 + TES(2098)%NYMD = 20090718 + TES(2099)%NYMD = 20090718 + TES(2100)%NYMD = 20090718 + TES(2101)%NYMD = 20090718 + TES(2102)%NYMD = 20090718 + TES(2103)%NYMD = 20090718 + TES(2104)%NYMD = 20090718 + TES(2105)%NYMD = 20090718 + TES(2106)%NYMD = 20090718 + TES(2107)%NYMD = 20090718 + TES(2108)%NYMD = 20090718 + TES(2109)%NYMD = 20090718 + TES(2110)%NYMD = 20090718 + TES(2111)%NYMD = 20090718 + TES(2112)%NYMD = 20090718 + TES(2113)%NYMD = 20090718 + TES(2114)%NYMD = 20090718 + TES(2115)%NYMD = 20090718 + TES(2116)%NYMD = 20090718 + TES(2117)%NYMD = 20090718 + TES(2118)%NYMD = 20090718 + TES(2119)%NYMD = 20090718 + TES(2120)%NYMD = 20090718 + TES(2121)%NYMD = 20090718 + TES(2122)%NYMD = 20090718 + TES(2123)%NYMD = 20090718 + TES(2124)%NYMD = 20090718 + TES(2125)%NYMD = 20090718 + TES(2126)%NYMD = 20090718 + TES(2127)%NYMD = 20090718 + TES(2128)%NYMD = 20090718 + TES(2129)%NYMD = 20090718 + TES(2130)%NYMD = 20090718 + TES(2131)%NYMD = 20090718 + TES(2132)%NYMD = 20090718 + TES(2133)%NYMD = 20090718 + TES(2134)%NYMD = 20090718 + TES(2135)%NYMD = 20090718 + TES(2136)%NYMD = 20090718 + TES(2137)%NYMD = 20090718 + TES(2138)%NYMD = 20090718 + TES(2139)%NYMD = 20090718 + TES(2140)%NYMD = 20090718 + TES(2141)%NYMD = 20090718 + TES(2142)%NYMD = 20090718 + TES(2143)%NYMD = 20090718 + TES(2144)%NYMD = 20090718 + TES(2145)%NYMD = 20090718 + TES(2146)%NYMD = 20090718 + TES(2147)%NYMD = 20090718 + TES(2148)%NYMD = 20090718 + TES(2149)%NYMD = 20090718 + TES(2150)%NYMD = 20090718 + TES(2151)%NYMD = 20090718 + TES(2152)%NYMD = 20090718 + TES(2153)%NYMD = 20090718 + TES(2154)%NYMD = 20090718 + TES(2155)%NYMD = 20090718 + TES(2156)%NYMD = 20090718 + TES(2157)%NYMD = 20090718 + TES(2158)%NYMD = 20090718 + TES(2159)%NYMD = 20090718 + TES(2160)%NYMD = 20090718 + TES(2161)%NYMD = 20090718 + TES(2162)%NYMD = 20090718 + TES(2163)%NYMD = 20090718 + TES(2164)%NYMD = 20090718 + TES(2165)%NYMD = 20090718 + TES(2166)%NYMD = 20090718 + TES(2167)%NYMD = 20090718 + TES(2168)%NYMD = 20090718 + TES(2169)%NYMD = 20090718 + TES(2170)%NYMD = 20090718 + TES(2171)%NYMD = 20090718 + TES(2172)%NYMD = 20090718 + TES(2173)%NYMD = 20090718 + TES(2174)%NYMD = 20090718 + TES(2175)%NYMD = 20090718 + TES(2176)%NYMD = 20090718 + TES(2177)%NYMD = 20090718 + TES(2178)%NYMD = 20090718 + TES(2179)%NYMD = 20090718 + TES(2180)%NYMD = 20090718 + TES(2181)%NYMD = 20090718 + TES(2182)%NYMD = 20090718 + TES(2183)%NYMD = 20090718 + TES(2184)%NYMD = 20090718 + TES(2185)%NYMD = 20090718 + TES(2186)%NYMD = 20090718 + TES(2187)%NYMD = 20090718 + TES(2188)%NYMD = 20090718 + TES(2189)%NYMD = 20090719 + TES(2190)%NYMD = 20090719 + TES(2191)%NYMD = 20090719 + TES(2192)%NYMD = 20090719 + TES(2193)%NYMD = 20090719 + TES(2194)%NYMD = 20090719 + TES(2195)%NYMD = 20090719 + TES(2196)%NYMD = 20090719 + TES(2197)%NYMD = 20090719 + TES(2198)%NYMD = 20090719 + TES(2199)%NYMD = 20090719 + TES(2200)%NYMD = 20090719 + TES(2201)%NYMD = 20090719 + TES(2202)%NYMD = 20090719 + TES(2203)%NYMD = 20090719 + TES(2204)%NYMD = 20090719 + TES(2205)%NYMD = 20090719 + TES(2206)%NYMD = 20090719 + TES(2207)%NYMD = 20090719 + TES(2208)%NYMD = 20090719 + TES(2209)%NYMD = 20090719 + TES(2210)%NYMD = 20090719 + TES(2211)%NYMD = 20090719 + TES(2212)%NYMD = 20090719 + TES(2213)%NYMD = 20090719 + TES(2214)%NYMD = 20090719 + TES(2215)%NYMD = 20090719 + TES(2216)%NYMD = 20090719 + TES(2217)%NYMD = 20090719 + TES(2218)%NYMD = 20090719 + TES(2219)%NYMD = 20090719 + TES(2220)%NYMD = 20090719 + TES(2221)%NYMD = 20090719 + TES(2222)%NYMD = 20090719 + TES(2223)%NYMD = 20090719 + TES(2224)%NYMD = 20090719 + TES(2225)%NYMD = 20090719 + TES(2226)%NYMD = 20090719 + TES(2227)%NYMD = 20090719 + TES(2228)%NYMD = 20090719 + TES(2229)%NYMD = 20090719 + TES(2230)%NYMD = 20090719 + TES(2231)%NYMD = 20090719 + TES(2232)%NYMD = 20090719 + TES(2233)%NYMD = 20090719 + TES(2234)%NYMD = 20090719 + TES(2235)%NYMD = 20090719 + TES(2236)%NYMD = 20090719 + TES(2237)%NYMD = 20090719 + TES(2238)%NYMD = 20090719 + TES(2239)%NYMD = 20090719 + TES(2240)%NYMD = 20090719 + TES(2241)%NYMD = 20090719 + TES(2242)%NYMD = 20090719 + TES(2243)%NYMD = 20090719 + TES(2244)%NYMD = 20090719 + TES(2245)%NYMD = 20090719 + TES(2246)%NYMD = 20090719 + TES(2247)%NYMD = 20090719 + TES(2248)%NYMD = 20090719 + TES(2249)%NYMD = 20090719 + TES(2250)%NYMD = 20090719 + TES(2251)%NYMD = 20090719 + TES(2252)%NYMD = 20090719 + TES(2253)%NYMD = 20090719 + TES(2254)%NYMD = 20090719 + TES(2255)%NYMD = 20090719 + TES(2256)%NYMD = 20090719 + TES(2257)%NYMD = 20090719 + TES(2258)%NYMD = 20090719 + TES(2259)%NYMD = 20090719 + TES(2260)%NYMD = 20090719 + TES(2261)%NYMD = 20090719 + TES(2262)%NYMD = 20090719 + TES(2263)%NYMD = 20090719 + TES(2264)%NYMD = 20090719 + TES(2265)%NYMD = 20090719 + TES(2266)%NYMD = 20090719 + TES(2267)%NYMD = 20090719 + TES(2268)%NYMD = 20090719 + TES(2269)%NYMD = 20090719 + TES(2270)%NYMD = 20090719 + TES(2271)%NYMD = 20090719 + TES(2272)%NYMD = 20090719 + TES(2273)%NYMD = 20090719 + TES(2274)%NYMD = 20090719 + TES(2275)%NYMD = 20090719 + TES(2276)%NYMD = 20090719 + TES(2277)%NYMD = 20090719 + TES(2278)%NYMD = 20090719 + TES(2279)%NYMD = 20090719 + TES(2280)%NYMD = 20090719 + TES(2281)%NYMD = 20090719 + TES(2282)%NYMD = 20090719 + TES(2283)%NYMD = 20090719 + TES(2284)%NYMD = 20090719 + TES(2285)%NYMD = 20090719 + TES(2286)%NYMD = 20090719 + TES(2287)%NYMD = 20090719 + TES(2288)%NYMD = 20090719 + TES(2289)%NYMD = 20090719 + TES(2290)%NYMD = 20090719 + TES(2291)%NYMD = 20090719 + TES(2292)%NYMD = 20090719 + TES(2293)%NYMD = 20090719 + TES(2294)%NYMD = 20090719 + TES(2295)%NYMD = 20090719 + TES(2296)%NYMD = 20090719 + TES(2297)%NYMD = 20090719 + TES(2298)%NYMD = 20090719 + TES(2299)%NYMD = 20090719 + TES(2300)%NYMD = 20090719 + TES(2301)%NYMD = 20090719 + TES(2302)%NYMD = 20090719 + TES(2303)%NYMD = 20090719 + TES(2304)%NYMD = 20090719 + TES(2305)%NYMD = 20090719 + TES(2306)%NYMD = 20090719 + TES(2307)%NYMD = 20090719 + TES(2308)%NYMD = 20090719 + TES(2309)%NYMD = 20090719 + TES(2310)%NYMD = 20090719 + TES(2311)%NYMD = 20090719 + TES(2312)%NYMD = 20090719 + TES(2313)%NYMD = 20090719 + TES(2314)%NYMD = 20090719 + TES(2315)%NYMD = 20090719 + TES(2316)%NYMD = 20090719 + TES(2317)%NYMD = 20090719 + TES(2318)%NYMD = 20090719 + TES(2319)%NYMD = 20090719 + TES(2320)%NYMD = 20090719 + TES(2321)%NYMD = 20090719 + TES(2322)%NYMD = 20090719 + TES(2323)%NYMD = 20090719 + TES(2324)%NYMD = 20090720 + TES(2325)%NYMD = 20090720 + TES(2326)%NYMD = 20090720 + TES(2327)%NYMD = 20090720 + TES(2328)%NYMD = 20090720 + TES(2329)%NYMD = 20090720 + TES(2330)%NYMD = 20090720 + TES(2331)%NYMD = 20090720 + TES(2332)%NYMD = 20090720 + TES(2333)%NYMD = 20090720 + TES(2334)%NYMD = 20090720 + TES(2335)%NYMD = 20090720 + TES(2336)%NYMD = 20090720 + TES(2337)%NYMD = 20090720 + TES(2338)%NYMD = 20090720 + TES(2339)%NYMD = 20090720 + TES(2340)%NYMD = 20090720 + TES(2341)%NYMD = 20090720 + TES(2342)%NYMD = 20090720 + TES(2343)%NYMD = 20090720 + TES(2344)%NYMD = 20090720 + TES(2345)%NYMD = 20090720 + TES(2346)%NYMD = 20090720 + TES(2347)%NYMD = 20090720 + TES(2348)%NYMD = 20090720 + TES(2349)%NYMD = 20090720 + TES(2350)%NYMD = 20090720 + TES(2351)%NYMD = 20090720 + TES(2352)%NYMD = 20090720 + TES(2353)%NYMD = 20090720 + TES(2354)%NYMD = 20090720 + TES(2355)%NYMD = 20090720 + TES(2356)%NYMD = 20090720 + TES(2357)%NYMD = 20090720 + TES(2358)%NYMD = 20090720 + TES(2359)%NYMD = 20090720 + TES(2360)%NYMD = 20090720 + TES(2361)%NYMD = 20090720 + TES(2362)%NYMD = 20090720 + TES(2363)%NYMD = 20090720 + TES(2364)%NYMD = 20090720 + TES(2365)%NYMD = 20090720 + TES(2366)%NYMD = 20090720 + TES(2367)%NYMD = 20090720 + TES(2368)%NYMD = 20090720 + TES(2369)%NYMD = 20090720 + TES(2370)%NYMD = 20090720 + TES(2371)%NYMD = 20090720 + TES(2372)%NYMD = 20090720 + TES(2373)%NYMD = 20090720 + TES(2374)%NYMD = 20090720 + TES(2375)%NYMD = 20090720 + TES(2376)%NYMD = 20090720 + TES(2377)%NYMD = 20090720 + TES(2378)%NYMD = 20090720 + TES(2379)%NYMD = 20090720 + TES(2380)%NYMD = 20090720 + TES(2381)%NYMD = 20090720 + TES(2382)%NYMD = 20090720 + TES(2383)%NYMD = 20090720 + TES(2384)%NYMD = 20090720 + TES(2385)%NYMD = 20090720 + TES(2386)%NYMD = 20090720 + TES(2387)%NYMD = 20090720 + TES(2388)%NYMD = 20090720 + TES(2389)%NYMD = 20090720 + TES(2390)%NYMD = 20090720 + TES(2391)%NYMD = 20090720 + TES(2392)%NYMD = 20090720 + TES(2393)%NYMD = 20090720 + TES(2394)%NYMD = 20090720 + TES(2395)%NYMD = 20090720 + TES(2396)%NYMD = 20090720 + TES(2397)%NYMD = 20090720 + TES(2398)%NYMD = 20090720 + TES(2399)%NYMD = 20090720 + TES(2400)%NYMD = 20090720 + TES(2401)%NYMD = 20090720 + TES(2402)%NYMD = 20090720 + TES(2403)%NYMD = 20090720 + TES(2404)%NYMD = 20090720 + TES(2405)%NYMD = 20090720 + TES(2406)%NYMD = 20090720 + TES(2407)%NYMD = 20090720 + TES(2408)%NYMD = 20090720 + TES(2409)%NYMD = 20090720 + TES(2410)%NYMD = 20090720 + TES(2411)%NYMD = 20090720 + TES(2412)%NYMD = 20090720 + TES(2413)%NYMD = 20090720 + TES(2414)%NYMD = 20090720 + TES(2415)%NYMD = 20090720 + TES(2416)%NYMD = 20090720 + TES(2417)%NYMD = 20090720 + TES(2418)%NYMD = 20090720 + TES(2419)%NYMD = 20090720 + TES(2420)%NYMD = 20090720 + TES(2421)%NYMD = 20090720 + TES(2422)%NYMD = 20090720 + TES(2423)%NYMD = 20090720 + TES(2424)%NYMD = 20090720 + TES(2425)%NYMD = 20090720 + TES(2426)%NYMD = 20090720 + TES(2427)%NYMD = 20090720 + TES(2428)%NYMD = 20090720 + TES(2429)%NYMD = 20090720 + TES(2430)%NYMD = 20090720 + TES(2431)%NYMD = 20090720 + TES(2432)%NYMD = 20090721 + TES(2433)%NYMD = 20090721 + TES(2434)%NYMD = 20090721 + TES(2435)%NYMD = 20090721 + TES(2436)%NYMD = 20090721 + TES(2437)%NYMD = 20090721 + TES(2438)%NYMD = 20090721 + TES(2439)%NYMD = 20090721 + TES(2440)%NYMD = 20090721 + TES(2441)%NYMD = 20090721 + TES(2442)%NYMD = 20090721 + TES(2443)%NYMD = 20090721 + TES(2444)%NYMD = 20090721 + TES(2445)%NYMD = 20090721 + TES(2446)%NYMD = 20090721 + TES(2447)%NYMD = 20090721 + TES(2448)%NYMD = 20090721 + TES(2449)%NYMD = 20090721 + TES(2450)%NYMD = 20090721 + TES(2451)%NYMD = 20090721 + TES(2452)%NYMD = 20090721 + TES(2453)%NYMD = 20090721 + TES(2454)%NYMD = 20090721 + TES(2455)%NYMD = 20090721 + TES(2456)%NYMD = 20090721 + TES(2457)%NYMD = 20090721 + TES(2458)%NYMD = 20090721 + TES(2459)%NYMD = 20090721 + TES(2460)%NYMD = 20090721 + TES(2461)%NYMD = 20090721 + TES(2462)%NYMD = 20090721 + TES(2463)%NYMD = 20090721 + TES(2464)%NYMD = 20090721 + TES(2465)%NYMD = 20090721 + TES(2466)%NYMD = 20090721 + TES(2467)%NYMD = 20090721 + TES(2468)%NYMD = 20090721 + TES(2469)%NYMD = 20090721 + TES(2470)%NYMD = 20090721 + TES(2471)%NYMD = 20090721 + TES(2472)%NYMD = 20090721 + TES(2473)%NYMD = 20090721 + TES(2474)%NYMD = 20090721 + TES(2475)%NYMD = 20090721 + TES(2476)%NYMD = 20090721 + TES(2477)%NYMD = 20090721 + TES(2478)%NYMD = 20090721 + TES(2479)%NYMD = 20090721 + TES(2480)%NYMD = 20090721 + TES(2481)%NYMD = 20090721 + TES(2482)%NYMD = 20090721 + TES(2483)%NYMD = 20090721 + TES(2484)%NYMD = 20090721 + TES(2485)%NYMD = 20090721 + TES(2486)%NYMD = 20090721 + TES(2487)%NYMD = 20090721 + TES(2488)%NYMD = 20090721 + TES(2489)%NYMD = 20090721 + TES(2490)%NYMD = 20090721 + TES(2491)%NYMD = 20090721 + TES(2492)%NYMD = 20090721 + TES(2493)%NYMD = 20090721 + TES(2494)%NYMD = 20090721 + TES(2495)%NYMD = 20090721 + TES(2496)%NYMD = 20090721 + TES(2497)%NYMD = 20090721 + TES(2498)%NYMD = 20090721 + TES(2499)%NYMD = 20090721 + TES(2500)%NYMD = 20090721 + TES(2501)%NYMD = 20090721 + TES(2502)%NYMD = 20090721 + TES(2503)%NYMD = 20090721 + TES(2504)%NYMD = 20090721 + TES(2505)%NYMD = 20090721 + TES(2506)%NYMD = 20090721 + TES(2507)%NYMD = 20090721 + TES(2508)%NYMD = 20090721 + TES(2509)%NYMD = 20090721 + TES(2510)%NYMD = 20090721 + TES(2511)%NYMD = 20090721 + TES(2512)%NYMD = 20090721 + TES(2513)%NYMD = 20090721 + TES(2514)%NYMD = 20090721 + TES(2515)%NYMD = 20090721 + TES(2516)%NYMD = 20090721 + TES(2517)%NYMD = 20090721 + TES(2518)%NYMD = 20090721 + TES(2519)%NYMD = 20090721 + TES(2520)%NYMD = 20090721 + TES(2521)%NYMD = 20090721 + TES(2522)%NYMD = 20090721 + TES(2523)%NYMD = 20090721 + TES(2524)%NYMD = 20090721 + TES(2525)%NYMD = 20090721 + TES(2526)%NYMD = 20090721 + TES(2527)%NYMD = 20090721 + TES(2528)%NYMD = 20090721 + TES(2529)%NYMD = 20090721 + TES(2530)%NYMD = 20090721 + TES(2531)%NYMD = 20090721 + TES(2532)%NYMD = 20090721 + TES(2533)%NYMD = 20090721 + TES(2534)%NYMD = 20090721 + TES(2535)%NYMD = 20090721 + TES(2536)%NYMD = 20090721 + TES(2537)%NYMD = 20090721 + TES(2538)%NYMD = 20090721 + TES(2539)%NYMD = 20090721 + TES(2540)%NYMD = 20090721 + TES(2541)%NYMD = 20090721 + TES(2542)%NYMD = 20090721 + TES(2543)%NYMD = 20090721 + TES(2544)%NYMD = 20090721 + TES(2545)%NYMD = 20090721 + TES(2546)%NYMD = 20090721 + TES(2547)%NYMD = 20090721 + TES(2548)%NYMD = 20090721 + TES(2549)%NYMD = 20090721 + TES(2550)%NYMD = 20090721 + TES(2551)%NYMD = 20090721 + TES(2552)%NYMD = 20090721 + TES(2553)%NYMD = 20090721 + TES(2554)%NYMD = 20090721 + TES(2555)%NYMD = 20090721 + TES(2556)%NYMD = 20090721 + TES(2557)%NYMD = 20090721 + TES(2558)%NYMD = 20090721 + TES(2559)%NYMD = 20090721 + TES(2560)%NYMD = 20090721 + TES(2561)%NYMD = 20090721 + TES(2562)%NYMD = 20090721 + TES(2563)%NYMD = 20090721 + TES(2564)%NYMD = 20090721 + TES(2565)%NYMD = 20090721 + TES(2566)%NYMD = 20090721 + TES(2567)%NYMD = 20090721 + TES(2568)%NYMD = 20090721 + TES(2569)%NYMD = 20090721 + TES(2570)%NYMD = 20090721 + TES(2571)%NYMD = 20090721 + TES(2572)%NYMD = 20090721 + TES(2573)%NYMD = 20090721 + TES(2574)%NYMD = 20090721 + TES(2575)%NYMD = 20090721 + TES(2576)%NYMD = 20090721 + TES(2577)%NYMD = 20090721 + TES(2578)%NYMD = 20090721 + TES(2579)%NYMD = 20090721 + TES(2580)%NYMD = 20090721 + TES(2581)%NYMD = 20090721 + TES(2582)%NYMD = 20090721 + TES(2583)%NYMD = 20090721 + TES(2584)%NYMD = 20090721 + TES(2585)%NYMD = 20090721 + TES(2586)%NYMD = 20090721 + TES(2587)%NYMD = 20090721 + TES(2588)%NYMD = 20090721 + TES(2589)%NYMD = 20090721 + TES(2590)%NYMD = 20090721 + TES(2591)%NYMD = 20090721 + TES(2592)%NYMD = 20090721 + TES(2593)%NYMD = 20090721 + TES(2594)%NYMD = 20090721 + TES(2595)%NYMD = 20090721 + TES(2596)%NYMD = 20090721 + TES(2597)%NYMD = 20090721 + TES(2598)%NYMD = 20090721 + TES(2599)%NYMD = 20090721 + TES(2600)%NYMD = 20090721 + TES(2601)%NYMD = 20090721 + TES(2602)%NYMD = 20090721 + TES(2603)%NYMD = 20090721 + TES(2604)%NYMD = 20090722 + TES(2605)%NYMD = 20090722 + TES(2606)%NYMD = 20090722 + TES(2607)%NYMD = 20090722 + TES(2608)%NYMD = 20090722 + TES(2609)%NYMD = 20090722 + TES(2610)%NYMD = 20090722 + TES(2611)%NYMD = 20090722 + TES(2612)%NYMD = 20090722 + TES(2613)%NYMD = 20090722 + TES(2614)%NYMD = 20090722 + TES(2615)%NYMD = 20090722 + TES(2616)%NYMD = 20090722 + TES(2617)%NYMD = 20090722 + TES(2618)%NYMD = 20090722 + TES(2619)%NYMD = 20090722 + TES(2620)%NYMD = 20090722 + TES(2621)%NYMD = 20090722 + TES(2622)%NYMD = 20090722 + TES(2623)%NYMD = 20090722 + TES(2624)%NYMD = 20090722 + TES(2625)%NYMD = 20090722 + TES(2626)%NYMD = 20090722 + TES(2627)%NYMD = 20090722 + TES(2628)%NYMD = 20090722 + TES(2629)%NYMD = 20090722 + TES(2630)%NYMD = 20090722 + TES(2631)%NYMD = 20090722 + TES(2632)%NYMD = 20090722 + TES(2633)%NYMD = 20090722 + TES(2634)%NYMD = 20090722 + TES(2635)%NYMD = 20090722 + TES(2636)%NYMD = 20090722 + TES(2637)%NYMD = 20090722 + TES(2638)%NYMD = 20090722 + TES(2639)%NYMD = 20090722 + TES(2640)%NYMD = 20090722 + TES(2641)%NYMD = 20090722 + TES(2642)%NYMD = 20090722 + TES(2643)%NYMD = 20090722 + TES(2644)%NYMD = 20090722 + TES(2645)%NYMD = 20090722 + TES(2646)%NYMD = 20090722 + TES(2647)%NYMD = 20090722 + TES(2648)%NYMD = 20090722 + TES(2649)%NYMD = 20090722 + TES(2650)%NYMD = 20090722 + TES(2651)%NYMD = 20090722 + TES(2652)%NYMD = 20090722 + TES(2653)%NYMD = 20090722 + TES(2654)%NYMD = 20090722 + TES(2655)%NYMD = 20090722 + TES(2656)%NYMD = 20090722 + TES(2657)%NYMD = 20090722 + TES(2658)%NYMD = 20090722 + TES(2659)%NYMD = 20090722 + TES(2660)%NYMD = 20090722 + TES(2661)%NYMD = 20090722 + TES(2662)%NYMD = 20090722 + TES(2663)%NYMD = 20090722 + TES(2664)%NYMD = 20090722 + TES(2665)%NYMD = 20090722 + TES(2666)%NYMD = 20090722 + TES(2667)%NYMD = 20090722 + TES(2668)%NYMD = 20090722 + TES(2669)%NYMD = 20090722 + TES(2670)%NYMD = 20090722 + TES(2671)%NYMD = 20090722 + TES(2672)%NYMD = 20090722 + TES(2673)%NYMD = 20090722 + TES(2674)%NYMD = 20090722 + TES(2675)%NYMD = 20090722 + TES(2676)%NYMD = 20090722 + TES(2677)%NYMD = 20090722 + TES(2678)%NYMD = 20090722 + TES(2679)%NYMD = 20090722 + TES(2680)%NYMD = 20090722 + TES(2681)%NYMD = 20090722 + TES(2682)%NYMD = 20090722 + TES(2683)%NYMD = 20090722 + TES(2684)%NYMD = 20090722 + TES(2685)%NYMD = 20090722 + TES(2686)%NYMD = 20090722 + TES(2687)%NYMD = 20090722 + TES(2688)%NYMD = 20090722 + TES(2689)%NYMD = 20090722 + TES(2690)%NYMD = 20090722 + TES(2691)%NYMD = 20090722 + TES(2692)%NYMD = 20090722 + TES(2693)%NYMD = 20090722 + TES(2694)%NYMD = 20090722 + TES(2695)%NYMD = 20090722 + TES(2696)%NYMD = 20090722 + TES(2697)%NYMD = 20090722 + TES(2698)%NYMD = 20090722 + TES(2699)%NYMD = 20090722 + TES(2700)%NYMD = 20090722 + TES(2701)%NYMD = 20090722 + TES(2702)%NYMD = 20090722 + TES(2703)%NYMD = 20090722 + TES(2704)%NYMD = 20090722 + TES(2705)%NYMD = 20090722 + TES(2706)%NYMD = 20090722 + TES(2707)%NYMD = 20090722 + TES(2708)%NYMD = 20090722 + TES(2709)%NYMD = 20090722 + TES(2710)%NYMD = 20090722 + TES(2711)%NYMD = 20090722 + TES(2712)%NYMD = 20090722 + TES(2713)%NYMD = 20090722 + TES(2714)%NYMD = 20090722 + TES(2715)%NYMD = 20090722 + TES(2716)%NYMD = 20090722 + TES(2717)%NYMD = 20090722 + TES(2718)%NYMD = 20090722 + TES(2719)%NYMD = 20090722 + TES(2720)%NYMD = 20090722 + TES(2721)%NYMD = 20090722 + TES(2722)%NYMD = 20090722 + TES(2723)%NYMD = 20090722 + TES(2724)%NYMD = 20090723 + TES(2725)%NYMD = 20090723 + TES(2726)%NYMD = 20090723 + TES(2727)%NYMD = 20090723 + TES(2728)%NYMD = 20090723 + TES(2729)%NYMD = 20090723 + TES(2730)%NYMD = 20090723 + TES(2731)%NYMD = 20090723 + TES(2732)%NYMD = 20090723 + TES(2733)%NYMD = 20090723 + TES(2734)%NYMD = 20090723 + TES(2735)%NYMD = 20090723 + TES(2736)%NYMD = 20090723 + TES(2737)%NYMD = 20090723 + TES(2738)%NYMD = 20090723 + TES(2739)%NYMD = 20090723 + TES(2740)%NYMD = 20090723 + TES(2741)%NYMD = 20090723 + TES(2742)%NYMD = 20090723 + TES(2743)%NYMD = 20090723 + TES(2744)%NYMD = 20090723 + TES(2745)%NYMD = 20090723 + TES(2746)%NYMD = 20090723 + TES(2747)%NYMD = 20090723 + TES(2748)%NYMD = 20090723 + TES(2749)%NYMD = 20090723 + TES(2750)%NYMD = 20090723 + TES(2751)%NYMD = 20090723 + TES(2752)%NYMD = 20090723 + TES(2753)%NYMD = 20090723 + TES(2754)%NYMD = 20090723 + TES(2755)%NYMD = 20090723 + TES(2756)%NYMD = 20090723 + TES(2757)%NYMD = 20090723 + TES(2758)%NYMD = 20090723 + TES(2759)%NYMD = 20090723 + TES(2760)%NYMD = 20090723 + TES(2761)%NYMD = 20090723 + TES(2762)%NYMD = 20090723 + TES(2763)%NYMD = 20090723 + TES(2764)%NYMD = 20090723 + TES(2765)%NYMD = 20090723 + TES(2766)%NYMD = 20090723 + TES(2767)%NYMD = 20090723 + TES(2768)%NYMD = 20090723 + TES(2769)%NYMD = 20090723 + TES(2770)%NYMD = 20090723 + TES(2771)%NYMD = 20090723 + TES(2772)%NYMD = 20090723 + TES(2773)%NYMD = 20090723 + TES(2774)%NYMD = 20090723 + TES(2775)%NYMD = 20090723 + TES(2776)%NYMD = 20090723 + TES(2777)%NYMD = 20090723 + TES(2778)%NYMD = 20090723 + TES(2779)%NYMD = 20090723 + TES(2780)%NYMD = 20090723 + TES(2781)%NYMD = 20090723 + TES(2782)%NYMD = 20090723 + TES(2783)%NYMD = 20090723 + TES(2784)%NYMD = 20090723 + TES(2785)%NYMD = 20090723 + TES(2786)%NYMD = 20090723 + TES(2787)%NYMD = 20090723 + TES(2788)%NYMD = 20090723 + TES(2789)%NYMD = 20090723 + TES(2790)%NYMD = 20090723 + TES(2791)%NYMD = 20090723 + TES(2792)%NYMD = 20090723 + TES(2793)%NYMD = 20090723 + TES(2794)%NYMD = 20090723 + TES(2795)%NYMD = 20090723 + TES(2796)%NYMD = 20090723 + TES(2797)%NYMD = 20090723 + TES(2798)%NYMD = 20090723 + TES(2799)%NYMD = 20090723 + TES(2800)%NYMD = 20090723 + TES(2801)%NYMD = 20090723 + TES(2802)%NYMD = 20090723 + TES(2803)%NYMD = 20090723 + TES(2804)%NYMD = 20090723 + TES(2805)%NYMD = 20090723 + TES(2806)%NYMD = 20090723 + TES(2807)%NYMD = 20090723 + TES(2808)%NYMD = 20090723 + TES(2809)%NYMD = 20090723 + TES(2810)%NYMD = 20090723 + TES(2811)%NYMD = 20090723 + TES(2812)%NYMD = 20090723 + TES(2813)%NYMD = 20090723 + TES(2814)%NYMD = 20090723 + TES(2815)%NYMD = 20090723 + TES(2816)%NYMD = 20090723 + TES(2817)%NYMD = 20090723 + TES(2818)%NYMD = 20090723 + TES(2819)%NYMD = 20090723 + TES(2820)%NYMD = 20090723 + TES(2821)%NYMD = 20090723 + TES(2822)%NYMD = 20090723 + TES(2823)%NYMD = 20090723 + TES(2824)%NYMD = 20090723 + TES(2825)%NYMD = 20090723 + TES(2826)%NYMD = 20090723 + TES(2827)%NYMD = 20090723 + TES(2828)%NYMD = 20090723 + TES(2829)%NYMD = 20090723 + TES(2830)%NYMD = 20090723 + TES(2831)%NYMD = 20090723 + TES(2832)%NYMD = 20090723 + TES(2833)%NYMD = 20090723 + TES(2834)%NYMD = 20090723 + TES(2835)%NYMD = 20090723 + TES(2836)%NYMD = 20090723 + TES(2837)%NYMD = 20090723 + TES(2838)%NYMD = 20090723 + TES(2839)%NYMD = 20090723 + TES(2840)%NYMD = 20090723 + TES(2841)%NYMD = 20090723 + TES(2842)%NYMD = 20090723 + TES(2843)%NYMD = 20090723 + TES(2844)%NYMD = 20090723 + TES(2845)%NYMD = 20090723 + TES(2846)%NYMD = 20090723 + TES(2847)%NYMD = 20090723 + TES(2848)%NYMD = 20090723 + TES(2849)%NYMD = 20090723 + TES(2850)%NYMD = 20090723 + TES(2851)%NYMD = 20090723 + TES(2852)%NYMD = 20090723 + TES(2853)%NYMD = 20090723 + TES(2854)%NYMD = 20090723 + TES(2855)%NYMD = 20090723 + TES(2856)%NYMD = 20090723 + TES(2857)%NYMD = 20090723 + TES(2858)%NYMD = 20090723 + TES(2859)%NYMD = 20090723 + TES(2860)%NYMD = 20090723 + TES(2861)%NYMD = 20090723 + TES(2862)%NYMD = 20090723 + TES(2863)%NYMD = 20090723 + TES(2864)%NYMD = 20090723 + TES(2865)%NYMD = 20090723 + TES(2866)%NYMD = 20090723 + TES(2867)%NYMD = 20090723 + TES(2868)%NYMD = 20090723 + TES(2869)%NYMD = 20090723 + TES(2870)%NYMD = 20090723 + TES(2871)%NYMD = 20090723 + TES(2872)%NYMD = 20090723 + TES(2873)%NYMD = 20090723 + TES(2874)%NYMD = 20090723 + TES(2875)%NYMD = 20090723 + TES(2876)%NYMD = 20090723 + TES(2877)%NYMD = 20090723 + TES(2878)%NYMD = 20090723 + TES(2879)%NYMD = 20090724 + TES(2880)%NYMD = 20090724 + TES(2881)%NYMD = 20090724 + TES(2882)%NYMD = 20090724 + TES(2883)%NYMD = 20090724 + TES(2884)%NYMD = 20090724 + TES(2885)%NYMD = 20090724 + TES(2886)%NYMD = 20090724 + TES(2887)%NYMD = 20090724 + TES(2888)%NYMD = 20090724 + TES(2889)%NYMD = 20090724 + TES(2890)%NYMD = 20090724 + TES(2891)%NYMD = 20090724 + TES(2892)%NYMD = 20090724 + TES(2893)%NYMD = 20090724 + TES(2894)%NYMD = 20090724 + TES(2895)%NYMD = 20090724 + TES(2896)%NYMD = 20090724 + TES(2897)%NYMD = 20090724 + TES(2898)%NYMD = 20090724 + TES(2899)%NYMD = 20090724 + TES(2900)%NYMD = 20090724 + TES(2901)%NYMD = 20090724 + TES(2902)%NYMD = 20090724 + TES(2903)%NYMD = 20090724 + TES(2904)%NYMD = 20090724 + TES(2905)%NYMD = 20090724 + TES(2906)%NYMD = 20090724 + TES(2907)%NYMD = 20090724 + TES(2908)%NYMD = 20090724 + TES(2909)%NYMD = 20090724 + TES(2910)%NYMD = 20090724 + TES(2911)%NYMD = 20090724 + TES(2912)%NYMD = 20090724 + TES(2913)%NYMD = 20090724 + TES(2914)%NYMD = 20090724 + TES(2915)%NYMD = 20090724 + TES(2916)%NYMD = 20090724 + TES(2917)%NYMD = 20090724 + TES(2918)%NYMD = 20090724 + TES(2919)%NYMD = 20090724 + TES(2920)%NYMD = 20090724 + TES(2921)%NYMD = 20090724 + TES(2922)%NYMD = 20090724 + TES(2923)%NYMD = 20090724 + TES(2924)%NYMD = 20090724 + TES(2925)%NYMD = 20090724 + TES(2926)%NYMD = 20090724 + TES(2927)%NYMD = 20090724 + TES(2928)%NYMD = 20090724 + TES(2929)%NYMD = 20090724 + TES(2930)%NYMD = 20090724 + TES(2931)%NYMD = 20090724 + TES(2932)%NYMD = 20090724 + TES(2933)%NYMD = 20090724 + TES(2934)%NYMD = 20090724 + TES(2935)%NYMD = 20090724 + TES(2936)%NYMD = 20090724 + TES(2937)%NYMD = 20090724 + TES(2938)%NYMD = 20090724 + TES(2939)%NYMD = 20090724 + TES(2940)%NYMD = 20090724 + TES(2941)%NYMD = 20090724 + TES(2942)%NYMD = 20090724 + TES(2943)%NYMD = 20090724 + TES(2944)%NYMD = 20090724 + TES(2945)%NYMD = 20090724 + TES(2946)%NYMD = 20090724 + TES(2947)%NYMD = 20090724 + TES(2948)%NYMD = 20090724 + TES(2949)%NYMD = 20090724 + TES(2950)%NYMD = 20090724 + TES(2951)%NYMD = 20090724 + TES(2952)%NYMD = 20090724 + TES(2953)%NYMD = 20090724 + TES(2954)%NYMD = 20090724 + TES(2955)%NYMD = 20090724 + TES(2956)%NYMD = 20090724 + TES(2957)%NYMD = 20090724 + TES(2958)%NYMD = 20090724 + TES(2959)%NYMD = 20090724 + TES(2960)%NYMD = 20090724 + TES(2961)%NYMD = 20090724 + TES(2962)%NYMD = 20090724 + TES(2963)%NYMD = 20090724 + TES(2964)%NYMD = 20090724 + TES(2965)%NYMD = 20090724 + TES(2966)%NYMD = 20090724 + TES(2967)%NYMD = 20090724 + TES(2968)%NYMD = 20090724 + TES(2969)%NYMD = 20090724 + TES(2970)%NYMD = 20090724 + TES(2971)%NYMD = 20090724 + TES(2972)%NYMD = 20090724 + TES(2973)%NYMD = 20090724 + TES(2974)%NYMD = 20090724 + TES(2975)%NYMD = 20090724 + TES(2976)%NYMD = 20090724 + TES(2977)%NYMD = 20090724 + TES(2978)%NYMD = 20090724 + TES(2979)%NYMD = 20090724 + TES(2980)%NYMD = 20090724 + TES(2981)%NYMD = 20090724 + TES(2982)%NYMD = 20090724 + TES(2983)%NYMD = 20090724 + TES(2984)%NYMD = 20090724 + TES(2985)%NYMD = 20090724 + TES(2986)%NYMD = 20090724 + TES(2987)%NYMD = 20090724 + TES(2988)%NYMD = 20090724 + TES(2989)%NYMD = 20090724 + TES(2990)%NYMD = 20090724 + TES(2991)%NYMD = 20090724 + TES(2992)%NYMD = 20090724 + TES(2993)%NYMD = 20090724 + TES(2994)%NYMD = 20090724 + TES(2995)%NYMD = 20090724 + TES(2996)%NYMD = 20090724 + TES(2997)%NYMD = 20090724 + TES(2998)%NYMD = 20090724 + TES(2999)%NYMD = 20090724 + TES(3000)%NYMD = 20090724 + TES(3001)%NYMD = 20090724 + TES(3002)%NYMD = 20090724 + TES(3003)%NYMD = 20090724 + TES(3004)%NYMD = 20090724 + TES(3005)%NYMD = 20090724 + TES(3006)%NYMD = 20090724 + TES(3007)%NYMD = 20090725 + TES(3008)%NYMD = 20090725 + TES(3009)%NYMD = 20090725 + TES(3010)%NYMD = 20090725 + TES(3011)%NYMD = 20090725 + TES(3012)%NYMD = 20090725 + TES(3013)%NYMD = 20090725 + TES(3014)%NYMD = 20090725 + TES(3015)%NYMD = 20090725 + TES(3016)%NYMD = 20090725 + TES(3017)%NYMD = 20090725 + TES(3018)%NYMD = 20090725 + TES(3019)%NYMD = 20090725 + TES(3020)%NYMD = 20090725 + TES(3021)%NYMD = 20090725 + TES(3022)%NYMD = 20090725 + TES(3023)%NYMD = 20090725 + TES(3024)%NYMD = 20090725 + TES(3025)%NYMD = 20090725 + TES(3026)%NYMD = 20090725 + TES(3027)%NYMD = 20090725 + TES(3028)%NYMD = 20090725 + TES(3029)%NYMD = 20090725 + TES(3030)%NYMD = 20090725 + TES(3031)%NYMD = 20090725 + TES(3032)%NYMD = 20090725 + TES(3033)%NYMD = 20090725 + TES(3034)%NYMD = 20090725 + TES(3035)%NYMD = 20090725 + TES(3036)%NYMD = 20090725 + TES(3037)%NYMD = 20090725 + TES(3038)%NYMD = 20090725 + TES(3039)%NYMD = 20090725 + TES(3040)%NYMD = 20090725 + TES(3041)%NYMD = 20090725 + TES(3042)%NYMD = 20090725 + TES(3043)%NYMD = 20090725 + TES(3044)%NYMD = 20090725 + TES(3045)%NYMD = 20090725 + TES(3046)%NYMD = 20090725 + TES(3047)%NYMD = 20090725 + TES(3048)%NYMD = 20090725 + TES(3049)%NYMD = 20090725 + TES(3050)%NYMD = 20090725 + TES(3051)%NYMD = 20090725 + TES(3052)%NYMD = 20090725 + TES(3053)%NYMD = 20090725 + TES(3054)%NYMD = 20090725 + TES(3055)%NYMD = 20090725 + TES(3056)%NYMD = 20090725 + TES(3057)%NYMD = 20090725 + TES(3058)%NYMD = 20090725 + TES(3059)%NYMD = 20090725 + TES(3060)%NYMD = 20090725 + TES(3061)%NYMD = 20090725 + TES(3062)%NYMD = 20090725 + TES(3063)%NYMD = 20090725 + TES(3064)%NYMD = 20090725 + TES(3065)%NYMD = 20090725 + TES(3066)%NYMD = 20090725 + TES(3067)%NYMD = 20090725 + TES(3068)%NYMD = 20090725 + TES(3069)%NYMD = 20090725 + TES(3070)%NYMD = 20090725 + TES(3071)%NYMD = 20090725 + TES(3072)%NYMD = 20090725 + TES(3073)%NYMD = 20090725 + TES(3074)%NYMD = 20090725 + TES(3075)%NYMD = 20090725 + TES(3076)%NYMD = 20090725 + TES(3077)%NYMD = 20090725 + TES(3078)%NYMD = 20090725 + TES(3079)%NYMD = 20090725 + TES(3080)%NYMD = 20090725 + TES(3081)%NYMD = 20090725 + TES(3082)%NYMD = 20090725 + TES(3083)%NYMD = 20090725 + TES(3084)%NYMD = 20090725 + TES(3085)%NYMD = 20090725 + TES(3086)%NYMD = 20090725 + TES(3087)%NYMD = 20090725 + TES(3088)%NYMD = 20090725 + TES(3089)%NYMD = 20090725 + TES(3090)%NYMD = 20090725 + TES(3091)%NYMD = 20090725 + TES(3092)%NYMD = 20090725 + TES(3093)%NYMD = 20090725 + TES(3094)%NYMD = 20090725 + TES(3095)%NYMD = 20090725 + TES(3096)%NYMD = 20090725 + TES(3097)%NYMD = 20090725 + TES(3098)%NYMD = 20090725 + TES(3099)%NYMD = 20090725 + TES(3100)%NYMD = 20090725 + TES(3101)%NYMD = 20090725 + TES(3102)%NYMD = 20090725 + TES(3103)%NYMD = 20090725 + TES(3104)%NYMD = 20090725 + TES(3105)%NYMD = 20090725 + TES(3106)%NYMD = 20090725 + TES(3107)%NYMD = 20090725 + TES(3108)%NYMD = 20090725 + TES(3109)%NYMD = 20090725 + TES(3110)%NYMD = 20090725 + TES(3111)%NYMD = 20090725 + TES(3112)%NYMD = 20090725 + TES(3113)%NYMD = 20090725 + TES(3114)%NYMD = 20090725 + TES(3115)%NYMD = 20090725 + TES(3116)%NYMD = 20090725 + TES(3117)%NYMD = 20090725 + TES(3118)%NYMD = 20090725 + TES(3119)%NYMD = 20090725 + TES(3120)%NYMD = 20090725 + TES(3121)%NYMD = 20090725 + TES(3122)%NYMD = 20090725 + TES(3123)%NYMD = 20090725 + TES(3124)%NYMD = 20090725 + TES(3125)%NYMD = 20090725 + TES(3126)%NYMD = 20090725 + TES(3127)%NYMD = 20090725 + TES(3128)%NYMD = 20090725 + TES(3129)%NYMD = 20090725 + TES(3130)%NYMD = 20090725 + TES(3131)%NYMD = 20090725 + TES(3132)%NYMD = 20090725 + TES(3133)%NYMD = 20090725 + TES(3134)%NYMD = 20090725 + TES(3135)%NYMD = 20090725 + TES(3136)%NYMD = 20090725 + TES(3137)%NYMD = 20090725 + TES(3138)%NYMD = 20090725 + TES(3139)%NYMD = 20090725 + TES(3140)%NYMD = 20090725 + TES(3141)%NYMD = 20090725 + TES(3142)%NYMD = 20090725 + TES(3143)%NYMD = 20090725 + TES(3144)%NYMD = 20090725 + TES(3145)%NYMD = 20090725 + TES(3146)%NYMD = 20090725 + TES(3147)%NYMD = 20090725 + TES(3148)%NYMD = 20090725 + TES(3149)%NYMD = 20090725 + TES(3150)%NYMD = 20090725 + TES(3151)%NYMD = 20090725 + TES(3152)%NYMD = 20090725 + TES(3153)%NYMD = 20090725 + TES(3154)%NYMD = 20090725 + TES(3155)%NYMD = 20090725 + TES(3156)%NYMD = 20090725 + TES(3157)%NYMD = 20090725 + TES(3158)%NYMD = 20090725 + TES(3159)%NYMD = 20090725 + TES(3160)%NYMD = 20090725 + TES(3161)%NYMD = 20090725 + TES(3162)%NYMD = 20090725 + TES(3163)%NYMD = 20090726 + TES(3164)%NYMD = 20090726 + TES(3165)%NYMD = 20090726 + TES(3166)%NYMD = 20090726 + TES(3167)%NYMD = 20090726 + TES(3168)%NYMD = 20090726 + TES(3169)%NYMD = 20090726 + TES(3170)%NYMD = 20090726 + TES(3171)%NYMD = 20090726 + TES(3172)%NYMD = 20090726 + TES(3173)%NYMD = 20090726 + TES(3174)%NYMD = 20090726 + TES(3175)%NYMD = 20090726 + TES(3176)%NYMD = 20090726 + TES(3177)%NYMD = 20090726 + TES(3178)%NYMD = 20090726 + TES(3179)%NYMD = 20090726 + TES(3180)%NYMD = 20090726 + TES(3181)%NYMD = 20090726 + TES(3182)%NYMD = 20090726 + TES(3183)%NYMD = 20090726 + TES(3184)%NYMD = 20090726 + TES(3185)%NYMD = 20090726 + TES(3186)%NYMD = 20090726 + TES(3187)%NYMD = 20090726 + TES(3188)%NYMD = 20090726 + TES(3189)%NYMD = 20090726 + TES(3190)%NYMD = 20090726 + TES(3191)%NYMD = 20090726 + TES(3192)%NYMD = 20090726 + TES(3193)%NYMD = 20090726 + TES(3194)%NYMD = 20090726 + TES(3195)%NYMD = 20090726 + TES(3196)%NYMD = 20090726 + TES(3197)%NYMD = 20090726 + TES(3198)%NYMD = 20090726 + TES(3199)%NYMD = 20090726 + TES(3200)%NYMD = 20090726 + TES(3201)%NYMD = 20090726 + TES(3202)%NYMD = 20090726 + TES(3203)%NYMD = 20090726 + TES(3204)%NYMD = 20090726 + TES(3205)%NYMD = 20090726 + TES(3206)%NYMD = 20090726 + TES(3207)%NYMD = 20090726 + TES(3208)%NYMD = 20090726 + TES(3209)%NYMD = 20090726 + TES(3210)%NYMD = 20090726 + TES(3211)%NYMD = 20090726 + TES(3212)%NYMD = 20090726 + TES(3213)%NYMD = 20090726 + TES(3214)%NYMD = 20090726 + TES(3215)%NYMD = 20090726 + TES(3216)%NYMD = 20090726 + TES(3217)%NYMD = 20090726 + TES(3218)%NYMD = 20090726 + TES(3219)%NYMD = 20090726 + TES(3220)%NYMD = 20090726 + TES(3221)%NYMD = 20090726 + TES(3222)%NYMD = 20090726 + TES(3223)%NYMD = 20090726 + TES(3224)%NYMD = 20090726 + TES(3225)%NYMD = 20090726 + TES(3226)%NYMD = 20090726 + TES(3227)%NYMD = 20090726 + TES(3228)%NYMD = 20090726 + TES(3229)%NYMD = 20090726 + TES(3230)%NYMD = 20090726 + TES(3231)%NYMD = 20090726 + TES(3232)%NYMD = 20090726 + TES(3233)%NYMD = 20090726 + TES(3234)%NYMD = 20090726 + TES(3235)%NYMD = 20090726 + TES(3236)%NYMD = 20090726 + TES(3237)%NYMD = 20090726 + TES(3238)%NYMD = 20090726 + TES(3239)%NYMD = 20090726 + TES(3240)%NYMD = 20090726 + TES(3241)%NYMD = 20090726 + TES(3242)%NYMD = 20090726 + TES(3243)%NYMD = 20090726 + TES(3244)%NYMD = 20090726 + TES(3245)%NYMD = 20090726 + TES(3246)%NYMD = 20090726 + TES(3247)%NYMD = 20090726 + TES(3248)%NYMD = 20090726 + TES(3249)%NYMD = 20090726 + TES(3250)%NYMD = 20090726 + TES(3251)%NYMD = 20090726 + TES(3252)%NYMD = 20090726 + TES(3253)%NYMD = 20090726 + TES(3254)%NYMD = 20090726 + TES(3255)%NYMD = 20090726 + TES(3256)%NYMD = 20090726 + TES(3257)%NYMD = 20090726 + TES(3258)%NYMD = 20090726 + TES(3259)%NYMD = 20090726 + TES(3260)%NYMD = 20090726 + TES(3261)%NYMD = 20090726 + TES(3262)%NYMD = 20090726 + TES(3263)%NYMD = 20090726 + TES(3264)%NYMD = 20090726 + TES(3265)%NYMD = 20090726 + TES(3266)%NYMD = 20090726 + TES(3267)%NYMD = 20090726 + TES(3268)%NYMD = 20090726 + TES(3269)%NYMD = 20090726 + TES(3270)%NYMD = 20090726 + TES(3271)%NYMD = 20090726 + TES(3272)%NYMD = 20090726 + TES(3273)%NYMD = 20090726 + TES(3274)%NYMD = 20090726 + TES(3275)%NYMD = 20090726 + TES(3276)%NYMD = 20090726 + TES(3277)%NYMD = 20090726 + TES(3278)%NYMD = 20090726 + TES(3279)%NYMD = 20090726 + TES(3280)%NYMD = 20090726 + TES(3281)%NYMD = 20090726 + TES(3282)%NYMD = 20090726 + TES(3283)%NYMD = 20090726 + TES(3284)%NYMD = 20090726 + TES(3285)%NYMD = 20090726 + TES(3286)%NYMD = 20090726 + TES(3287)%NYMD = 20090726 + TES(3288)%NYMD = 20090726 + TES(3289)%NYMD = 20090726 + TES(3290)%NYMD = 20090727 + TES(3291)%NYMD = 20090727 + TES(3292)%NYMD = 20090727 + TES(3293)%NYMD = 20090727 + TES(3294)%NYMD = 20090727 + TES(3295)%NYMD = 20090727 + TES(3296)%NYMD = 20090727 + TES(3297)%NYMD = 20090727 + TES(3298)%NYMD = 20090727 + TES(3299)%NYMD = 20090727 + TES(3300)%NYMD = 20090727 + TES(3301)%NYMD = 20090727 + TES(3302)%NYMD = 20090727 + TES(3303)%NYMD = 20090727 + TES(3304)%NYMD = 20090727 + TES(3305)%NYMD = 20090727 + TES(3306)%NYMD = 20090727 + TES(3307)%NYMD = 20090727 + TES(3308)%NYMD = 20090727 + TES(3309)%NYMD = 20090727 + TES(3310)%NYMD = 20090727 + TES(3311)%NYMD = 20090727 + TES(3312)%NYMD = 20090727 + TES(3313)%NYMD = 20090727 + TES(3314)%NYMD = 20090727 + TES(3315)%NYMD = 20090727 + TES(3316)%NYMD = 20090727 + TES(3317)%NYMD = 20090727 + TES(3318)%NYMD = 20090727 + TES(3319)%NYMD = 20090727 + TES(3320)%NYMD = 20090727 + TES(3321)%NYMD = 20090727 + TES(3322)%NYMD = 20090727 + TES(3323)%NYMD = 20090727 + TES(3324)%NYMD = 20090727 + TES(3325)%NYMD = 20090727 + TES(3326)%NYMD = 20090727 + TES(3327)%NYMD = 20090727 + TES(3328)%NYMD = 20090727 + TES(3329)%NYMD = 20090727 + TES(3330)%NYMD = 20090727 + TES(3331)%NYMD = 20090727 + TES(3332)%NYMD = 20090727 + TES(3333)%NYMD = 20090727 + TES(3334)%NYMD = 20090727 + TES(3335)%NYMD = 20090727 + TES(3336)%NYMD = 20090727 + TES(3337)%NYMD = 20090727 + TES(3338)%NYMD = 20090727 + TES(3339)%NYMD = 20090727 + TES(3340)%NYMD = 20090727 + TES(3341)%NYMD = 20090727 + TES(3342)%NYMD = 20090727 + TES(3343)%NYMD = 20090727 + TES(3344)%NYMD = 20090727 + TES(3345)%NYMD = 20090727 + TES(3346)%NYMD = 20090727 + TES(3347)%NYMD = 20090727 + TES(3348)%NYMD = 20090727 + TES(3349)%NYMD = 20090727 + TES(3350)%NYMD = 20090727 + TES(3351)%NYMD = 20090727 + TES(3352)%NYMD = 20090727 + TES(3353)%NYMD = 20090727 + TES(3354)%NYMD = 20090727 + TES(3355)%NYMD = 20090727 + TES(3356)%NYMD = 20090727 + TES(3357)%NYMD = 20090727 + TES(3358)%NYMD = 20090727 + TES(3359)%NYMD = 20090727 + TES(3360)%NYMD = 20090727 + TES(3361)%NYMD = 20090727 + TES(3362)%NYMD = 20090727 + TES(3363)%NYMD = 20090727 + TES(3364)%NYMD = 20090727 + TES(3365)%NYMD = 20090727 + TES(3366)%NYMD = 20090727 + TES(3367)%NYMD = 20090727 + TES(3368)%NYMD = 20090727 + TES(3369)%NYMD = 20090727 + TES(3370)%NYMD = 20090727 + TES(3371)%NYMD = 20090727 + TES(3372)%NYMD = 20090727 + TES(3373)%NYMD = 20090727 + TES(3374)%NYMD = 20090727 + TES(3375)%NYMD = 20090727 + TES(3376)%NYMD = 20090727 + TES(3377)%NYMD = 20090727 + TES(3378)%NYMD = 20090727 + TES(3379)%NYMD = 20090727 + TES(3380)%NYMD = 20090727 + TES(3381)%NYMD = 20090727 + TES(3382)%NYMD = 20090727 + TES(3383)%NYMD = 20090727 + TES(3384)%NYMD = 20090727 + TES(3385)%NYMD = 20090727 + TES(3386)%NYMD = 20090727 + TES(3387)%NYMD = 20090727 + TES(3388)%NYMD = 20090727 + TES(3389)%NYMD = 20090727 + TES(3390)%NYMD = 20090727 + TES(3391)%NYMD = 20090727 + TES(3392)%NYMD = 20090727 + TES(3393)%NYMD = 20090727 + TES(3394)%NYMD = 20090727 + TES(3395)%NYMD = 20090727 + TES(3396)%NYMD = 20090727 + TES(3397)%NYMD = 20090727 + TES(3398)%NYMD = 20090727 + TES(3399)%NYMD = 20090727 + TES(3400)%NYMD = 20090727 + TES(3401)%NYMD = 20090727 + TES(3402)%NYMD = 20090727 + TES(3403)%NYMD = 20090727 + TES(3404)%NYMD = 20090727 + TES(3405)%NYMD = 20090727 + TES(3406)%NYMD = 20090727 + TES(3407)%NYMD = 20090727 + TES(3408)%NYMD = 20090727 + TES(3409)%NYMD = 20090727 + TES(3410)%NYMD = 20090727 + TES(3411)%NYMD = 20090727 + TES(3412)%NYMD = 20090727 + TES(3413)%NYMD = 20090727 + TES(3414)%NYMD = 20090727 + TES(3415)%NYMD = 20090727 + TES(3416)%NYMD = 20090727 + TES(3417)%NYMD = 20090727 + TES(3418)%NYMD = 20090727 + TES(3419)%NYMD = 20090727 + TES(3420)%NYMD = 20090727 + TES(3421)%NYMD = 20090727 + TES(3422)%NYMD = 20090727 + TES(3423)%NYMD = 20090727 + TES(3424)%NYMD = 20090727 + TES(3425)%NYMD = 20090727 + TES(3426)%NYMD = 20090727 + TES(3427)%NYMD = 20090727 + TES(3428)%NYMD = 20090727 + TES(3429)%NYMD = 20090727 + TES(3430)%NYMD = 20090727 + TES(3431)%NYMD = 20090727 + TES(3432)%NYMD = 20090727 + TES(3433)%NYMD = 20090727 + TES(3434)%NYMD = 20090727 + TES(3435)%NYMD = 20090727 + TES(3436)%NYMD = 20090727 + TES(3437)%NYMD = 20090727 + TES(3438)%NYMD = 20090727 + TES(3439)%NYMD = 20090727 + TES(3440)%NYMD = 20090727 + TES(3441)%NYMD = 20090727 + TES(3442)%NYMD = 20090727 + TES(3443)%NYMD = 20090728 + TES(3444)%NYMD = 20090728 + TES(3445)%NYMD = 20090728 + TES(3446)%NYMD = 20090728 + TES(3447)%NYMD = 20090728 + TES(3448)%NYMD = 20090728 + TES(3449)%NYMD = 20090728 + TES(3450)%NYMD = 20090728 + TES(3451)%NYMD = 20090728 + TES(3452)%NYMD = 20090728 + TES(3453)%NYMD = 20090728 + TES(3454)%NYMD = 20090728 + TES(3455)%NYMD = 20090728 + TES(3456)%NYMD = 20090728 + TES(3457)%NYMD = 20090728 + TES(3458)%NYMD = 20090728 + TES(3459)%NYMD = 20090728 + TES(3460)%NYMD = 20090728 + TES(3461)%NYMD = 20090728 + TES(3462)%NYMD = 20090728 + TES(3463)%NYMD = 20090728 + TES(3464)%NYMD = 20090728 + TES(3465)%NYMD = 20090728 + TES(3466)%NYMD = 20090728 + TES(3467)%NYMD = 20090728 + TES(3468)%NYMD = 20090728 + TES(3469)%NYMD = 20090728 + TES(3470)%NYMD = 20090728 + TES(3471)%NYMD = 20090728 + TES(3472)%NYMD = 20090728 + TES(3473)%NYMD = 20090728 + TES(3474)%NYMD = 20090728 + TES(3475)%NYMD = 20090728 + TES(3476)%NYMD = 20090728 + TES(3477)%NYMD = 20090728 + TES(3478)%NYMD = 20090728 + TES(3479)%NYMD = 20090728 + TES(3480)%NYMD = 20090728 + TES(3481)%NYMD = 20090728 + TES(3482)%NYMD = 20090728 + TES(3483)%NYMD = 20090728 + TES(3484)%NYMD = 20090728 + TES(3485)%NYMD = 20090728 + TES(3486)%NYMD = 20090728 + TES(3487)%NYMD = 20090728 + TES(3488)%NYMD = 20090728 + TES(3489)%NYMD = 20090728 + TES(3490)%NYMD = 20090728 + TES(3491)%NYMD = 20090728 + TES(3492)%NYMD = 20090728 + TES(3493)%NYMD = 20090728 + TES(3494)%NYMD = 20090728 + TES(3495)%NYMD = 20090728 + TES(3496)%NYMD = 20090728 + TES(3497)%NYMD = 20090728 + TES(3498)%NYMD = 20090728 + TES(3499)%NYMD = 20090728 + TES(3500)%NYMD = 20090728 + TES(3501)%NYMD = 20090728 + TES(3502)%NYMD = 20090728 + TES(3503)%NYMD = 20090728 + TES(3504)%NYMD = 20090728 + TES(3505)%NYMD = 20090728 + TES(3506)%NYMD = 20090728 + TES(3507)%NYMD = 20090728 + TES(3508)%NYMD = 20090728 + TES(3509)%NYMD = 20090728 + TES(3510)%NYMD = 20090728 + TES(3511)%NYMD = 20090728 + TES(3512)%NYMD = 20090728 + TES(3513)%NYMD = 20090728 + TES(3514)%NYMD = 20090728 + TES(3515)%NYMD = 20090728 + TES(3516)%NYMD = 20090728 + TES(3517)%NYMD = 20090728 + TES(3518)%NYMD = 20090728 + TES(3519)%NYMD = 20090728 + TES(3520)%NYMD = 20090728 + TES(3521)%NYMD = 20090728 + TES(3522)%NYMD = 20090728 + TES(3523)%NYMD = 20090728 + TES(3524)%NYMD = 20090728 + TES(3525)%NYMD = 20090728 + TES(3526)%NYMD = 20090728 + TES(3527)%NYMD = 20090728 + TES(3528)%NYMD = 20090728 + TES(3529)%NYMD = 20090728 + TES(3530)%NYMD = 20090728 + TES(3531)%NYMD = 20090728 + TES(3532)%NYMD = 20090728 + TES(3533)%NYMD = 20090728 + TES(3534)%NYMD = 20090728 + TES(3535)%NYMD = 20090728 + TES(3536)%NYMD = 20090728 + TES(3537)%NYMD = 20090728 + TES(3538)%NYMD = 20090728 + TES(3539)%NYMD = 20090728 + TES(3540)%NYMD = 20090728 + TES(3541)%NYMD = 20090728 + TES(3542)%NYMD = 20090728 + TES(3543)%NYMD = 20090728 + TES(3544)%NYMD = 20090728 + TES(3545)%NYMD = 20090728 + TES(3546)%NYMD = 20090728 + TES(3547)%NYMD = 20090728 + TES(3548)%NYMD = 20090728 + TES(3549)%NYMD = 20090728 + TES(3550)%NYMD = 20090728 + TES(3551)%NYMD = 20090728 + TES(3552)%NYMD = 20090728 + TES(3553)%NYMD = 20090728 + TES(3554)%NYMD = 20090728 + TES(3555)%NYMD = 20090728 + TES(3556)%NYMD = 20090728 + TES(3557)%NYMD = 20090728 + TES(3558)%NYMD = 20090728 + TES(3559)%NYMD = 20090728 + TES(3560)%NYMD = 20090728 + TES(3561)%NYMD = 20090728 + TES(3562)%NYMD = 20090728 + TES(3563)%NYMD = 20090728 + TES(3564)%NYMD = 20090728 + TES(3565)%NYMD = 20090728 + TES(3566)%NYMD = 20090728 + TES(3567)%NYMD = 20090728 + TES(3568)%NYMD = 20090728 + TES(3569)%NYMD = 20090728 + TES(3570)%NYMD = 20090728 + TES(3571)%NYMD = 20090728 + TES(3572)%NYMD = 20090728 + TES(3573)%NYMD = 20090728 + TES(3574)%NYMD = 20090728 + TES(3575)%NYMD = 20090729 + TES(3576)%NYMD = 20090729 + TES(3577)%NYMD = 20090729 + TES(3578)%NYMD = 20090729 + TES(3579)%NYMD = 20090729 + TES(3580)%NYMD = 20090729 + TES(3581)%NYMD = 20090729 + TES(3582)%NYMD = 20090729 + TES(3583)%NYMD = 20090729 + TES(3584)%NYMD = 20090729 + TES(3585)%NYMD = 20090729 + TES(3586)%NYMD = 20090729 + TES(3587)%NYMD = 20090729 + TES(3588)%NYMD = 20090729 + TES(3589)%NYMD = 20090729 + TES(3590)%NYMD = 20090729 + TES(3591)%NYMD = 20090729 + TES(3592)%NYMD = 20090729 + TES(3593)%NYMD = 20090729 + TES(3594)%NYMD = 20090729 + TES(3595)%NYMD = 20090729 + TES(3596)%NYMD = 20090729 + TES(3597)%NYMD = 20090729 + TES(3598)%NYMD = 20090729 + TES(3599)%NYMD = 20090729 + TES(3600)%NYMD = 20090729 + TES(3601)%NYMD = 20090729 + TES(3602)%NYMD = 20090729 + TES(3603)%NYMD = 20090729 + TES(3604)%NYMD = 20090729 + TES(3605)%NYMD = 20090729 + TES(3606)%NYMD = 20090729 + TES(3607)%NYMD = 20090729 + TES(3608)%NYMD = 20090729 + TES(3609)%NYMD = 20090729 + TES(3610)%NYMD = 20090729 + TES(3611)%NYMD = 20090729 + TES(3612)%NYMD = 20090729 + TES(3613)%NYMD = 20090729 + TES(3614)%NYMD = 20090729 + TES(3615)%NYMD = 20090729 + TES(3616)%NYMD = 20090729 + TES(3617)%NYMD = 20090729 + TES(3618)%NYMD = 20090729 + TES(3619)%NYMD = 20090729 + TES(3620)%NYMD = 20090729 + TES(3621)%NYMD = 20090729 + TES(3622)%NYMD = 20090729 + TES(3623)%NYMD = 20090729 + TES(3624)%NYMD = 20090729 + TES(3625)%NYMD = 20090729 + TES(3626)%NYMD = 20090729 + TES(3627)%NYMD = 20090729 + TES(3628)%NYMD = 20090729 + TES(3629)%NYMD = 20090729 + TES(3630)%NYMD = 20090729 + TES(3631)%NYMD = 20090729 + TES(3632)%NYMD = 20090729 + TES(3633)%NYMD = 20090729 + TES(3634)%NYMD = 20090729 + TES(3635)%NYMD = 20090729 + TES(3636)%NYMD = 20090729 + TES(3637)%NYMD = 20090729 + TES(3638)%NYMD = 20090729 + TES(3639)%NYMD = 20090729 + TES(3640)%NYMD = 20090729 + TES(3641)%NYMD = 20090729 + TES(3642)%NYMD = 20090729 + TES(3643)%NYMD = 20090729 + TES(3644)%NYMD = 20090729 + TES(3645)%NYMD = 20090729 + TES(3646)%NYMD = 20090729 + TES(3647)%NYMD = 20090729 + TES(3648)%NYMD = 20090729 + TES(3649)%NYMD = 20090729 + TES(3650)%NYMD = 20090729 + TES(3651)%NYMD = 20090729 + TES(3652)%NYMD = 20090729 + TES(3653)%NYMD = 20090729 + TES(3654)%NYMD = 20090729 + TES(3655)%NYMD = 20090729 + TES(3656)%NYMD = 20090729 + TES(3657)%NYMD = 20090729 + TES(3658)%NYMD = 20090729 + TES(3659)%NYMD = 20090729 + TES(3660)%NYMD = 20090729 + TES(3661)%NYMD = 20090729 + TES(3662)%NYMD = 20090729 + TES(3663)%NYMD = 20090729 + TES(3664)%NYMD = 20090729 + TES(3665)%NYMD = 20090729 + TES(3666)%NYMD = 20090729 + TES(3667)%NYMD = 20090729 + TES(3668)%NYMD = 20090729 + TES(3669)%NYMD = 20090729 + TES(3670)%NYMD = 20090729 + TES(3671)%NYMD = 20090729 + TES(3672)%NYMD = 20090729 + TES(3673)%NYMD = 20090729 + TES(3674)%NYMD = 20090729 + TES(3675)%NYMD = 20090729 + TES(3676)%NYMD = 20090729 + TES(3677)%NYMD = 20090729 + TES(3678)%NYMD = 20090729 + TES(3679)%NYMD = 20090729 + TES(3680)%NYMD = 20090729 + TES(3681)%NYMD = 20090729 + TES(3682)%NYMD = 20090729 + TES(3683)%NYMD = 20090729 + TES(3684)%NYMD = 20090729 + TES(3685)%NYMD = 20090729 + TES(3686)%NYMD = 20090729 + TES(3687)%NYMD = 20090729 + TES(3688)%NYMD = 20090729 + TES(3689)%NYMD = 20090729 + TES(3690)%NYMD = 20090729 + TES(3691)%NYMD = 20090729 + TES(3692)%NYMD = 20090729 + TES(3693)%NYMD = 20090729 + TES(3694)%NYMD = 20090729 + TES(3695)%NYMD = 20090729 + TES(3696)%NYMD = 20090729 + TES(3697)%NYMD = 20090729 + TES(3698)%NYMD = 20090729 + TES(3699)%NYMD = 20090729 + TES(3700)%NYMD = 20090729 + TES(3701)%NYMD = 20090729 + TES(3702)%NYMD = 20090729 + TES(3703)%NYMD = 20090729 + TES(3704)%NYMD = 20090729 + TES(3705)%NYMD = 20090730 + TES(3706)%NYMD = 20090730 + TES(3707)%NYMD = 20090730 + TES(3708)%NYMD = 20090730 + TES(3709)%NYMD = 20090730 + TES(3710)%NYMD = 20090730 + TES(3711)%NYMD = 20090730 + TES(3712)%NYMD = 20090730 + TES(3713)%NYMD = 20090730 + TES(3714)%NYMD = 20090730 + TES(3715)%NYMD = 20090730 + TES(3716)%NYMD = 20090730 + TES(3717)%NYMD = 20090730 + TES(3718)%NYMD = 20090730 + TES(3719)%NYMD = 20090730 + TES(3720)%NYMD = 20090730 + TES(3721)%NYMD = 20090730 + TES(3722)%NYMD = 20090730 + TES(3723)%NYMD = 20090730 + TES(3724)%NYMD = 20090730 + TES(3725)%NYMD = 20090730 + TES(3726)%NYMD = 20090730 + TES(3727)%NYMD = 20090730 + TES(3728)%NYMD = 20090730 + TES(3729)%NYMD = 20090730 + TES(3730)%NYMD = 20090730 + TES(3731)%NYMD = 20090730 + TES(3732)%NYMD = 20090730 + TES(3733)%NYMD = 20090730 + TES(3734)%NYMD = 20090730 + TES(3735)%NYMD = 20090730 + TES(3736)%NYMD = 20090730 + TES(3737)%NYMD = 20090730 + TES(3738)%NYMD = 20090730 + TES(3739)%NYMD = 20090730 + TES(3740)%NYMD = 20090730 + TES(3741)%NYMD = 20090730 + TES(3742)%NYMD = 20090730 + TES(3743)%NYMD = 20090730 + TES(3744)%NYMD = 20090730 + TES(3745)%NYMD = 20090730 + TES(3746)%NYMD = 20090730 + TES(3747)%NYMD = 20090730 + TES(3748)%NYMD = 20090730 + TES(3749)%NYMD = 20090730 + TES(3750)%NYMD = 20090730 + TES(3751)%NYMD = 20090730 + TES(3752)%NYMD = 20090730 + TES(3753)%NYMD = 20090730 + TES(3754)%NYMD = 20090730 + TES(3755)%NYMD = 20090730 + TES(3756)%NYMD = 20090730 + TES(3757)%NYMD = 20090730 + TES(3758)%NYMD = 20090730 + TES(3759)%NYMD = 20090730 + TES(3760)%NYMD = 20090730 + TES(3761)%NYMD = 20090730 + TES(3762)%NYMD = 20090730 + TES(3763)%NYMD = 20090730 + TES(3764)%NYMD = 20090730 + TES(3765)%NYMD = 20090730 + TES(3766)%NYMD = 20090730 + TES(3767)%NYMD = 20090730 + TES(3768)%NYMD = 20090730 + TES(3769)%NYMD = 20090730 + TES(3770)%NYMD = 20090730 + TES(3771)%NYMD = 20090730 + TES(3772)%NYMD = 20090730 + TES(3773)%NYMD = 20090730 + TES(3774)%NYMD = 20090730 + TES(3775)%NYMD = 20090730 + TES(3776)%NYMD = 20090730 + TES(3777)%NYMD = 20090730 + TES(3778)%NYMD = 20090730 + TES(3779)%NYMD = 20090730 + TES(3780)%NYMD = 20090730 + TES(3781)%NYMD = 20090730 + TES(3782)%NYMD = 20090730 + TES(3783)%NYMD = 20090730 + TES(3784)%NYMD = 20090730 + TES(3785)%NYMD = 20090730 + TES(3786)%NYMD = 20090730 + TES(3787)%NYMD = 20090730 + TES(3788)%NYMD = 20090730 + TES(3789)%NYMD = 20090730 + TES(3790)%NYMD = 20090730 + TES(3791)%NYMD = 20090730 + TES(3792)%NYMD = 20090730 + TES(3793)%NYMD = 20090730 + TES(3794)%NYMD = 20090730 + TES(3795)%NYMD = 20090730 + TES(3796)%NYMD = 20090730 + TES(3797)%NYMD = 20090730 + TES(3798)%NYMD = 20090730 + TES(3799)%NYMD = 20090730 + TES(3800)%NYMD = 20090730 + TES(3801)%NYMD = 20090730 + TES(3802)%NYMD = 20090730 + TES(3803)%NYMD = 20090730 + TES(3804)%NYMD = 20090730 + TES(3805)%NYMD = 20090730 + TES(3806)%NYMD = 20090730 + TES(3807)%NYMD = 20090730 + TES(3808)%NYMD = 20090730 + TES(3809)%NYMD = 20090730 + TES(3810)%NYMD = 20090730 + TES(3811)%NYMD = 20090730 + TES(3812)%NYMD = 20090730 + TES(3813)%NYMD = 20090730 + TES(3814)%NYMD = 20090730 + TES(3815)%NYMD = 20090730 + TES(3816)%NYMD = 20090730 + TES(3817)%NYMD = 20090730 + TES(3818)%NYMD = 20090730 + TES(3819)%NYMD = 20090730 + TES(3820)%NYMD = 20090730 + TES(3821)%NYMD = 20090730 + TES(3822)%NYMD = 20090730 + TES(3823)%NYMD = 20090730 + TES(3824)%NYMD = 20090730 + TES(3825)%NYMD = 20090730 + TES(3826)%NYMD = 20090730 + TES(3827)%NYMD = 20090730 + TES(3828)%NYMD = 20090730 + TES(3829)%NYMD = 20090730 + TES(3830)%NYMD = 20090730 + TES(3831)%NYMD = 20090730 + TES(3832)%NYMD = 20090730 + TES(3833)%NYMD = 20090730 + TES(3834)%NYMD = 20090730 + TES(3835)%NYMD = 20090730 + TES(3836)%NYMD = 20090730 + TES(3837)%NYMD = 20090730 + TES(3838)%NYMD = 20090730 + TES(3839)%NYMD = 20090730 + TES(3840)%NYMD = 20090730 + TES(3841)%NYMD = 20090731 + TES(3842)%NYMD = 20090731 + TES(3843)%NYMD = 20090731 + TES(3844)%NYMD = 20090731 + TES(3845)%NYMD = 20090731 + TES(3846)%NYMD = 20090731 + TES(3847)%NYMD = 20090731 + TES(3848)%NYMD = 20090731 + TES(3849)%NYMD = 20090731 + TES(3850)%NYMD = 20090731 + TES(3851)%NYMD = 20090731 + TES(3852)%NYMD = 20090731 + TES(3853)%NYMD = 20090731 + TES(3854)%NYMD = 20090731 + TES(3855)%NYMD = 20090731 + TES(3856)%NYMD = 20090731 + TES(3857)%NYMD = 20090731 + TES(3858)%NYMD = 20090731 + TES(3859)%NYMD = 20090731 + TES(3860)%NYMD = 20090731 + TES(3861)%NYMD = 20090731 + TES(3862)%NYMD = 20090731 + TES(3863)%NYMD = 20090731 + TES(3864)%NYMD = 20090731 + TES(3865)%NYMD = 20090731 + TES(3866)%NYMD = 20090731 + TES(3867)%NYMD = 20090731 + TES(3868)%NYMD = 20090731 + TES(3869)%NYMD = 20090731 + TES(3870)%NYMD = 20090731 + TES(3871)%NYMD = 20090731 + TES(3872)%NYMD = 20090731 + TES(3873)%NYMD = 20090731 + TES(3874)%NYMD = 20090731 + TES(3875)%NYMD = 20090731 + TES(3876)%NYMD = 20090731 + TES(3877)%NYMD = 20090731 + TES(3878)%NYMD = 20090731 + TES(3879)%NYMD = 20090731 + TES(3880)%NYMD = 20090731 + TES(3881)%NYMD = 20090731 + TES(3882)%NYMD = 20090731 + TES(3883)%NYMD = 20090731 + TES(3884)%NYMD = 20090731 + TES(3885)%NYMD = 20090731 + TES(3886)%NYMD = 20090731 + TES(3887)%NYMD = 20090731 + TES(3888)%NYMD = 20090731 + TES(3889)%NYMD = 20090731 + TES(3890)%NYMD = 20090731 + TES(3891)%NYMD = 20090731 + TES(3892)%NYMD = 20090731 + TES(3893)%NYMD = 20090731 + TES(3894)%NYMD = 20090731 + TES(3895)%NYMD = 20090731 + TES(3896)%NYMD = 20090731 + TES(3897)%NYMD = 20090731 + TES(3898)%NYMD = 20090731 + TES(3899)%NYMD = 20090731 + TES(3900)%NYMD = 20090731 + TES(3901)%NYMD = 20090731 + TES(3902)%NYMD = 20090731 + TES(3903)%NYMD = 20090731 + TES(3904)%NYMD = 20090731 + TES(3905)%NYMD = 20090731 + TES(3906)%NYMD = 20090731 + TES(3907)%NYMD = 20090731 + TES(3908)%NYMD = 20090731 + TES(3909)%NYMD = 20090731 + TES(3910)%NYMD = 20090731 + TES(3911)%NYMD = 20090731 + TES(3912)%NYMD = 20090731 + TES(3913)%NYMD = 20090731 + TES(3914)%NYMD = 20090731 + TES(3915)%NYMD = 20090731 + TES(3916)%NYMD = 20090731 + TES(3917)%NYMD = 20090731 + TES(3918)%NYMD = 20090731 + TES(3919)%NYMD = 20090731 + TES(3920)%NYMD = 20090731 + TES(3921)%NYMD = 20090731 + TES(3922)%NYMD = 20090731 + TES(3923)%NYMD = 20090731 + TES(3924)%NYMD = 20090731 + TES(3925)%NYMD = 20090731 + TES(3926)%NYMD = 20090731 + TES(3927)%NYMD = 20090731 + TES(3928)%NYMD = 20090731 + TES(3929)%NYMD = 20090731 + TES(3930)%NYMD = 20090731 + TES(3931)%NYMD = 20090731 + TES(3932)%NYMD = 20090731 + TES(3933)%NYMD = 20090731 + TES(3934)%NYMD = 20090731 + TES(3935)%NYMD = 20090731 + TES(3936)%NYMD = 20090731 + TES(3937)%NYMD = 20090731 + TES(3938)%NYMD = 20090731 + TES(3939)%NYMD = 20090731 + TES(3940)%NYMD = 20090731 + TES(3941)%NYMD = 20090731 + TES(3942)%NYMD = 20090731 + TES(3943)%NYMD = 20090731 + TES(3944)%NYMD = 20090731 + TES(3945)%NYMD = 20090731 + TES(3946)%NYMD = 20090731 + TES(3947)%NYMD = 20090731 + TES(3948)%NYMD = 20090731 + TES(3949)%NYMD = 20090731 + TES(3950)%NYMD = 20090731 + TES(3951)%NYMD = 20090731 + TES(3952)%NYMD = 20090731 + TES(3953)%NYMD = 20090731 + TES(3954)%NYMD = 20090731 + TES(3955)%NYMD = 20090731 + TES(3956)%NYMD = 20090731 + TES(3957)%NYMD = 20090731 + TES(3958)%NYMD = 20090731 + TES(3959)%NYMD = 20090731 + TES(3960)%NYMD = 20090731 + TES(3961)%NYMD = 20090731 + TES(3962)%NYMD = 20090731 + TES(3963)%NYMD = 20090731 + TES(3964)%NYMD = 20090731 + TES(3965)%NYMD = 20090731 + TES(3966)%NYMD = 20090731 + TES(3967)%NYMD = 20090731 + TES(3968)%NYMD = 20090731 + TES(3969)%NYMD = 20090731 + TES(3970)%NYMD = 20090731 + TES(3971)%NYMD = 20090731 + TES(3972)%NYMD = 20090731 + TES(3973)%NYMD = 20090731 + TES(3974)%NYMD = 20090731 + TES(3975)%NYMD = 20090731 + TES(3976)%NYMD = 20090731 + TES(3977)%NYMD = 20090731 + TES(3978)%NYMD = 20090731 + TES(3979)%NYMD = 20090731 + TES(3980)%NYMD = 20090731 + TES(3981)%NYMD = 20090731 + TES(3982)%NYMD = 20090731 + TES(3983)%NYMD = 20090731 + TES(3984)%NYMD = 20090731 + TES(3985)%NYMD = 20090731 + TES(3986)%NYMD = 20090731 + TES(3987)%NYMD = 20090731 + TES(3988)%NYMD = 20090731 + TES(3989)%NYMD = 20090731 + TES(3990)%NYMD = 20090731 + TES(3991)%NYMD = 20090731 + + + TES(1)%NHMS = 101700 + TES(2)%NHMS = 101700 + TES(3)%NHMS = 101800 + TES(4)%NHMS = 101900 + TES(5)%NHMS = 102000 + TES(6)%NHMS = 102100 + TES(7)%NHMS = 102100 + TES(8)%NHMS = 102200 + TES(9)%NHMS = 102200 + TES(10)%NHMS = 102300 + TES(11)%NHMS = 102300 + TES(12)%NHMS = 104100 + TES(13)%NHMS = 104100 + TES(14)%NHMS = 104200 + TES(15)%NHMS = 114000 + TES(16)%NHMS = 114300 + TES(17)%NHMS = 114300 + TES(18)%NHMS = 114400 + TES(19)%NHMS = 114700 + TES(20)%NHMS = 114800 + TES(21)%NHMS = 115100 + TES(22)%NHMS = 115300 + TES(23)%NHMS = 115500 + TES(24)%NHMS = 115600 + TES(25)%NHMS = 115700 + TES(26)%NHMS = 115700 + TES(27)%NHMS = 115800 + TES(28)%NHMS = 115900 + TES(29)%NHMS = 115900 + TES(30)%NHMS = 120000 + TES(31)%NHMS = 120100 + TES(32)%NHMS = 132600 + TES(33)%NHMS = 132700 + TES(34)%NHMS = 132700 + TES(35)%NHMS = 155500 + TES(36)%NHMS = 155800 + TES(37)%NHMS = 155800 + TES(38)%NHMS = 160200 + TES(39)%NHMS = 160200 + TES(40)%NHMS = 163800 + TES(41)%NHMS = 163800 + TES(42)%NHMS = 163800 + TES(43)%NHMS = 163900 + TES(44)%NHMS = 163900 + TES(45)%NHMS = 164000 + TES(46)%NHMS = 164000 + TES(47)%NHMS = 165500 + TES(48)%NHMS = 165500 + TES(49)%NHMS = 165600 + TES(50)%NHMS = 165600 + TES(51)%NHMS = 165700 + TES(52)%NHMS = 171600 + TES(53)%NHMS = 171700 + TES(54)%NHMS = 171700 + TES(55)%NHMS = 172200 + TES(56)%NHMS = 172900 + TES(57)%NHMS = 172900 + TES(58)%NHMS = 172900 + TES(59)%NHMS = 173700 + TES(60)%NHMS = 174100 + TES(61)%NHMS = 181000 + TES(62)%NHMS = 181100 + TES(63)%NHMS = 181200 + TES(64)%NHMS = 181200 + TES(65)%NHMS = 181400 + TES(66)%NHMS = 181400 + TES(67)%NHMS = 181500 + TES(68)%NHMS = 181500 + TES(69)%NHMS = 181600 + TES(70)%NHMS = 181700 + TES(71)%NHMS = 181700 + TES(72)%NHMS = 181800 + TES(73)%NHMS = 181800 + TES(74)%NHMS = 181900 + TES(75)%NHMS = 181900 + TES(76)%NHMS = 182000 + TES(77)%NHMS = 182000 + TES(78)%NHMS = 182000 + TES(79)%NHMS = 182100 + TES(80)%NHMS = 182300 + TES(81)%NHMS = 182400 + TES(82)%NHMS = 182600 + TES(83)%NHMS = 183000 + TES(84)%NHMS = 183100 + TES(85)%NHMS = 183100 + TES(86)%NHMS = 183200 + TES(87)%NHMS = 183300 + TES(88)%NHMS = 183500 + TES(89)%NHMS = 183500 + TES(90)%NHMS = 183600 + TES(91)%NHMS = 185400 + TES(92)%NHMS = 185400 + TES(93)%NHMS = 185500 + TES(94)%NHMS = 185500 + TES(95)%NHMS = 185500 + TES(96)%NHMS = 185600 + TES(97)%NHMS = 185600 + TES(98)%NHMS = 185700 + TES(99)%NHMS = 190400 + TES(100)%NHMS = 190500 + TES(101)%NHMS = 190500 + TES(102)%NHMS = 190500 + TES(103)%NHMS = 190800 + TES(104)%NHMS = 190900 + TES(105)%NHMS = 200400 + TES(106)%NHMS = 200500 + TES(107)%NHMS = 200600 + TES(108)%NHMS = 200700 + TES(109)%NHMS = 200800 + TES(110)%NHMS = 200900 + TES(111)%NHMS = 200900 + TES(112)%NHMS = 201000 + TES(113)%NHMS = 201200 + TES(114)%NHMS = 201300 + TES(115)%NHMS = 201400 + TES(116)%NHMS = 201500 + TES(117)%NHMS = 201600 + TES(118)%NHMS = 203200 + TES(119)%NHMS = 203300 + TES(120)%NHMS = 203300 + TES(121)%NHMS = 203500 + TES(122)%NHMS = 203600 + TES(123)%NHMS = 203600 + TES(124)%NHMS = 203600 + TES(125)%NHMS = 203700 + TES(126)%NHMS = 203700 + TES(127)%NHMS = 204100 + TES(128)%NHMS = 204200 + TES(129)%NHMS = 204500 + TES(130)%NHMS = 215300 + TES(131)%NHMS = 221300 + TES(132)%NHMS = 221300 + TES(133)%NHMS = 221800 + TES(134)%NHMS = 223300 + TES(135)%NHMS = 223300 + TES(136)%NHMS = 223300 + TES(137)%NHMS = 223400 + TES(138)%NHMS = 233300 + TES(139)%NHMS = 233400 + TES(140)%NHMS = 235000 + TES(141)%NHMS = 235100 + TES(142)%NHMS = 235100 + TES(143)%NHMS = 235200 + TES(144)%NHMS = 235300 + TES(145)%NHMS = 235400 + TES(146)%NHMS = 235500 + TES(147)%NHMS = 235600 + TES(148)%NHMS = 235600 + TES(149)%NHMS = 000100 + TES(150)%NHMS = 000100 + TES(151)%NHMS = 000200 + TES(152)%NHMS = 000300 + TES(153)%NHMS = 000500 + TES(154)%NHMS = 000500 + TES(155)%NHMS = 000600 + TES(156)%NHMS = 000700 + TES(157)%NHMS = 000800 + TES(158)%NHMS = 000800 + TES(159)%NHMS = 000900 + TES(160)%NHMS = 000900 + TES(161)%NHMS = 001000 + TES(162)%NHMS = 001000 + TES(163)%NHMS = 001100 + TES(164)%NHMS = 012900 + TES(165)%NHMS = 013200 + TES(166)%NHMS = 013300 + TES(167)%NHMS = 013400 + TES(168)%NHMS = 013600 + TES(169)%NHMS = 014200 + TES(170)%NHMS = 014300 + TES(171)%NHMS = 014300 + TES(172)%NHMS = 014400 + TES(173)%NHMS = 030800 + TES(174)%NHMS = 031000 + TES(175)%NHMS = 031700 + TES(176)%NHMS = 040500 + TES(177)%NHMS = 040500 + TES(178)%NHMS = 040600 + TES(179)%NHMS = 040700 + TES(180)%NHMS = 040700 + TES(181)%NHMS = 040800 + TES(182)%NHMS = 042600 + TES(183)%NHMS = 042700 + TES(184)%NHMS = 042800 + TES(185)%NHMS = 042800 + TES(186)%NHMS = 042900 + TES(187)%NHMS = 050400 + TES(188)%NHMS = 050400 + TES(189)%NHMS = 050400 + TES(190)%NHMS = 050500 + TES(191)%NHMS = 050500 + TES(192)%NHMS = 050600 + TES(193)%NHMS = 050700 + TES(194)%NHMS = 050700 + TES(195)%NHMS = 050800 + TES(196)%NHMS = 051000 + TES(197)%NHMS = 051100 + TES(198)%NHMS = 051200 + TES(199)%NHMS = 051200 + TES(200)%NHMS = 054800 + TES(201)%NHMS = 055200 + TES(202)%NHMS = 055300 + TES(203)%NHMS = 055400 + TES(204)%NHMS = 055500 + TES(205)%NHMS = 060600 + TES(206)%NHMS = 060600 + TES(207)%NHMS = 060900 + TES(208)%NHMS = 060900 + TES(209)%NHMS = 061000 + TES(210)%NHMS = 062700 + TES(211)%NHMS = 062800 + TES(212)%NHMS = 062800 + TES(213)%NHMS = 063000 + TES(214)%NHMS = 064100 + TES(215)%NHMS = 064300 + TES(216)%NHMS = 064400 + TES(217)%NHMS = 064400 + TES(218)%NHMS = 064500 + TES(219)%NHMS = 064500 + TES(220)%NHMS = 073900 + TES(221)%NHMS = 074000 + TES(222)%NHMS = 074100 + TES(223)%NHMS = 074300 + TES(224)%NHMS = 074400 + TES(225)%NHMS = 074500 + TES(226)%NHMS = 074600 + TES(227)%NHMS = 074600 + TES(228)%NHMS = 074800 + TES(229)%NHMS = 080700 + TES(230)%NHMS = 080700 + TES(231)%NHMS = 081000 + TES(232)%NHMS = 081000 + TES(233)%NHMS = 081100 + TES(234)%NHMS = 081100 + TES(235)%NHMS = 081200 + TES(236)%NHMS = 081200 + TES(237)%NHMS = 081700 + TES(238)%NHMS = 092000 + TES(239)%NHMS = 092100 + TES(240)%NHMS = 092300 + TES(241)%NHMS = 092300 + TES(242)%NHMS = 092400 + TES(243)%NHMS = 092400 + TES(244)%NHMS = 092500 + TES(245)%NHMS = 092500 + TES(246)%NHMS = 092600 + TES(247)%NHMS = 092700 + TES(248)%NHMS = 092700 + TES(249)%NHMS = 094400 + TES(250)%NHMS = 094500 + TES(251)%NHMS = 094600 + TES(252)%NHMS = 094600 + TES(253)%NHMS = 094700 + TES(254)%NHMS = 094700 + TES(255)%NHMS = 094800 + TES(256)%NHMS = 094800 + TES(257)%NHMS = 094800 + TES(258)%NHMS = 094900 + TES(259)%NHMS = 095000 + TES(260)%NHMS = 095100 + TES(261)%NHMS = 095100 + TES(262)%NHMS = 104500 + TES(263)%NHMS = 105000 + TES(264)%NHMS = 105100 + TES(265)%NHMS = 105200 + TES(266)%NHMS = 105900 + TES(267)%NHMS = 110000 + TES(268)%NHMS = 110100 + TES(269)%NHMS = 110200 + TES(270)%NHMS = 110600 + TES(271)%NHMS = 112300 + TES(272)%NHMS = 112300 + TES(273)%NHMS = 114400 + TES(274)%NHMS = 100400 + TES(275)%NHMS = 100500 + TES(276)%NHMS = 100600 + TES(277)%NHMS = 100800 + TES(278)%NHMS = 100900 + TES(279)%NHMS = 100900 + TES(280)%NHMS = 101000 + TES(281)%NHMS = 101100 + TES(282)%NHMS = 102700 + TES(283)%NHMS = 102800 + TES(284)%NHMS = 102900 + TES(285)%NHMS = 103000 + TES(286)%NHMS = 113300 + TES(287)%NHMS = 113300 + TES(288)%NHMS = 113300 + TES(289)%NHMS = 113800 + TES(290)%NHMS = 113900 + TES(291)%NHMS = 114000 + TES(292)%NHMS = 114400 + TES(293)%NHMS = 114400 + TES(294)%NHMS = 114500 + TES(295)%NHMS = 114600 + TES(296)%NHMS = 114600 + TES(297)%NHMS = 114700 + TES(298)%NHMS = 114800 + TES(299)%NHMS = 131500 + TES(300)%NHMS = 132400 + TES(301)%NHMS = 132700 + TES(302)%NHMS = 134600 + TES(303)%NHMS = 154300 + TES(304)%NHMS = 154600 + TES(305)%NHMS = 154600 + TES(306)%NHMS = 154700 + TES(307)%NHMS = 154900 + TES(308)%NHMS = 155000 + TES(309)%NHMS = 162600 + TES(310)%NHMS = 162700 + TES(311)%NHMS = 162700 + TES(312)%NHMS = 162800 + TES(313)%NHMS = 162800 + TES(314)%NHMS = 164300 + TES(315)%NHMS = 170500 + TES(316)%NHMS = 171900 + TES(317)%NHMS = 172000 + TES(318)%NHMS = 172300 + TES(319)%NHMS = 172800 + TES(320)%NHMS = 172800 + TES(321)%NHMS = 175900 + TES(322)%NHMS = 175900 + TES(323)%NHMS = 180000 + TES(324)%NHMS = 180000 + TES(325)%NHMS = 180100 + TES(326)%NHMS = 180200 + TES(327)%NHMS = 180200 + TES(328)%NHMS = 180400 + TES(329)%NHMS = 180700 + TES(330)%NHMS = 180800 + TES(331)%NHMS = 180800 + TES(332)%NHMS = 180900 + TES(333)%NHMS = 181000 + TES(334)%NHMS = 181100 + TES(335)%NHMS = 181900 + TES(336)%NHMS = 182000 + TES(337)%NHMS = 182100 + TES(338)%NHMS = 182300 + TES(339)%NHMS = 184300 + TES(340)%NHMS = 184300 + TES(341)%NHMS = 184800 + TES(342)%NHMS = 184900 + TES(343)%NHMS = 185000 + TES(344)%NHMS = 185400 + TES(345)%NHMS = 185500 + TES(346)%NHMS = 185800 + TES(347)%NHMS = 185900 + TES(348)%NHMS = 195200 + TES(349)%NHMS = 195500 + TES(350)%NHMS = 195600 + TES(351)%NHMS = 195600 + TES(352)%NHMS = 195700 + TES(353)%NHMS = 195800 + TES(354)%NHMS = 200100 + TES(355)%NHMS = 200300 + TES(356)%NHMS = 202000 + TES(357)%NHMS = 202000 + TES(358)%NHMS = 202100 + TES(359)%NHMS = 202100 + TES(360)%NHMS = 202200 + TES(361)%NHMS = 202200 + TES(362)%NHMS = 202400 + TES(363)%NHMS = 202500 + TES(364)%NHMS = 202600 + TES(365)%NHMS = 203000 + TES(366)%NHMS = 203000 + TES(367)%NHMS = 203100 + TES(368)%NHMS = 214100 + TES(369)%NHMS = 214100 + TES(370)%NHMS = 214200 + TES(371)%NHMS = 214200 + TES(372)%NHMS = 214300 + TES(373)%NHMS = 220000 + TES(374)%NHMS = 220100 + TES(375)%NHMS = 220300 + TES(376)%NHMS = 220600 + TES(377)%NHMS = 220600 + TES(378)%NHMS = 220700 + TES(379)%NHMS = 222000 + TES(380)%NHMS = 233900 + TES(381)%NHMS = 234000 + TES(382)%NHMS = 234000 + TES(383)%NHMS = 234100 + TES(384)%NHMS = 234100 + TES(385)%NHMS = 234200 + TES(386)%NHMS = 234300 + TES(387)%NHMS = 234300 + TES(388)%NHMS = 234400 + TES(389)%NHMS = 234400 + TES(390)%NHMS = 234500 + TES(391)%NHMS = 234500 + TES(392)%NHMS = 234700 + TES(393)%NHMS = 234900 + TES(394)%NHMS = 234900 + TES(395)%NHMS = 235100 + TES(396)%NHMS = 235200 + TES(397)%NHMS = 235200 + TES(398)%NHMS = 235300 + TES(399)%NHMS = 235300 + TES(400)%NHMS = 235400 + TES(401)%NHMS = 235400 + TES(402)%NHMS = 235500 + TES(403)%NHMS = 235500 + TES(404)%NHMS = 235600 + TES(405)%NHMS = 235700 + TES(406)%NHMS = 235700 + TES(407)%NHMS = 235800 + TES(408)%NHMS = 235800 + TES(409)%NHMS = 000400 + TES(410)%NHMS = 000400 + TES(411)%NHMS = 012000 + TES(412)%NHMS = 012000 + TES(413)%NHMS = 012200 + TES(414)%NHMS = 012400 + TES(415)%NHMS = 012500 + TES(416)%NHMS = 012800 + TES(417)%NHMS = 013000 + TES(418)%NHMS = 022500 + TES(419)%NHMS = 023700 + TES(420)%NHMS = 023800 + TES(421)%NHMS = 025600 + TES(422)%NHMS = 025600 + TES(423)%NHMS = 035300 + TES(424)%NHMS = 035400 + TES(425)%NHMS = 035400 + TES(426)%NHMS = 035500 + TES(427)%NHMS = 035900 + TES(428)%NHMS = 041500 + TES(429)%NHMS = 041500 + TES(430)%NHMS = 041600 + TES(431)%NHMS = 041600 + TES(432)%NHMS = 041700 + TES(433)%NHMS = 041700 + TES(434)%NHMS = 041700 + TES(435)%NHMS = 041800 + TES(436)%NHMS = 045200 + TES(437)%NHMS = 045200 + TES(438)%NHMS = 045300 + TES(439)%NHMS = 045400 + TES(440)%NHMS = 045600 + TES(441)%NHMS = 045700 + TES(442)%NHMS = 045800 + TES(443)%NHMS = 045800 + TES(444)%NHMS = 045900 + TES(445)%NHMS = 045900 + TES(446)%NHMS = 050000 + TES(447)%NHMS = 053900 + TES(448)%NHMS = 054400 + TES(449)%NHMS = 054800 + TES(450)%NHMS = 054900 + TES(451)%NHMS = 055000 + TES(452)%NHMS = 055200 + TES(453)%NHMS = 055300 + TES(454)%NHMS = 055400 + TES(455)%NHMS = 055500 + TES(456)%NHMS = 055500 + TES(457)%NHMS = 055600 + TES(458)%NHMS = 055600 + TES(459)%NHMS = 055700 + TES(460)%NHMS = 055700 + TES(461)%NHMS = 062500 + TES(462)%NHMS = 062700 + TES(463)%NHMS = 063100 + TES(464)%NHMS = 063200 + TES(465)%NHMS = 063200 + TES(466)%NHMS = 063400 + TES(467)%NHMS = 063400 + TES(468)%NHMS = 072900 + TES(469)%NHMS = 073000 + TES(470)%NHMS = 073400 + TES(471)%NHMS = 073400 + TES(472)%NHMS = 073500 + TES(473)%NHMS = 073500 + TES(474)%NHMS = 073500 + TES(475)%NHMS = 073600 + TES(476)%NHMS = 075200 + TES(477)%NHMS = 075300 + TES(478)%NHMS = 075500 + TES(479)%NHMS = 075500 + TES(480)%NHMS = 075600 + TES(481)%NHMS = 075700 + TES(482)%NHMS = 075700 + TES(483)%NHMS = 075900 + TES(484)%NHMS = 080000 + TES(485)%NHMS = 080400 + TES(486)%NHMS = 080500 + TES(487)%NHMS = 090700 + TES(488)%NHMS = 091200 + TES(489)%NHMS = 091400 + TES(490)%NHMS = 091400 + TES(491)%NHMS = 091500 + TES(492)%NHMS = 093300 + TES(493)%NHMS = 093300 + TES(494)%NHMS = 093400 + TES(495)%NHMS = 093500 + TES(496)%NHMS = 093600 + TES(497)%NHMS = 093600 + TES(498)%NHMS = 093700 + TES(499)%NHMS = 093800 + TES(500)%NHMS = 093800 + TES(501)%NHMS = 094000 + TES(502)%NHMS = 104100 + TES(503)%NHMS = 104200 + TES(504)%NHMS = 104800 + TES(505)%NHMS = 104800 + TES(506)%NHMS = 105000 + TES(507)%NHMS = 105100 + TES(508)%NHMS = 105100 + TES(509)%NHMS = 105200 + TES(510)%NHMS = 105200 + TES(511)%NHMS = 105300 + TES(512)%NHMS = 105300 + TES(513)%NHMS = 105300 + TES(514)%NHMS = 105400 + TES(515)%NHMS = 111100 + TES(516)%NHMS = 111100 + TES(517)%NHMS = 111200 + TES(518)%NHMS = 095600 + TES(519)%NHMS = 095700 + TES(520)%NHMS = 101500 + TES(521)%NHMS = 101500 + TES(522)%NHMS = 101600 + TES(523)%NHMS = 101600 + TES(524)%NHMS = 101700 + TES(525)%NHMS = 101700 + TES(526)%NHMS = 101800 + TES(527)%NHMS = 101900 + TES(528)%NHMS = 102000 + TES(529)%NHMS = 103700 + TES(530)%NHMS = 111900 + TES(531)%NHMS = 112100 + TES(532)%NHMS = 112100 + TES(533)%NHMS = 112200 + TES(534)%NHMS = 112300 + TES(535)%NHMS = 112900 + TES(536)%NHMS = 113100 + TES(537)%NHMS = 113100 + TES(538)%NHMS = 113200 + TES(539)%NHMS = 113200 + TES(540)%NHMS = 113300 + TES(541)%NHMS = 113500 + TES(542)%NHMS = 113500 + TES(543)%NHMS = 113600 + TES(544)%NHMS = 115300 + TES(545)%NHMS = 125000 + TES(546)%NHMS = 125300 + TES(547)%NHMS = 125300 + TES(548)%NHMS = 125400 + TES(549)%NHMS = 125600 + TES(550)%NHMS = 125700 + TES(551)%NHMS = 125900 + TES(552)%NHMS = 125900 + TES(553)%NHMS = 130000 + TES(554)%NHMS = 130000 + TES(555)%NHMS = 130100 + TES(556)%NHMS = 130200 + TES(557)%NHMS = 130900 + TES(558)%NHMS = 130900 + TES(559)%NHMS = 131000 + TES(560)%NHMS = 131200 + TES(561)%NHMS = 131300 + TES(562)%NHMS = 131300 + TES(563)%NHMS = 131400 + TES(564)%NHMS = 131500 + TES(565)%NHMS = 131500 + TES(566)%NHMS = 135200 + TES(567)%NHMS = 140100 + TES(568)%NHMS = 140200 + TES(569)%NHMS = 153400 + TES(570)%NHMS = 153400 + TES(571)%NHMS = 153500 + TES(572)%NHMS = 153600 + TES(573)%NHMS = 153600 + TES(574)%NHMS = 153900 + TES(575)%NHMS = 161500 + TES(576)%NHMS = 165300 + TES(577)%NHMS = 165500 + TES(578)%NHMS = 165600 + TES(579)%NHMS = 165600 + TES(580)%NHMS = 170600 + TES(581)%NHMS = 170700 + TES(582)%NHMS = 171100 + TES(583)%NHMS = 171300 + TES(584)%NHMS = 171600 + TES(585)%NHMS = 174700 + TES(586)%NHMS = 174700 + TES(587)%NHMS = 174700 + TES(588)%NHMS = 174900 + TES(589)%NHMS = 175000 + TES(590)%NHMS = 175000 + TES(591)%NHMS = 175100 + TES(592)%NHMS = 175100 + TES(593)%NHMS = 175200 + TES(594)%NHMS = 175200 + TES(595)%NHMS = 175300 + TES(596)%NHMS = 175400 + TES(597)%NHMS = 175400 + TES(598)%NHMS = 175500 + TES(599)%NHMS = 175700 + TES(600)%NHMS = 175800 + TES(601)%NHMS = 175800 + TES(602)%NHMS = 180800 + TES(603)%NHMS = 180900 + TES(604)%NHMS = 181000 + TES(605)%NHMS = 181100 + TES(606)%NHMS = 182900 + TES(607)%NHMS = 183200 + TES(608)%NHMS = 183400 + TES(609)%NHMS = 183500 + TES(610)%NHMS = 183700 + TES(611)%NHMS = 183800 + TES(612)%NHMS = 183800 + TES(613)%NHMS = 183900 + TES(614)%NHMS = 184200 + TES(615)%NHMS = 184700 + TES(616)%NHMS = 193900 + TES(617)%NHMS = 193900 + TES(618)%NHMS = 194300 + TES(619)%NHMS = 194600 + TES(620)%NHMS = 194600 + TES(621)%NHMS = 194700 + TES(622)%NHMS = 194700 + TES(623)%NHMS = 194800 + TES(624)%NHMS = 194900 + TES(625)%NHMS = 195000 + TES(626)%NHMS = 200800 + TES(627)%NHMS = 200800 + TES(628)%NHMS = 200900 + TES(629)%NHMS = 200900 + TES(630)%NHMS = 201000 + TES(631)%NHMS = 201200 + TES(632)%NHMS = 201400 + TES(633)%NHMS = 201400 + TES(634)%NHMS = 201500 + TES(635)%NHMS = 201700 + TES(636)%NHMS = 201700 + TES(637)%NHMS = 201800 + TES(638)%NHMS = 201800 + TES(639)%NHMS = 212500 + TES(640)%NHMS = 212500 + TES(641)%NHMS = 212700 + TES(642)%NHMS = 212800 + TES(643)%NHMS = 212900 + TES(644)%NHMS = 212900 + TES(645)%NHMS = 214700 + TES(646)%NHMS = 214800 + TES(647)%NHMS = 214900 + TES(648)%NHMS = 214900 + TES(649)%NHMS = 215000 + TES(650)%NHMS = 215400 + TES(651)%NHMS = 215500 + TES(652)%NHMS = 230900 + TES(653)%NHMS = 232600 + TES(654)%NHMS = 232900 + TES(655)%NHMS = 232900 + TES(656)%NHMS = 233000 + TES(657)%NHMS = 233000 + TES(658)%NHMS = 233100 + TES(659)%NHMS = 233100 + TES(660)%NHMS = 233200 + TES(661)%NHMS = 233900 + TES(662)%NHMS = 234100 + TES(663)%NHMS = 234100 + TES(664)%NHMS = 234200 + TES(665)%NHMS = 234200 + TES(666)%NHMS = 234300 + TES(667)%NHMS = 234300 + TES(668)%NHMS = 234400 + TES(669)%NHMS = 234400 + TES(670)%NHMS = 234500 + TES(671)%NHMS = 234500 + TES(672)%NHMS = 234600 + TES(673)%NHMS = 234600 + TES(674)%NHMS = 234700 + TES(675)%NHMS = 234900 + TES(676)%NHMS = 235100 + TES(677)%NHMS = 010400 + TES(678)%NHMS = 010500 + TES(679)%NHMS = 010600 + TES(680)%NHMS = 010600 + TES(681)%NHMS = 010700 + TES(682)%NHMS = 010800 + TES(683)%NHMS = 010800 + TES(684)%NHMS = 011000 + TES(685)%NHMS = 011000 + TES(686)%NHMS = 011400 + TES(687)%NHMS = 011500 + TES(688)%NHMS = 011600 + TES(689)%NHMS = 011800 + TES(690)%NHMS = 011800 + TES(691)%NHMS = 011900 + TES(692)%NHMS = 011900 + TES(693)%NHMS = 022500 + TES(694)%NHMS = 022600 + TES(695)%NHMS = 024800 + TES(696)%NHMS = 024800 + TES(697)%NHMS = 024900 + TES(698)%NHMS = 024900 + TES(699)%NHMS = 025300 + TES(700)%NHMS = 025400 + TES(701)%NHMS = 025600 + TES(702)%NHMS = 034800 + TES(703)%NHMS = 040000 + TES(704)%NHMS = 040000 + TES(705)%NHMS = 040200 + TES(706)%NHMS = 040300 + TES(707)%NHMS = 040300 + TES(708)%NHMS = 040400 + TES(709)%NHMS = 040400 + TES(710)%NHMS = 040500 + TES(711)%NHMS = 040600 + TES(712)%NHMS = 044000 + TES(713)%NHMS = 044100 + TES(714)%NHMS = 044100 + TES(715)%NHMS = 044100 + TES(716)%NHMS = 044300 + TES(717)%NHMS = 044400 + TES(718)%NHMS = 044400 + TES(719)%NHMS = 044500 + TES(720)%NHMS = 044600 + TES(721)%NHMS = 052200 + TES(722)%NHMS = 052300 + TES(723)%NHMS = 052400 + TES(724)%NHMS = 053000 + TES(725)%NHMS = 053100 + TES(726)%NHMS = 053100 + TES(727)%NHMS = 053200 + TES(728)%NHMS = 053300 + TES(729)%NHMS = 053300 + TES(730)%NHMS = 053500 + TES(731)%NHMS = 053600 + TES(732)%NHMS = 053700 + TES(733)%NHMS = 053800 + TES(734)%NHMS = 053800 + TES(735)%NHMS = 053800 + TES(736)%NHMS = 053900 + TES(737)%NHMS = 054100 + TES(738)%NHMS = 054100 + TES(739)%NHMS = 054200 + TES(740)%NHMS = 054200 + TES(741)%NHMS = 054300 + TES(742)%NHMS = 054300 + TES(743)%NHMS = 054400 + TES(744)%NHMS = 054500 + TES(745)%NHMS = 060400 + TES(746)%NHMS = 061500 + TES(747)%NHMS = 061800 + TES(748)%NHMS = 061900 + TES(749)%NHMS = 062000 + TES(750)%NHMS = 062000 + TES(751)%NHMS = 062100 + TES(752)%NHMS = 062200 + TES(753)%NHMS = 062200 + TES(754)%NHMS = 070700 + TES(755)%NHMS = 070800 + TES(756)%NHMS = 071400 + TES(757)%NHMS = 072000 + TES(758)%NHMS = 072100 + TES(759)%NHMS = 072100 + TES(760)%NHMS = 072200 + TES(761)%NHMS = 072200 + TES(762)%NHMS = 072300 + TES(763)%NHMS = 072300 + TES(764)%NHMS = 072400 + TES(765)%NHMS = 074000 + TES(766)%NHMS = 074000 + TES(767)%NHMS = 074100 + TES(768)%NHMS = 074100 + TES(769)%NHMS = 074200 + TES(770)%NHMS = 074200 + TES(771)%NHMS = 074300 + TES(772)%NHMS = 074400 + TES(773)%NHMS = 074400 + TES(774)%NHMS = 074400 + TES(775)%NHMS = 074500 + TES(776)%NHMS = 074600 + TES(777)%NHMS = 074700 + TES(778)%NHMS = 075100 + TES(779)%NHMS = 075200 + TES(780)%NHMS = 085500 + TES(781)%NHMS = 090000 + TES(782)%NHMS = 090100 + TES(783)%NHMS = 091900 + TES(784)%NHMS = 092000 + TES(785)%NHMS = 092000 + TES(786)%NHMS = 092000 + TES(787)%NHMS = 092100 + TES(788)%NHMS = 092100 + TES(789)%NHMS = 092200 + TES(790)%NHMS = 092400 + TES(791)%NHMS = 092400 + TES(792)%NHMS = 092500 + TES(793)%NHMS = 092600 + TES(794)%NHMS = 092600 + TES(795)%NHMS = 102700 + TES(796)%NHMS = 103000 + TES(797)%NHMS = 103600 + TES(798)%NHMS = 103700 + TES(799)%NHMS = 103800 + TES(800)%NHMS = 103900 + TES(801)%NHMS = 103900 + TES(802)%NHMS = 104100 + TES(803)%NHMS = 105900 + TES(804)%NHMS = 092700 + TES(805)%NHMS = 093100 + TES(806)%NHMS = 093200 + TES(807)%NHMS = 093200 + TES(808)%NHMS = 093300 + TES(809)%NHMS = 093300 + TES(810)%NHMS = 093300 + TES(811)%NHMS = 095000 + TES(812)%NHMS = 095200 + TES(813)%NHMS = 095300 + TES(814)%NHMS = 095300 + TES(815)%NHMS = 095300 + TES(816)%NHMS = 095400 + TES(817)%NHMS = 095400 + TES(818)%NHMS = 095500 + TES(819)%NHMS = 095500 + TES(820)%NHMS = 104900 + TES(821)%NHMS = 105000 + TES(822)%NHMS = 105100 + TES(823)%NHMS = 105100 + TES(824)%NHMS = 105700 + TES(825)%NHMS = 105700 + TES(826)%NHMS = 105800 + TES(827)%NHMS = 110600 + TES(828)%NHMS = 110700 + TES(829)%NHMS = 111000 + TES(830)%NHMS = 111000 + TES(831)%NHMS = 111100 + TES(832)%NHMS = 111100 + TES(833)%NHMS = 111200 + TES(834)%NHMS = 112900 + TES(835)%NHMS = 112900 + TES(836)%NHMS = 112900 + TES(837)%NHMS = 122600 + TES(838)%NHMS = 122600 + TES(839)%NHMS = 122700 + TES(840)%NHMS = 122900 + TES(841)%NHMS = 123000 + TES(842)%NHMS = 123000 + TES(843)%NHMS = 123100 + TES(844)%NHMS = 123200 + TES(845)%NHMS = 123300 + TES(846)%NHMS = 123300 + TES(847)%NHMS = 123400 + TES(848)%NHMS = 123400 + TES(849)%NHMS = 123900 + TES(850)%NHMS = 124000 + TES(851)%NHMS = 124500 + TES(852)%NHMS = 124700 + TES(853)%NHMS = 130800 + TES(854)%NHMS = 133500 + TES(855)%NHMS = 133500 + TES(856)%NHMS = 141700 + TES(857)%NHMS = 141700 + TES(858)%NHMS = 164500 + TES(859)%NHMS = 172600 + TES(860)%NHMS = 172700 + TES(861)%NHMS = 172800 + TES(862)%NHMS = 172800 + TES(863)%NHMS = 173000 + TES(864)%NHMS = 173200 + TES(865)%NHMS = 173200 + TES(866)%NHMS = 173300 + TES(867)%NHMS = 174400 + TES(868)%NHMS = 174400 + TES(869)%NHMS = 174500 + TES(870)%NHMS = 174500 + TES(871)%NHMS = 174500 + TES(872)%NHMS = 174600 + TES(873)%NHMS = 174600 + TES(874)%NHMS = 174700 + TES(875)%NHMS = 174800 + TES(876)%NHMS = 180400 + TES(877)%NHMS = 180500 + TES(878)%NHMS = 180600 + TES(879)%NHMS = 180700 + TES(880)%NHMS = 180700 + TES(881)%NHMS = 180800 + TES(882)%NHMS = 181000 + TES(883)%NHMS = 181300 + TES(884)%NHMS = 181300 + TES(885)%NHMS = 181400 + TES(886)%NHMS = 182000 + TES(887)%NHMS = 182000 + TES(888)%NHMS = 182100 + TES(889)%NHMS = 182100 + TES(890)%NHMS = 185600 + TES(891)%NHMS = 185700 + TES(892)%NHMS = 185700 + TES(893)%NHMS = 185900 + TES(894)%NHMS = 185900 + TES(895)%NHMS = 191200 + TES(896)%NHMS = 191400 + TES(897)%NHMS = 191900 + TES(898)%NHMS = 191900 + TES(899)%NHMS = 192100 + TES(900)%NHMS = 192100 + TES(901)%NHMS = 192100 + TES(902)%NHMS = 192200 + TES(903)%NHMS = 192300 + TES(904)%NHMS = 192300 + TES(905)%NHMS = 194300 + TES(906)%NHMS = 194400 + TES(907)%NHMS = 194400 + TES(908)%NHMS = 194500 + TES(909)%NHMS = 194700 + TES(910)%NHMS = 194900 + TES(911)%NHMS = 195100 + TES(912)%NHMS = 195100 + TES(913)%NHMS = 195300 + TES(914)%NHMS = 210100 + TES(915)%NHMS = 210200 + TES(916)%NHMS = 210200 + TES(917)%NHMS = 210200 + TES(918)%NHMS = 210300 + TES(919)%NHMS = 212200 + TES(920)%NHMS = 212200 + TES(921)%NHMS = 212300 + TES(922)%NHMS = 212400 + TES(923)%NHMS = 212500 + TES(924)%NHMS = 212500 + TES(925)%NHMS = 212600 + TES(926)%NHMS = 212600 + TES(927)%NHMS = 212700 + TES(928)%NHMS = 212700 + TES(929)%NHMS = 212800 + TES(930)%NHMS = 212900 + TES(931)%NHMS = 230100 + TES(932)%NHMS = 230100 + TES(933)%NHMS = 230200 + TES(934)%NHMS = 230300 + TES(935)%NHMS = 230400 + TES(936)%NHMS = 230600 + TES(937)%NHMS = 230700 + TES(938)%NHMS = 230800 + TES(939)%NHMS = 231500 + TES(940)%NHMS = 231500 + TES(941)%NHMS = 231500 + TES(942)%NHMS = 231600 + TES(943)%NHMS = 231600 + TES(944)%NHMS = 231700 + TES(945)%NHMS = 231900 + TES(946)%NHMS = 232000 + TES(947)%NHMS = 232000 + TES(948)%NHMS = 232100 + TES(949)%NHMS = 232200 + TES(950)%NHMS = 232300 + TES(951)%NHMS = 232500 + TES(952)%NHMS = 001300 + TES(953)%NHMS = 004000 + TES(954)%NHMS = 004000 + TES(955)%NHMS = 004100 + TES(956)%NHMS = 004100 + TES(957)%NHMS = 004100 + TES(958)%NHMS = 004200 + TES(959)%NHMS = 004200 + TES(960)%NHMS = 004300 + TES(961)%NHMS = 004300 + TES(962)%NHMS = 004400 + TES(963)%NHMS = 004400 + TES(964)%NHMS = 004500 + TES(965)%NHMS = 004500 + TES(966)%NHMS = 004600 + TES(967)%NHMS = 004800 + TES(968)%NHMS = 004900 + TES(969)%NHMS = 004900 + TES(970)%NHMS = 005000 + TES(971)%NHMS = 005100 + TES(972)%NHMS = 005200 + TES(973)%NHMS = 005600 + TES(974)%NHMS = 005600 + TES(975)%NHMS = 005600 + TES(976)%NHMS = 005700 + TES(977)%NHMS = 005700 + TES(978)%NHMS = 014000 + TES(979)%NHMS = 021800 + TES(980)%NHMS = 022200 + TES(981)%NHMS = 022200 + TES(982)%NHMS = 022300 + TES(983)%NHMS = 022400 + TES(984)%NHMS = 022400 + TES(985)%NHMS = 022500 + TES(986)%NHMS = 023000 + TES(987)%NHMS = 023100 + TES(988)%NHMS = 023200 + TES(989)%NHMS = 023200 + TES(990)%NHMS = 033800 + TES(991)%NHMS = 033800 + TES(992)%NHMS = 033900 + TES(993)%NHMS = 034100 + TES(994)%NHMS = 041500 + TES(995)%NHMS = 041600 + TES(996)%NHMS = 041700 + TES(997)%NHMS = 041700 + TES(998)%NHMS = 041800 + TES(999)%NHMS = 041800 + TES(1000)%NHMS = 041900 + TES(1001)%NHMS = 041900 + TES(1002)%NHMS = 045500 + TES(1003)%NHMS = 045800 + TES(1004)%NHMS = 045900 + TES(1005)%NHMS = 051400 + TES(1006)%NHMS = 051700 + TES(1007)%NHMS = 051800 + TES(1008)%NHMS = 051900 + TES(1009)%NHMS = 052000 + TES(1010)%NHMS = 055000 + TES(1011)%NHMS = 055100 + TES(1012)%NHMS = 055400 + TES(1013)%NHMS = 055400 + TES(1014)%NHMS = 055500 + TES(1015)%NHMS = 055600 + TES(1016)%NHMS = 055700 + TES(1017)%NHMS = 055800 + TES(1018)%NHMS = 055900 + TES(1019)%NHMS = 060100 + TES(1020)%NHMS = 060200 + TES(1021)%NHMS = 060200 + TES(1022)%NHMS = 060300 + TES(1023)%NHMS = 060300 + TES(1024)%NHMS = 060400 + TES(1025)%NHMS = 060400 + TES(1026)%NHMS = 060500 + TES(1027)%NHMS = 060500 + TES(1028)%NHMS = 064100 + TES(1029)%NHMS = 064100 + TES(1030)%NHMS = 064500 + TES(1031)%NHMS = 064600 + TES(1032)%NHMS = 064800 + TES(1033)%NHMS = 064900 + TES(1034)%NHMS = 065100 + TES(1035)%NHMS = 065300 + TES(1036)%NHMS = 065300 + TES(1037)%NHMS = 065500 + TES(1038)%NHMS = 065600 + TES(1039)%NHMS = 065700 + TES(1040)%NHMS = 065700 + TES(1041)%NHMS = 065800 + TES(1042)%NHMS = 065800 + TES(1043)%NHMS = 065900 + TES(1044)%NHMS = 071700 + TES(1045)%NHMS = 071700 + TES(1046)%NHMS = 071700 + TES(1047)%NHMS = 071800 + TES(1048)%NHMS = 071900 + TES(1049)%NHMS = 071900 + TES(1050)%NHMS = 072000 + TES(1051)%NHMS = 072000 + TES(1052)%NHMS = 072100 + TES(1053)%NHMS = 072200 + TES(1054)%NHMS = 072200 + TES(1055)%NHMS = 072500 + TES(1056)%NHMS = 082300 + TES(1057)%NHMS = 082800 + TES(1058)%NHMS = 082800 + TES(1059)%NHMS = 082800 + TES(1060)%NHMS = 082900 + TES(1061)%NHMS = 083200 + TES(1062)%NHMS = 083500 + TES(1063)%NHMS = 083500 + TES(1064)%NHMS = 083700 + TES(1065)%NHMS = 085700 + TES(1066)%NHMS = 085800 + TES(1067)%NHMS = 090000 + TES(1068)%NHMS = 090100 + TES(1069)%NHMS = 090200 + TES(1070)%NHMS = 090300 + TES(1071)%NHMS = 090300 + TES(1072)%NHMS = 090300 + TES(1073)%NHMS = 100600 + TES(1074)%NHMS = 100700 + TES(1075)%NHMS = 100900 + TES(1076)%NHMS = 101000 + TES(1077)%NHMS = 101100 + TES(1078)%NHMS = 101100 + TES(1079)%NHMS = 101200 + TES(1080)%NHMS = 101400 + TES(1081)%NHMS = 101400 + TES(1082)%NHMS = 101500 + TES(1083)%NHMS = 101500 + TES(1084)%NHMS = 103300 + TES(1085)%NHMS = 103400 + TES(1086)%NHMS = 103400 + TES(1087)%NHMS = 103500 + TES(1088)%NHMS = 103600 + TES(1089)%NHMS = 103600 + TES(1090)%NHMS = 103700 + TES(1091)%NHMS = 091700 + TES(1092)%NHMS = 091800 + TES(1093)%NHMS = 091900 + TES(1094)%NHMS = 092100 + TES(1095)%NHMS = 092100 + TES(1096)%NHMS = 093700 + TES(1097)%NHMS = 093800 + TES(1098)%NHMS = 093900 + TES(1099)%NHMS = 094000 + TES(1100)%NHMS = 094200 + TES(1101)%NHMS = 094200 + TES(1102)%NHMS = 094300 + TES(1103)%NHMS = 094300 + TES(1104)%NHMS = 094400 + TES(1105)%NHMS = 094400 + TES(1106)%NHMS = 094600 + TES(1107)%NHMS = 104400 + TES(1108)%NHMS = 104500 + TES(1109)%NHMS = 104600 + TES(1110)%NHMS = 105100 + TES(1111)%NHMS = 105300 + TES(1112)%NHMS = 105400 + TES(1113)%NHMS = 105600 + TES(1114)%NHMS = 105700 + TES(1115)%NHMS = 105700 + TES(1116)%NHMS = 105800 + TES(1117)%NHMS = 105800 + TES(1118)%NHMS = 105900 + TES(1119)%NHMS = 111600 + TES(1120)%NHMS = 111700 + TES(1121)%NHMS = 111800 + TES(1122)%NHMS = 111800 + TES(1123)%NHMS = 121400 + TES(1124)%NHMS = 121400 + TES(1125)%NHMS = 121600 + TES(1126)%NHMS = 121800 + TES(1127)%NHMS = 121800 + TES(1128)%NHMS = 121900 + TES(1129)%NHMS = 121900 + TES(1130)%NHMS = 122000 + TES(1131)%NHMS = 122100 + TES(1132)%NHMS = 122100 + TES(1133)%NHMS = 122400 + TES(1134)%NHMS = 122400 + TES(1135)%NHMS = 122500 + TES(1136)%NHMS = 122500 + TES(1137)%NHMS = 123000 + TES(1138)%NHMS = 123300 + TES(1139)%NHMS = 123400 + TES(1140)%NHMS = 123500 + TES(1141)%NHMS = 123600 + TES(1142)%NHMS = 163200 + TES(1143)%NHMS = 163400 + TES(1144)%NHMS = 163600 + TES(1145)%NHMS = 163800 + TES(1146)%NHMS = 171300 + TES(1147)%NHMS = 171400 + TES(1148)%NHMS = 171400 + TES(1149)%NHMS = 171500 + TES(1150)%NHMS = 171500 + TES(1151)%NHMS = 171600 + TES(1152)%NHMS = 171600 + TES(1153)%NHMS = 171700 + TES(1154)%NHMS = 171700 + TES(1155)%NHMS = 171800 + TES(1156)%NHMS = 171800 + TES(1157)%NHMS = 171800 + TES(1158)%NHMS = 171900 + TES(1159)%NHMS = 171900 + TES(1160)%NHMS = 172000 + TES(1161)%NHMS = 173200 + TES(1162)%NHMS = 173200 + TES(1163)%NHMS = 173500 + TES(1164)%NHMS = 175300 + TES(1165)%NHMS = 175300 + TES(1166)%NHMS = 175400 + TES(1167)%NHMS = 175500 + TES(1168)%NHMS = 175500 + TES(1169)%NHMS = 175600 + TES(1170)%NHMS = 175700 + TES(1171)%NHMS = 180000 + TES(1172)%NHMS = 180700 + TES(1173)%NHMS = 180800 + TES(1174)%NHMS = 180800 + TES(1175)%NHMS = 180900 + TES(1176)%NHMS = 181000 + TES(1177)%NHMS = 184700 + TES(1178)%NHMS = 184700 + TES(1179)%NHMS = 184800 + TES(1180)%NHMS = 184900 + TES(1181)%NHMS = 185400 + TES(1182)%NHMS = 185500 + TES(1183)%NHMS = 185600 + TES(1184)%NHMS = 185600 + TES(1185)%NHMS = 185700 + TES(1186)%NHMS = 185700 + TES(1187)%NHMS = 185800 + TES(1188)%NHMS = 185800 + TES(1189)%NHMS = 190400 + TES(1190)%NHMS = 190700 + TES(1191)%NHMS = 190900 + TES(1192)%NHMS = 191000 + TES(1193)%NHMS = 191100 + TES(1194)%NHMS = 191200 + TES(1195)%NHMS = 193000 + TES(1196)%NHMS = 193100 + TES(1197)%NHMS = 193200 + TES(1198)%NHMS = 193300 + TES(1199)%NHMS = 193400 + TES(1200)%NHMS = 194000 + TES(1201)%NHMS = 194000 + TES(1202)%NHMS = 194100 + TES(1203)%NHMS = 194400 + TES(1204)%NHMS = 194400 + TES(1205)%NHMS = 204500 + TES(1206)%NHMS = 204500 + TES(1207)%NHMS = 204600 + TES(1208)%NHMS = 204700 + TES(1209)%NHMS = 204800 + TES(1210)%NHMS = 205000 + TES(1211)%NHMS = 205100 + TES(1212)%NHMS = 205100 + TES(1213)%NHMS = 205300 + TES(1214)%NHMS = 205300 + TES(1215)%NHMS = 211000 + TES(1216)%NHMS = 211100 + TES(1217)%NHMS = 211200 + TES(1218)%NHMS = 211300 + TES(1219)%NHMS = 211400 + TES(1220)%NHMS = 211600 + TES(1221)%NHMS = 211700 + TES(1222)%NHMS = 211700 + TES(1223)%NHMS = 212000 + TES(1224)%NHMS = 224800 + TES(1225)%NHMS = 224900 + TES(1226)%NHMS = 224900 + TES(1227)%NHMS = 225000 + TES(1228)%NHMS = 225000 + TES(1229)%NHMS = 225100 + TES(1230)%NHMS = 225800 + TES(1231)%NHMS = 225900 + TES(1232)%NHMS = 225900 + TES(1233)%NHMS = 230000 + TES(1234)%NHMS = 230300 + TES(1235)%NHMS = 230300 + TES(1236)%NHMS = 230400 + TES(1237)%NHMS = 230500 + TES(1238)%NHMS = 230600 + TES(1239)%NHMS = 230700 + TES(1240)%NHMS = 230700 + TES(1241)%NHMS = 230800 + TES(1242)%NHMS = 230800 + TES(1243)%NHMS = 230900 + TES(1244)%NHMS = 230900 + TES(1245)%NHMS = 231000 + TES(1246)%NHMS = 231100 + TES(1247)%NHMS = 002700 + TES(1248)%NHMS = 002800 + TES(1249)%NHMS = 002800 + TES(1250)%NHMS = 002900 + TES(1251)%NHMS = 003000 + TES(1252)%NHMS = 003000 + TES(1253)%NHMS = 003200 + TES(1254)%NHMS = 003200 + TES(1255)%NHMS = 003600 + TES(1256)%NHMS = 003600 + TES(1257)%NHMS = 003700 + TES(1258)%NHMS = 003700 + TES(1259)%NHMS = 003800 + TES(1260)%NHMS = 004100 + TES(1261)%NHMS = 004200 + TES(1262)%NHMS = 004200 + TES(1263)%NHMS = 004500 + TES(1264)%NHMS = 004600 + TES(1265)%NHMS = 004700 + TES(1266)%NHMS = 004800 + TES(1267)%NHMS = 004800 + TES(1268)%NHMS = 020600 + TES(1269)%NHMS = 021000 + TES(1270)%NHMS = 021000 + TES(1271)%NHMS = 021300 + TES(1272)%NHMS = 021400 + TES(1273)%NHMS = 022100 + TES(1274)%NHMS = 030700 + TES(1275)%NHMS = 040400 + TES(1276)%NHMS = 044000 + TES(1277)%NHMS = 044500 + TES(1278)%NHMS = 044500 + TES(1279)%NHMS = 044600 + TES(1280)%NHMS = 044600 + TES(1281)%NHMS = 044800 + TES(1282)%NHMS = 050400 + TES(1283)%NHMS = 050800 + TES(1284)%NHMS = 053900 + TES(1285)%NHMS = 053900 + TES(1286)%NHMS = 054000 + TES(1287)%NHMS = 054000 + TES(1288)%NHMS = 054100 + TES(1289)%NHMS = 054100 + TES(1290)%NHMS = 054200 + TES(1291)%NHMS = 054200 + TES(1292)%NHMS = 054300 + TES(1293)%NHMS = 054300 + TES(1294)%NHMS = 054400 + TES(1295)%NHMS = 054500 + TES(1296)%NHMS = 054800 + TES(1297)%NHMS = 054900 + TES(1298)%NHMS = 054900 + TES(1299)%NHMS = 054900 + TES(1300)%NHMS = 055000 + TES(1301)%NHMS = 055000 + TES(1302)%NHMS = 055100 + TES(1303)%NHMS = 055200 + TES(1304)%NHMS = 055200 + TES(1305)%NHMS = 055300 + TES(1306)%NHMS = 055300 + TES(1307)%NHMS = 062000 + TES(1308)%NHMS = 062100 + TES(1309)%NHMS = 062100 + TES(1310)%NHMS = 062200 + TES(1311)%NHMS = 062200 + TES(1312)%NHMS = 062300 + TES(1313)%NHMS = 062400 + TES(1314)%NHMS = 063000 + TES(1315)%NHMS = 063000 + TES(1316)%NHMS = 063400 + TES(1317)%NHMS = 063600 + TES(1318)%NHMS = 063700 + TES(1319)%NHMS = 063700 + TES(1320)%NHMS = 063800 + TES(1321)%NHMS = 064300 + TES(1322)%NHMS = 064400 + TES(1323)%NHMS = 064400 + TES(1324)%NHMS = 064500 + TES(1325)%NHMS = 064500 + TES(1326)%NHMS = 064500 + TES(1327)%NHMS = 064600 + TES(1328)%NHMS = 064600 + TES(1329)%NHMS = 070800 + TES(1330)%NHMS = 071200 + TES(1331)%NHMS = 071300 + TES(1332)%NHMS = 081500 + TES(1333)%NHMS = 081600 + TES(1334)%NHMS = 081600 + TES(1335)%NHMS = 081700 + TES(1336)%NHMS = 082000 + TES(1337)%NHMS = 082100 + TES(1338)%NHMS = 082100 + TES(1339)%NHMS = 082200 + TES(1340)%NHMS = 082300 + TES(1341)%NHMS = 082500 + TES(1342)%NHMS = 082500 + TES(1343)%NHMS = 084300 + TES(1344)%NHMS = 084400 + TES(1345)%NHMS = 084400 + TES(1346)%NHMS = 084600 + TES(1347)%NHMS = 084700 + TES(1348)%NHMS = 084800 + TES(1349)%NHMS = 084900 + TES(1350)%NHMS = 084900 + TES(1351)%NHMS = 085000 + TES(1352)%NHMS = 085100 + TES(1353)%NHMS = 085100 + TES(1354)%NHMS = 085200 + TES(1355)%NHMS = 085200 + TES(1356)%NHMS = 100200 + TES(1357)%NHMS = 100200 + TES(1358)%NHMS = 100300 + TES(1359)%NHMS = 100300 + TES(1360)%NHMS = 100400 + TES(1361)%NHMS = 102100 + TES(1362)%NHMS = 102100 + TES(1363)%NHMS = 102200 + TES(1364)%NHMS = 102200 + TES(1365)%NHMS = 102300 + TES(1366)%NHMS = 102300 + TES(1367)%NHMS = 102400 + TES(1368)%NHMS = 102400 + TES(1369)%NHMS = 102500 + TES(1370)%NHMS = 102500 + TES(1371)%NHMS = 102600 + TES(1372)%NHMS = 102600 + TES(1373)%NHMS = 103300 + TES(1374)%NHMS = 103400 + TES(1375)%NHMS = 104400 + TES(1376)%NHMS = 104500 + TES(1377)%NHMS = 104600 + TES(1378)%NHMS = 104700 + TES(1379)%NHMS = 110500 + TES(1380)%NHMS = 110500 + TES(1381)%NHMS = 120200 + TES(1382)%NHMS = 120200 + TES(1383)%NHMS = 120300 + TES(1384)%NHMS = 120300 + TES(1385)%NHMS = 120400 + TES(1386)%NHMS = 120400 + TES(1387)%NHMS = 120500 + TES(1388)%NHMS = 120500 + TES(1389)%NHMS = 120600 + TES(1390)%NHMS = 120600 + TES(1391)%NHMS = 120800 + TES(1392)%NHMS = 121000 + TES(1393)%NHMS = 121100 + TES(1394)%NHMS = 121200 + TES(1395)%NHMS = 122100 + TES(1396)%NHMS = 122200 + TES(1397)%NHMS = 122300 + TES(1398)%NHMS = 122400 + TES(1399)%NHMS = 122400 + TES(1400)%NHMS = 122500 + TES(1401)%NHMS = 135200 + TES(1402)%NHMS = 135300 + TES(1403)%NHMS = 135800 + TES(1404)%NHMS = 143600 + TES(1405)%NHMS = 160100 + TES(1406)%NHMS = 160200 + TES(1407)%NHMS = 160200 + TES(1408)%NHMS = 160200 + TES(1409)%NHMS = 161900 + TES(1410)%NHMS = 161900 + TES(1411)%NHMS = 162200 + TES(1412)%NHMS = 162200 + TES(1413)%NHMS = 162200 + TES(1414)%NHMS = 162300 + TES(1415)%NHMS = 162600 + TES(1416)%NHMS = 170000 + TES(1417)%NHMS = 170100 + TES(1418)%NHMS = 170100 + TES(1419)%NHMS = 170200 + TES(1420)%NHMS = 170200 + TES(1421)%NHMS = 170400 + TES(1422)%NHMS = 170500 + TES(1423)%NHMS = 170500 + TES(1424)%NHMS = 170600 + TES(1425)%NHMS = 170600 + TES(1426)%NHMS = 171900 + TES(1427)%NHMS = 172100 + TES(1428)%NHMS = 173900 + TES(1429)%NHMS = 174000 + TES(1430)%NHMS = 174300 + TES(1431)%NHMS = 174400 + TES(1432)%NHMS = 175500 + TES(1433)%NHMS = 175800 + TES(1434)%NHMS = 183400 + TES(1435)%NHMS = 183500 + TES(1436)%NHMS = 183500 + TES(1437)%NHMS = 183500 + TES(1438)%NHMS = 183600 + TES(1439)%NHMS = 183600 + TES(1440)%NHMS = 183700 + TES(1441)%NHMS = 184100 + TES(1442)%NHMS = 184100 + TES(1443)%NHMS = 184300 + TES(1444)%NHMS = 184400 + TES(1445)%NHMS = 184500 + TES(1446)%NHMS = 184600 + TES(1447)%NHMS = 184600 + TES(1448)%NHMS = 184800 + TES(1449)%NHMS = 185300 + TES(1450)%NHMS = 185300 + TES(1451)%NHMS = 185400 + TES(1452)%NHMS = 185600 + TES(1453)%NHMS = 185600 + TES(1454)%NHMS = 185700 + TES(1455)%NHMS = 185800 + TES(1456)%NHMS = 185800 + TES(1457)%NHMS = 185900 + TES(1458)%NHMS = 190000 + TES(1459)%NHMS = 190000 + TES(1460)%NHMS = 190000 + TES(1461)%NHMS = 190100 + TES(1462)%NHMS = 191900 + TES(1463)%NHMS = 192000 + TES(1464)%NHMS = 192000 + TES(1465)%NHMS = 192100 + TES(1466)%NHMS = 192100 + TES(1467)%NHMS = 192500 + TES(1468)%NHMS = 192600 + TES(1469)%NHMS = 192600 + TES(1470)%NHMS = 192700 + TES(1471)%NHMS = 192800 + TES(1472)%NHMS = 192900 + TES(1473)%NHMS = 192900 + TES(1474)%NHMS = 203000 + TES(1475)%NHMS = 203000 + TES(1476)%NHMS = 203100 + TES(1477)%NHMS = 203200 + TES(1478)%NHMS = 203400 + TES(1479)%NHMS = 203500 + TES(1480)%NHMS = 203600 + TES(1481)%NHMS = 203900 + TES(1482)%NHMS = 203900 + TES(1483)%NHMS = 205800 + TES(1484)%NHMS = 205900 + TES(1485)%NHMS = 210000 + TES(1486)%NHMS = 210200 + TES(1487)%NHMS = 210500 + TES(1488)%NHMS = 210700 + TES(1489)%NHMS = 223600 + TES(1490)%NHMS = 223700 + TES(1491)%NHMS = 223700 + TES(1492)%NHMS = 223800 + TES(1493)%NHMS = 223800 + TES(1494)%NHMS = 223900 + TES(1495)%NHMS = 224100 + TES(1496)%NHMS = 224400 + TES(1497)%NHMS = 224600 + TES(1498)%NHMS = 224600 + TES(1499)%NHMS = 224800 + TES(1500)%NHMS = 225200 + TES(1501)%NHMS = 225200 + TES(1502)%NHMS = 225700 + TES(1503)%NHMS = 235700 + TES(1504)%NHMS = 001700 + TES(1505)%NHMS = 002000 + TES(1506)%NHMS = 002100 + TES(1507)%NHMS = 002400 + TES(1508)%NHMS = 002500 + TES(1509)%NHMS = 002500 + TES(1510)%NHMS = 002600 + TES(1511)%NHMS = 002800 + TES(1512)%NHMS = 002900 + TES(1513)%NHMS = 002900 + TES(1514)%NHMS = 003000 + TES(1515)%NHMS = 003100 + TES(1516)%NHMS = 003200 + TES(1517)%NHMS = 003200 + TES(1518)%NHMS = 003300 + TES(1519)%NHMS = 003400 + TES(1520)%NHMS = 003400 + TES(1521)%NHMS = 003600 + TES(1522)%NHMS = 003700 + TES(1523)%NHMS = 015400 + TES(1524)%NHMS = 015500 + TES(1525)%NHMS = 015600 + TES(1526)%NHMS = 015800 + TES(1527)%NHMS = 020400 + TES(1528)%NHMS = 020400 + TES(1529)%NHMS = 020500 + TES(1530)%NHMS = 020700 + TES(1531)%NHMS = 020800 + TES(1532)%NHMS = 020800 + TES(1533)%NHMS = 024800 + TES(1534)%NHMS = 031200 + TES(1535)%NHMS = 042700 + TES(1536)%NHMS = 042700 + TES(1537)%NHMS = 042900 + TES(1538)%NHMS = 042900 + TES(1539)%NHMS = 043000 + TES(1540)%NHMS = 043000 + TES(1541)%NHMS = 043200 + TES(1542)%NHMS = 043300 + TES(1543)%NHMS = 043300 + TES(1544)%NHMS = 043700 + TES(1545)%NHMS = 044800 + TES(1546)%NHMS = 044800 + TES(1547)%NHMS = 045400 + TES(1548)%NHMS = 052700 + TES(1549)%NHMS = 052800 + TES(1550)%NHMS = 052800 + TES(1551)%NHMS = 052900 + TES(1552)%NHMS = 053000 + TES(1553)%NHMS = 053000 + TES(1554)%NHMS = 053100 + TES(1555)%NHMS = 053300 + TES(1556)%NHMS = 053400 + TES(1557)%NHMS = 053500 + TES(1558)%NHMS = 053500 + TES(1559)%NHMS = 053600 + TES(1560)%NHMS = 053700 + TES(1561)%NHMS = 053700 + TES(1562)%NHMS = 053800 + TES(1563)%NHMS = 053800 + TES(1564)%NHMS = 053900 + TES(1565)%NHMS = 053900 + TES(1566)%NHMS = 053900 + TES(1567)%NHMS = 054000 + TES(1568)%NHMS = 060800 + TES(1569)%NHMS = 061000 + TES(1570)%NHMS = 061100 + TES(1571)%NHMS = 061200 + TES(1572)%NHMS = 061700 + TES(1573)%NHMS = 061700 + TES(1574)%NHMS = 061800 + TES(1575)%NHMS = 062400 + TES(1576)%NHMS = 062500 + TES(1577)%NHMS = 062500 + TES(1578)%NHMS = 062500 + TES(1579)%NHMS = 062800 + TES(1580)%NHMS = 063000 + TES(1581)%NHMS = 063200 + TES(1582)%NHMS = 063300 + TES(1583)%NHMS = 063300 + TES(1584)%NHMS = 063400 + TES(1585)%NHMS = 063400 + TES(1586)%NHMS = 065400 + TES(1587)%NHMS = 065500 + TES(1588)%NHMS = 070100 + TES(1589)%NHMS = 070500 + TES(1590)%NHMS = 070700 + TES(1591)%NHMS = 070700 + TES(1592)%NHMS = 070800 + TES(1593)%NHMS = 080300 + TES(1594)%NHMS = 080300 + TES(1595)%NHMS = 080400 + TES(1596)%NHMS = 080600 + TES(1597)%NHMS = 080900 + TES(1598)%NHMS = 080900 + TES(1599)%NHMS = 081000 + TES(1600)%NHMS = 081000 + TES(1601)%NHMS = 081100 + TES(1602)%NHMS = 081200 + TES(1603)%NHMS = 081300 + TES(1604)%NHMS = 083000 + TES(1605)%NHMS = 083100 + TES(1606)%NHMS = 083100 + TES(1607)%NHMS = 083200 + TES(1608)%NHMS = 083200 + TES(1609)%NHMS = 083600 + TES(1610)%NHMS = 083700 + TES(1611)%NHMS = 083700 + TES(1612)%NHMS = 083800 + TES(1613)%NHMS = 083800 + TES(1614)%NHMS = 083900 + TES(1615)%NHMS = 084000 + TES(1616)%NHMS = 094500 + TES(1617)%NHMS = 095100 + TES(1618)%NHMS = 095200 + TES(1619)%NHMS = 100800 + TES(1620)%NHMS = 100800 + TES(1621)%NHMS = 101100 + TES(1622)%NHMS = 101200 + TES(1623)%NHMS = 101300 + TES(1624)%NHMS = 101300 + TES(1625)%NHMS = 101400 + TES(1626)%NHMS = 101500 + TES(1627)%NHMS = 111400 + TES(1628)%NHMS = 111500 + TES(1629)%NHMS = 111500 + TES(1630)%NHMS = 111700 + TES(1631)%NHMS = 111800 + TES(1632)%NHMS = 111800 + TES(1633)%NHMS = 112300 + TES(1634)%NHMS = 112400 + TES(1635)%NHMS = 112700 + TES(1636)%NHMS = 112700 + TES(1637)%NHMS = 112800 + TES(1638)%NHMS = 112800 + TES(1639)%NHMS = 112900 + TES(1640)%NHMS = 112900 + TES(1641)%NHMS = 113000 + TES(1642)%NHMS = 114700 + TES(1643)%NHMS = 103100 + TES(1644)%NHMS = 103200 + TES(1645)%NHMS = 103200 + TES(1646)%NHMS = 103200 + TES(1647)%NHMS = 103300 + TES(1648)%NHMS = 103500 + TES(1649)%NHMS = 103500 + TES(1650)%NHMS = 105200 + TES(1651)%NHMS = 105200 + TES(1652)%NHMS = 105200 + TES(1653)%NHMS = 105300 + TES(1654)%NHMS = 105300 + TES(1655)%NHMS = 105400 + TES(1656)%NHMS = 115200 + TES(1657)%NHMS = 115300 + TES(1658)%NHMS = 115300 + TES(1659)%NHMS = 115400 + TES(1660)%NHMS = 115500 + TES(1661)%NHMS = 115500 + TES(1662)%NHMS = 115600 + TES(1663)%NHMS = 115800 + TES(1664)%NHMS = 115900 + TES(1665)%NHMS = 120000 + TES(1666)%NHMS = 120100 + TES(1667)%NHMS = 120300 + TES(1668)%NHMS = 120400 + TES(1669)%NHMS = 120500 + TES(1670)%NHMS = 120900 + TES(1671)%NHMS = 121000 + TES(1672)%NHMS = 121000 + TES(1673)%NHMS = 121100 + TES(1674)%NHMS = 121100 + TES(1675)%NHMS = 121200 + TES(1676)%NHMS = 133800 + TES(1677)%NHMS = 134000 + TES(1678)%NHMS = 134100 + TES(1679)%NHMS = 134600 + TES(1680)%NHMS = 134800 + TES(1681)%NHMS = 154900 + TES(1682)%NHMS = 154900 + TES(1683)%NHMS = 160800 + TES(1684)%NHMS = 160900 + TES(1685)%NHMS = 161300 + TES(1686)%NHMS = 161400 + TES(1687)%NHMS = 164900 + TES(1688)%NHMS = 164900 + TES(1689)%NHMS = 165000 + TES(1690)%NHMS = 165000 + TES(1691)%NHMS = 165100 + TES(1692)%NHMS = 165100 + TES(1693)%NHMS = 165200 + TES(1694)%NHMS = 165300 + TES(1695)%NHMS = 170800 + TES(1696)%NHMS = 170900 + TES(1697)%NHMS = 172700 + TES(1698)%NHMS = 172700 + TES(1699)%NHMS = 173000 + TES(1700)%NHMS = 173100 + TES(1701)%NHMS = 173100 + TES(1702)%NHMS = 173200 + TES(1703)%NHMS = 173600 + TES(1704)%NHMS = 174400 + TES(1705)%NHMS = 174400 + TES(1706)%NHMS = 174500 + TES(1707)%NHMS = 174900 + TES(1708)%NHMS = 175000 + TES(1709)%NHMS = 182200 + TES(1710)%NHMS = 182300 + TES(1711)%NHMS = 182300 + TES(1712)%NHMS = 182400 + TES(1713)%NHMS = 182500 + TES(1714)%NHMS = 182600 + TES(1715)%NHMS = 182900 + TES(1716)%NHMS = 183000 + TES(1717)%NHMS = 183000 + TES(1718)%NHMS = 183100 + TES(1719)%NHMS = 183100 + TES(1720)%NHMS = 183200 + TES(1721)%NHMS = 183200 + TES(1722)%NHMS = 183300 + TES(1723)%NHMS = 183500 + TES(1724)%NHMS = 183600 + TES(1725)%NHMS = 183800 + TES(1726)%NHMS = 184000 + TES(1727)%NHMS = 184200 + TES(1728)%NHMS = 184300 + TES(1729)%NHMS = 184400 + TES(1730)%NHMS = 184600 + TES(1731)%NHMS = 184700 + TES(1732)%NHMS = 184900 + TES(1733)%NHMS = 190600 + TES(1734)%NHMS = 190600 + TES(1735)%NHMS = 190700 + TES(1736)%NHMS = 190700 + TES(1737)%NHMS = 190800 + TES(1738)%NHMS = 190800 + TES(1739)%NHMS = 190900 + TES(1740)%NHMS = 190900 + TES(1741)%NHMS = 191200 + TES(1742)%NHMS = 191400 + TES(1743)%NHMS = 201700 + TES(1744)%NHMS = 201700 + TES(1745)%NHMS = 201800 + TES(1746)%NHMS = 201900 + TES(1747)%NHMS = 202200 + TES(1748)%NHMS = 202300 + TES(1749)%NHMS = 202400 + TES(1750)%NHMS = 202500 + TES(1751)%NHMS = 202500 + TES(1752)%NHMS = 202500 + TES(1753)%NHMS = 202600 + TES(1754)%NHMS = 202700 + TES(1755)%NHMS = 202700 + TES(1756)%NHMS = 202800 + TES(1757)%NHMS = 202800 + TES(1758)%NHMS = 204500 + TES(1759)%NHMS = 204500 + TES(1760)%NHMS = 204500 + TES(1761)%NHMS = 204600 + TES(1762)%NHMS = 204700 + TES(1763)%NHMS = 204700 + TES(1764)%NHMS = 204800 + TES(1765)%NHMS = 204900 + TES(1766)%NHMS = 204900 + TES(1767)%NHMS = 205000 + TES(1768)%NHMS = 205200 + TES(1769)%NHMS = 205400 + TES(1770)%NHMS = 205400 + TES(1771)%NHMS = 222400 + TES(1772)%NHMS = 222400 + TES(1773)%NHMS = 222500 + TES(1774)%NHMS = 222600 + TES(1775)%NHMS = 222600 + TES(1776)%NHMS = 222600 + TES(1777)%NHMS = 222700 + TES(1778)%NHMS = 222700 + TES(1779)%NHMS = 222800 + TES(1780)%NHMS = 222800 + TES(1781)%NHMS = 222900 + TES(1782)%NHMS = 223200 + TES(1783)%NHMS = 223800 + TES(1784)%NHMS = 223900 + TES(1785)%NHMS = 000300 + TES(1786)%NHMS = 000300 + TES(1787)%NHMS = 000400 + TES(1788)%NHMS = 000500 + TES(1789)%NHMS = 000500 + TES(1790)%NHMS = 000600 + TES(1791)%NHMS = 000600 + TES(1792)%NHMS = 000800 + TES(1793)%NHMS = 001100 + TES(1794)%NHMS = 001100 + TES(1795)%NHMS = 001300 + TES(1796)%NHMS = 001500 + TES(1797)%NHMS = 001600 + TES(1798)%NHMS = 001700 + TES(1799)%NHMS = 001800 + TES(1800)%NHMS = 001900 + TES(1801)%NHMS = 001900 + TES(1802)%NHMS = 001900 + TES(1803)%NHMS = 002000 + TES(1804)%NHMS = 002100 + TES(1805)%NHMS = 002200 + TES(1806)%NHMS = 002200 + TES(1807)%NHMS = 002500 + TES(1808)%NHMS = 002500 + TES(1809)%NHMS = 002600 + TES(1810)%NHMS = 002700 + TES(1811)%NHMS = 014100 + TES(1812)%NHMS = 014200 + TES(1813)%NHMS = 014300 + TES(1814)%NHMS = 014300 + TES(1815)%NHMS = 014400 + TES(1816)%NHMS = 014400 + TES(1817)%NHMS = 014800 + TES(1818)%NHMS = 015300 + TES(1819)%NHMS = 015500 + TES(1820)%NHMS = 015600 + TES(1821)%NHMS = 041700 + TES(1822)%NHMS = 041700 + TES(1823)%NHMS = 041700 + TES(1824)%NHMS = 041800 + TES(1825)%NHMS = 041900 + TES(1826)%NHMS = 042000 + TES(1827)%NHMS = 042100 + TES(1828)%NHMS = 042100 + TES(1829)%NHMS = 042200 + TES(1830)%NHMS = 042200 + TES(1831)%NHMS = 042200 + TES(1832)%NHMS = 042300 + TES(1833)%NHMS = 042500 + TES(1834)%NHMS = 042500 + TES(1835)%NHMS = 043800 + TES(1836)%NHMS = 043800 + TES(1837)%NHMS = 044200 + TES(1838)%NHMS = 044200 + TES(1839)%NHMS = 051600 + TES(1840)%NHMS = 051700 + TES(1841)%NHMS = 051800 + TES(1842)%NHMS = 051800 + TES(1843)%NHMS = 051900 + TES(1844)%NHMS = 051900 + TES(1845)%NHMS = 052000 + TES(1846)%NHMS = 052000 + TES(1847)%NHMS = 052100 + TES(1848)%NHMS = 052100 + TES(1849)%NHMS = 052200 + TES(1850)%NHMS = 052300 + TES(1851)%NHMS = 052400 + TES(1852)%NHMS = 055700 + TES(1853)%NHMS = 060300 + TES(1854)%NHMS = 060400 + TES(1855)%NHMS = 060500 + TES(1856)%NHMS = 060600 + TES(1857)%NHMS = 060600 + TES(1858)%NHMS = 061200 + TES(1859)%NHMS = 061300 + TES(1860)%NHMS = 061400 + TES(1861)%NHMS = 061900 + TES(1862)%NHMS = 061900 + TES(1863)%NHMS = 062000 + TES(1864)%NHMS = 062000 + TES(1865)%NHMS = 062100 + TES(1866)%NHMS = 064000 + TES(1867)%NHMS = 064000 + TES(1868)%NHMS = 064200 + TES(1869)%NHMS = 064900 + TES(1870)%NHMS = 065200 + TES(1871)%NHMS = 065200 + TES(1872)%NHMS = 065300 + TES(1873)%NHMS = 065300 + TES(1874)%NHMS = 065400 + TES(1875)%NHMS = 075000 + TES(1876)%NHMS = 075100 + TES(1877)%NHMS = 075500 + TES(1878)%NHMS = 075700 + TES(1879)%NHMS = 075800 + TES(1880)%NHMS = 075900 + TES(1881)%NHMS = 080000 + TES(1882)%NHMS = 080000 + TES(1883)%NHMS = 080000 + TES(1884)%NHMS = 082100 + TES(1885)%NHMS = 082100 + TES(1886)%NHMS = 082200 + TES(1887)%NHMS = 082200 + TES(1888)%NHMS = 082400 + TES(1889)%NHMS = 082400 + TES(1890)%NHMS = 082500 + TES(1891)%NHMS = 082500 + TES(1892)%NHMS = 082800 + TES(1893)%NHMS = 082800 + TES(1894)%NHMS = 082900 + TES(1895)%NHMS = 093300 + TES(1896)%NHMS = 093500 + TES(1897)%NHMS = 093700 + TES(1898)%NHMS = 093900 + TES(1899)%NHMS = 093900 + TES(1900)%NHMS = 095600 + TES(1901)%NHMS = 095600 + TES(1902)%NHMS = 095700 + TES(1903)%NHMS = 095700 + TES(1904)%NHMS = 095700 + TES(1905)%NHMS = 095800 + TES(1906)%NHMS = 095800 + TES(1907)%NHMS = 095900 + TES(1908)%NHMS = 095900 + TES(1909)%NHMS = 100000 + TES(1910)%NHMS = 100000 + TES(1911)%NHMS = 100100 + TES(1912)%NHMS = 100100 + TES(1913)%NHMS = 100200 + TES(1914)%NHMS = 100300 + TES(1915)%NHMS = 105600 + TES(1916)%NHMS = 110200 + TES(1917)%NHMS = 110300 + TES(1918)%NHMS = 110300 + TES(1919)%NHMS = 110600 + TES(1920)%NHMS = 110600 + TES(1921)%NHMS = 111500 + TES(1922)%NHMS = 111600 + TES(1923)%NHMS = 111700 + TES(1924)%NHMS = 111800 + TES(1925)%NHMS = 111800 + TES(1926)%NHMS = 101700 + TES(1927)%NHMS = 101800 + TES(1928)%NHMS = 102000 + TES(1929)%NHMS = 102100 + TES(1930)%NHMS = 102100 + TES(1931)%NHMS = 102200 + TES(1932)%NHMS = 102200 + TES(1933)%NHMS = 102300 + TES(1934)%NHMS = 104000 + TES(1935)%NHMS = 104000 + TES(1936)%NHMS = 104100 + TES(1937)%NHMS = 104100 + TES(1938)%NHMS = 104100 + TES(1939)%NHMS = 104200 + TES(1940)%NHMS = 113900 + TES(1941)%NHMS = 113900 + TES(1942)%NHMS = 114000 + TES(1943)%NHMS = 114100 + TES(1944)%NHMS = 114100 + TES(1945)%NHMS = 114200 + TES(1946)%NHMS = 114400 + TES(1947)%NHMS = 114500 + TES(1948)%NHMS = 114500 + TES(1949)%NHMS = 114700 + TES(1950)%NHMS = 114800 + TES(1951)%NHMS = 115000 + TES(1952)%NHMS = 115500 + TES(1953)%NHMS = 115600 + TES(1954)%NHMS = 115600 + TES(1955)%NHMS = 115700 + TES(1956)%NHMS = 115700 + TES(1957)%NHMS = 115800 + TES(1958)%NHMS = 115900 + TES(1959)%NHMS = 120000 + TES(1960)%NHMS = 120100 + TES(1961)%NHMS = 120100 + TES(1962)%NHMS = 120200 + TES(1963)%NHMS = 132600 + TES(1964)%NHMS = 132700 + TES(1965)%NHMS = 132800 + TES(1966)%NHMS = 133100 + TES(1967)%NHMS = 133500 + TES(1968)%NHMS = 133600 + TES(1969)%NHMS = 133800 + TES(1970)%NHMS = 133900 + TES(1971)%NHMS = 155800 + TES(1972)%NHMS = 160100 + TES(1973)%NHMS = 160200 + TES(1974)%NHMS = 165600 + TES(1975)%NHMS = 171700 + TES(1976)%NHMS = 171800 + TES(1977)%NHMS = 172200 + TES(1978)%NHMS = 173700 + TES(1979)%NHMS = 173900 + TES(1980)%NHMS = 173900 + TES(1981)%NHMS = 174000 + TES(1982)%NHMS = 174100 + TES(1983)%NHMS = 181200 + TES(1984)%NHMS = 181200 + TES(1985)%NHMS = 181400 + TES(1986)%NHMS = 181500 + TES(1987)%NHMS = 181600 + TES(1988)%NHMS = 181600 + TES(1989)%NHMS = 181700 + TES(1990)%NHMS = 181800 + TES(1991)%NHMS = 181800 + TES(1992)%NHMS = 181900 + TES(1993)%NHMS = 181900 + TES(1994)%NHMS = 182000 + TES(1995)%NHMS = 182000 + TES(1996)%NHMS = 182100 + TES(1997)%NHMS = 182200 + TES(1998)%NHMS = 182600 + TES(1999)%NHMS = 183500 + TES(2000)%NHMS = 183500 + TES(2001)%NHMS = 183600 + TES(2002)%NHMS = 185300 + TES(2003)%NHMS = 185400 + TES(2004)%NHMS = 185400 + TES(2005)%NHMS = 185500 + TES(2006)%NHMS = 185500 + TES(2007)%NHMS = 185600 + TES(2008)%NHMS = 185800 + TES(2009)%NHMS = 190200 + TES(2010)%NHMS = 190300 + TES(2011)%NHMS = 190300 + TES(2012)%NHMS = 190300 + TES(2013)%NHMS = 190900 + TES(2014)%NHMS = 191000 + TES(2015)%NHMS = 191000 + TES(2016)%NHMS = 200400 + TES(2017)%NHMS = 200400 + TES(2018)%NHMS = 200500 + TES(2019)%NHMS = 200700 + TES(2020)%NHMS = 200800 + TES(2021)%NHMS = 200900 + TES(2022)%NHMS = 201000 + TES(2023)%NHMS = 201000 + TES(2024)%NHMS = 201200 + TES(2025)%NHMS = 201300 + TES(2026)%NHMS = 201400 + TES(2027)%NHMS = 201400 + TES(2028)%NHMS = 201500 + TES(2029)%NHMS = 201500 + TES(2030)%NHMS = 201600 + TES(2031)%NHMS = 203200 + TES(2032)%NHMS = 203300 + TES(2033)%NHMS = 203400 + TES(2034)%NHMS = 203400 + TES(2035)%NHMS = 203600 + TES(2036)%NHMS = 203600 + TES(2037)%NHMS = 203700 + TES(2038)%NHMS = 203700 + TES(2039)%NHMS = 203900 + TES(2040)%NHMS = 204100 + TES(2041)%NHMS = 204100 + TES(2042)%NHMS = 204200 + TES(2043)%NHMS = 204300 + TES(2044)%NHMS = 204400 + TES(2045)%NHMS = 215400 + TES(2046)%NHMS = 221100 + TES(2047)%NHMS = 221200 + TES(2048)%NHMS = 221200 + TES(2049)%NHMS = 221300 + TES(2050)%NHMS = 221300 + TES(2051)%NHMS = 221400 + TES(2052)%NHMS = 221400 + TES(2053)%NHMS = 221500 + TES(2054)%NHMS = 221700 + TES(2055)%NHMS = 222000 + TES(2056)%NHMS = 222100 + TES(2057)%NHMS = 222100 + TES(2058)%NHMS = 223200 + TES(2059)%NHMS = 223300 + TES(2060)%NHMS = 223300 + TES(2061)%NHMS = 223400 + TES(2062)%NHMS = 223400 + TES(2063)%NHMS = 223500 + TES(2064)%NHMS = 233300 + TES(2065)%NHMS = 235000 + TES(2066)%NHMS = 235100 + TES(2067)%NHMS = 235200 + TES(2068)%NHMS = 235200 + TES(2069)%NHMS = 235600 + TES(2070)%NHMS = 235600 + TES(2071)%NHMS = 235800 + TES(2072)%NHMS = 235900 + TES(2073)%NHMS = 000000 + TES(2074)%NHMS = 000100 + TES(2075)%NHMS = 000100 + TES(2076)%NHMS = 000200 + TES(2077)%NHMS = 000200 + TES(2078)%NHMS = 000500 + TES(2079)%NHMS = 000600 + TES(2080)%NHMS = 000700 + TES(2081)%NHMS = 000700 + TES(2082)%NHMS = 000700 + TES(2083)%NHMS = 000800 + TES(2084)%NHMS = 000900 + TES(2085)%NHMS = 001000 + TES(2086)%NHMS = 001200 + TES(2087)%NHMS = 001400 + TES(2088)%NHMS = 012900 + TES(2089)%NHMS = 013200 + TES(2090)%NHMS = 013300 + TES(2091)%NHMS = 013500 + TES(2092)%NHMS = 013600 + TES(2093)%NHMS = 014000 + TES(2094)%NHMS = 014200 + TES(2095)%NHMS = 023800 + TES(2096)%NHMS = 040500 + TES(2097)%NHMS = 040500 + TES(2098)%NHMS = 040500 + TES(2099)%NHMS = 040600 + TES(2100)%NHMS = 040800 + TES(2101)%NHMS = 042700 + TES(2102)%NHMS = 042700 + TES(2103)%NHMS = 050300 + TES(2104)%NHMS = 050500 + TES(2105)%NHMS = 050600 + TES(2106)%NHMS = 050600 + TES(2107)%NHMS = 050600 + TES(2108)%NHMS = 050700 + TES(2109)%NHMS = 050800 + TES(2110)%NHMS = 050900 + TES(2111)%NHMS = 051000 + TES(2112)%NHMS = 051100 + TES(2113)%NHMS = 051100 + TES(2114)%NHMS = 051200 + TES(2115)%NHMS = 054400 + TES(2116)%NHMS = 054400 + TES(2117)%NHMS = 054800 + TES(2118)%NHMS = 055100 + TES(2119)%NHMS = 055200 + TES(2120)%NHMS = 055300 + TES(2121)%NHMS = 055400 + TES(2122)%NHMS = 055400 + TES(2123)%NHMS = 055900 + TES(2124)%NHMS = 060000 + TES(2125)%NHMS = 060300 + TES(2126)%NHMS = 060300 + TES(2127)%NHMS = 060600 + TES(2128)%NHMS = 060600 + TES(2129)%NHMS = 064100 + TES(2130)%NHMS = 064200 + TES(2131)%NHMS = 064300 + TES(2132)%NHMS = 064300 + TES(2133)%NHMS = 064400 + TES(2134)%NHMS = 064500 + TES(2135)%NHMS = 064500 + TES(2136)%NHMS = 073800 + TES(2137)%NHMS = 073800 + TES(2138)%NHMS = 073900 + TES(2139)%NHMS = 074400 + TES(2140)%NHMS = 074400 + TES(2141)%NHMS = 074500 + TES(2142)%NHMS = 074500 + TES(2143)%NHMS = 074600 + TES(2144)%NHMS = 074700 + TES(2145)%NHMS = 074800 + TES(2146)%NHMS = 074800 + TES(2147)%NHMS = 080400 + TES(2148)%NHMS = 080600 + TES(2149)%NHMS = 080600 + TES(2150)%NHMS = 080900 + TES(2151)%NHMS = 081100 + TES(2152)%NHMS = 081200 + TES(2153)%NHMS = 091900 + TES(2154)%NHMS = 092200 + TES(2155)%NHMS = 092300 + TES(2156)%NHMS = 092400 + TES(2157)%NHMS = 092500 + TES(2158)%NHMS = 092500 + TES(2159)%NHMS = 092600 + TES(2160)%NHMS = 092600 + TES(2161)%NHMS = 092700 + TES(2162)%NHMS = 094300 + TES(2163)%NHMS = 094400 + TES(2164)%NHMS = 094400 + TES(2165)%NHMS = 094500 + TES(2166)%NHMS = 094500 + TES(2167)%NHMS = 094600 + TES(2168)%NHMS = 094700 + TES(2169)%NHMS = 094700 + TES(2170)%NHMS = 094800 + TES(2171)%NHMS = 094900 + TES(2172)%NHMS = 095000 + TES(2173)%NHMS = 104400 + TES(2174)%NHMS = 104500 + TES(2175)%NHMS = 105000 + TES(2176)%NHMS = 105100 + TES(2177)%NHMS = 105900 + TES(2178)%NHMS = 110000 + TES(2179)%NHMS = 110000 + TES(2180)%NHMS = 110200 + TES(2181)%NHMS = 110300 + TES(2182)%NHMS = 110300 + TES(2183)%NHMS = 110400 + TES(2184)%NHMS = 110500 + TES(2185)%NHMS = 110500 + TES(2186)%NHMS = 110600 + TES(2187)%NHMS = 112300 + TES(2188)%NHMS = 114300 + TES(2189)%NHMS = 100400 + TES(2190)%NHMS = 100500 + TES(2191)%NHMS = 100800 + TES(2192)%NHMS = 100800 + TES(2193)%NHMS = 100900 + TES(2194)%NHMS = 100900 + TES(2195)%NHMS = 100900 + TES(2196)%NHMS = 101000 + TES(2197)%NHMS = 101000 + TES(2198)%NHMS = 102700 + TES(2199)%NHMS = 102700 + TES(2200)%NHMS = 102900 + TES(2201)%NHMS = 102900 + TES(2202)%NHMS = 102900 + TES(2203)%NHMS = 103000 + TES(2204)%NHMS = 103200 + TES(2205)%NHMS = 112800 + TES(2206)%NHMS = 112900 + TES(2207)%NHMS = 113000 + TES(2208)%NHMS = 113100 + TES(2209)%NHMS = 113100 + TES(2210)%NHMS = 113200 + TES(2211)%NHMS = 113200 + TES(2212)%NHMS = 113300 + TES(2213)%NHMS = 113400 + TES(2214)%NHMS = 113400 + TES(2215)%NHMS = 113600 + TES(2216)%NHMS = 113700 + TES(2217)%NHMS = 113900 + TES(2218)%NHMS = 114000 + TES(2219)%NHMS = 114400 + TES(2220)%NHMS = 114400 + TES(2221)%NHMS = 114500 + TES(2222)%NHMS = 114500 + TES(2223)%NHMS = 131100 + TES(2224)%NHMS = 131400 + TES(2225)%NHMS = 132300 + TES(2226)%NHMS = 154700 + TES(2227)%NHMS = 154700 + TES(2228)%NHMS = 162600 + TES(2229)%NHMS = 162800 + TES(2230)%NHMS = 170500 + TES(2231)%NHMS = 171900 + TES(2232)%NHMS = 172300 + TES(2233)%NHMS = 172600 + TES(2234)%NHMS = 172700 + TES(2235)%NHMS = 172700 + TES(2236)%NHMS = 172800 + TES(2237)%NHMS = 180000 + TES(2238)%NHMS = 180000 + TES(2239)%NHMS = 180200 + TES(2240)%NHMS = 180300 + TES(2241)%NHMS = 180300 + TES(2242)%NHMS = 180400 + TES(2243)%NHMS = 180400 + TES(2244)%NHMS = 180500 + TES(2245)%NHMS = 180500 + TES(2246)%NHMS = 180600 + TES(2247)%NHMS = 180600 + TES(2248)%NHMS = 180600 + TES(2249)%NHMS = 180700 + TES(2250)%NHMS = 180700 + TES(2251)%NHMS = 180800 + TES(2252)%NHMS = 180800 + TES(2253)%NHMS = 181000 + TES(2254)%NHMS = 181900 + TES(2255)%NHMS = 182000 + TES(2256)%NHMS = 182000 + TES(2257)%NHMS = 182100 + TES(2258)%NHMS = 182100 + TES(2259)%NHMS = 182100 + TES(2260)%NHMS = 182200 + TES(2261)%NHMS = 184100 + TES(2262)%NHMS = 184200 + TES(2263)%NHMS = 184200 + TES(2264)%NHMS = 184400 + TES(2265)%NHMS = 184400 + TES(2266)%NHMS = 184600 + TES(2267)%NHMS = 184800 + TES(2268)%NHMS = 184900 + TES(2269)%NHMS = 184900 + TES(2270)%NHMS = 185000 + TES(2271)%NHMS = 185400 + TES(2272)%NHMS = 185400 + TES(2273)%NHMS = 185500 + TES(2274)%NHMS = 185700 + TES(2275)%NHMS = 185800 + TES(2276)%NHMS = 185800 + TES(2277)%NHMS = 195600 + TES(2278)%NHMS = 195700 + TES(2279)%NHMS = 200000 + TES(2280)%NHMS = 200200 + TES(2281)%NHMS = 200200 + TES(2282)%NHMS = 200200 + TES(2283)%NHMS = 202000 + TES(2284)%NHMS = 202100 + TES(2285)%NHMS = 202100 + TES(2286)%NHMS = 202200 + TES(2287)%NHMS = 202200 + TES(2288)%NHMS = 202300 + TES(2289)%NHMS = 202700 + TES(2290)%NHMS = 214100 + TES(2291)%NHMS = 215900 + TES(2292)%NHMS = 220000 + TES(2293)%NHMS = 220000 + TES(2294)%NHMS = 220100 + TES(2295)%NHMS = 220200 + TES(2296)%NHMS = 220300 + TES(2297)%NHMS = 220500 + TES(2298)%NHMS = 221000 + TES(2299)%NHMS = 222000 + TES(2300)%NHMS = 233800 + TES(2301)%NHMS = 233800 + TES(2302)%NHMS = 234000 + TES(2303)%NHMS = 234100 + TES(2304)%NHMS = 234100 + TES(2305)%NHMS = 234200 + TES(2306)%NHMS = 234300 + TES(2307)%NHMS = 234300 + TES(2308)%NHMS = 234400 + TES(2309)%NHMS = 234400 + TES(2310)%NHMS = 234500 + TES(2311)%NHMS = 235000 + TES(2312)%NHMS = 235100 + TES(2313)%NHMS = 235200 + TES(2314)%NHMS = 235300 + TES(2315)%NHMS = 235300 + TES(2316)%NHMS = 235500 + TES(2317)%NHMS = 235500 + TES(2318)%NHMS = 235600 + TES(2319)%NHMS = 235600 + TES(2320)%NHMS = 235700 + TES(2321)%NHMS = 235700 + TES(2322)%NHMS = 235800 + TES(2323)%NHMS = 235800 + TES(2324)%NHMS = 000300 + TES(2325)%NHMS = 011900 + TES(2326)%NHMS = 011900 + TES(2327)%NHMS = 012000 + TES(2328)%NHMS = 012000 + TES(2329)%NHMS = 012100 + TES(2330)%NHMS = 012400 + TES(2331)%NHMS = 012500 + TES(2332)%NHMS = 013000 + TES(2333)%NHMS = 023700 + TES(2334)%NHMS = 023800 + TES(2335)%NHMS = 025600 + TES(2336)%NHMS = 030600 + TES(2337)%NHMS = 035400 + TES(2338)%NHMS = 035400 + TES(2339)%NHMS = 035400 + TES(2340)%NHMS = 041100 + TES(2341)%NHMS = 041400 + TES(2342)%NHMS = 041400 + TES(2343)%NHMS = 041400 + TES(2344)%NHMS = 041500 + TES(2345)%NHMS = 041800 + TES(2346)%NHMS = 045100 + TES(2347)%NHMS = 045300 + TES(2348)%NHMS = 045400 + TES(2349)%NHMS = 045400 + TES(2350)%NHMS = 045500 + TES(2351)%NHMS = 045500 + TES(2352)%NHMS = 045500 + TES(2353)%NHMS = 045600 + TES(2354)%NHMS = 045600 + TES(2355)%NHMS = 045700 + TES(2356)%NHMS = 045800 + TES(2357)%NHMS = 045900 + TES(2358)%NHMS = 050000 + TES(2359)%NHMS = 053200 + TES(2360)%NHMS = 053900 + TES(2361)%NHMS = 054700 + TES(2362)%NHMS = 054800 + TES(2363)%NHMS = 054900 + TES(2364)%NHMS = 055000 + TES(2365)%NHMS = 055100 + TES(2366)%NHMS = 055100 + TES(2367)%NHMS = 055100 + TES(2368)%NHMS = 055200 + TES(2369)%NHMS = 055300 + TES(2370)%NHMS = 055500 + TES(2371)%NHMS = 055600 + TES(2372)%NHMS = 055700 + TES(2373)%NHMS = 061500 + TES(2374)%NHMS = 061600 + TES(2375)%NHMS = 062500 + TES(2376)%NHMS = 062700 + TES(2377)%NHMS = 062700 + TES(2378)%NHMS = 062800 + TES(2379)%NHMS = 062900 + TES(2380)%NHMS = 062900 + TES(2381)%NHMS = 063000 + TES(2382)%NHMS = 063100 + TES(2383)%NHMS = 063200 + TES(2384)%NHMS = 063200 + TES(2385)%NHMS = 063200 + TES(2386)%NHMS = 063300 + TES(2387)%NHMS = 072500 + TES(2388)%NHMS = 072600 + TES(2389)%NHMS = 072600 + TES(2390)%NHMS = 073000 + TES(2391)%NHMS = 073100 + TES(2392)%NHMS = 073300 + TES(2393)%NHMS = 073300 + TES(2394)%NHMS = 073300 + TES(2395)%NHMS = 073400 + TES(2396)%NHMS = 073500 + TES(2397)%NHMS = 073500 + TES(2398)%NHMS = 073600 + TES(2399)%NHMS = 075300 + TES(2400)%NHMS = 075400 + TES(2401)%NHMS = 075400 + TES(2402)%NHMS = 075500 + TES(2403)%NHMS = 075600 + TES(2404)%NHMS = 075700 + TES(2405)%NHMS = 075800 + TES(2406)%NHMS = 075800 + TES(2407)%NHMS = 075900 + TES(2408)%NHMS = 075900 + TES(2409)%NHMS = 080000 + TES(2410)%NHMS = 080300 + TES(2411)%NHMS = 080400 + TES(2412)%NHMS = 080400 + TES(2413)%NHMS = 091300 + TES(2414)%NHMS = 091300 + TES(2415)%NHMS = 093100 + TES(2416)%NHMS = 093200 + TES(2417)%NHMS = 093300 + TES(2418)%NHMS = 093300 + TES(2419)%NHMS = 093400 + TES(2420)%NHMS = 093400 + TES(2421)%NHMS = 093500 + TES(2422)%NHMS = 093600 + TES(2423)%NHMS = 093700 + TES(2424)%NHMS = 093800 + TES(2425)%NHMS = 093800 + TES(2426)%NHMS = 093900 + TES(2427)%NHMS = 103800 + TES(2428)%NHMS = 104800 + TES(2429)%NHMS = 105200 + TES(2430)%NHMS = 111000 + TES(2431)%NHMS = 111000 + TES(2432)%NHMS = 095600 + TES(2433)%NHMS = 101400 + TES(2434)%NHMS = 101500 + TES(2435)%NHMS = 101500 + TES(2436)%NHMS = 101700 + TES(2437)%NHMS = 101700 + TES(2438)%NHMS = 101800 + TES(2439)%NHMS = 101900 + TES(2440)%NHMS = 111600 + TES(2441)%NHMS = 111700 + TES(2442)%NHMS = 111800 + TES(2443)%NHMS = 111900 + TES(2444)%NHMS = 111900 + TES(2445)%NHMS = 111900 + TES(2446)%NHMS = 112300 + TES(2447)%NHMS = 112400 + TES(2448)%NHMS = 112400 + TES(2449)%NHMS = 112600 + TES(2450)%NHMS = 112900 + TES(2451)%NHMS = 113000 + TES(2452)%NHMS = 113100 + TES(2453)%NHMS = 113100 + TES(2454)%NHMS = 113200 + TES(2455)%NHMS = 113200 + TES(2456)%NHMS = 113300 + TES(2457)%NHMS = 113300 + TES(2458)%NHMS = 113400 + TES(2459)%NHMS = 113400 + TES(2460)%NHMS = 113400 + TES(2461)%NHMS = 113700 + TES(2462)%NHMS = 125000 + TES(2463)%NHMS = 125000 + TES(2464)%NHMS = 125200 + TES(2465)%NHMS = 125300 + TES(2466)%NHMS = 125300 + TES(2467)%NHMS = 125400 + TES(2468)%NHMS = 125500 + TES(2469)%NHMS = 125500 + TES(2470)%NHMS = 125600 + TES(2471)%NHMS = 125700 + TES(2472)%NHMS = 125900 + TES(2473)%NHMS = 130000 + TES(2474)%NHMS = 130000 + TES(2475)%NHMS = 130000 + TES(2476)%NHMS = 130100 + TES(2477)%NHMS = 130200 + TES(2478)%NHMS = 131000 + TES(2479)%NHMS = 131100 + TES(2480)%NHMS = 131100 + TES(2481)%NHMS = 131200 + TES(2482)%NHMS = 135200 + TES(2483)%NHMS = 140100 + TES(2484)%NHMS = 153400 + TES(2485)%NHMS = 153400 + TES(2486)%NHMS = 153500 + TES(2487)%NHMS = 153700 + TES(2488)%NHMS = 153900 + TES(2489)%NHMS = 170600 + TES(2490)%NHMS = 171000 + TES(2491)%NHMS = 171200 + TES(2492)%NHMS = 171500 + TES(2493)%NHMS = 171500 + TES(2494)%NHMS = 174900 + TES(2495)%NHMS = 174900 + TES(2496)%NHMS = 175100 + TES(2497)%NHMS = 175100 + TES(2498)%NHMS = 175200 + TES(2499)%NHMS = 175300 + TES(2500)%NHMS = 175400 + TES(2501)%NHMS = 175500 + TES(2502)%NHMS = 175500 + TES(2503)%NHMS = 175600 + TES(2504)%NHMS = 175600 + TES(2505)%NHMS = 175700 + TES(2506)%NHMS = 175700 + TES(2507)%NHMS = 175800 + TES(2508)%NHMS = 175800 + TES(2509)%NHMS = 175900 + TES(2510)%NHMS = 180800 + TES(2511)%NHMS = 180900 + TES(2512)%NHMS = 180900 + TES(2513)%NHMS = 181000 + TES(2514)%NHMS = 181000 + TES(2515)%NHMS = 181000 + TES(2516)%NHMS = 181100 + TES(2517)%NHMS = 182900 + TES(2518)%NHMS = 183000 + TES(2519)%NHMS = 183000 + TES(2520)%NHMS = 183000 + TES(2521)%NHMS = 183100 + TES(2522)%NHMS = 183100 + TES(2523)%NHMS = 183200 + TES(2524)%NHMS = 183400 + TES(2525)%NHMS = 183400 + TES(2526)%NHMS = 183500 + TES(2527)%NHMS = 183500 + TES(2528)%NHMS = 183700 + TES(2529)%NHMS = 183800 + TES(2530)%NHMS = 183800 + TES(2531)%NHMS = 183900 + TES(2532)%NHMS = 183900 + TES(2533)%NHMS = 184000 + TES(2534)%NHMS = 184000 + TES(2535)%NHMS = 184100 + TES(2536)%NHMS = 192100 + TES(2537)%NHMS = 192100 + TES(2538)%NHMS = 193900 + TES(2539)%NHMS = 193900 + TES(2540)%NHMS = 194000 + TES(2541)%NHMS = 194400 + TES(2542)%NHMS = 194500 + TES(2543)%NHMS = 194700 + TES(2544)%NHMS = 194700 + TES(2545)%NHMS = 194800 + TES(2546)%NHMS = 194900 + TES(2547)%NHMS = 200800 + TES(2548)%NHMS = 200800 + TES(2549)%NHMS = 200900 + TES(2550)%NHMS = 200900 + TES(2551)%NHMS = 201000 + TES(2552)%NHMS = 201200 + TES(2553)%NHMS = 201300 + TES(2554)%NHMS = 201300 + TES(2555)%NHMS = 201400 + TES(2556)%NHMS = 201500 + TES(2557)%NHMS = 201500 + TES(2558)%NHMS = 201600 + TES(2559)%NHMS = 212300 + TES(2560)%NHMS = 212300 + TES(2561)%NHMS = 212700 + TES(2562)%NHMS = 212700 + TES(2563)%NHMS = 212800 + TES(2564)%NHMS = 212900 + TES(2565)%NHMS = 213000 + TES(2566)%NHMS = 214700 + TES(2567)%NHMS = 214700 + TES(2568)%NHMS = 214800 + TES(2569)%NHMS = 214800 + TES(2570)%NHMS = 214900 + TES(2571)%NHMS = 214900 + TES(2572)%NHMS = 215000 + TES(2573)%NHMS = 215100 + TES(2574)%NHMS = 215200 + TES(2575)%NHMS = 215200 + TES(2576)%NHMS = 215200 + TES(2577)%NHMS = 215500 + TES(2578)%NHMS = 215600 + TES(2579)%NHMS = 232800 + TES(2580)%NHMS = 232900 + TES(2581)%NHMS = 232900 + TES(2582)%NHMS = 233000 + TES(2583)%NHMS = 233000 + TES(2584)%NHMS = 233100 + TES(2585)%NHMS = 233100 + TES(2586)%NHMS = 233800 + TES(2587)%NHMS = 233900 + TES(2588)%NHMS = 233900 + TES(2589)%NHMS = 234000 + TES(2590)%NHMS = 234000 + TES(2591)%NHMS = 234000 + TES(2592)%NHMS = 234100 + TES(2593)%NHMS = 234200 + TES(2594)%NHMS = 234300 + TES(2595)%NHMS = 234400 + TES(2596)%NHMS = 234500 + TES(2597)%NHMS = 234600 + TES(2598)%NHMS = 234700 + TES(2599)%NHMS = 234800 + TES(2600)%NHMS = 234900 + TES(2601)%NHMS = 235000 + TES(2602)%NHMS = 235000 + TES(2603)%NHMS = 235100 + TES(2604)%NHMS = 010500 + TES(2605)%NHMS = 010600 + TES(2606)%NHMS = 010700 + TES(2607)%NHMS = 010700 + TES(2608)%NHMS = 010800 + TES(2609)%NHMS = 011000 + TES(2610)%NHMS = 011000 + TES(2611)%NHMS = 011400 + TES(2612)%NHMS = 011500 + TES(2613)%NHMS = 011500 + TES(2614)%NHMS = 011600 + TES(2615)%NHMS = 011600 + TES(2616)%NHMS = 011800 + TES(2617)%NHMS = 011800 + TES(2618)%NHMS = 011900 + TES(2619)%NHMS = 012100 + TES(2620)%NHMS = 022500 + TES(2621)%NHMS = 022600 + TES(2622)%NHMS = 022600 + TES(2623)%NHMS = 024500 + TES(2624)%NHMS = 024800 + TES(2625)%NHMS = 024800 + TES(2626)%NHMS = 024900 + TES(2627)%NHMS = 025400 + TES(2628)%NHMS = 025500 + TES(2629)%NHMS = 025500 + TES(2630)%NHMS = 025600 + TES(2631)%NHMS = 035300 + TES(2632)%NHMS = 040300 + TES(2633)%NHMS = 040300 + TES(2634)%NHMS = 040300 + TES(2635)%NHMS = 040400 + TES(2636)%NHMS = 040400 + TES(2637)%NHMS = 040500 + TES(2638)%NHMS = 043900 + TES(2639)%NHMS = 044000 + TES(2640)%NHMS = 044100 + TES(2641)%NHMS = 044200 + TES(2642)%NHMS = 044300 + TES(2643)%NHMS = 044300 + TES(2644)%NHMS = 044300 + TES(2645)%NHMS = 044400 + TES(2646)%NHMS = 044500 + TES(2647)%NHMS = 044500 + TES(2648)%NHMS = 052200 + TES(2649)%NHMS = 052300 + TES(2650)%NHMS = 052400 + TES(2651)%NHMS = 052800 + TES(2652)%NHMS = 053000 + TES(2653)%NHMS = 053100 + TES(2654)%NHMS = 053100 + TES(2655)%NHMS = 053200 + TES(2656)%NHMS = 053600 + TES(2657)%NHMS = 053800 + TES(2658)%NHMS = 053900 + TES(2659)%NHMS = 054000 + TES(2660)%NHMS = 054200 + TES(2661)%NHMS = 054400 + TES(2662)%NHMS = 054400 + TES(2663)%NHMS = 054500 + TES(2664)%NHMS = 060400 + TES(2665)%NHMS = 061600 + TES(2666)%NHMS = 061600 + TES(2667)%NHMS = 061700 + TES(2668)%NHMS = 061900 + TES(2669)%NHMS = 062000 + TES(2670)%NHMS = 062100 + TES(2671)%NHMS = 062100 + TES(2672)%NHMS = 062200 + TES(2673)%NHMS = 070700 + TES(2674)%NHMS = 071300 + TES(2675)%NHMS = 071400 + TES(2676)%NHMS = 071500 + TES(2677)%NHMS = 072100 + TES(2678)%NHMS = 072100 + TES(2679)%NHMS = 072100 + TES(2680)%NHMS = 074000 + TES(2681)%NHMS = 074000 + TES(2682)%NHMS = 074100 + TES(2683)%NHMS = 074100 + TES(2684)%NHMS = 074200 + TES(2685)%NHMS = 074200 + TES(2686)%NHMS = 074300 + TES(2687)%NHMS = 074300 + TES(2688)%NHMS = 074400 + TES(2689)%NHMS = 074400 + TES(2690)%NHMS = 074600 + TES(2691)%NHMS = 074700 + TES(2692)%NHMS = 074700 + TES(2693)%NHMS = 074800 + TES(2694)%NHMS = 075100 + TES(2695)%NHMS = 075200 + TES(2696)%NHMS = 075200 + TES(2697)%NHMS = 090100 + TES(2698)%NHMS = 090200 + TES(2699)%NHMS = 090200 + TES(2700)%NHMS = 092100 + TES(2701)%NHMS = 092100 + TES(2702)%NHMS = 092200 + TES(2703)%NHMS = 092200 + TES(2704)%NHMS = 092300 + TES(2705)%NHMS = 092300 + TES(2706)%NHMS = 092400 + TES(2707)%NHMS = 092400 + TES(2708)%NHMS = 092500 + TES(2709)%NHMS = 092600 + TES(2710)%NHMS = 092600 + TES(2711)%NHMS = 092700 + TES(2712)%NHMS = 092800 + TES(2713)%NHMS = 102700 + TES(2714)%NHMS = 103600 + TES(2715)%NHMS = 103700 + TES(2716)%NHMS = 103800 + TES(2717)%NHMS = 103800 + TES(2718)%NHMS = 103900 + TES(2719)%NHMS = 105800 + TES(2720)%NHMS = 105900 + TES(2721)%NHMS = 105900 + TES(2722)%NHMS = 105900 + TES(2723)%NHMS = 110000 + TES(2724)%NHMS = 093700 + TES(2725)%NHMS = 094300 + TES(2726)%NHMS = 094300 + TES(2727)%NHMS = 094500 + TES(2728)%NHMS = 100200 + TES(2729)%NHMS = 100300 + TES(2730)%NHMS = 100400 + TES(2731)%NHMS = 100400 + TES(2732)%NHMS = 100500 + TES(2733)%NHMS = 100500 + TES(2734)%NHMS = 100600 + TES(2735)%NHMS = 100700 + TES(2736)%NHMS = 100700 + TES(2737)%NHMS = 100700 + TES(2738)%NHMS = 110200 + TES(2739)%NHMS = 111000 + TES(2740)%NHMS = 111000 + TES(2741)%NHMS = 111100 + TES(2742)%NHMS = 112000 + TES(2743)%NHMS = 112100 + TES(2744)%NHMS = 112100 + TES(2745)%NHMS = 112200 + TES(2746)%NHMS = 112200 + TES(2747)%NHMS = 112300 + TES(2748)%NHMS = 112300 + TES(2749)%NHMS = 123800 + TES(2750)%NHMS = 123800 + TES(2751)%NHMS = 124100 + TES(2752)%NHMS = 124200 + TES(2753)%NHMS = 124300 + TES(2754)%NHMS = 124400 + TES(2755)%NHMS = 124400 + TES(2756)%NHMS = 124400 + TES(2757)%NHMS = 124500 + TES(2758)%NHMS = 124600 + TES(2759)%NHMS = 124600 + TES(2760)%NHMS = 124900 + TES(2761)%NHMS = 124900 + TES(2762)%NHMS = 125100 + TES(2763)%NHMS = 125200 + TES(2764)%NHMS = 130000 + TES(2765)%NHMS = 130100 + TES(2766)%NHMS = 130200 + TES(2767)%NHMS = 130300 + TES(2768)%NHMS = 132100 + TES(2769)%NHMS = 134100 + TES(2770)%NHMS = 142800 + TES(2771)%NHMS = 142900 + TES(2772)%NHMS = 143000 + TES(2773)%NHMS = 152200 + TES(2774)%NHMS = 152300 + TES(2775)%NHMS = 152300 + TES(2776)%NHMS = 152400 + TES(2777)%NHMS = 152400 + TES(2778)%NHMS = 152500 + TES(2779)%NHMS = 152500 + TES(2780)%NHMS = 152600 + TES(2781)%NHMS = 165700 + TES(2782)%NHMS = 165800 + TES(2783)%NHMS = 165800 + TES(2784)%NHMS = 165900 + TES(2785)%NHMS = 170200 + TES(2786)%NHMS = 170300 + TES(2787)%NHMS = 173500 + TES(2788)%NHMS = 173600 + TES(2789)%NHMS = 173600 + TES(2790)%NHMS = 173700 + TES(2791)%NHMS = 174000 + TES(2792)%NHMS = 174100 + TES(2793)%NHMS = 174200 + TES(2794)%NHMS = 174300 + TES(2795)%NHMS = 174300 + TES(2796)%NHMS = 174400 + TES(2797)%NHMS = 174500 + TES(2798)%NHMS = 174500 + TES(2799)%NHMS = 174600 + TES(2800)%NHMS = 174600 + TES(2801)%NHMS = 174700 + TES(2802)%NHMS = 175600 + TES(2803)%NHMS = 175700 + TES(2804)%NHMS = 175700 + TES(2805)%NHMS = 175800 + TES(2806)%NHMS = 175800 + TES(2807)%NHMS = 175900 + TES(2808)%NHMS = 175900 + TES(2809)%NHMS = 180000 + TES(2810)%NHMS = 181900 + TES(2811)%NHMS = 181900 + TES(2812)%NHMS = 182000 + TES(2813)%NHMS = 182500 + TES(2814)%NHMS = 182600 + TES(2815)%NHMS = 190900 + TES(2816)%NHMS = 190900 + TES(2817)%NHMS = 191000 + TES(2818)%NHMS = 192500 + TES(2819)%NHMS = 192600 + TES(2820)%NHMS = 192800 + TES(2821)%NHMS = 193100 + TES(2822)%NHMS = 193100 + TES(2823)%NHMS = 193200 + TES(2824)%NHMS = 193300 + TES(2825)%NHMS = 193300 + TES(2826)%NHMS = 193400 + TES(2827)%NHMS = 193500 + TES(2828)%NHMS = 193500 + TES(2829)%NHMS = 193700 + TES(2830)%NHMS = 193900 + TES(2831)%NHMS = 195800 + TES(2832)%NHMS = 200000 + TES(2833)%NHMS = 200100 + TES(2834)%NHMS = 200100 + TES(2835)%NHMS = 200200 + TES(2836)%NHMS = 200300 + TES(2837)%NHMS = 200400 + TES(2838)%NHMS = 200500 + TES(2839)%NHMS = 211000 + TES(2840)%NHMS = 211100 + TES(2841)%NHMS = 211500 + TES(2842)%NHMS = 211600 + TES(2843)%NHMS = 213500 + TES(2844)%NHMS = 213600 + TES(2845)%NHMS = 213600 + TES(2846)%NHMS = 213600 + TES(2847)%NHMS = 213700 + TES(2848)%NHMS = 213800 + TES(2849)%NHMS = 213800 + TES(2850)%NHMS = 214000 + TES(2851)%NHMS = 214100 + TES(2852)%NHMS = 231300 + TES(2853)%NHMS = 231400 + TES(2854)%NHMS = 231500 + TES(2855)%NHMS = 231600 + TES(2856)%NHMS = 231700 + TES(2857)%NHMS = 231800 + TES(2858)%NHMS = 231900 + TES(2859)%NHMS = 232300 + TES(2860)%NHMS = 232500 + TES(2861)%NHMS = 232800 + TES(2862)%NHMS = 232800 + TES(2863)%NHMS = 232800 + TES(2864)%NHMS = 232900 + TES(2865)%NHMS = 233000 + TES(2866)%NHMS = 233100 + TES(2867)%NHMS = 233100 + TES(2868)%NHMS = 233200 + TES(2869)%NHMS = 233200 + TES(2870)%NHMS = 233300 + TES(2871)%NHMS = 233400 + TES(2872)%NHMS = 233500 + TES(2873)%NHMS = 233500 + TES(2874)%NHMS = 233600 + TES(2875)%NHMS = 233700 + TES(2876)%NHMS = 233800 + TES(2877)%NHMS = 233800 + TES(2878)%NHMS = 233900 + TES(2879)%NHMS = 005300 + TES(2880)%NHMS = 005300 + TES(2881)%NHMS = 005400 + TES(2882)%NHMS = 005500 + TES(2883)%NHMS = 005500 + TES(2884)%NHMS = 005600 + TES(2885)%NHMS = 005600 + TES(2886)%NHMS = 010100 + TES(2887)%NHMS = 010100 + TES(2888)%NHMS = 010200 + TES(2889)%NHMS = 010300 + TES(2890)%NHMS = 010700 + TES(2891)%NHMS = 010700 + TES(2892)%NHMS = 010800 + TES(2893)%NHMS = 010900 + TES(2894)%NHMS = 021400 + TES(2895)%NHMS = 023200 + TES(2896)%NHMS = 023300 + TES(2897)%NHMS = 023400 + TES(2898)%NHMS = 023600 + TES(2899)%NHMS = 023600 + TES(2900)%NHMS = 023600 + TES(2901)%NHMS = 023800 + TES(2902)%NHMS = 024100 + TES(2903)%NHMS = 024200 + TES(2904)%NHMS = 024200 + TES(2905)%NHMS = 024300 + TES(2906)%NHMS = 024400 + TES(2907)%NHMS = 024400 + TES(2908)%NHMS = 024500 + TES(2909)%NHMS = 035000 + TES(2910)%NHMS = 035100 + TES(2911)%NHMS = 035200 + TES(2912)%NHMS = 042700 + TES(2913)%NHMS = 042800 + TES(2914)%NHMS = 042900 + TES(2915)%NHMS = 043000 + TES(2916)%NHMS = 043100 + TES(2917)%NHMS = 043200 + TES(2918)%NHMS = 050700 + TES(2919)%NHMS = 051500 + TES(2920)%NHMS = 051900 + TES(2921)%NHMS = 052400 + TES(2922)%NHMS = 052500 + TES(2923)%NHMS = 052900 + TES(2924)%NHMS = 052900 + TES(2925)%NHMS = 052900 + TES(2926)%NHMS = 053000 + TES(2927)%NHMS = 053100 + TES(2928)%NHMS = 053200 + TES(2929)%NHMS = 060100 + TES(2930)%NHMS = 060200 + TES(2931)%NHMS = 060300 + TES(2932)%NHMS = 060300 + TES(2933)%NHMS = 060400 + TES(2934)%NHMS = 060400 + TES(2935)%NHMS = 060500 + TES(2936)%NHMS = 060600 + TES(2937)%NHMS = 060600 + TES(2938)%NHMS = 060900 + TES(2939)%NHMS = 060900 + TES(2940)%NHMS = 061000 + TES(2941)%NHMS = 061100 + TES(2942)%NHMS = 061100 + TES(2943)%NHMS = 061300 + TES(2944)%NHMS = 061300 + TES(2945)%NHMS = 061400 + TES(2946)%NHMS = 065300 + TES(2947)%NHMS = 065400 + TES(2948)%NHMS = 065500 + TES(2949)%NHMS = 065900 + TES(2950)%NHMS = 070000 + TES(2951)%NHMS = 070000 + TES(2952)%NHMS = 070200 + TES(2953)%NHMS = 070600 + TES(2954)%NHMS = 070700 + TES(2955)%NHMS = 070800 + TES(2956)%NHMS = 070900 + TES(2957)%NHMS = 071000 + TES(2958)%NHMS = 072700 + TES(2959)%NHMS = 072800 + TES(2960)%NHMS = 073100 + TES(2961)%NHMS = 073200 + TES(2962)%NHMS = 073200 + TES(2963)%NHMS = 073300 + TES(2964)%NHMS = 073400 + TES(2965)%NHMS = 073500 + TES(2966)%NHMS = 073500 + TES(2967)%NHMS = 073500 + TES(2968)%NHMS = 073800 + TES(2969)%NHMS = 074000 + TES(2970)%NHMS = 074000 + TES(2971)%NHMS = 083600 + TES(2972)%NHMS = 083700 + TES(2973)%NHMS = 083700 + TES(2974)%NHMS = 083800 + TES(2975)%NHMS = 084100 + TES(2976)%NHMS = 084100 + TES(2977)%NHMS = 084500 + TES(2978)%NHMS = 085000 + TES(2979)%NHMS = 090700 + TES(2980)%NHMS = 090800 + TES(2981)%NHMS = 090900 + TES(2982)%NHMS = 090900 + TES(2983)%NHMS = 091000 + TES(2984)%NHMS = 091000 + TES(2985)%NHMS = 091100 + TES(2986)%NHMS = 091100 + TES(2987)%NHMS = 091200 + TES(2988)%NHMS = 091200 + TES(2989)%NHMS = 091300 + TES(2990)%NHMS = 091400 + TES(2991)%NHMS = 091500 + TES(2992)%NHMS = 101700 + TES(2993)%NHMS = 102100 + TES(2994)%NHMS = 102200 + TES(2995)%NHMS = 102400 + TES(2996)%NHMS = 102600 + TES(2997)%NHMS = 102700 + TES(2998)%NHMS = 102700 + TES(2999)%NHMS = 102700 + TES(3000)%NHMS = 102800 + TES(3001)%NHMS = 102900 + TES(3002)%NHMS = 104600 + TES(3003)%NHMS = 104600 + TES(3004)%NHMS = 104700 + TES(3005)%NHMS = 104700 + TES(3006)%NHMS = 104800 + TES(3007)%NHMS = 093000 + TES(3008)%NHMS = 093100 + TES(3009)%NHMS = 093200 + TES(3010)%NHMS = 093200 + TES(3011)%NHMS = 093300 + TES(3012)%NHMS = 093300 + TES(3013)%NHMS = 095000 + TES(3014)%NHMS = 095000 + TES(3015)%NHMS = 095000 + TES(3016)%NHMS = 095100 + TES(3017)%NHMS = 095100 + TES(3018)%NHMS = 095200 + TES(3019)%NHMS = 095200 + TES(3020)%NHMS = 095300 + TES(3021)%NHMS = 095300 + TES(3022)%NHMS = 095400 + TES(3023)%NHMS = 095400 + TES(3024)%NHMS = 095500 + TES(3025)%NHMS = 095500 + TES(3026)%NHMS = 095600 + TES(3027)%NHMS = 095600 + TES(3028)%NHMS = 095700 + TES(3029)%NHMS = 105600 + TES(3030)%NHMS = 105700 + TES(3031)%NHMS = 105700 + TES(3032)%NHMS = 110700 + TES(3033)%NHMS = 111100 + TES(3034)%NHMS = 111200 + TES(3035)%NHMS = 112800 + TES(3036)%NHMS = 112900 + TES(3037)%NHMS = 122500 + TES(3038)%NHMS = 122600 + TES(3039)%NHMS = 122600 + TES(3040)%NHMS = 122700 + TES(3041)%NHMS = 122700 + TES(3042)%NHMS = 122700 + TES(3043)%NHMS = 122800 + TES(3044)%NHMS = 122900 + TES(3045)%NHMS = 123000 + TES(3046)%NHMS = 123100 + TES(3047)%NHMS = 123100 + TES(3048)%NHMS = 123200 + TES(3049)%NHMS = 123200 + TES(3050)%NHMS = 123300 + TES(3051)%NHMS = 123300 + TES(3052)%NHMS = 123500 + TES(3053)%NHMS = 123600 + TES(3054)%NHMS = 123600 + TES(3055)%NHMS = 123700 + TES(3056)%NHMS = 123700 + TES(3057)%NHMS = 123700 + TES(3058)%NHMS = 123900 + TES(3059)%NHMS = 132900 + TES(3060)%NHMS = 133400 + TES(3061)%NHMS = 133500 + TES(3062)%NHMS = 141400 + TES(3063)%NHMS = 141900 + TES(3064)%NHMS = 164200 + TES(3065)%NHMS = 164500 + TES(3066)%NHMS = 164500 + TES(3067)%NHMS = 164600 + TES(3068)%NHMS = 165000 + TES(3069)%NHMS = 172400 + TES(3070)%NHMS = 172600 + TES(3071)%NHMS = 172600 + TES(3072)%NHMS = 172700 + TES(3073)%NHMS = 172700 + TES(3074)%NHMS = 172700 + TES(3075)%NHMS = 172800 + TES(3076)%NHMS = 172800 + TES(3077)%NHMS = 172900 + TES(3078)%NHMS = 173100 + TES(3079)%NHMS = 173100 + TES(3080)%NHMS = 173200 + TES(3081)%NHMS = 173200 + TES(3082)%NHMS = 174500 + TES(3083)%NHMS = 174700 + TES(3084)%NHMS = 174700 + TES(3085)%NHMS = 174700 + TES(3086)%NHMS = 180400 + TES(3087)%NHMS = 180400 + TES(3088)%NHMS = 180500 + TES(3089)%NHMS = 180500 + TES(3090)%NHMS = 180600 + TES(3091)%NHMS = 180700 + TES(3092)%NHMS = 181000 + TES(3093)%NHMS = 181200 + TES(3094)%NHMS = 181200 + TES(3095)%NHMS = 182100 + TES(3096)%NHMS = 182100 + TES(3097)%NHMS = 185700 + TES(3098)%NHMS = 185700 + TES(3099)%NHMS = 185800 + TES(3100)%NHMS = 185800 + TES(3101)%NHMS = 185800 + TES(3102)%NHMS = 185900 + TES(3103)%NHMS = 185900 + TES(3104)%NHMS = 190000 + TES(3105)%NHMS = 190800 + TES(3106)%NHMS = 190800 + TES(3107)%NHMS = 190900 + TES(3108)%NHMS = 191200 + TES(3109)%NHMS = 191400 + TES(3110)%NHMS = 191800 + TES(3111)%NHMS = 191900 + TES(3112)%NHMS = 192100 + TES(3113)%NHMS = 192300 + TES(3114)%NHMS = 192400 + TES(3115)%NHMS = 192500 + TES(3116)%NHMS = 192500 + TES(3117)%NHMS = 194300 + TES(3118)%NHMS = 194500 + TES(3119)%NHMS = 194500 + TES(3120)%NHMS = 194600 + TES(3121)%NHMS = 194900 + TES(3122)%NHMS = 194900 + TES(3123)%NHMS = 195000 + TES(3124)%NHMS = 195100 + TES(3125)%NHMS = 205900 + TES(3126)%NHMS = 205900 + TES(3127)%NHMS = 210000 + TES(3128)%NHMS = 210200 + TES(3129)%NHMS = 210200 + TES(3130)%NHMS = 210300 + TES(3131)%NHMS = 210300 + TES(3132)%NHMS = 210400 + TES(3133)%NHMS = 210400 + TES(3134)%NHMS = 212200 + TES(3135)%NHMS = 212300 + TES(3136)%NHMS = 212400 + TES(3137)%NHMS = 212500 + TES(3138)%NHMS = 212500 + TES(3139)%NHMS = 212600 + TES(3140)%NHMS = 212800 + TES(3141)%NHMS = 212900 + TES(3142)%NHMS = 213000 + TES(3143)%NHMS = 213000 + TES(3144)%NHMS = 213100 + TES(3145)%NHMS = 230100 + TES(3146)%NHMS = 230200 + TES(3147)%NHMS = 230300 + TES(3148)%NHMS = 230300 + TES(3149)%NHMS = 230700 + TES(3150)%NHMS = 231400 + TES(3151)%NHMS = 231500 + TES(3152)%NHMS = 231600 + TES(3153)%NHMS = 231700 + TES(3154)%NHMS = 231700 + TES(3155)%NHMS = 231700 + TES(3156)%NHMS = 231800 + TES(3157)%NHMS = 231900 + TES(3158)%NHMS = 232000 + TES(3159)%NHMS = 232100 + TES(3160)%NHMS = 232100 + TES(3161)%NHMS = 232200 + TES(3162)%NHMS = 232200 + TES(3163)%NHMS = 001300 + TES(3164)%NHMS = 004000 + TES(3165)%NHMS = 004000 + TES(3166)%NHMS = 004200 + TES(3167)%NHMS = 004300 + TES(3168)%NHMS = 004400 + TES(3169)%NHMS = 004400 + TES(3170)%NHMS = 004500 + TES(3171)%NHMS = 004500 + TES(3172)%NHMS = 004800 + TES(3173)%NHMS = 004900 + TES(3174)%NHMS = 004900 + TES(3175)%NHMS = 005300 + TES(3176)%NHMS = 005300 + TES(3177)%NHMS = 005500 + TES(3178)%NHMS = 005600 + TES(3179)%NHMS = 005600 + TES(3180)%NHMS = 005700 + TES(3181)%NHMS = 020200 + TES(3182)%NHMS = 022100 + TES(3183)%NHMS = 022100 + TES(3184)%NHMS = 022600 + TES(3185)%NHMS = 022900 + TES(3186)%NHMS = 023100 + TES(3187)%NHMS = 023200 + TES(3188)%NHMS = 023200 + TES(3189)%NHMS = 033800 + TES(3190)%NHMS = 041600 + TES(3191)%NHMS = 041600 + TES(3192)%NHMS = 041600 + TES(3193)%NHMS = 041700 + TES(3194)%NHMS = 041800 + TES(3195)%NHMS = 041800 + TES(3196)%NHMS = 041900 + TES(3197)%NHMS = 041900 + TES(3198)%NHMS = 042000 + TES(3199)%NHMS = 045300 + TES(3200)%NHMS = 045400 + TES(3201)%NHMS = 045500 + TES(3202)%NHMS = 045900 + TES(3203)%NHMS = 051300 + TES(3204)%NHMS = 051400 + TES(3205)%NHMS = 051500 + TES(3206)%NHMS = 051700 + TES(3207)%NHMS = 051700 + TES(3208)%NHMS = 051800 + TES(3209)%NHMS = 051900 + TES(3210)%NHMS = 055000 + TES(3211)%NHMS = 055100 + TES(3212)%NHMS = 055100 + TES(3213)%NHMS = 055300 + TES(3214)%NHMS = 055500 + TES(3215)%NHMS = 055600 + TES(3216)%NHMS = 055700 + TES(3217)%NHMS = 055800 + TES(3218)%NHMS = 060000 + TES(3219)%NHMS = 060200 + TES(3220)%NHMS = 060200 + TES(3221)%NHMS = 060300 + TES(3222)%NHMS = 060300 + TES(3223)%NHMS = 060300 + TES(3224)%NHMS = 060400 + TES(3225)%NHMS = 060400 + TES(3226)%NHMS = 060500 + TES(3227)%NHMS = 060500 + TES(3228)%NHMS = 060600 + TES(3229)%NHMS = 064000 + TES(3230)%NHMS = 064600 + TES(3231)%NHMS = 064600 + TES(3232)%NHMS = 064900 + TES(3233)%NHMS = 065200 + TES(3234)%NHMS = 065300 + TES(3235)%NHMS = 065400 + TES(3236)%NHMS = 065400 + TES(3237)%NHMS = 065400 + TES(3238)%NHMS = 065500 + TES(3239)%NHMS = 065600 + TES(3240)%NHMS = 065700 + TES(3241)%NHMS = 065700 + TES(3242)%NHMS = 065800 + TES(3243)%NHMS = 071500 + TES(3244)%NHMS = 071600 + TES(3245)%NHMS = 071700 + TES(3246)%NHMS = 071800 + TES(3247)%NHMS = 071900 + TES(3248)%NHMS = 072000 + TES(3249)%NHMS = 072200 + TES(3250)%NHMS = 072400 + TES(3251)%NHMS = 072900 + TES(3252)%NHMS = 082300 + TES(3253)%NHMS = 082300 + TES(3254)%NHMS = 082500 + TES(3255)%NHMS = 082500 + TES(3256)%NHMS = 082600 + TES(3257)%NHMS = 083200 + TES(3258)%NHMS = 083300 + TES(3259)%NHMS = 083300 + TES(3260)%NHMS = 083500 + TES(3261)%NHMS = 083500 + TES(3262)%NHMS = 083600 + TES(3263)%NHMS = 083700 + TES(3264)%NHMS = 083700 + TES(3265)%NHMS = 085400 + TES(3266)%NHMS = 085500 + TES(3267)%NHMS = 085500 + TES(3268)%NHMS = 085600 + TES(3269)%NHMS = 085700 + TES(3270)%NHMS = 085900 + TES(3271)%NHMS = 085900 + TES(3272)%NHMS = 090200 + TES(3273)%NHMS = 090200 + TES(3274)%NHMS = 090300 + TES(3275)%NHMS = 090300 + TES(3276)%NHMS = 090400 + TES(3277)%NHMS = 100600 + TES(3278)%NHMS = 100900 + TES(3279)%NHMS = 101000 + TES(3280)%NHMS = 101400 + TES(3281)%NHMS = 101500 + TES(3282)%NHMS = 101500 + TES(3283)%NHMS = 101600 + TES(3284)%NHMS = 103300 + TES(3285)%NHMS = 103300 + TES(3286)%NHMS = 103400 + TES(3287)%NHMS = 103500 + TES(3288)%NHMS = 103500 + TES(3289)%NHMS = 103600 + TES(3290)%NHMS = 091900 + TES(3291)%NHMS = 092100 + TES(3292)%NHMS = 093800 + TES(3293)%NHMS = 093800 + TES(3294)%NHMS = 094100 + TES(3295)%NHMS = 094200 + TES(3296)%NHMS = 094300 + TES(3297)%NHMS = 094400 + TES(3298)%NHMS = 104400 + TES(3299)%NHMS = 104500 + TES(3300)%NHMS = 104500 + TES(3301)%NHMS = 104800 + TES(3302)%NHMS = 105400 + TES(3303)%NHMS = 105500 + TES(3304)%NHMS = 105600 + TES(3305)%NHMS = 110000 + TES(3306)%NHMS = 111600 + TES(3307)%NHMS = 111700 + TES(3308)%NHMS = 121300 + TES(3309)%NHMS = 121400 + TES(3310)%NHMS = 121400 + TES(3311)%NHMS = 121500 + TES(3312)%NHMS = 121600 + TES(3313)%NHMS = 121600 + TES(3314)%NHMS = 121700 + TES(3315)%NHMS = 121800 + TES(3316)%NHMS = 121800 + TES(3317)%NHMS = 121900 + TES(3318)%NHMS = 122000 + TES(3319)%NHMS = 122100 + TES(3320)%NHMS = 122100 + TES(3321)%NHMS = 122200 + TES(3322)%NHMS = 122300 + TES(3323)%NHMS = 122700 + TES(3324)%NHMS = 122900 + TES(3325)%NHMS = 123200 + TES(3326)%NHMS = 123400 + TES(3327)%NHMS = 123500 + TES(3328)%NHMS = 123500 + TES(3329)%NHMS = 123600 + TES(3330)%NHMS = 123600 + TES(3331)%NHMS = 123600 + TES(3332)%NHMS = 140300 + TES(3333)%NHMS = 140300 + TES(3334)%NHMS = 140400 + TES(3335)%NHMS = 140500 + TES(3336)%NHMS = 144700 + TES(3337)%NHMS = 163400 + TES(3338)%NHMS = 163400 + TES(3339)%NHMS = 163800 + TES(3340)%NHMS = 171300 + TES(3341)%NHMS = 171400 + TES(3342)%NHMS = 171500 + TES(3343)%NHMS = 171600 + TES(3344)%NHMS = 171700 + TES(3345)%NHMS = 171800 + TES(3346)%NHMS = 171900 + TES(3347)%NHMS = 173100 + TES(3348)%NHMS = 173500 + TES(3349)%NHMS = 173500 + TES(3350)%NHMS = 175200 + TES(3351)%NHMS = 175300 + TES(3352)%NHMS = 175300 + TES(3353)%NHMS = 175400 + TES(3354)%NHMS = 175500 + TES(3355)%NHMS = 175500 + TES(3356)%NHMS = 175600 + TES(3357)%NHMS = 175600 + TES(3358)%NHMS = 175700 + TES(3359)%NHMS = 180900 + TES(3360)%NHMS = 181000 + TES(3361)%NHMS = 184500 + TES(3362)%NHMS = 184600 + TES(3363)%NHMS = 184600 + TES(3364)%NHMS = 184700 + TES(3365)%NHMS = 184700 + TES(3366)%NHMS = 184800 + TES(3367)%NHMS = 184900 + TES(3368)%NHMS = 185400 + TES(3369)%NHMS = 185400 + TES(3370)%NHMS = 185600 + TES(3371)%NHMS = 185600 + TES(3372)%NHMS = 185700 + TES(3373)%NHMS = 185700 + TES(3374)%NHMS = 190700 + TES(3375)%NHMS = 190700 + TES(3376)%NHMS = 190800 + TES(3377)%NHMS = 190800 + TES(3378)%NHMS = 190900 + TES(3379)%NHMS = 191200 + TES(3380)%NHMS = 191300 + TES(3381)%NHMS = 193100 + TES(3382)%NHMS = 193100 + TES(3383)%NHMS = 193200 + TES(3384)%NHMS = 193200 + TES(3385)%NHMS = 193300 + TES(3386)%NHMS = 193400 + TES(3387)%NHMS = 193400 + TES(3388)%NHMS = 193600 + TES(3389)%NHMS = 193700 + TES(3390)%NHMS = 193700 + TES(3391)%NHMS = 193700 + TES(3392)%NHMS = 194400 + TES(3393)%NHMS = 204500 + TES(3394)%NHMS = 204600 + TES(3395)%NHMS = 204900 + TES(3396)%NHMS = 204900 + TES(3397)%NHMS = 205000 + TES(3398)%NHMS = 205000 + TES(3399)%NHMS = 205100 + TES(3400)%NHMS = 205100 + TES(3401)%NHMS = 205200 + TES(3402)%NHMS = 205300 + TES(3403)%NHMS = 210900 + TES(3404)%NHMS = 211000 + TES(3405)%NHMS = 211000 + TES(3406)%NHMS = 211100 + TES(3407)%NHMS = 211200 + TES(3408)%NHMS = 211200 + TES(3409)%NHMS = 211300 + TES(3410)%NHMS = 211300 + TES(3411)%NHMS = 211400 + TES(3412)%NHMS = 211400 + TES(3413)%NHMS = 211500 + TES(3414)%NHMS = 211700 + TES(3415)%NHMS = 211700 + TES(3416)%NHMS = 211800 + TES(3417)%NHMS = 224800 + TES(3418)%NHMS = 224900 + TES(3419)%NHMS = 224900 + TES(3420)%NHMS = 225000 + TES(3421)%NHMS = 225000 + TES(3422)%NHMS = 225500 + TES(3423)%NHMS = 225900 + TES(3424)%NHMS = 230000 + TES(3425)%NHMS = 230000 + TES(3426)%NHMS = 230100 + TES(3427)%NHMS = 230200 + TES(3428)%NHMS = 230200 + TES(3429)%NHMS = 230300 + TES(3430)%NHMS = 230300 + TES(3431)%NHMS = 230400 + TES(3432)%NHMS = 230500 + TES(3433)%NHMS = 230500 + TES(3434)%NHMS = 230600 + TES(3435)%NHMS = 230600 + TES(3436)%NHMS = 230700 + TES(3437)%NHMS = 230700 + TES(3438)%NHMS = 230800 + TES(3439)%NHMS = 230800 + TES(3440)%NHMS = 230900 + TES(3441)%NHMS = 231000 + TES(3442)%NHMS = 231100 + TES(3443)%NHMS = 002900 + TES(3444)%NHMS = 002900 + TES(3445)%NHMS = 003000 + TES(3446)%NHMS = 003000 + TES(3447)%NHMS = 003200 + TES(3448)%NHMS = 003200 + TES(3449)%NHMS = 003400 + TES(3450)%NHMS = 003600 + TES(3451)%NHMS = 003700 + TES(3452)%NHMS = 003700 + TES(3453)%NHMS = 003800 + TES(3454)%NHMS = 004100 + TES(3455)%NHMS = 004100 + TES(3456)%NHMS = 004300 + TES(3457)%NHMS = 004300 + TES(3458)%NHMS = 004400 + TES(3459)%NHMS = 004500 + TES(3460)%NHMS = 004500 + TES(3461)%NHMS = 004600 + TES(3462)%NHMS = 004700 + TES(3463)%NHMS = 004800 + TES(3464)%NHMS = 020600 + TES(3465)%NHMS = 020800 + TES(3466)%NHMS = 020800 + TES(3467)%NHMS = 020900 + TES(3468)%NHMS = 021000 + TES(3469)%NHMS = 021000 + TES(3470)%NHMS = 021100 + TES(3471)%NHMS = 021500 + TES(3472)%NHMS = 021600 + TES(3473)%NHMS = 021600 + TES(3474)%NHMS = 021800 + TES(3475)%NHMS = 022000 + TES(3476)%NHMS = 025900 + TES(3477)%NHMS = 030700 + TES(3478)%NHMS = 040300 + TES(3479)%NHMS = 040400 + TES(3480)%NHMS = 044100 + TES(3481)%NHMS = 044200 + TES(3482)%NHMS = 044500 + TES(3483)%NHMS = 044600 + TES(3484)%NHMS = 044600 + TES(3485)%NHMS = 044700 + TES(3486)%NHMS = 045000 + TES(3487)%NHMS = 050200 + TES(3488)%NHMS = 050200 + TES(3489)%NHMS = 050300 + TES(3490)%NHMS = 050300 + TES(3491)%NHMS = 050400 + TES(3492)%NHMS = 050500 + TES(3493)%NHMS = 050500 + TES(3494)%NHMS = 050600 + TES(3495)%NHMS = 054000 + TES(3496)%NHMS = 054000 + TES(3497)%NHMS = 054100 + TES(3498)%NHMS = 054100 + TES(3499)%NHMS = 054200 + TES(3500)%NHMS = 054200 + TES(3501)%NHMS = 054300 + TES(3502)%NHMS = 054300 + TES(3503)%NHMS = 054400 + TES(3504)%NHMS = 054400 + TES(3505)%NHMS = 054500 + TES(3506)%NHMS = 054800 + TES(3507)%NHMS = 054900 + TES(3508)%NHMS = 055000 + TES(3509)%NHMS = 055000 + TES(3510)%NHMS = 055100 + TES(3511)%NHMS = 055100 + TES(3512)%NHMS = 055200 + TES(3513)%NHMS = 055200 + TES(3514)%NHMS = 055200 + TES(3515)%NHMS = 055300 + TES(3516)%NHMS = 062000 + TES(3517)%NHMS = 062100 + TES(3518)%NHMS = 062200 + TES(3519)%NHMS = 062700 + TES(3520)%NHMS = 062900 + TES(3521)%NHMS = 063000 + TES(3522)%NHMS = 063700 + TES(3523)%NHMS = 063700 + TES(3524)%NHMS = 063700 + TES(3525)%NHMS = 063900 + TES(3526)%NHMS = 064000 + TES(3527)%NHMS = 064200 + TES(3528)%NHMS = 064300 + TES(3529)%NHMS = 064400 + TES(3530)%NHMS = 064500 + TES(3531)%NHMS = 064600 + TES(3532)%NHMS = 064600 + TES(3533)%NHMS = 070300 + TES(3534)%NHMS = 070400 + TES(3535)%NHMS = 070500 + TES(3536)%NHMS = 070500 + TES(3537)%NHMS = 070600 + TES(3538)%NHMS = 070700 + TES(3539)%NHMS = 070700 + TES(3540)%NHMS = 070800 + TES(3541)%NHMS = 071300 + TES(3542)%NHMS = 071500 + TES(3543)%NHMS = 081300 + TES(3544)%NHMS = 081400 + TES(3545)%NHMS = 082000 + TES(3546)%NHMS = 082100 + TES(3547)%NHMS = 082100 + TES(3548)%NHMS = 082200 + TES(3549)%NHMS = 082300 + TES(3550)%NHMS = 082400 + TES(3551)%NHMS = 082400 + TES(3552)%NHMS = 082400 + TES(3553)%NHMS = 084200 + TES(3554)%NHMS = 084300 + TES(3555)%NHMS = 084400 + TES(3556)%NHMS = 084500 + TES(3557)%NHMS = 084500 + TES(3558)%NHMS = 084600 + TES(3559)%NHMS = 084700 + TES(3560)%NHMS = 084700 + TES(3561)%NHMS = 084800 + TES(3562)%NHMS = 084900 + TES(3563)%NHMS = 084900 + TES(3564)%NHMS = 085000 + TES(3565)%NHMS = 085100 + TES(3566)%NHMS = 085200 + TES(3567)%NHMS = 085200 + TES(3568)%NHMS = 100400 + TES(3569)%NHMS = 100400 + TES(3570)%NHMS = 102000 + TES(3571)%NHMS = 102100 + TES(3572)%NHMS = 102100 + TES(3573)%NHMS = 102200 + TES(3574)%NHMS = 102200 + TES(3575)%NHMS = 103300 + TES(3576)%NHMS = 103400 + TES(3577)%NHMS = 103500 + TES(3578)%NHMS = 104200 + TES(3579)%NHMS = 104300 + TES(3580)%NHMS = 104500 + TES(3581)%NHMS = 104700 + TES(3582)%NHMS = 110500 + TES(3583)%NHMS = 110500 + TES(3584)%NHMS = 120100 + TES(3585)%NHMS = 120200 + TES(3586)%NHMS = 120300 + TES(3587)%NHMS = 120300 + TES(3588)%NHMS = 120400 + TES(3589)%NHMS = 120400 + TES(3590)%NHMS = 120500 + TES(3591)%NHMS = 120600 + TES(3592)%NHMS = 120700 + TES(3593)%NHMS = 120800 + TES(3594)%NHMS = 120900 + TES(3595)%NHMS = 121000 + TES(3596)%NHMS = 121100 + TES(3597)%NHMS = 121400 + TES(3598)%NHMS = 122100 + TES(3599)%NHMS = 122100 + TES(3600)%NHMS = 122200 + TES(3601)%NHMS = 122300 + TES(3602)%NHMS = 122400 + TES(3603)%NHMS = 122500 + TES(3604)%NHMS = 135000 + TES(3605)%NHMS = 135200 + TES(3606)%NHMS = 135300 + TES(3607)%NHMS = 143600 + TES(3608)%NHMS = 160100 + TES(3609)%NHMS = 160200 + TES(3610)%NHMS = 160200 + TES(3611)%NHMS = 160300 + TES(3612)%NHMS = 162100 + TES(3613)%NHMS = 162200 + TES(3614)%NHMS = 162200 + TES(3615)%NHMS = 162300 + TES(3616)%NHMS = 162600 + TES(3617)%NHMS = 170000 + TES(3618)%NHMS = 170100 + TES(3619)%NHMS = 170100 + TES(3620)%NHMS = 170100 + TES(3621)%NHMS = 170300 + TES(3622)%NHMS = 170500 + TES(3623)%NHMS = 170500 + TES(3624)%NHMS = 170600 + TES(3625)%NHMS = 170600 + TES(3626)%NHMS = 171900 + TES(3627)%NHMS = 172200 + TES(3628)%NHMS = 174100 + TES(3629)%NHMS = 174100 + TES(3630)%NHMS = 174100 + TES(3631)%NHMS = 174200 + TES(3632)%NHMS = 174300 + TES(3633)%NHMS = 174400 + TES(3634)%NHMS = 174400 + TES(3635)%NHMS = 174500 + TES(3636)%NHMS = 174500 + TES(3637)%NHMS = 175100 + TES(3638)%NHMS = 175100 + TES(3639)%NHMS = 175800 + TES(3640)%NHMS = 183300 + TES(3641)%NHMS = 183400 + TES(3642)%NHMS = 183400 + TES(3643)%NHMS = 183500 + TES(3644)%NHMS = 183600 + TES(3645)%NHMS = 183600 + TES(3646)%NHMS = 183700 + TES(3647)%NHMS = 183800 + TES(3648)%NHMS = 183800 + TES(3649)%NHMS = 184100 + TES(3650)%NHMS = 184200 + TES(3651)%NHMS = 184300 + TES(3652)%NHMS = 184500 + TES(3653)%NHMS = 184600 + TES(3654)%NHMS = 185100 + TES(3655)%NHMS = 185300 + TES(3656)%NHMS = 185300 + TES(3657)%NHMS = 185400 + TES(3658)%NHMS = 185600 + TES(3659)%NHMS = 185600 + TES(3660)%NHMS = 185700 + TES(3661)%NHMS = 185700 + TES(3662)%NHMS = 185800 + TES(3663)%NHMS = 185900 + TES(3664)%NHMS = 185900 + TES(3665)%NHMS = 190000 + TES(3666)%NHMS = 190100 + TES(3667)%NHMS = 191800 + TES(3668)%NHMS = 192100 + TES(3669)%NHMS = 192700 + TES(3670)%NHMS = 192800 + TES(3671)%NHMS = 193000 + TES(3672)%NHMS = 202900 + TES(3673)%NHMS = 203000 + TES(3674)%NHMS = 203000 + TES(3675)%NHMS = 203500 + TES(3676)%NHMS = 203600 + TES(3677)%NHMS = 203600 + TES(3678)%NHMS = 203800 + TES(3679)%NHMS = 203800 + TES(3680)%NHMS = 203900 + TES(3681)%NHMS = 203900 + TES(3682)%NHMS = 204000 + TES(3683)%NHMS = 205700 + TES(3684)%NHMS = 205800 + TES(3685)%NHMS = 205900 + TES(3686)%NHMS = 205900 + TES(3687)%NHMS = 210000 + TES(3688)%NHMS = 210100 + TES(3689)%NHMS = 210200 + TES(3690)%NHMS = 210300 + TES(3691)%NHMS = 210400 + TES(3692)%NHMS = 210700 + TES(3693)%NHMS = 223600 + TES(3694)%NHMS = 223600 + TES(3695)%NHMS = 223800 + TES(3696)%NHMS = 223800 + TES(3697)%NHMS = 223900 + TES(3698)%NHMS = 224400 + TES(3699)%NHMS = 224400 + TES(3700)%NHMS = 224700 + TES(3701)%NHMS = 224800 + TES(3702)%NHMS = 225100 + TES(3703)%NHMS = 225600 + TES(3704)%NHMS = 235700 + TES(3705)%NHMS = 001500 + TES(3706)%NHMS = 001500 + TES(3707)%NHMS = 001600 + TES(3708)%NHMS = 002000 + TES(3709)%NHMS = 002000 + TES(3710)%NHMS = 002100 + TES(3711)%NHMS = 002300 + TES(3712)%NHMS = 002400 + TES(3713)%NHMS = 002500 + TES(3714)%NHMS = 003000 + TES(3715)%NHMS = 003200 + TES(3716)%NHMS = 003200 + TES(3717)%NHMS = 003200 + TES(3718)%NHMS = 003300 + TES(3719)%NHMS = 003400 + TES(3720)%NHMS = 003500 + TES(3721)%NHMS = 003700 + TES(3722)%NHMS = 003700 + TES(3723)%NHMS = 015500 + TES(3724)%NHMS = 015600 + TES(3725)%NHMS = 015700 + TES(3726)%NHMS = 015800 + TES(3727)%NHMS = 020100 + TES(3728)%NHMS = 020300 + TES(3729)%NHMS = 020400 + TES(3730)%NHMS = 020500 + TES(3731)%NHMS = 020600 + TES(3732)%NHMS = 020700 + TES(3733)%NHMS = 020800 + TES(3734)%NHMS = 020800 + TES(3735)%NHMS = 020800 + TES(3736)%NHMS = 024800 + TES(3737)%NHMS = 031200 + TES(3738)%NHMS = 042700 + TES(3739)%NHMS = 043200 + TES(3740)%NHMS = 043200 + TES(3741)%NHMS = 043300 + TES(3742)%NHMS = 043300 + TES(3743)%NHMS = 043800 + TES(3744)%NHMS = 044800 + TES(3745)%NHMS = 044900 + TES(3746)%NHMS = 045000 + TES(3747)%NHMS = 045000 + TES(3748)%NHMS = 045100 + TES(3749)%NHMS = 045100 + TES(3750)%NHMS = 045200 + TES(3751)%NHMS = 045400 + TES(3752)%NHMS = 045400 + TES(3753)%NHMS = 052800 + TES(3754)%NHMS = 052900 + TES(3755)%NHMS = 053100 + TES(3756)%NHMS = 053100 + TES(3757)%NHMS = 053200 + TES(3758)%NHMS = 053300 + TES(3759)%NHMS = 053400 + TES(3760)%NHMS = 053400 + TES(3761)%NHMS = 053500 + TES(3762)%NHMS = 053500 + TES(3763)%NHMS = 053600 + TES(3764)%NHMS = 053700 + TES(3765)%NHMS = 053700 + TES(3766)%NHMS = 053800 + TES(3767)%NHMS = 053800 + TES(3768)%NHMS = 053900 + TES(3769)%NHMS = 053900 + TES(3770)%NHMS = 054000 + TES(3771)%NHMS = 054000 + TES(3772)%NHMS = 060800 + TES(3773)%NHMS = 060900 + TES(3774)%NHMS = 061200 + TES(3775)%NHMS = 061500 + TES(3776)%NHMS = 061700 + TES(3777)%NHMS = 061700 + TES(3778)%NHMS = 061800 + TES(3779)%NHMS = 061800 + TES(3780)%NHMS = 062300 + TES(3781)%NHMS = 062400 + TES(3782)%NHMS = 062500 + TES(3783)%NHMS = 062800 + TES(3784)%NHMS = 063300 + TES(3785)%NHMS = 063300 + TES(3786)%NHMS = 063400 + TES(3787)%NHMS = 065100 + TES(3788)%NHMS = 065100 + TES(3789)%NHMS = 070000 + TES(3790)%NHMS = 070400 + TES(3791)%NHMS = 070700 + TES(3792)%NHMS = 070700 + TES(3793)%NHMS = 080400 + TES(3794)%NHMS = 080800 + TES(3795)%NHMS = 080800 + TES(3796)%NHMS = 080900 + TES(3797)%NHMS = 081000 + TES(3798)%NHMS = 081100 + TES(3799)%NHMS = 081200 + TES(3800)%NHMS = 081300 + TES(3801)%NHMS = 083000 + TES(3802)%NHMS = 083100 + TES(3803)%NHMS = 083100 + TES(3804)%NHMS = 083200 + TES(3805)%NHMS = 083400 + TES(3806)%NHMS = 083700 + TES(3807)%NHMS = 083700 + TES(3808)%NHMS = 083800 + TES(3809)%NHMS = 083900 + TES(3810)%NHMS = 083900 + TES(3811)%NHMS = 083900 + TES(3812)%NHMS = 084000 + TES(3813)%NHMS = 094700 + TES(3814)%NHMS = 094900 + TES(3815)%NHMS = 095000 + TES(3816)%NHMS = 095100 + TES(3817)%NHMS = 100800 + TES(3818)%NHMS = 101000 + TES(3819)%NHMS = 101000 + TES(3820)%NHMS = 101000 + TES(3821)%NHMS = 101100 + TES(3822)%NHMS = 101200 + TES(3823)%NHMS = 101200 + TES(3824)%NHMS = 101300 + TES(3825)%NHMS = 111300 + TES(3826)%NHMS = 111400 + TES(3827)%NHMS = 111400 + TES(3828)%NHMS = 111500 + TES(3829)%NHMS = 111600 + TES(3830)%NHMS = 111600 + TES(3831)%NHMS = 111600 + TES(3832)%NHMS = 111700 + TES(3833)%NHMS = 112600 + TES(3834)%NHMS = 112600 + TES(3835)%NHMS = 112800 + TES(3836)%NHMS = 112800 + TES(3837)%NHMS = 112900 + TES(3838)%NHMS = 112900 + TES(3839)%NHMS = 113000 + TES(3840)%NHMS = 114700 + TES(3841)%NHMS = 102100 + TES(3842)%NHMS = 102500 + TES(3843)%NHMS = 102700 + TES(3844)%NHMS = 102800 + TES(3845)%NHMS = 102900 + TES(3846)%NHMS = 103100 + TES(3847)%NHMS = 103100 + TES(3848)%NHMS = 103200 + TES(3849)%NHMS = 103200 + TES(3850)%NHMS = 103300 + TES(3851)%NHMS = 103300 + TES(3852)%NHMS = 103400 + TES(3853)%NHMS = 103400 + TES(3854)%NHMS = 103500 + TES(3855)%NHMS = 105100 + TES(3856)%NHMS = 105200 + TES(3857)%NHMS = 105200 + TES(3858)%NHMS = 105300 + TES(3859)%NHMS = 105300 + TES(3860)%NHMS = 105400 + TES(3861)%NHMS = 115100 + TES(3862)%NHMS = 115100 + TES(3863)%NHMS = 115200 + TES(3864)%NHMS = 115300 + TES(3865)%NHMS = 115400 + TES(3866)%NHMS = 115500 + TES(3867)%NHMS = 115500 + TES(3868)%NHMS = 115500 + TES(3869)%NHMS = 115600 + TES(3870)%NHMS = 115600 + TES(3871)%NHMS = 115900 + TES(3872)%NHMS = 115900 + TES(3873)%NHMS = 120400 + TES(3874)%NHMS = 120500 + TES(3875)%NHMS = 120500 + TES(3876)%NHMS = 120900 + TES(3877)%NHMS = 121000 + TES(3878)%NHMS = 121000 + TES(3879)%NHMS = 121100 + TES(3880)%NHMS = 121200 + TES(3881)%NHMS = 121400 + TES(3882)%NHMS = 133800 + TES(3883)%NHMS = 134100 + TES(3884)%NHMS = 134100 + TES(3885)%NHMS = 154900 + TES(3886)%NHMS = 160800 + TES(3887)%NHMS = 160900 + TES(3888)%NHMS = 160900 + TES(3889)%NHMS = 161000 + TES(3890)%NHMS = 161000 + TES(3891)%NHMS = 161100 + TES(3892)%NHMS = 161300 + TES(3893)%NHMS = 161400 + TES(3894)%NHMS = 164800 + TES(3895)%NHMS = 164900 + TES(3896)%NHMS = 164900 + TES(3897)%NHMS = 164900 + TES(3898)%NHMS = 165000 + TES(3899)%NHMS = 165000 + TES(3900)%NHMS = 165100 + TES(3901)%NHMS = 165100 + TES(3902)%NHMS = 165200 + TES(3903)%NHMS = 165200 + TES(3904)%NHMS = 165300 + TES(3905)%NHMS = 170800 + TES(3906)%NHMS = 170800 + TES(3907)%NHMS = 170900 + TES(3908)%NHMS = 171000 + TES(3909)%NHMS = 172700 + TES(3910)%NHMS = 172800 + TES(3911)%NHMS = 172900 + TES(3912)%NHMS = 172900 + TES(3913)%NHMS = 173000 + TES(3914)%NHMS = 173100 + TES(3915)%NHMS = 173300 + TES(3916)%NHMS = 174400 + TES(3917)%NHMS = 174400 + TES(3918)%NHMS = 174900 + TES(3919)%NHMS = 175000 + TES(3920)%NHMS = 182300 + TES(3921)%NHMS = 182400 + TES(3922)%NHMS = 182400 + TES(3923)%NHMS = 182500 + TES(3924)%NHMS = 182500 + TES(3925)%NHMS = 182600 + TES(3926)%NHMS = 182600 + TES(3927)%NHMS = 182800 + TES(3928)%NHMS = 182900 + TES(3929)%NHMS = 183000 + TES(3930)%NHMS = 183000 + TES(3931)%NHMS = 183100 + TES(3932)%NHMS = 183100 + TES(3933)%NHMS = 183200 + TES(3934)%NHMS = 183200 + TES(3935)%NHMS = 183300 + TES(3936)%NHMS = 183500 + TES(3937)%NHMS = 184000 + TES(3938)%NHMS = 184000 + TES(3939)%NHMS = 184400 + TES(3940)%NHMS = 184400 + TES(3941)%NHMS = 184500 + TES(3942)%NHMS = 184500 + TES(3943)%NHMS = 184600 + TES(3944)%NHMS = 184600 + TES(3945)%NHMS = 184600 + TES(3946)%NHMS = 184800 + TES(3947)%NHMS = 190600 + TES(3948)%NHMS = 190600 + TES(3949)%NHMS = 190700 + TES(3950)%NHMS = 190700 + TES(3951)%NHMS = 190800 + TES(3952)%NHMS = 190900 + TES(3953)%NHMS = 191200 + TES(3954)%NHMS = 192100 + TES(3955)%NHMS = 201700 + TES(3956)%NHMS = 201700 + TES(3957)%NHMS = 201800 + TES(3958)%NHMS = 201900 + TES(3959)%NHMS = 201900 + TES(3960)%NHMS = 202000 + TES(3961)%NHMS = 202200 + TES(3962)%NHMS = 202300 + TES(3963)%NHMS = 202500 + TES(3964)%NHMS = 202700 + TES(3965)%NHMS = 202700 + TES(3966)%NHMS = 202700 + TES(3967)%NHMS = 204500 + TES(3968)%NHMS = 204500 + TES(3969)%NHMS = 204600 + TES(3970)%NHMS = 204600 + TES(3971)%NHMS = 204700 + TES(3972)%NHMS = 204700 + TES(3973)%NHMS = 204700 + TES(3974)%NHMS = 204800 + TES(3975)%NHMS = 204900 + TES(3976)%NHMS = 204900 + TES(3977)%NHMS = 205200 + TES(3978)%NHMS = 205400 + TES(3979)%NHMS = 205600 + TES(3980)%NHMS = 205600 + TES(3981)%NHMS = 205700 + TES(3982)%NHMS = 220700 + TES(3983)%NHMS = 222500 + TES(3984)%NHMS = 222600 + TES(3985)%NHMS = 222800 + TES(3986)%NHMS = 222800 + TES(3987)%NHMS = 223000 + TES(3988)%NHMS = 223200 + TES(3989)%NHMS = 223200 + TES(3990)%NHMS = 223700 + TES(3991)%NHMS = 223800 + + + TES(1)%FILENAME = TRIM('retv_vars.10642_0018_003.cdf') + TES(2)%FILENAME = TRIM('retv_vars.10642_0018_004.cdf') + TES(3)%FILENAME = TRIM('retv_vars.10642_0019_003.cdf') + TES(4)%FILENAME = TRIM('retv_vars.10642_0020_003.cdf') + TES(5)%FILENAME = TRIM('retv_vars.10642_0021_002.cdf') + TES(6)%FILENAME = TRIM('retv_vars.10642_0021_003.cdf') + TES(7)%FILENAME = TRIM('retv_vars.10642_0021_004.cdf') + TES(8)%FILENAME = TRIM('retv_vars.10642_0022_002.cdf') + TES(9)%FILENAME = TRIM('retv_vars.10642_0022_003.cdf') + TES(10)%FILENAME = TRIM('retv_vars.10642_0022_004.cdf') + TES(11)%FILENAME = TRIM('retv_vars.10642_0023_002.cdf') + TES(12)%FILENAME = TRIM('retv_vars.10642_0028_002.cdf') + TES(13)%FILENAME = TRIM('retv_vars.10642_0028_003.cdf') + TES(14)%FILENAME = TRIM('retv_vars.10642_0029_002.cdf') + TES(15)%FILENAME = TRIM('retv_vars.10642_0055_002.cdf') + TES(16)%FILENAME = TRIM('retv_vars.10642_0057_002.cdf') + TES(17)%FILENAME = TRIM('retv_vars.10642_0057_003.cdf') + TES(18)%FILENAME = TRIM('retv_vars.10642_0058_002.cdf') + TES(19)%FILENAME = TRIM('retv_vars.10642_0060_003.cdf') + TES(20)%FILENAME = TRIM('retv_vars.10642_0061_002.cdf') + TES(21)%FILENAME = TRIM('retv_vars.10642_0063_002.cdf') + TES(22)%FILENAME = TRIM('retv_vars.10642_0064_004.cdf') + TES(23)%FILENAME = TRIM('retv_vars.10642_0066_003.cdf') + TES(24)%FILENAME = TRIM('retv_vars.10642_0066_004.cdf') + TES(25)%FILENAME = TRIM('retv_vars.10642_0067_003.cdf') + TES(26)%FILENAME = TRIM('retv_vars.10642_0067_004.cdf') + TES(27)%FILENAME = TRIM('retv_vars.10642_0068_003.cdf') + TES(28)%FILENAME = TRIM('retv_vars.10642_0069_002.cdf') + TES(29)%FILENAME = TRIM('retv_vars.10642_0069_003.cdf') + TES(30)%FILENAME = TRIM('retv_vars.10642_0069_004.cdf') + TES(31)%FILENAME = TRIM('retv_vars.10642_0070_004.cdf') + TES(32)%FILENAME = TRIM('retv_vars.10642_0108_004.cdf') + TES(33)%FILENAME = TRIM('retv_vars.10642_0109_002.cdf') + TES(34)%FILENAME = TRIM('retv_vars.10642_0109_003.cdf') + TES(35)%FILENAME = TRIM('retv_vars.10642_0185_002.cdf') + TES(36)%FILENAME = TRIM('retv_vars.10642_0187_003.cdf') + TES(37)%FILENAME = TRIM('retv_vars.10642_0187_004.cdf') + TES(38)%FILENAME = TRIM('retv_vars.10642_0190_003.cdf') + TES(39)%FILENAME = TRIM('retv_vars.10642_0190_004.cdf') + TES(40)%FILENAME = TRIM('retv_vars.10642_0199_004.cdf') + TES(41)%FILENAME = TRIM('retv_vars.10642_0200_002.cdf') + TES(42)%FILENAME = TRIM('retv_vars.10642_0200_003.cdf') + TES(43)%FILENAME = TRIM('retv_vars.10642_0200_004.cdf') + TES(44)%FILENAME = TRIM('retv_vars.10642_0201_002.cdf') + TES(45)%FILENAME = TRIM('retv_vars.10642_0201_003.cdf') + TES(46)%FILENAME = TRIM('retv_vars.10642_0201_004.cdf') + TES(47)%FILENAME = TRIM('retv_vars.10642_0212_003.cdf') + TES(48)%FILENAME = TRIM('retv_vars.10642_0212_004.cdf') + TES(49)%FILENAME = TRIM('retv_vars.10642_0213_002.cdf') + TES(50)%FILENAME = TRIM('retv_vars.10642_0213_003.cdf') + TES(51)%FILENAME = TRIM('retv_vars.10642_0213_004.cdf') + TES(52)%FILENAME = TRIM('retv_vars.10642_0220_002.cdf') + TES(53)%FILENAME = TRIM('retv_vars.10642_0220_003.cdf') + TES(54)%FILENAME = TRIM('retv_vars.10642_0220_004.cdf') + TES(55)%FILENAME = TRIM('retv_vars.10642_0224_002.cdf') + TES(56)%FILENAME = TRIM('retv_vars.10642_0229_002.cdf') + TES(57)%FILENAME = TRIM('retv_vars.10642_0229_003.cdf') + TES(58)%FILENAME = TRIM('retv_vars.10642_0229_004.cdf') + TES(59)%FILENAME = TRIM('retv_vars.10642_0235_003.cdf') + TES(60)%FILENAME = TRIM('retv_vars.10642_0238_002.cdf') + TES(61)%FILENAME = TRIM('retv_vars.10642_0243_003.cdf') + TES(62)%FILENAME = TRIM('retv_vars.10642_0244_002.cdf') + TES(63)%FILENAME = TRIM('retv_vars.10642_0244_003.cdf') + TES(64)%FILENAME = TRIM('retv_vars.10642_0244_004.cdf') + TES(65)%FILENAME = TRIM('retv_vars.10642_0245_004.cdf') + TES(66)%FILENAME = TRIM('retv_vars.10642_0246_002.cdf') + TES(67)%FILENAME = TRIM('retv_vars.10642_0246_003.cdf') + TES(68)%FILENAME = TRIM('retv_vars.10642_0246_004.cdf') + TES(69)%FILENAME = TRIM('retv_vars.10642_0247_004.cdf') + TES(70)%FILENAME = TRIM('retv_vars.10642_0248_002.cdf') + TES(71)%FILENAME = TRIM('retv_vars.10642_0248_003.cdf') + TES(72)%FILENAME = TRIM('retv_vars.10642_0248_004.cdf') + TES(73)%FILENAME = TRIM('retv_vars.10642_0249_002.cdf') + TES(74)%FILENAME = TRIM('retv_vars.10642_0249_003.cdf') + TES(75)%FILENAME = TRIM('retv_vars.10642_0249_004.cdf') + TES(76)%FILENAME = TRIM('retv_vars.10642_0250_002.cdf') + TES(77)%FILENAME = TRIM('retv_vars.10642_0250_003.cdf') + TES(78)%FILENAME = TRIM('retv_vars.10642_0250_004.cdf') + TES(79)%FILENAME = TRIM('retv_vars.10642_0251_003.cdf') + TES(80)%FILENAME = TRIM('retv_vars.10642_0252_004.cdf') + TES(81)%FILENAME = TRIM('retv_vars.10642_0253_002.cdf') + TES(82)%FILENAME = TRIM('retv_vars.10642_0254_004.cdf') + TES(83)%FILENAME = TRIM('retv_vars.10642_0258_002.cdf') + TES(84)%FILENAME = TRIM('retv_vars.10642_0258_003.cdf') + TES(85)%FILENAME = TRIM('retv_vars.10642_0258_004.cdf') + TES(86)%FILENAME = TRIM('retv_vars.10642_0259_003.cdf') + TES(87)%FILENAME = TRIM('retv_vars.10642_0259_004.cdf') + TES(88)%FILENAME = TRIM('retv_vars.10642_0261_003.cdf') + TES(89)%FILENAME = TRIM('retv_vars.10642_0261_004.cdf') + TES(90)%FILENAME = TRIM('retv_vars.10642_0262_002.cdf') + TES(91)%FILENAME = TRIM('retv_vars.10642_0267_002.cdf') + TES(92)%FILENAME = TRIM('retv_vars.10642_0267_003.cdf') + TES(93)%FILENAME = TRIM('retv_vars.10642_0267_004.cdf') + TES(94)%FILENAME = TRIM('retv_vars.10642_0268_002.cdf') + TES(95)%FILENAME = TRIM('retv_vars.10642_0268_003.cdf') + TES(96)%FILENAME = TRIM('retv_vars.10642_0268_004.cdf') + TES(97)%FILENAME = TRIM('retv_vars.10642_0269_002.cdf') + TES(98)%FILENAME = TRIM('retv_vars.10642_0269_004.cdf') + TES(99)%FILENAME = TRIM('retv_vars.10642_0274_003.cdf') + TES(100)%FILENAME = TRIM('retv_vars.10642_0275_002.cdf') + TES(101)%FILENAME = TRIM('retv_vars.10642_0275_003.cdf') + TES(102)%FILENAME = TRIM('retv_vars.10642_0275_004.cdf') + TES(103)%FILENAME = TRIM('retv_vars.10642_0277_004.cdf') + TES(104)%FILENAME = TRIM('retv_vars.10642_0278_002.cdf') + TES(105)%FILENAME = TRIM('retv_vars.10642_0302_003.cdf') + TES(106)%FILENAME = TRIM('retv_vars.10642_0302_004.cdf') + TES(107)%FILENAME = TRIM('retv_vars.10642_0303_004.cdf') + TES(108)%FILENAME = TRIM('retv_vars.10642_0304_004.cdf') + TES(109)%FILENAME = TRIM('retv_vars.10642_0305_002.cdf') + TES(110)%FILENAME = TRIM('retv_vars.10642_0305_004.cdf') + TES(111)%FILENAME = TRIM('retv_vars.10642_0306_002.cdf') + TES(112)%FILENAME = TRIM('retv_vars.10642_0306_004.cdf') + TES(113)%FILENAME = TRIM('retv_vars.10642_0308_002.cdf') + TES(114)%FILENAME = TRIM('retv_vars.10642_0309_002.cdf') + TES(115)%FILENAME = TRIM('retv_vars.10642_0309_004.cdf') + TES(116)%FILENAME = TRIM('retv_vars.10642_0310_002.cdf') + TES(117)%FILENAME = TRIM('retv_vars.10642_0310_004.cdf') + TES(118)%FILENAME = TRIM('retv_vars.10642_0315_002.cdf') + TES(119)%FILENAME = TRIM('retv_vars.10642_0315_003.cdf') + TES(120)%FILENAME = TRIM('retv_vars.10642_0315_004.cdf') + TES(121)%FILENAME = TRIM('retv_vars.10642_0317_002.cdf') + TES(122)%FILENAME = TRIM('retv_vars.10642_0317_003.cdf') + TES(123)%FILENAME = TRIM('retv_vars.10642_0317_004.cdf') + TES(124)%FILENAME = TRIM('retv_vars.10642_0318_002.cdf') + TES(125)%FILENAME = TRIM('retv_vars.10642_0318_003.cdf') + TES(126)%FILENAME = TRIM('retv_vars.10642_0318_004.cdf') + TES(127)%FILENAME = TRIM('retv_vars.10642_0321_004.cdf') + TES(128)%FILENAME = TRIM('retv_vars.10642_0322_003.cdf') + TES(129)%FILENAME = TRIM('retv_vars.10642_0324_003.cdf') + TES(130)%FILENAME = TRIM('retv_vars.10642_0358_002.cdf') + TES(131)%FILENAME = TRIM('retv_vars.10642_0364_002.cdf') + TES(132)%FILENAME = TRIM('retv_vars.10642_0364_003.cdf') + TES(133)%FILENAME = TRIM('retv_vars.10642_0367_004.cdf') + TES(134)%FILENAME = TRIM('retv_vars.10642_0378_004.cdf') + TES(135)%FILENAME = TRIM('retv_vars.10642_0379_002.cdf') + TES(136)%FILENAME = TRIM('retv_vars.10642_0379_003.cdf') + TES(137)%FILENAME = TRIM('retv_vars.10642_0379_004.cdf') + TES(138)%FILENAME = TRIM('retv_vars.10642_0406_003.cdf') + TES(139)%FILENAME = TRIM('retv_vars.10642_0407_002.cdf') + TES(140)%FILENAME = TRIM('retv_vars.10642_0411_002.cdf') + TES(141)%FILENAME = TRIM('retv_vars.10642_0411_003.cdf') + TES(142)%FILENAME = TRIM('retv_vars.10642_0411_004.cdf') + TES(143)%FILENAME = TRIM('retv_vars.10642_0412_002.cdf') + TES(144)%FILENAME = TRIM('retv_vars.10642_0412_004.cdf') + TES(145)%FILENAME = TRIM('retv_vars.10642_0413_003.cdf') + TES(146)%FILENAME = TRIM('retv_vars.10642_0414_004.cdf') + TES(147)%FILENAME = TRIM('retv_vars.10642_0415_002.cdf') + TES(148)%FILENAME = TRIM('retv_vars.10642_0415_003.cdf') + TES(149)%FILENAME = TRIM('retv_vars.10642_0418_004.cdf') + TES(150)%FILENAME = TRIM('retv_vars.10642_0419_002.cdf') + TES(151)%FILENAME = TRIM('retv_vars.10642_0419_003.cdf') + TES(152)%FILENAME = TRIM('retv_vars.10642_0420_002.cdf') + TES(153)%FILENAME = TRIM('retv_vars.10642_0421_004.cdf') + TES(154)%FILENAME = TRIM('retv_vars.10642_0422_002.cdf') + TES(155)%FILENAME = TRIM('retv_vars.10642_0422_004.cdf') + TES(156)%FILENAME = TRIM('retv_vars.10642_0423_003.cdf') + TES(157)%FILENAME = TRIM('retv_vars.10642_0423_004.cdf') + TES(158)%FILENAME = TRIM('retv_vars.10642_0424_002.cdf') + TES(159)%FILENAME = TRIM('retv_vars.10642_0424_003.cdf') + TES(160)%FILENAME = TRIM('retv_vars.10642_0424_004.cdf') + TES(161)%FILENAME = TRIM('retv_vars.10642_0425_002.cdf') + TES(162)%FILENAME = TRIM('retv_vars.10642_0425_004.cdf') + TES(163)%FILENAME = TRIM('retv_vars.10642_0426_003.cdf') + TES(164)%FILENAME = TRIM('retv_vars.10642_0459_002.cdf') + TES(165)%FILENAME = TRIM('retv_vars.10642_0461_003.cdf') + TES(166)%FILENAME = TRIM('retv_vars.10642_0462_002.cdf') + TES(167)%FILENAME = TRIM('retv_vars.10642_0462_003.cdf') + TES(168)%FILENAME = TRIM('retv_vars.10642_0463_004.cdf') + TES(169)%FILENAME = TRIM('retv_vars.10642_0468_004.cdf') + TES(170)%FILENAME = TRIM('retv_vars.10642_0469_002.cdf') + TES(171)%FILENAME = TRIM('retv_vars.10642_0469_003.cdf') + TES(172)%FILENAME = TRIM('retv_vars.10642_0469_004.cdf') + TES(173)%FILENAME = TRIM('retv_vars.10642_0507_003.cdf') + TES(174)%FILENAME = TRIM('retv_vars.10642_0508_003.cdf') + TES(175)%FILENAME = TRIM('retv_vars.10642_0513_003.cdf') + TES(176)%FILENAME = TRIM('retv_vars.10642_0532_003.cdf') + TES(177)%FILENAME = TRIM('retv_vars.10642_0532_004.cdf') + TES(178)%FILENAME = TRIM('retv_vars.10642_0533_003.cdf') + TES(179)%FILENAME = TRIM('retv_vars.10642_0533_004.cdf') + TES(180)%FILENAME = TRIM('retv_vars.10642_0534_002.cdf') + TES(181)%FILENAME = TRIM('retv_vars.10642_0534_003.cdf') + TES(182)%FILENAME = TRIM('retv_vars.10642_0548_002.cdf') + TES(183)%FILENAME = TRIM('retv_vars.10642_0548_004.cdf') + TES(184)%FILENAME = TRIM('retv_vars.10642_0549_002.cdf') + TES(185)%FILENAME = TRIM('retv_vars.10642_0549_004.cdf') + TES(186)%FILENAME = TRIM('retv_vars.10642_0550_002.cdf') + TES(187)%FILENAME = TRIM('retv_vars.10642_0567_003.cdf') + TES(188)%FILENAME = TRIM('retv_vars.10642_0567_004.cdf') + TES(189)%FILENAME = TRIM('retv_vars.10642_0568_002.cdf') + TES(190)%FILENAME = TRIM('retv_vars.10642_0568_003.cdf') + TES(191)%FILENAME = TRIM('retv_vars.10642_0568_004.cdf') + TES(192)%FILENAME = TRIM('retv_vars.10642_0569_003.cdf') + TES(193)%FILENAME = TRIM('retv_vars.10642_0569_004.cdf') + TES(194)%FILENAME = TRIM('retv_vars.10642_0570_002.cdf') + TES(195)%FILENAME = TRIM('retv_vars.10642_0570_003.cdf') + TES(196)%FILENAME = TRIM('retv_vars.10642_0572_003.cdf') + TES(197)%FILENAME = TRIM('retv_vars.10642_0573_002.cdf') + TES(198)%FILENAME = TRIM('retv_vars.10642_0573_003.cdf') + TES(199)%FILENAME = TRIM('retv_vars.10642_0573_004.cdf') + TES(200)%FILENAME = TRIM('retv_vars.10642_0583_003.cdf') + TES(201)%FILENAME = TRIM('retv_vars.10642_0586_003.cdf') + TES(202)%FILENAME = TRIM('retv_vars.10642_0587_002.cdf') + TES(203)%FILENAME = TRIM('retv_vars.10642_0587_004.cdf') + TES(204)%FILENAME = TRIM('retv_vars.10642_0588_002.cdf') + TES(205)%FILENAME = TRIM('retv_vars.10642_0596_003.cdf') + TES(206)%FILENAME = TRIM('retv_vars.10642_0596_004.cdf') + TES(207)%FILENAME = TRIM('retv_vars.10642_0598_003.cdf') + TES(208)%FILENAME = TRIM('retv_vars.10642_0598_004.cdf') + TES(209)%FILENAME = TRIM('retv_vars.10642_0599_002.cdf') + TES(210)%FILENAME = TRIM('retv_vars.10642_0604_002.cdf') + TES(211)%FILENAME = TRIM('retv_vars.10642_0604_003.cdf') + TES(212)%FILENAME = TRIM('retv_vars.10642_0604_004.cdf') + TES(213)%FILENAME = TRIM('retv_vars.10642_0605_004.cdf') + TES(214)%FILENAME = TRIM('retv_vars.10642_0614_002.cdf') + TES(215)%FILENAME = TRIM('retv_vars.10642_0615_003.cdf') + TES(216)%FILENAME = TRIM('retv_vars.10642_0616_002.cdf') + TES(217)%FILENAME = TRIM('retv_vars.10642_0616_003.cdf') + TES(218)%FILENAME = TRIM('retv_vars.10642_0616_004.cdf') + TES(219)%FILENAME = TRIM('retv_vars.10642_0617_002.cdf') + TES(220)%FILENAME = TRIM('retv_vars.10642_0640_002.cdf') + TES(221)%FILENAME = TRIM('retv_vars.10642_0640_004.cdf') + TES(222)%FILENAME = TRIM('retv_vars.10642_0641_004.cdf') + TES(223)%FILENAME = TRIM('retv_vars.10642_0643_003.cdf') + TES(224)%FILENAME = TRIM('retv_vars.10642_0643_004.cdf') + TES(225)%FILENAME = TRIM('retv_vars.10642_0644_004.cdf') + TES(226)%FILENAME = TRIM('retv_vars.10642_0645_002.cdf') + TES(227)%FILENAME = TRIM('retv_vars.10642_0645_004.cdf') + TES(228)%FILENAME = TRIM('retv_vars.10642_0647_002.cdf') + TES(229)%FILENAME = TRIM('retv_vars.10642_0652_003.cdf') + TES(230)%FILENAME = TRIM('retv_vars.10642_0653_002.cdf') + TES(231)%FILENAME = TRIM('retv_vars.10642_0654_004.cdf') + TES(232)%FILENAME = TRIM('retv_vars.10642_0655_002.cdf') + TES(233)%FILENAME = TRIM('retv_vars.10642_0655_003.cdf') + TES(234)%FILENAME = TRIM('retv_vars.10642_0655_004.cdf') + TES(235)%FILENAME = TRIM('retv_vars.10642_0656_002.cdf') + TES(236)%FILENAME = TRIM('retv_vars.10642_0656_003.cdf') + TES(237)%FILENAME = TRIM('retv_vars.10642_0659_004.cdf') + TES(238)%FILENAME = TRIM('retv_vars.10642_0690_002.cdf') + TES(239)%FILENAME = TRIM('retv_vars.10642_0690_003.cdf') + TES(240)%FILENAME = TRIM('retv_vars.10642_0691_004.cdf') + TES(241)%FILENAME = TRIM('retv_vars.10642_0692_003.cdf') + TES(242)%FILENAME = TRIM('retv_vars.10642_0692_004.cdf') + TES(243)%FILENAME = TRIM('retv_vars.10642_0693_002.cdf') + TES(244)%FILENAME = TRIM('retv_vars.10642_0693_003.cdf') + TES(245)%FILENAME = TRIM('retv_vars.10642_0693_004.cdf') + TES(246)%FILENAME = TRIM('retv_vars.10642_0694_003.cdf') + TES(247)%FILENAME = TRIM('retv_vars.10642_0694_004.cdf') + TES(248)%FILENAME = TRIM('retv_vars.10642_0695_002.cdf') + TES(249)%FILENAME = TRIM('retv_vars.10642_0699_004.cdf') + TES(250)%FILENAME = TRIM('retv_vars.10642_0700_003.cdf') + TES(251)%FILENAME = TRIM('retv_vars.10642_0700_004.cdf') + TES(252)%FILENAME = TRIM('retv_vars.10642_0701_002.cdf') + TES(253)%FILENAME = TRIM('retv_vars.10642_0701_003.cdf') + TES(254)%FILENAME = TRIM('retv_vars.10642_0701_004.cdf') + TES(255)%FILENAME = TRIM('retv_vars.10642_0702_002.cdf') + TES(256)%FILENAME = TRIM('retv_vars.10642_0702_003.cdf') + TES(257)%FILENAME = TRIM('retv_vars.10642_0702_004.cdf') + TES(258)%FILENAME = TRIM('retv_vars.10642_0703_002.cdf') + TES(259)%FILENAME = TRIM('retv_vars.10642_0703_004.cdf') + TES(260)%FILENAME = TRIM('retv_vars.10642_0704_003.cdf') + TES(261)%FILENAME = TRIM('retv_vars.10642_0704_004.cdf') + TES(262)%FILENAME = TRIM('retv_vars.10642_0728_002.cdf') + TES(263)%FILENAME = TRIM('retv_vars.10642_0731_004.cdf') + TES(264)%FILENAME = TRIM('retv_vars.10642_0732_002.cdf') + TES(265)%FILENAME = TRIM('retv_vars.10642_0733_002.cdf') + TES(266)%FILENAME = TRIM('retv_vars.10642_0738_003.cdf') + TES(267)%FILENAME = TRIM('retv_vars.10642_0739_002.cdf') + TES(268)%FILENAME = TRIM('retv_vars.10642_0739_003.cdf') + TES(269)%FILENAME = TRIM('retv_vars.10642_0740_003.cdf') + TES(270)%FILENAME = TRIM('retv_vars.10642_0743_002.cdf') + TES(271)%FILENAME = TRIM('retv_vars.10642_0747_003.cdf') + TES(272)%FILENAME = TRIM('retv_vars.10642_0747_004.cdf') + TES(273)%FILENAME = TRIM('retv_vars.10642_0762_004.cdf') + TES(274)%FILENAME = TRIM('retv_vars.10647_0018_002.cdf') + TES(275)%FILENAME = TRIM('retv_vars.10647_0019_002.cdf') + TES(276)%FILENAME = TRIM('retv_vars.10647_0019_003.cdf') + TES(277)%FILENAME = TRIM('retv_vars.10647_0021_003.cdf') + TES(278)%FILENAME = TRIM('retv_vars.10647_0021_004.cdf') + TES(279)%FILENAME = TRIM('retv_vars.10647_0022_002.cdf') + TES(280)%FILENAME = TRIM('retv_vars.10647_0022_004.cdf') + TES(281)%FILENAME = TRIM('retv_vars.10647_0023_002.cdf') + TES(282)%FILENAME = TRIM('retv_vars.10647_0027_003.cdf') + TES(283)%FILENAME = TRIM('retv_vars.10647_0028_002.cdf') + TES(284)%FILENAME = TRIM('retv_vars.10647_0028_003.cdf') + TES(285)%FILENAME = TRIM('retv_vars.10647_0029_003.cdf') + TES(286)%FILENAME = TRIM('retv_vars.10647_0058_004.cdf') + TES(287)%FILENAME = TRIM('retv_vars.10647_0059_002.cdf') + TES(288)%FILENAME = TRIM('retv_vars.10647_0059_003.cdf') + TES(289)%FILENAME = TRIM('retv_vars.10647_0063_002.cdf') + TES(290)%FILENAME = TRIM('retv_vars.10647_0063_004.cdf') + TES(291)%FILENAME = TRIM('retv_vars.10647_0064_002.cdf') + TES(292)%FILENAME = TRIM('retv_vars.10647_0067_002.cdf') + TES(293)%FILENAME = TRIM('retv_vars.10647_0067_003.cdf') + TES(294)%FILENAME = TRIM('retv_vars.10647_0067_004.cdf') + TES(295)%FILENAME = TRIM('retv_vars.10647_0068_003.cdf') + TES(296)%FILENAME = TRIM('retv_vars.10647_0068_004.cdf') + TES(297)%FILENAME = TRIM('retv_vars.10647_0069_002.cdf') + TES(298)%FILENAME = TRIM('retv_vars.10647_0070_002.cdf') + TES(299)%FILENAME = TRIM('retv_vars.10647_0109_003.cdf') + TES(300)%FILENAME = TRIM('retv_vars.10647_0115_004.cdf') + TES(301)%FILENAME = TRIM('retv_vars.10647_0118_002.cdf') + TES(302)%FILENAME = TRIM('retv_vars.10647_0124_003.cdf') + TES(303)%FILENAME = TRIM('retv_vars.10647_0185_003.cdf') + TES(304)%FILENAME = TRIM('retv_vars.10647_0187_003.cdf') + TES(305)%FILENAME = TRIM('retv_vars.10647_0187_004.cdf') + TES(306)%FILENAME = TRIM('retv_vars.10647_0188_003.cdf') + TES(307)%FILENAME = TRIM('retv_vars.10647_0189_004.cdf') + TES(308)%FILENAME = TRIM('retv_vars.10647_0190_004.cdf') + TES(309)%FILENAME = TRIM('retv_vars.10647_0200_003.cdf') + TES(310)%FILENAME = TRIM('retv_vars.10647_0200_004.cdf') + TES(311)%FILENAME = TRIM('retv_vars.10647_0201_003.cdf') + TES(312)%FILENAME = TRIM('retv_vars.10647_0201_004.cdf') + TES(313)%FILENAME = TRIM('retv_vars.10647_0202_002.cdf') + TES(314)%FILENAME = TRIM('retv_vars.10647_0212_004.cdf') + TES(315)%FILENAME = TRIM('retv_vars.10647_0221_002.cdf') + TES(316)%FILENAME = TRIM('retv_vars.10647_0231_002.cdf') + TES(317)%FILENAME = TRIM('retv_vars.10647_0231_004.cdf') + TES(318)%FILENAME = TRIM('retv_vars.10647_0234_003.cdf') + TES(319)%FILENAME = TRIM('retv_vars.10647_0237_003.cdf') + TES(320)%FILENAME = TRIM('retv_vars.10647_0237_004.cdf') + TES(321)%FILENAME = TRIM('retv_vars.10647_0244_002.cdf') + TES(322)%FILENAME = TRIM('retv_vars.10647_0244_003.cdf') + TES(323)%FILENAME = TRIM('retv_vars.10647_0244_004.cdf') + TES(324)%FILENAME = TRIM('retv_vars.10647_0245_002.cdf') + TES(325)%FILENAME = TRIM('retv_vars.10647_0245_004.cdf') + TES(326)%FILENAME = TRIM('retv_vars.10647_0246_002.cdf') + TES(327)%FILENAME = TRIM('retv_vars.10647_0246_003.cdf') + TES(328)%FILENAME = TRIM('retv_vars.10647_0248_002.cdf') + TES(329)%FILENAME = TRIM('retv_vars.10647_0250_002.cdf') + TES(330)%FILENAME = TRIM('retv_vars.10647_0250_004.cdf') + TES(331)%FILENAME = TRIM('retv_vars.10647_0251_002.cdf') + TES(332)%FILENAME = TRIM('retv_vars.10647_0251_003.cdf') + TES(333)%FILENAME = TRIM('retv_vars.10647_0252_002.cdf') + TES(334)%FILENAME = TRIM('retv_vars.10647_0252_004.cdf') + TES(335)%FILENAME = TRIM('retv_vars.10647_0259_002.cdf') + TES(336)%FILENAME = TRIM('retv_vars.10647_0259_003.cdf') + TES(337)%FILENAME = TRIM('retv_vars.10647_0260_003.cdf') + TES(338)%FILENAME = TRIM('retv_vars.10647_0261_003.cdf') + TES(339)%FILENAME = TRIM('retv_vars.10647_0268_002.cdf') + TES(340)%FILENAME = TRIM('retv_vars.10647_0268_003.cdf') + TES(341)%FILENAME = TRIM('retv_vars.10647_0271_004.cdf') + TES(342)%FILENAME = TRIM('retv_vars.10647_0272_003.cdf') + TES(343)%FILENAME = TRIM('retv_vars.10647_0273_004.cdf') + TES(344)%FILENAME = TRIM('retv_vars.10647_0276_004.cdf') + TES(345)%FILENAME = TRIM('retv_vars.10647_0277_002.cdf') + TES(346)%FILENAME = TRIM('retv_vars.10647_0279_003.cdf') + TES(347)%FILENAME = TRIM('retv_vars.10647_0279_004.cdf') + TES(348)%FILENAME = TRIM('retv_vars.10647_0302_003.cdf') + TES(349)%FILENAME = TRIM('retv_vars.10647_0305_002.cdf') + TES(350)%FILENAME = TRIM('retv_vars.10647_0305_003.cdf') + TES(351)%FILENAME = TRIM('retv_vars.10647_0305_004.cdf') + TES(352)%FILENAME = TRIM('retv_vars.10647_0306_002.cdf') + TES(353)%FILENAME = TRIM('retv_vars.10647_0307_002.cdf') + TES(354)%FILENAME = TRIM('retv_vars.10647_0309_002.cdf') + TES(355)%FILENAME = TRIM('retv_vars.10647_0310_003.cdf') + TES(356)%FILENAME = TRIM('retv_vars.10647_0315_002.cdf') + TES(357)%FILENAME = TRIM('retv_vars.10647_0315_003.cdf') + TES(358)%FILENAME = TRIM('retv_vars.10647_0315_004.cdf') + TES(359)%FILENAME = TRIM('retv_vars.10647_0316_002.cdf') + TES(360)%FILENAME = TRIM('retv_vars.10647_0316_003.cdf') + TES(361)%FILENAME = TRIM('retv_vars.10647_0316_004.cdf') + TES(362)%FILENAME = TRIM('retv_vars.10647_0317_004.cdf') + TES(363)%FILENAME = TRIM('retv_vars.10647_0318_003.cdf') + TES(364)%FILENAME = TRIM('retv_vars.10647_0319_004.cdf') + TES(365)%FILENAME = TRIM('retv_vars.10647_0322_002.cdf') + TES(366)%FILENAME = TRIM('retv_vars.10647_0322_003.cdf') + TES(367)%FILENAME = TRIM('retv_vars.10647_0323_003.cdf') + TES(368)%FILENAME = TRIM('retv_vars.10647_0358_002.cdf') + TES(369)%FILENAME = TRIM('retv_vars.10647_0358_003.cdf') + TES(370)%FILENAME = TRIM('retv_vars.10647_0358_004.cdf') + TES(371)%FILENAME = TRIM('retv_vars.10647_0359_002.cdf') + TES(372)%FILENAME = TRIM('retv_vars.10647_0359_003.cdf') + TES(373)%FILENAME = TRIM('retv_vars.10647_0364_002.cdf') + TES(374)%FILENAME = TRIM('retv_vars.10647_0364_003.cdf') + TES(375)%FILENAME = TRIM('retv_vars.10647_0366_002.cdf') + TES(376)%FILENAME = TRIM('retv_vars.10647_0368_002.cdf') + TES(377)%FILENAME = TRIM('retv_vars.10647_0368_004.cdf') + TES(378)%FILENAME = TRIM('retv_vars.10647_0369_002.cdf') + TES(379)%FILENAME = TRIM('retv_vars.10647_0378_003.cdf') + TES(380)%FILENAME = TRIM('retv_vars.10647_0412_002.cdf') + TES(381)%FILENAME = TRIM('retv_vars.10647_0412_003.cdf') + TES(382)%FILENAME = TRIM('retv_vars.10647_0412_004.cdf') + TES(383)%FILENAME = TRIM('retv_vars.10647_0413_002.cdf') + TES(384)%FILENAME = TRIM('retv_vars.10647_0413_003.cdf') + TES(385)%FILENAME = TRIM('retv_vars.10647_0414_002.cdf') + TES(386)%FILENAME = TRIM('retv_vars.10647_0414_004.cdf') + TES(387)%FILENAME = TRIM('retv_vars.10647_0415_002.cdf') + TES(388)%FILENAME = TRIM('retv_vars.10647_0415_003.cdf') + TES(389)%FILENAME = TRIM('retv_vars.10647_0415_004.cdf') + TES(390)%FILENAME = TRIM('retv_vars.10647_0416_002.cdf') + TES(391)%FILENAME = TRIM('retv_vars.10647_0416_003.cdf') + TES(392)%FILENAME = TRIM('retv_vars.10647_0417_003.cdf') + TES(393)%FILENAME = TRIM('retv_vars.10647_0419_002.cdf') + TES(394)%FILENAME = TRIM('retv_vars.10647_0419_003.cdf') + TES(395)%FILENAME = TRIM('retv_vars.10647_0420_004.cdf') + TES(396)%FILENAME = TRIM('retv_vars.10647_0421_002.cdf') + TES(397)%FILENAME = TRIM('retv_vars.10647_0421_003.cdf') + TES(398)%FILENAME = TRIM('retv_vars.10647_0422_002.cdf') + TES(399)%FILENAME = TRIM('retv_vars.10647_0422_003.cdf') + TES(400)%FILENAME = TRIM('retv_vars.10647_0422_004.cdf') + TES(401)%FILENAME = TRIM('retv_vars.10647_0423_002.cdf') + TES(402)%FILENAME = TRIM('retv_vars.10647_0423_003.cdf') + TES(403)%FILENAME = TRIM('retv_vars.10647_0423_004.cdf') + TES(404)%FILENAME = TRIM('retv_vars.10647_0424_002.cdf') + TES(405)%FILENAME = TRIM('retv_vars.10647_0424_004.cdf') + TES(406)%FILENAME = TRIM('retv_vars.10647_0425_002.cdf') + TES(407)%FILENAME = TRIM('retv_vars.10647_0425_003.cdf') + TES(408)%FILENAME = TRIM('retv_vars.10647_0425_004.cdf') + TES(409)%FILENAME = TRIM('retv_vars.10647_0429_004.cdf') + TES(410)%FILENAME = TRIM('retv_vars.10647_0430_002.cdf') + TES(411)%FILENAME = TRIM('retv_vars.10647_0461_003.cdf') + TES(412)%FILENAME = TRIM('retv_vars.10647_0461_004.cdf') + TES(413)%FILENAME = TRIM('retv_vars.10647_0462_004.cdf') + TES(414)%FILENAME = TRIM('retv_vars.10647_0464_003.cdf') + TES(415)%FILENAME = TRIM('retv_vars.10647_0465_003.cdf') + TES(416)%FILENAME = TRIM('retv_vars.10647_0467_003.cdf') + TES(417)%FILENAME = TRIM('retv_vars.10647_0468_004.cdf') + TES(418)%FILENAME = TRIM('retv_vars.10647_0493_002.cdf') + TES(419)%FILENAME = TRIM('retv_vars.10647_0501_004.cdf') + TES(420)%FILENAME = TRIM('retv_vars.10647_0502_002.cdf') + TES(421)%FILENAME = TRIM('retv_vars.10647_0507_003.cdf') + TES(422)%FILENAME = TRIM('retv_vars.10647_0507_004.cdf') + TES(423)%FILENAME = TRIM('retv_vars.10647_0533_002.cdf') + TES(424)%FILENAME = TRIM('retv_vars.10647_0533_003.cdf') + TES(425)%FILENAME = TRIM('retv_vars.10647_0533_004.cdf') + TES(426)%FILENAME = TRIM('retv_vars.10647_0534_002.cdf') + TES(427)%FILENAME = TRIM('retv_vars.10647_0537_003.cdf') + TES(428)%FILENAME = TRIM('retv_vars.10647_0548_004.cdf') + TES(429)%FILENAME = TRIM('retv_vars.10647_0549_002.cdf') + TES(430)%FILENAME = TRIM('retv_vars.10647_0549_003.cdf') + TES(431)%FILENAME = TRIM('retv_vars.10647_0549_004.cdf') + TES(432)%FILENAME = TRIM('retv_vars.10647_0550_002.cdf') + TES(433)%FILENAME = TRIM('retv_vars.10647_0550_003.cdf') + TES(434)%FILENAME = TRIM('retv_vars.10647_0550_004.cdf') + TES(435)%FILENAME = TRIM('retv_vars.10647_0551_003.cdf') + TES(436)%FILENAME = TRIM('retv_vars.10647_0567_004.cdf') + TES(437)%FILENAME = TRIM('retv_vars.10647_0568_003.cdf') + TES(438)%FILENAME = TRIM('retv_vars.10647_0569_002.cdf') + TES(439)%FILENAME = TRIM('retv_vars.10647_0569_003.cdf') + TES(440)%FILENAME = TRIM('retv_vars.10647_0571_002.cdf') + TES(441)%FILENAME = TRIM('retv_vars.10647_0572_002.cdf') + TES(442)%FILENAME = TRIM('retv_vars.10647_0572_003.cdf') + TES(443)%FILENAME = TRIM('retv_vars.10647_0572_004.cdf') + TES(444)%FILENAME = TRIM('retv_vars.10647_0573_002.cdf') + TES(445)%FILENAME = TRIM('retv_vars.10647_0573_003.cdf') + TES(446)%FILENAME = TRIM('retv_vars.10647_0573_004.cdf') + TES(447)%FILENAME = TRIM('retv_vars.10647_0585_004.cdf') + TES(448)%FILENAME = TRIM('retv_vars.10647_0589_002.cdf') + TES(449)%FILENAME = TRIM('retv_vars.10647_0592_003.cdf') + TES(450)%FILENAME = TRIM('retv_vars.10647_0593_002.cdf') + TES(451)%FILENAME = TRIM('retv_vars.10647_0593_004.cdf') + TES(452)%FILENAME = TRIM('retv_vars.10647_0595_002.cdf') + TES(453)%FILENAME = TRIM('retv_vars.10647_0595_004.cdf') + TES(454)%FILENAME = TRIM('retv_vars.10647_0596_003.cdf') + TES(455)%FILENAME = TRIM('retv_vars.10647_0597_003.cdf') + TES(456)%FILENAME = TRIM('retv_vars.10647_0597_004.cdf') + TES(457)%FILENAME = TRIM('retv_vars.10647_0598_002.cdf') + TES(458)%FILENAME = TRIM('retv_vars.10647_0598_003.cdf') + TES(459)%FILENAME = TRIM('retv_vars.10647_0598_004.cdf') + TES(460)%FILENAME = TRIM('retv_vars.10647_0599_002.cdf') + TES(461)%FILENAME = TRIM('retv_vars.10647_0611_003.cdf') + TES(462)%FILENAME = TRIM('retv_vars.10647_0613_002.cdf') + TES(463)%FILENAME = TRIM('retv_vars.10647_0615_004.cdf') + TES(464)%FILENAME = TRIM('retv_vars.10647_0616_003.cdf') + TES(465)%FILENAME = TRIM('retv_vars.10647_0616_004.cdf') + TES(466)%FILENAME = TRIM('retv_vars.10647_0617_004.cdf') + TES(467)%FILENAME = TRIM('retv_vars.10647_0618_002.cdf') + TES(468)%FILENAME = TRIM('retv_vars.10647_0642_002.cdf') + TES(469)%FILENAME = TRIM('retv_vars.10647_0642_004.cdf') + TES(470)%FILENAME = TRIM('retv_vars.10647_0645_003.cdf') + TES(471)%FILENAME = TRIM('retv_vars.10647_0645_004.cdf') + TES(472)%FILENAME = TRIM('retv_vars.10647_0646_002.cdf') + TES(473)%FILENAME = TRIM('retv_vars.10647_0646_003.cdf') + TES(474)%FILENAME = TRIM('retv_vars.10647_0646_004.cdf') + TES(475)%FILENAME = TRIM('retv_vars.10647_0647_002.cdf') + TES(476)%FILENAME = TRIM('retv_vars.10647_0651_002.cdf') + TES(477)%FILENAME = TRIM('retv_vars.10647_0651_004.cdf') + TES(478)%FILENAME = TRIM('retv_vars.10647_0653_002.cdf') + TES(479)%FILENAME = TRIM('retv_vars.10647_0653_003.cdf') + TES(480)%FILENAME = TRIM('retv_vars.10647_0654_002.cdf') + TES(481)%FILENAME = TRIM('retv_vars.10647_0654_003.cdf') + TES(482)%FILENAME = TRIM('retv_vars.10647_0654_004.cdf') + TES(483)%FILENAME = TRIM('retv_vars.10647_0655_004.cdf') + TES(484)%FILENAME = TRIM('retv_vars.10647_0656_003.cdf') + TES(485)%FILENAME = TRIM('retv_vars.10647_0659_004.cdf') + TES(486)%FILENAME = TRIM('retv_vars.10647_0660_002.cdf') + TES(487)%FILENAME = TRIM('retv_vars.10647_0689_004.cdf') + TES(488)%FILENAME = TRIM('retv_vars.10647_0693_002.cdf') + TES(489)%FILENAME = TRIM('retv_vars.10647_0694_003.cdf') + TES(490)%FILENAME = TRIM('retv_vars.10647_0694_004.cdf') + TES(491)%FILENAME = TRIM('retv_vars.10647_0695_002.cdf') + TES(492)%FILENAME = TRIM('retv_vars.10647_0700_003.cdf') + TES(493)%FILENAME = TRIM('retv_vars.10647_0700_004.cdf') + TES(494)%FILENAME = TRIM('retv_vars.10647_0701_003.cdf') + TES(495)%FILENAME = TRIM('retv_vars.10647_0701_004.cdf') + TES(496)%FILENAME = TRIM('retv_vars.10647_0702_003.cdf') + TES(497)%FILENAME = TRIM('retv_vars.10647_0702_004.cdf') + TES(498)%FILENAME = TRIM('retv_vars.10647_0703_002.cdf') + TES(499)%FILENAME = TRIM('retv_vars.10647_0704_002.cdf') + TES(500)%FILENAME = TRIM('retv_vars.10647_0704_003.cdf') + TES(501)%FILENAME = TRIM('retv_vars.10647_0705_003.cdf') + TES(502)%FILENAME = TRIM('retv_vars.10647_0733_004.cdf') + TES(503)%FILENAME = TRIM('retv_vars.10647_0734_003.cdf') + TES(504)%FILENAME = TRIM('retv_vars.10647_0738_004.cdf') + TES(505)%FILENAME = TRIM('retv_vars.10647_0739_003.cdf') + TES(506)%FILENAME = TRIM('retv_vars.10647_0740_004.cdf') + TES(507)%FILENAME = TRIM('retv_vars.10647_0741_002.cdf') + TES(508)%FILENAME = TRIM('retv_vars.10647_0741_003.cdf') + TES(509)%FILENAME = TRIM('retv_vars.10647_0741_004.cdf') + TES(510)%FILENAME = TRIM('retv_vars.10647_0742_002.cdf') + TES(511)%FILENAME = TRIM('retv_vars.10647_0742_003.cdf') + TES(512)%FILENAME = TRIM('retv_vars.10647_0742_004.cdf') + TES(513)%FILENAME = TRIM('retv_vars.10647_0743_002.cdf') + TES(514)%FILENAME = TRIM('retv_vars.10647_0743_003.cdf') + TES(515)%FILENAME = TRIM('retv_vars.10647_0747_004.cdf') + TES(516)%FILENAME = TRIM('retv_vars.10647_0748_002.cdf') + TES(517)%FILENAME = TRIM('retv_vars.10647_0748_003.cdf') + TES(518)%FILENAME = TRIM('retv_vars.10649_0021_003.cdf') + TES(519)%FILENAME = TRIM('retv_vars.10649_0022_003.cdf') + TES(520)%FILENAME = TRIM('retv_vars.10649_0027_002.cdf') + TES(521)%FILENAME = TRIM('retv_vars.10649_0027_004.cdf') + TES(522)%FILENAME = TRIM('retv_vars.10649_0028_002.cdf') + TES(523)%FILENAME = TRIM('retv_vars.10649_0028_003.cdf') + TES(524)%FILENAME = TRIM('retv_vars.10649_0028_004.cdf') + TES(525)%FILENAME = TRIM('retv_vars.10649_0029_002.cdf') + TES(526)%FILENAME = TRIM('retv_vars.10649_0029_003.cdf') + TES(527)%FILENAME = TRIM('retv_vars.10649_0030_002.cdf') + TES(528)%FILENAME = TRIM('retv_vars.10649_0030_004.cdf') + TES(529)%FILENAME = TRIM('retv_vars.10649_0043_003.cdf') + TES(530)%FILENAME = TRIM('retv_vars.10649_0058_002.cdf') + TES(531)%FILENAME = TRIM('retv_vars.10649_0059_003.cdf') + TES(532)%FILENAME = TRIM('retv_vars.10649_0059_004.cdf') + TES(533)%FILENAME = TRIM('retv_vars.10649_0060_003.cdf') + TES(534)%FILENAME = TRIM('retv_vars.10649_0060_004.cdf') + TES(535)%FILENAME = TRIM('retv_vars.10649_0065_002.cdf') + TES(536)%FILENAME = TRIM('retv_vars.10649_0066_004.cdf') + TES(537)%FILENAME = TRIM('retv_vars.10649_0067_002.cdf') + TES(538)%FILENAME = TRIM('retv_vars.10649_0067_003.cdf') + TES(539)%FILENAME = TRIM('retv_vars.10649_0067_004.cdf') + TES(540)%FILENAME = TRIM('retv_vars.10649_0068_003.cdf') + TES(541)%FILENAME = TRIM('retv_vars.10649_0069_003.cdf') + TES(542)%FILENAME = TRIM('retv_vars.10649_0069_004.cdf') + TES(543)%FILENAME = TRIM('retv_vars.10649_0070_002.cdf') + TES(544)%FILENAME = TRIM('retv_vars.10649_0075_002.cdf') + TES(545)%FILENAME = TRIM('retv_vars.10649_0100_002.cdf') + TES(546)%FILENAME = TRIM('retv_vars.10649_0102_003.cdf') + TES(547)%FILENAME = TRIM('retv_vars.10649_0102_004.cdf') + TES(548)%FILENAME = TRIM('retv_vars.10649_0103_003.cdf') + TES(549)%FILENAME = TRIM('retv_vars.10649_0104_004.cdf') + TES(550)%FILENAME = TRIM('retv_vars.10649_0105_002.cdf') + TES(551)%FILENAME = TRIM('retv_vars.10649_0106_004.cdf') + TES(552)%FILENAME = TRIM('retv_vars.10649_0107_002.cdf') + TES(553)%FILENAME = TRIM('retv_vars.10649_0107_003.cdf') + TES(554)%FILENAME = TRIM('retv_vars.10649_0107_004.cdf') + TES(555)%FILENAME = TRIM('retv_vars.10649_0108_003.cdf') + TES(556)%FILENAME = TRIM('retv_vars.10649_0108_004.cdf') + TES(557)%FILENAME = TRIM('retv_vars.10649_0114_002.cdf') + TES(558)%FILENAME = TRIM('retv_vars.10649_0114_003.cdf') + TES(559)%FILENAME = TRIM('retv_vars.10649_0115_002.cdf') + TES(560)%FILENAME = TRIM('retv_vars.10649_0116_002.cdf') + TES(561)%FILENAME = TRIM('retv_vars.10649_0117_002.cdf') + TES(562)%FILENAME = TRIM('retv_vars.10649_0117_003.cdf') + TES(563)%FILENAME = TRIM('retv_vars.10649_0117_004.cdf') + TES(564)%FILENAME = TRIM('retv_vars.10649_0118_003.cdf') + TES(565)%FILENAME = TRIM('retv_vars.10649_0118_004.cdf') + TES(566)%FILENAME = TRIM('retv_vars.10649_0137_004.cdf') + TES(567)%FILENAME = TRIM('retv_vars.10649_0144_003.cdf') + TES(568)%FILENAME = TRIM('retv_vars.10649_0144_004.cdf') + TES(569)%FILENAME = TRIM('retv_vars.10649_0187_004.cdf') + TES(570)%FILENAME = TRIM('retv_vars.10649_0188_002.cdf') + TES(571)%FILENAME = TRIM('retv_vars.10649_0189_002.cdf') + TES(572)%FILENAME = TRIM('retv_vars.10649_0189_003.cdf') + TES(573)%FILENAME = TRIM('retv_vars.10649_0189_004.cdf') + TES(574)%FILENAME = TRIM('retv_vars.10649_0191_004.cdf') + TES(575)%FILENAME = TRIM('retv_vars.10649_0201_002.cdf') + TES(576)%FILENAME = TRIM('retv_vars.10649_0221_003.cdf') + TES(577)%FILENAME = TRIM('retv_vars.10649_0222_003.cdf') + TES(578)%FILENAME = TRIM('retv_vars.10649_0223_003.cdf') + TES(579)%FILENAME = TRIM('retv_vars.10649_0223_004.cdf') + TES(580)%FILENAME = TRIM('retv_vars.10649_0231_002.cdf') + TES(581)%FILENAME = TRIM('retv_vars.10649_0231_003.cdf') + TES(582)%FILENAME = TRIM('retv_vars.10649_0234_002.cdf') + TES(583)%FILENAME = TRIM('retv_vars.10649_0236_002.cdf') + TES(584)%FILENAME = TRIM('retv_vars.10649_0237_004.cdf') + TES(585)%FILENAME = TRIM('retv_vars.10649_0244_002.cdf') + TES(586)%FILENAME = TRIM('retv_vars.10649_0244_003.cdf') + TES(587)%FILENAME = TRIM('retv_vars.10649_0244_004.cdf') + TES(588)%FILENAME = TRIM('retv_vars.10649_0245_004.cdf') + TES(589)%FILENAME = TRIM('retv_vars.10649_0246_003.cdf') + TES(590)%FILENAME = TRIM('retv_vars.10649_0246_004.cdf') + TES(591)%FILENAME = TRIM('retv_vars.10649_0247_002.cdf') + TES(592)%FILENAME = TRIM('retv_vars.10649_0247_003.cdf') + TES(593)%FILENAME = TRIM('retv_vars.10649_0248_002.cdf') + TES(594)%FILENAME = TRIM('retv_vars.10649_0248_003.cdf') + TES(595)%FILENAME = TRIM('retv_vars.10649_0248_004.cdf') + TES(596)%FILENAME = TRIM('retv_vars.10649_0249_003.cdf') + TES(597)%FILENAME = TRIM('retv_vars.10649_0249_004.cdf') + TES(598)%FILENAME = TRIM('retv_vars.10649_0250_002.cdf') + TES(599)%FILENAME = TRIM('retv_vars.10649_0252_002.cdf') + TES(600)%FILENAME = TRIM('retv_vars.10649_0252_003.cdf') + TES(601)%FILENAME = TRIM('retv_vars.10649_0252_004.cdf') + TES(602)%FILENAME = TRIM('retv_vars.10649_0260_002.cdf') + TES(603)%FILENAME = TRIM('retv_vars.10649_0260_003.cdf') + TES(604)%FILENAME = TRIM('retv_vars.10649_0261_002.cdf') + TES(605)%FILENAME = TRIM('retv_vars.10649_0261_004.cdf') + TES(606)%FILENAME = TRIM('retv_vars.10649_0267_002.cdf') + TES(607)%FILENAME = TRIM('retv_vars.10649_0269_003.cdf') + TES(608)%FILENAME = TRIM('retv_vars.10649_0270_004.cdf') + TES(609)%FILENAME = TRIM('retv_vars.10649_0271_004.cdf') + TES(610)%FILENAME = TRIM('retv_vars.10649_0273_002.cdf') + TES(611)%FILENAME = TRIM('retv_vars.10649_0273_003.cdf') + TES(612)%FILENAME = TRIM('retv_vars.10649_0274_002.cdf') + TES(613)%FILENAME = TRIM('retv_vars.10649_0274_004.cdf') + TES(614)%FILENAME = TRIM('retv_vars.10649_0276_003.cdf') + TES(615)%FILENAME = TRIM('retv_vars.10649_0280_002.cdf') + TES(616)%FILENAME = TRIM('retv_vars.10649_0302_002.cdf') + TES(617)%FILENAME = TRIM('retv_vars.10649_0302_003.cdf') + TES(618)%FILENAME = TRIM('retv_vars.10649_0305_003.cdf') + TES(619)%FILENAME = TRIM('retv_vars.10649_0307_002.cdf') + TES(620)%FILENAME = TRIM('retv_vars.10649_0307_003.cdf') + TES(621)%FILENAME = TRIM('retv_vars.10649_0307_004.cdf') + TES(622)%FILENAME = TRIM('retv_vars.10649_0308_002.cdf') + TES(623)%FILENAME = TRIM('retv_vars.10649_0308_003.cdf') + TES(624)%FILENAME = TRIM('retv_vars.10649_0309_003.cdf') + TES(625)%FILENAME = TRIM('retv_vars.10649_0310_003.cdf') + TES(626)%FILENAME = TRIM('retv_vars.10649_0315_002.cdf') + TES(627)%FILENAME = TRIM('retv_vars.10649_0315_003.cdf') + TES(628)%FILENAME = TRIM('retv_vars.10649_0315_004.cdf') + TES(629)%FILENAME = TRIM('retv_vars.10649_0316_003.cdf') + TES(630)%FILENAME = TRIM('retv_vars.10649_0316_004.cdf') + TES(631)%FILENAME = TRIM('retv_vars.10649_0318_003.cdf') + TES(632)%FILENAME = TRIM('retv_vars.10649_0319_003.cdf') + TES(633)%FILENAME = TRIM('retv_vars.10649_0319_004.cdf') + TES(634)%FILENAME = TRIM('retv_vars.10649_0320_003.cdf') + TES(635)%FILENAME = TRIM('retv_vars.10649_0321_004.cdf') + TES(636)%FILENAME = TRIM('retv_vars.10649_0322_002.cdf') + TES(637)%FILENAME = TRIM('retv_vars.10649_0322_003.cdf') + TES(638)%FILENAME = TRIM('retv_vars.10649_0322_004.cdf') + TES(639)%FILENAME = TRIM('retv_vars.10649_0355_002.cdf') + TES(640)%FILENAME = TRIM('retv_vars.10649_0355_004.cdf') + TES(641)%FILENAME = TRIM('retv_vars.10649_0357_002.cdf') + TES(642)%FILENAME = TRIM('retv_vars.10649_0357_003.cdf') + TES(643)%FILENAME = TRIM('retv_vars.10649_0358_002.cdf') + TES(644)%FILENAME = TRIM('retv_vars.10649_0358_003.cdf') + TES(645)%FILENAME = TRIM('retv_vars.10649_0363_004.cdf') + TES(646)%FILENAME = TRIM('retv_vars.10649_0364_003.cdf') + TES(647)%FILENAME = TRIM('retv_vars.10649_0364_004.cdf') + TES(648)%FILENAME = TRIM('retv_vars.10649_0365_002.cdf') + TES(649)%FILENAME = TRIM('retv_vars.10649_0365_004.cdf') + TES(650)%FILENAME = TRIM('retv_vars.10649_0368_004.cdf') + TES(651)%FILENAME = TRIM('retv_vars.10649_0369_004.cdf') + TES(652)%FILENAME = TRIM('retv_vars.10649_0407_002.cdf') + TES(653)%FILENAME = TRIM('retv_vars.10649_0411_003.cdf') + TES(654)%FILENAME = TRIM('retv_vars.10649_0413_003.cdf') + TES(655)%FILENAME = TRIM('retv_vars.10649_0413_004.cdf') + TES(656)%FILENAME = TRIM('retv_vars.10649_0414_002.cdf') + TES(657)%FILENAME = TRIM('retv_vars.10649_0414_003.cdf') + TES(658)%FILENAME = TRIM('retv_vars.10649_0414_004.cdf') + TES(659)%FILENAME = TRIM('retv_vars.10649_0415_002.cdf') + TES(660)%FILENAME = TRIM('retv_vars.10649_0415_003.cdf') + TES(661)%FILENAME = TRIM('retv_vars.10649_0421_002.cdf') + TES(662)%FILENAME = TRIM('retv_vars.10649_0422_002.cdf') + TES(663)%FILENAME = TRIM('retv_vars.10649_0422_003.cdf') + TES(664)%FILENAME = TRIM('retv_vars.10649_0422_004.cdf') + TES(665)%FILENAME = TRIM('retv_vars.10649_0423_003.cdf') + TES(666)%FILENAME = TRIM('retv_vars.10649_0423_004.cdf') + TES(667)%FILENAME = TRIM('retv_vars.10649_0424_002.cdf') + TES(668)%FILENAME = TRIM('retv_vars.10649_0424_003.cdf') + TES(669)%FILENAME = TRIM('retv_vars.10649_0424_004.cdf') + TES(670)%FILENAME = TRIM('retv_vars.10649_0425_002.cdf') + TES(671)%FILENAME = TRIM('retv_vars.10649_0425_003.cdf') + TES(672)%FILENAME = TRIM('retv_vars.10649_0425_004.cdf') + TES(673)%FILENAME = TRIM('retv_vars.10649_0426_002.cdf') + TES(674)%FILENAME = TRIM('retv_vars.10649_0426_004.cdf') + TES(675)%FILENAME = TRIM('retv_vars.10649_0428_002.cdf') + TES(676)%FILENAME = TRIM('retv_vars.10649_0429_003.cdf') + TES(677)%FILENAME = TRIM('retv_vars.10649_0459_002.cdf') + TES(678)%FILENAME = TRIM('retv_vars.10649_0459_004.cdf') + TES(679)%FILENAME = TRIM('retv_vars.10649_0460_002.cdf') + TES(680)%FILENAME = TRIM('retv_vars.10649_0460_003.cdf') + TES(681)%FILENAME = TRIM('retv_vars.10649_0460_004.cdf') + TES(682)%FILENAME = TRIM('retv_vars.10649_0461_003.cdf') + TES(683)%FILENAME = TRIM('retv_vars.10649_0461_004.cdf') + TES(684)%FILENAME = TRIM('retv_vars.10649_0463_002.cdf') + TES(685)%FILENAME = TRIM('retv_vars.10649_0463_003.cdf') + TES(686)%FILENAME = TRIM('retv_vars.10649_0466_003.cdf') + TES(687)%FILENAME = TRIM('retv_vars.10649_0467_002.cdf') + TES(688)%FILENAME = TRIM('retv_vars.10649_0467_003.cdf') + TES(689)%FILENAME = TRIM('retv_vars.10649_0469_002.cdf') + TES(690)%FILENAME = TRIM('retv_vars.10649_0469_003.cdf') + TES(691)%FILENAME = TRIM('retv_vars.10649_0469_004.cdf') + TES(692)%FILENAME = TRIM('retv_vars.10649_0470_002.cdf') + TES(693)%FILENAME = TRIM('retv_vars.10649_0502_002.cdf') + TES(694)%FILENAME = TRIM('retv_vars.10649_0502_003.cdf') + TES(695)%FILENAME = TRIM('retv_vars.10649_0510_003.cdf') + TES(696)%FILENAME = TRIM('retv_vars.10649_0510_004.cdf') + TES(697)%FILENAME = TRIM('retv_vars.10649_0511_002.cdf') + TES(698)%FILENAME = TRIM('retv_vars.10649_0511_003.cdf') + TES(699)%FILENAME = TRIM('retv_vars.10649_0514_003.cdf') + TES(700)%FILENAME = TRIM('retv_vars.10649_0515_002.cdf') + TES(701)%FILENAME = TRIM('retv_vars.10649_0516_004.cdf') + TES(702)%FILENAME = TRIM('retv_vars.10649_0538_002.cdf') + TES(703)%FILENAME = TRIM('retv_vars.10649_0546_004.cdf') + TES(704)%FILENAME = TRIM('retv_vars.10649_0547_002.cdf') + TES(705)%FILENAME = TRIM('retv_vars.10649_0548_004.cdf') + TES(706)%FILENAME = TRIM('retv_vars.10649_0549_002.cdf') + TES(707)%FILENAME = TRIM('retv_vars.10649_0549_003.cdf') + TES(708)%FILENAME = TRIM('retv_vars.10649_0549_004.cdf') + TES(709)%FILENAME = TRIM('retv_vars.10649_0550_002.cdf') + TES(710)%FILENAME = TRIM('retv_vars.10649_0550_003.cdf') + TES(711)%FILENAME = TRIM('retv_vars.10649_0551_002.cdf') + TES(712)%FILENAME = TRIM('retv_vars.10649_0568_002.cdf') + TES(713)%FILENAME = TRIM('retv_vars.10649_0568_004.cdf') + TES(714)%FILENAME = TRIM('retv_vars.10649_0569_002.cdf') + TES(715)%FILENAME = TRIM('retv_vars.10649_0569_003.cdf') + TES(716)%FILENAME = TRIM('retv_vars.10649_0570_003.cdf') + TES(717)%FILENAME = TRIM('retv_vars.10649_0571_002.cdf') + TES(718)%FILENAME = TRIM('retv_vars.10649_0571_003.cdf') + TES(719)%FILENAME = TRIM('retv_vars.10649_0572_002.cdf') + TES(720)%FILENAME = TRIM('retv_vars.10649_0573_002.cdf') + TES(721)%FILENAME = TRIM('retv_vars.10649_0582_002.cdf') + TES(722)%FILENAME = TRIM('retv_vars.10649_0583_003.cdf') + TES(723)%FILENAME = TRIM('retv_vars.10649_0583_004.cdf') + TES(724)%FILENAME = TRIM('retv_vars.10649_0588_003.cdf') + TES(725)%FILENAME = TRIM('retv_vars.10649_0588_004.cdf') + TES(726)%FILENAME = TRIM('retv_vars.10649_0589_002.cdf') + TES(727)%FILENAME = TRIM('retv_vars.10649_0589_003.cdf') + TES(728)%FILENAME = TRIM('retv_vars.10649_0590_002.cdf') + TES(729)%FILENAME = TRIM('retv_vars.10649_0590_003.cdf') + TES(730)%FILENAME = TRIM('retv_vars.10649_0592_002.cdf') + TES(731)%FILENAME = TRIM('retv_vars.10649_0592_004.cdf') + TES(732)%FILENAME = TRIM('retv_vars.10649_0593_002.cdf') + TES(733)%FILENAME = TRIM('retv_vars.10649_0593_004.cdf') + TES(734)%FILENAME = TRIM('retv_vars.10649_0594_002.cdf') + TES(735)%FILENAME = TRIM('retv_vars.10649_0594_003.cdf') + TES(736)%FILENAME = TRIM('retv_vars.10649_0594_004.cdf') + TES(737)%FILENAME = TRIM('retv_vars.10649_0596_002.cdf') + TES(738)%FILENAME = TRIM('retv_vars.10649_0596_003.cdf') + TES(739)%FILENAME = TRIM('retv_vars.10649_0596_004.cdf') + TES(740)%FILENAME = TRIM('retv_vars.10649_0597_002.cdf') + TES(741)%FILENAME = TRIM('retv_vars.10649_0597_003.cdf') + TES(742)%FILENAME = TRIM('retv_vars.10649_0597_004.cdf') + TES(743)%FILENAME = TRIM('retv_vars.10649_0598_003.cdf') + TES(744)%FILENAME = TRIM('retv_vars.10649_0599_002.cdf') + TES(745)%FILENAME = TRIM('retv_vars.10649_0605_003.cdf') + TES(746)%FILENAME = TRIM('retv_vars.10649_0613_002.cdf') + TES(747)%FILENAME = TRIM('retv_vars.10649_0615_004.cdf') + TES(748)%FILENAME = TRIM('retv_vars.10649_0616_003.cdf') + TES(749)%FILENAME = TRIM('retv_vars.10649_0616_004.cdf') + TES(750)%FILENAME = TRIM('retv_vars.10649_0617_002.cdf') + TES(751)%FILENAME = TRIM('retv_vars.10649_0617_003.cdf') + TES(752)%FILENAME = TRIM('retv_vars.10649_0618_002.cdf') + TES(753)%FILENAME = TRIM('retv_vars.10649_0618_003.cdf') + TES(754)%FILENAME = TRIM('retv_vars.10649_0634_004.cdf') + TES(755)%FILENAME = TRIM('retv_vars.10649_0635_003.cdf') + TES(756)%FILENAME = TRIM('retv_vars.10649_0639_004.cdf') + TES(757)%FILENAME = TRIM('retv_vars.10649_0644_004.cdf') + TES(758)%FILENAME = TRIM('retv_vars.10649_0645_002.cdf') + TES(759)%FILENAME = TRIM('retv_vars.10649_0645_003.cdf') + TES(760)%FILENAME = TRIM('retv_vars.10649_0645_004.cdf') + TES(761)%FILENAME = TRIM('retv_vars.10649_0646_002.cdf') + TES(762)%FILENAME = TRIM('retv_vars.10649_0646_003.cdf') + TES(763)%FILENAME = TRIM('retv_vars.10649_0646_004.cdf') + TES(764)%FILENAME = TRIM('retv_vars.10649_0647_002.cdf') + TES(765)%FILENAME = TRIM('retv_vars.10649_0651_002.cdf') + TES(766)%FILENAME = TRIM('retv_vars.10649_0651_003.cdf') + TES(767)%FILENAME = TRIM('retv_vars.10649_0651_004.cdf') + TES(768)%FILENAME = TRIM('retv_vars.10649_0652_002.cdf') + TES(769)%FILENAME = TRIM('retv_vars.10649_0652_003.cdf') + TES(770)%FILENAME = TRIM('retv_vars.10649_0652_004.cdf') + TES(771)%FILENAME = TRIM('retv_vars.10649_0653_002.cdf') + TES(772)%FILENAME = TRIM('retv_vars.10649_0653_004.cdf') + TES(773)%FILENAME = TRIM('retv_vars.10649_0654_002.cdf') + TES(774)%FILENAME = TRIM('retv_vars.10649_0654_003.cdf') + TES(775)%FILENAME = TRIM('retv_vars.10649_0655_002.cdf') + TES(776)%FILENAME = TRIM('retv_vars.10649_0655_003.cdf') + TES(777)%FILENAME = TRIM('retv_vars.10649_0656_003.cdf') + TES(778)%FILENAME = TRIM('retv_vars.10649_0659_002.cdf') + TES(779)%FILENAME = TRIM('retv_vars.10649_0659_004.cdf') + TES(780)%FILENAME = TRIM('retv_vars.10649_0690_002.cdf') + TES(781)%FILENAME = TRIM('retv_vars.10649_0693_004.cdf') + TES(782)%FILENAME = TRIM('retv_vars.10649_0694_003.cdf') + TES(783)%FILENAME = TRIM('retv_vars.10649_0699_002.cdf') + TES(784)%FILENAME = TRIM('retv_vars.10649_0699_004.cdf') + TES(785)%FILENAME = TRIM('retv_vars.10649_0700_002.cdf') + TES(786)%FILENAME = TRIM('retv_vars.10649_0700_003.cdf') + TES(787)%FILENAME = TRIM('retv_vars.10649_0700_004.cdf') + TES(788)%FILENAME = TRIM('retv_vars.10649_0701_002.cdf') + TES(789)%FILENAME = TRIM('retv_vars.10649_0701_004.cdf') + TES(790)%FILENAME = TRIM('retv_vars.10649_0702_004.cdf') + TES(791)%FILENAME = TRIM('retv_vars.10649_0703_002.cdf') + TES(792)%FILENAME = TRIM('retv_vars.10649_0703_004.cdf') + TES(793)%FILENAME = TRIM('retv_vars.10649_0704_003.cdf') + TES(794)%FILENAME = TRIM('retv_vars.10649_0704_004.cdf') + TES(795)%FILENAME = TRIM('retv_vars.10649_0732_004.cdf') + TES(796)%FILENAME = TRIM('retv_vars.10649_0734_004.cdf') + TES(797)%FILENAME = TRIM('retv_vars.10649_0739_002.cdf') + TES(798)%FILENAME = TRIM('retv_vars.10649_0740_002.cdf') + TES(799)%FILENAME = TRIM('retv_vars.10649_0741_002.cdf') + TES(800)%FILENAME = TRIM('retv_vars.10649_0741_003.cdf') + TES(801)%FILENAME = TRIM('retv_vars.10649_0741_004.cdf') + TES(802)%FILENAME = TRIM('retv_vars.10649_0743_003.cdf') + TES(803)%FILENAME = TRIM('retv_vars.10649_0748_002.cdf') + TES(804)%FILENAME = TRIM('retv_vars.10656_0018_003.cdf') + TES(805)%FILENAME = TRIM('retv_vars.10656_0021_003.cdf') + TES(806)%FILENAME = TRIM('retv_vars.10656_0021_004.cdf') + TES(807)%FILENAME = TRIM('retv_vars.10656_0022_002.cdf') + TES(808)%FILENAME = TRIM('retv_vars.10656_0022_003.cdf') + TES(809)%FILENAME = TRIM('retv_vars.10656_0022_004.cdf') + TES(810)%FILENAME = TRIM('retv_vars.10656_0023_002.cdf') + TES(811)%FILENAME = TRIM('retv_vars.10656_0027_003.cdf') + TES(812)%FILENAME = TRIM('retv_vars.10656_0028_003.cdf') + TES(813)%FILENAME = TRIM('retv_vars.10656_0029_002.cdf') + TES(814)%FILENAME = TRIM('retv_vars.10656_0029_003.cdf') + TES(815)%FILENAME = TRIM('retv_vars.10656_0029_004.cdf') + TES(816)%FILENAME = TRIM('retv_vars.10656_0030_002.cdf') + TES(817)%FILENAME = TRIM('retv_vars.10656_0030_003.cdf') + TES(818)%FILENAME = TRIM('retv_vars.10656_0030_004.cdf') + TES(819)%FILENAME = TRIM('retv_vars.10656_0031_002.cdf') + TES(820)%FILENAME = TRIM('retv_vars.10656_0054_003.cdf') + TES(821)%FILENAME = TRIM('retv_vars.10656_0055_002.cdf') + TES(822)%FILENAME = TRIM('retv_vars.10656_0055_003.cdf') + TES(823)%FILENAME = TRIM('retv_vars.10656_0055_004.cdf') + TES(824)%FILENAME = TRIM('retv_vars.10656_0059_004.cdf') + TES(825)%FILENAME = TRIM('retv_vars.10656_0060_002.cdf') + TES(826)%FILENAME = TRIM('retv_vars.10656_0060_003.cdf') + TES(827)%FILENAME = TRIM('retv_vars.10656_0066_004.cdf') + TES(828)%FILENAME = TRIM('retv_vars.10656_0067_002.cdf') + TES(829)%FILENAME = TRIM('retv_vars.10656_0069_003.cdf') + TES(830)%FILENAME = TRIM('retv_vars.10656_0069_004.cdf') + TES(831)%FILENAME = TRIM('retv_vars.10656_0070_002.cdf') + TES(832)%FILENAME = TRIM('retv_vars.10656_0070_003.cdf') + TES(833)%FILENAME = TRIM('retv_vars.10656_0070_004.cdf') + TES(834)%FILENAME = TRIM('retv_vars.10656_0075_002.cdf') + TES(835)%FILENAME = TRIM('retv_vars.10656_0075_003.cdf') + TES(836)%FILENAME = TRIM('retv_vars.10656_0075_004.cdf') + TES(837)%FILENAME = TRIM('retv_vars.10656_0100_004.cdf') + TES(838)%FILENAME = TRIM('retv_vars.10656_0101_002.cdf') + TES(839)%FILENAME = TRIM('retv_vars.10656_0101_003.cdf') + TES(840)%FILENAME = TRIM('retv_vars.10656_0102_004.cdf') + TES(841)%FILENAME = TRIM('retv_vars.10656_0103_004.cdf') + TES(842)%FILENAME = TRIM('retv_vars.10656_0104_002.cdf') + TES(843)%FILENAME = TRIM('retv_vars.10656_0104_003.cdf') + TES(844)%FILENAME = TRIM('retv_vars.10656_0105_002.cdf') + TES(845)%FILENAME = TRIM('retv_vars.10656_0105_004.cdf') + TES(846)%FILENAME = TRIM('retv_vars.10656_0106_002.cdf') + TES(847)%FILENAME = TRIM('retv_vars.10656_0106_003.cdf') + TES(848)%FILENAME = TRIM('retv_vars.10656_0106_004.cdf') + TES(849)%FILENAME = TRIM('retv_vars.10656_0110_003.cdf') + TES(850)%FILENAME = TRIM('retv_vars.10656_0110_004.cdf') + TES(851)%FILENAME = TRIM('retv_vars.10656_0114_003.cdf') + TES(852)%FILENAME = TRIM('retv_vars.10656_0116_003.cdf') + TES(853)%FILENAME = TRIM('retv_vars.10656_0123_003.cdf') + TES(854)%FILENAME = TRIM('retv_vars.10656_0143_002.cdf') + TES(855)%FILENAME = TRIM('retv_vars.10656_0143_003.cdf') + TES(856)%FILENAME = TRIM('retv_vars.10656_0157_004.cdf') + TES(857)%FILENAME = TRIM('retv_vars.10656_0158_002.cdf') + TES(858)%FILENAME = TRIM('retv_vars.10656_0233_003.cdf') + TES(859)%FILENAME = TRIM('retv_vars.10656_0247_003.cdf') + TES(860)%FILENAME = TRIM('retv_vars.10656_0247_004.cdf') + TES(861)%FILENAME = TRIM('retv_vars.10656_0248_003.cdf') + TES(862)%FILENAME = TRIM('retv_vars.10656_0248_004.cdf') + TES(863)%FILENAME = TRIM('retv_vars.10656_0250_003.cdf') + TES(864)%FILENAME = TRIM('retv_vars.10656_0251_003.cdf') + TES(865)%FILENAME = TRIM('retv_vars.10656_0251_004.cdf') + TES(866)%FILENAME = TRIM('retv_vars.10656_0252_002.cdf') + TES(867)%FILENAME = TRIM('retv_vars.10656_0260_002.cdf') + TES(868)%FILENAME = TRIM('retv_vars.10656_0260_003.cdf') + TES(869)%FILENAME = TRIM('retv_vars.10656_0260_004.cdf') + TES(870)%FILENAME = TRIM('retv_vars.10656_0261_002.cdf') + TES(871)%FILENAME = TRIM('retv_vars.10656_0261_003.cdf') + TES(872)%FILENAME = TRIM('retv_vars.10656_0261_004.cdf') + TES(873)%FILENAME = TRIM('retv_vars.10656_0262_002.cdf') + TES(874)%FILENAME = TRIM('retv_vars.10656_0262_003.cdf') + TES(875)%FILENAME = TRIM('retv_vars.10656_0263_002.cdf') + TES(876)%FILENAME = TRIM('retv_vars.10656_0267_002.cdf') + TES(877)%FILENAME = TRIM('retv_vars.10656_0267_003.cdf') + TES(878)%FILENAME = TRIM('retv_vars.10656_0268_004.cdf') + TES(879)%FILENAME = TRIM('retv_vars.10656_0269_002.cdf') + TES(880)%FILENAME = TRIM('retv_vars.10656_0269_003.cdf') + TES(881)%FILENAME = TRIM('retv_vars.10656_0269_004.cdf') + TES(882)%FILENAME = TRIM('retv_vars.10656_0271_004.cdf') + TES(883)%FILENAME = TRIM('retv_vars.10656_0273_003.cdf') + TES(884)%FILENAME = TRIM('retv_vars.10656_0273_004.cdf') + TES(885)%FILENAME = TRIM('retv_vars.10656_0274_003.cdf') + TES(886)%FILENAME = TRIM('retv_vars.10656_0278_004.cdf') + TES(887)%FILENAME = TRIM('retv_vars.10656_0279_002.cdf') + TES(888)%FILENAME = TRIM('retv_vars.10656_0279_003.cdf') + TES(889)%FILENAME = TRIM('retv_vars.10656_0279_004.cdf') + TES(890)%FILENAME = TRIM('retv_vars.10656_0289_002.cdf') + TES(891)%FILENAME = TRIM('retv_vars.10656_0289_003.cdf') + TES(892)%FILENAME = TRIM('retv_vars.10656_0289_004.cdf') + TES(893)%FILENAME = TRIM('retv_vars.10656_0290_004.cdf') + TES(894)%FILENAME = TRIM('retv_vars.10656_0291_002.cdf') + TES(895)%FILENAME = TRIM('retv_vars.10656_0300_004.cdf') + TES(896)%FILENAME = TRIM('retv_vars.10656_0302_002.cdf') + TES(897)%FILENAME = TRIM('retv_vars.10656_0305_003.cdf') + TES(898)%FILENAME = TRIM('retv_vars.10656_0305_004.cdf') + TES(899)%FILENAME = TRIM('retv_vars.10656_0306_004.cdf') + TES(900)%FILENAME = TRIM('retv_vars.10656_0307_002.cdf') + TES(901)%FILENAME = TRIM('retv_vars.10656_0307_003.cdf') + TES(902)%FILENAME = TRIM('retv_vars.10656_0307_004.cdf') + TES(903)%FILENAME = TRIM('retv_vars.10656_0308_003.cdf') + TES(904)%FILENAME = TRIM('retv_vars.10656_0308_004.cdf') + TES(905)%FILENAME = TRIM('retv_vars.10656_0315_003.cdf') + TES(906)%FILENAME = TRIM('retv_vars.10656_0315_004.cdf') + TES(907)%FILENAME = TRIM('retv_vars.10656_0316_002.cdf') + TES(908)%FILENAME = TRIM('retv_vars.10656_0316_003.cdf') + TES(909)%FILENAME = TRIM('retv_vars.10656_0318_003.cdf') + TES(910)%FILENAME = TRIM('retv_vars.10656_0319_004.cdf') + TES(911)%FILENAME = TRIM('retv_vars.10656_0320_004.cdf') + TES(912)%FILENAME = TRIM('retv_vars.10656_0321_002.cdf') + TES(913)%FILENAME = TRIM('retv_vars.10656_0322_004.cdf') + TES(914)%FILENAME = TRIM('retv_vars.10656_0355_004.cdf') + TES(915)%FILENAME = TRIM('retv_vars.10656_0356_003.cdf') + TES(916)%FILENAME = TRIM('retv_vars.10656_0356_004.cdf') + TES(917)%FILENAME = TRIM('retv_vars.10656_0357_002.cdf') + TES(918)%FILENAME = TRIM('retv_vars.10656_0357_003.cdf') + TES(919)%FILENAME = TRIM('retv_vars.10656_0363_003.cdf') + TES(920)%FILENAME = TRIM('retv_vars.10656_0363_004.cdf') + TES(921)%FILENAME = TRIM('retv_vars.10656_0364_003.cdf') + TES(922)%FILENAME = TRIM('retv_vars.10656_0365_002.cdf') + TES(923)%FILENAME = TRIM('retv_vars.10656_0365_003.cdf') + TES(924)%FILENAME = TRIM('retv_vars.10656_0365_004.cdf') + TES(925)%FILENAME = TRIM('retv_vars.10656_0366_002.cdf') + TES(926)%FILENAME = TRIM('retv_vars.10656_0366_003.cdf') + TES(927)%FILENAME = TRIM('retv_vars.10656_0366_004.cdf') + TES(928)%FILENAME = TRIM('retv_vars.10656_0367_002.cdf') + TES(929)%FILENAME = TRIM('retv_vars.10656_0367_004.cdf') + TES(930)%FILENAME = TRIM('retv_vars.10656_0368_003.cdf') + TES(931)%FILENAME = TRIM('retv_vars.10656_0411_002.cdf') + TES(932)%FILENAME = TRIM('retv_vars.10656_0411_003.cdf') + TES(933)%FILENAME = TRIM('retv_vars.10656_0411_004.cdf') + TES(934)%FILENAME = TRIM('retv_vars.10656_0412_004.cdf') + TES(935)%FILENAME = TRIM('retv_vars.10656_0413_002.cdf') + TES(936)%FILENAME = TRIM('retv_vars.10656_0415_002.cdf') + TES(937)%FILENAME = TRIM('retv_vars.10656_0415_004.cdf') + TES(938)%FILENAME = TRIM('retv_vars.10656_0416_002.cdf') + TES(939)%FILENAME = TRIM('retv_vars.10656_0421_002.cdf') + TES(940)%FILENAME = TRIM('retv_vars.10656_0421_003.cdf') + TES(941)%FILENAME = TRIM('retv_vars.10656_0421_004.cdf') + TES(942)%FILENAME = TRIM('retv_vars.10656_0422_002.cdf') + TES(943)%FILENAME = TRIM('retv_vars.10656_0422_003.cdf') + TES(944)%FILENAME = TRIM('retv_vars.10656_0423_002.cdf') + TES(945)%FILENAME = TRIM('retv_vars.10656_0424_002.cdf') + TES(946)%FILENAME = TRIM('retv_vars.10656_0424_004.cdf') + TES(947)%FILENAME = TRIM('retv_vars.10656_0425_002.cdf') + TES(948)%FILENAME = TRIM('retv_vars.10656_0425_004.cdf') + TES(949)%FILENAME = TRIM('retv_vars.10656_0426_004.cdf') + TES(950)%FILENAME = TRIM('retv_vars.10656_0427_002.cdf') + TES(951)%FILENAME = TRIM('retv_vars.10656_0429_002.cdf') + TES(952)%FILENAME = TRIM('retv_vars.10656_0447_003.cdf') + TES(953)%FILENAME = TRIM('retv_vars.10656_0459_002.cdf') + TES(954)%FILENAME = TRIM('retv_vars.10656_0459_003.cdf') + TES(955)%FILENAME = TRIM('retv_vars.10656_0459_004.cdf') + TES(956)%FILENAME = TRIM('retv_vars.10656_0460_002.cdf') + TES(957)%FILENAME = TRIM('retv_vars.10656_0460_003.cdf') + TES(958)%FILENAME = TRIM('retv_vars.10656_0460_004.cdf') + TES(959)%FILENAME = TRIM('retv_vars.10656_0461_002.cdf') + TES(960)%FILENAME = TRIM('retv_vars.10656_0461_003.cdf') + TES(961)%FILENAME = TRIM('retv_vars.10656_0461_004.cdf') + TES(962)%FILENAME = TRIM('retv_vars.10656_0462_002.cdf') + TES(963)%FILENAME = TRIM('retv_vars.10656_0462_003.cdf') + TES(964)%FILENAME = TRIM('retv_vars.10656_0462_004.cdf') + TES(965)%FILENAME = TRIM('retv_vars.10656_0463_002.cdf') + TES(966)%FILENAME = TRIM('retv_vars.10656_0463_003.cdf') + TES(967)%FILENAME = TRIM('retv_vars.10656_0465_003.cdf') + TES(968)%FILENAME = TRIM('retv_vars.10656_0465_004.cdf') + TES(969)%FILENAME = TRIM('retv_vars.10656_0466_002.cdf') + TES(970)%FILENAME = TRIM('retv_vars.10656_0466_003.cdf') + TES(971)%FILENAME = TRIM('retv_vars.10656_0467_004.cdf') + TES(972)%FILENAME = TRIM('retv_vars.10656_0468_002.cdf') + TES(973)%FILENAME = TRIM('retv_vars.10656_0470_004.cdf') + TES(974)%FILENAME = TRIM('retv_vars.10656_0471_002.cdf') + TES(975)%FILENAME = TRIM('retv_vars.10656_0471_003.cdf') + TES(976)%FILENAME = TRIM('retv_vars.10656_0471_004.cdf') + TES(977)%FILENAME = TRIM('retv_vars.10656_0472_002.cdf') + TES(978)%FILENAME = TRIM('retv_vars.10656_0486_004.cdf') + TES(979)%FILENAME = TRIM('retv_vars.10656_0507_002.cdf') + TES(980)%FILENAME = TRIM('retv_vars.10656_0509_003.cdf') + TES(981)%FILENAME = TRIM('retv_vars.10656_0509_004.cdf') + TES(982)%FILENAME = TRIM('retv_vars.10656_0510_003.cdf') + TES(983)%FILENAME = TRIM('retv_vars.10656_0511_002.cdf') + TES(984)%FILENAME = TRIM('retv_vars.10656_0511_003.cdf') + TES(985)%FILENAME = TRIM('retv_vars.10656_0511_004.cdf') + TES(986)%FILENAME = TRIM('retv_vars.10656_0515_004.cdf') + TES(987)%FILENAME = TRIM('retv_vars.10656_0516_003.cdf') + TES(988)%FILENAME = TRIM('retv_vars.10656_0516_004.cdf') + TES(989)%FILENAME = TRIM('retv_vars.10656_0517_003.cdf') + TES(990)%FILENAME = TRIM('retv_vars.10656_0549_002.cdf') + TES(991)%FILENAME = TRIM('retv_vars.10656_0549_003.cdf') + TES(992)%FILENAME = TRIM('retv_vars.10656_0550_002.cdf') + TES(993)%FILENAME = TRIM('retv_vars.10656_0551_002.cdf') + TES(994)%FILENAME = TRIM('retv_vars.10656_0568_003.cdf') + TES(995)%FILENAME = TRIM('retv_vars.10656_0569_002.cdf') + TES(996)%FILENAME = TRIM('retv_vars.10656_0569_003.cdf') + TES(997)%FILENAME = TRIM('retv_vars.10656_0569_004.cdf') + TES(998)%FILENAME = TRIM('retv_vars.10656_0570_002.cdf') + TES(999)%FILENAME = TRIM('retv_vars.10656_0570_003.cdf') + TES(1000)%FILENAME = TRIM('retv_vars.10656_0570_004.cdf') + TES(1001)%FILENAME = TRIM('retv_vars.10656_0571_002.cdf') + TES(1002)%FILENAME = TRIM('retv_vars.10656_0581_002.cdf') + TES(1003)%FILENAME = TRIM('retv_vars.10656_0583_002.cdf') + TES(1004)%FILENAME = TRIM('retv_vars.10656_0583_004.cdf') + TES(1005)%FILENAME = TRIM('retv_vars.10656_0594_003.cdf') + TES(1006)%FILENAME = TRIM('retv_vars.10656_0597_002.cdf') + TES(1007)%FILENAME = TRIM('retv_vars.10656_0597_003.cdf') + TES(1008)%FILENAME = TRIM('retv_vars.10656_0598_002.cdf') + TES(1009)%FILENAME = TRIM('retv_vars.10656_0599_002.cdf') + TES(1010)%FILENAME = TRIM('retv_vars.10656_0613_003.cdf') + TES(1011)%FILENAME = TRIM('retv_vars.10656_0614_002.cdf') + TES(1012)%FILENAME = TRIM('retv_vars.10656_0615_004.cdf') + TES(1013)%FILENAME = TRIM('retv_vars.10656_0616_002.cdf') + TES(1014)%FILENAME = TRIM('retv_vars.10656_0616_003.cdf') + TES(1015)%FILENAME = TRIM('retv_vars.10656_0617_004.cdf') + TES(1016)%FILENAME = TRIM('retv_vars.10656_0618_002.cdf') + TES(1017)%FILENAME = TRIM('retv_vars.10656_0619_002.cdf') + TES(1018)%FILENAME = TRIM('retv_vars.10656_0619_003.cdf') + TES(1019)%FILENAME = TRIM('retv_vars.10656_0620_004.cdf') + TES(1020)%FILENAME = TRIM('retv_vars.10656_0621_004.cdf') + TES(1021)%FILENAME = TRIM('retv_vars.10656_0622_002.cdf') + TES(1022)%FILENAME = TRIM('retv_vars.10656_0622_003.cdf') + TES(1023)%FILENAME = TRIM('retv_vars.10656_0622_004.cdf') + TES(1024)%FILENAME = TRIM('retv_vars.10656_0623_002.cdf') + TES(1025)%FILENAME = TRIM('retv_vars.10656_0623_003.cdf') + TES(1026)%FILENAME = TRIM('retv_vars.10656_0623_004.cdf') + TES(1027)%FILENAME = TRIM('retv_vars.10656_0624_002.cdf') + TES(1028)%FILENAME = TRIM('retv_vars.10656_0633_004.cdf') + TES(1029)%FILENAME = TRIM('retv_vars.10656_0634_003.cdf') + TES(1030)%FILENAME = TRIM('retv_vars.10656_0637_002.cdf') + TES(1031)%FILENAME = TRIM('retv_vars.10656_0638_002.cdf') + TES(1032)%FILENAME = TRIM('retv_vars.10656_0639_002.cdf') + TES(1033)%FILENAME = TRIM('retv_vars.10656_0640_002.cdf') + TES(1034)%FILENAME = TRIM('retv_vars.10656_0641_002.cdf') + TES(1035)%FILENAME = TRIM('retv_vars.10656_0642_004.cdf') + TES(1036)%FILENAME = TRIM('retv_vars.10656_0643_002.cdf') + TES(1037)%FILENAME = TRIM('retv_vars.10656_0644_003.cdf') + TES(1038)%FILENAME = TRIM('retv_vars.10656_0645_002.cdf') + TES(1039)%FILENAME = TRIM('retv_vars.10656_0645_004.cdf') + TES(1040)%FILENAME = TRIM('retv_vars.10656_0646_002.cdf') + TES(1041)%FILENAME = TRIM('retv_vars.10656_0646_003.cdf') + TES(1042)%FILENAME = TRIM('retv_vars.10656_0646_004.cdf') + TES(1043)%FILENAME = TRIM('retv_vars.10656_0647_002.cdf') + TES(1044)%FILENAME = TRIM('retv_vars.10656_0652_002.cdf') + TES(1045)%FILENAME = TRIM('retv_vars.10656_0652_003.cdf') + TES(1046)%FILENAME = TRIM('retv_vars.10656_0652_004.cdf') + TES(1047)%FILENAME = TRIM('retv_vars.10656_0653_002.cdf') + TES(1048)%FILENAME = TRIM('retv_vars.10656_0653_004.cdf') + TES(1049)%FILENAME = TRIM('retv_vars.10656_0654_002.cdf') + TES(1050)%FILENAME = TRIM('retv_vars.10656_0654_003.cdf') + TES(1051)%FILENAME = TRIM('retv_vars.10656_0654_004.cdf') + TES(1052)%FILENAME = TRIM('retv_vars.10656_0655_002.cdf') + TES(1053)%FILENAME = TRIM('retv_vars.10656_0655_004.cdf') + TES(1054)%FILENAME = TRIM('retv_vars.10656_0656_002.cdf') + TES(1055)%FILENAME = TRIM('retv_vars.10656_0658_002.cdf') + TES(1056)%FILENAME = TRIM('retv_vars.10656_0684_004.cdf') + TES(1057)%FILENAME = TRIM('retv_vars.10656_0687_004.cdf') + TES(1058)%FILENAME = TRIM('retv_vars.10656_0688_002.cdf') + TES(1059)%FILENAME = TRIM('retv_vars.10656_0688_003.cdf') + TES(1060)%FILENAME = TRIM('retv_vars.10656_0689_002.cdf') + TES(1061)%FILENAME = TRIM('retv_vars.10656_0691_002.cdf') + TES(1062)%FILENAME = TRIM('retv_vars.10656_0693_002.cdf') + TES(1063)%FILENAME = TRIM('retv_vars.10656_0693_003.cdf') + TES(1064)%FILENAME = TRIM('retv_vars.10656_0694_003.cdf') + TES(1065)%FILENAME = TRIM('retv_vars.10656_0701_002.cdf') + TES(1066)%FILENAME = TRIM('retv_vars.10656_0701_004.cdf') + TES(1067)%FILENAME = TRIM('retv_vars.10656_0703_003.cdf') + TES(1068)%FILENAME = TRIM('retv_vars.10656_0704_002.cdf') + TES(1069)%FILENAME = TRIM('retv_vars.10656_0705_002.cdf') + TES(1070)%FILENAME = TRIM('retv_vars.10656_0705_003.cdf') + TES(1071)%FILENAME = TRIM('retv_vars.10656_0705_004.cdf') + TES(1072)%FILENAME = TRIM('retv_vars.10656_0706_002.cdf') + TES(1073)%FILENAME = TRIM('retv_vars.10656_0735_004.cdf') + TES(1074)%FILENAME = TRIM('retv_vars.10656_0736_003.cdf') + TES(1075)%FILENAME = TRIM('retv_vars.10656_0737_004.cdf') + TES(1076)%FILENAME = TRIM('retv_vars.10656_0738_004.cdf') + TES(1077)%FILENAME = TRIM('retv_vars.10656_0739_002.cdf') + TES(1078)%FILENAME = TRIM('retv_vars.10656_0739_003.cdf') + TES(1079)%FILENAME = TRIM('retv_vars.10656_0740_002.cdf') + TES(1080)%FILENAME = TRIM('retv_vars.10656_0741_003.cdf') + TES(1081)%FILENAME = TRIM('retv_vars.10656_0741_004.cdf') + TES(1082)%FILENAME = TRIM('retv_vars.10656_0742_002.cdf') + TES(1083)%FILENAME = TRIM('retv_vars.10656_0742_003.cdf') + TES(1084)%FILENAME = TRIM('retv_vars.10656_0747_003.cdf') + TES(1085)%FILENAME = TRIM('retv_vars.10656_0747_004.cdf') + TES(1086)%FILENAME = TRIM('retv_vars.10656_0748_002.cdf') + TES(1087)%FILENAME = TRIM('retv_vars.10656_0748_004.cdf') + TES(1088)%FILENAME = TRIM('retv_vars.10656_0749_003.cdf') + TES(1089)%FILENAME = TRIM('retv_vars.10656_0749_004.cdf') + TES(1090)%FILENAME = TRIM('retv_vars.10656_0750_002.cdf') + TES(1091)%FILENAME = TRIM('retv_vars.10658_0020_003.cdf') + TES(1092)%FILENAME = TRIM('retv_vars.10658_0020_004.cdf') + TES(1093)%FILENAME = TRIM('retv_vars.10658_0021_004.cdf') + TES(1094)%FILENAME = TRIM('retv_vars.10658_0022_004.cdf') + TES(1095)%FILENAME = TRIM('retv_vars.10658_0023_002.cdf') + TES(1096)%FILENAME = TRIM('retv_vars.10658_0027_002.cdf') + TES(1097)%FILENAME = TRIM('retv_vars.10658_0027_003.cdf') + TES(1098)%FILENAME = TRIM('retv_vars.10658_0028_003.cdf') + TES(1099)%FILENAME = TRIM('retv_vars.10658_0028_004.cdf') + TES(1100)%FILENAME = TRIM('retv_vars.10658_0030_002.cdf') + TES(1101)%FILENAME = TRIM('retv_vars.10658_0030_003.cdf') + TES(1102)%FILENAME = TRIM('retv_vars.10658_0031_002.cdf') + TES(1103)%FILENAME = TRIM('retv_vars.10658_0031_003.cdf') + TES(1104)%FILENAME = TRIM('retv_vars.10658_0031_004.cdf') + TES(1105)%FILENAME = TRIM('retv_vars.10658_0032_002.cdf') + TES(1106)%FILENAME = TRIM('retv_vars.10658_0033_002.cdf') + TES(1107)%FILENAME = TRIM('retv_vars.10658_0059_004.cdf') + TES(1108)%FILENAME = TRIM('retv_vars.10658_0060_003.cdf') + TES(1109)%FILENAME = TRIM('retv_vars.10658_0061_002.cdf') + TES(1110)%FILENAME = TRIM('retv_vars.10658_0064_004.cdf') + TES(1111)%FILENAME = TRIM('retv_vars.10658_0066_002.cdf') + TES(1112)%FILENAME = TRIM('retv_vars.10658_0066_004.cdf') + TES(1113)%FILENAME = TRIM('retv_vars.10658_0068_002.cdf') + TES(1114)%FILENAME = TRIM('retv_vars.10658_0068_004.cdf') + TES(1115)%FILENAME = TRIM('retv_vars.10658_0069_002.cdf') + TES(1116)%FILENAME = TRIM('retv_vars.10658_0069_003.cdf') + TES(1117)%FILENAME = TRIM('retv_vars.10658_0070_002.cdf') + TES(1118)%FILENAME = TRIM('retv_vars.10658_0070_003.cdf') + TES(1119)%FILENAME = TRIM('retv_vars.10658_0075_002.cdf') + TES(1120)%FILENAME = TRIM('retv_vars.10658_0075_003.cdf') + TES(1121)%FILENAME = TRIM('retv_vars.10658_0076_002.cdf') + TES(1122)%FILENAME = TRIM('retv_vars.10658_0076_003.cdf') + TES(1123)%FILENAME = TRIM('retv_vars.10658_0101_002.cdf') + TES(1124)%FILENAME = TRIM('retv_vars.10658_0101_003.cdf') + TES(1125)%FILENAME = TRIM('retv_vars.10658_0102_004.cdf') + TES(1126)%FILENAME = TRIM('retv_vars.10658_0103_004.cdf') + TES(1127)%FILENAME = TRIM('retv_vars.10658_0104_002.cdf') + TES(1128)%FILENAME = TRIM('retv_vars.10658_0104_003.cdf') + TES(1129)%FILENAME = TRIM('retv_vars.10658_0104_004.cdf') + TES(1130)%FILENAME = TRIM('retv_vars.10658_0105_004.cdf') + TES(1131)%FILENAME = TRIM('retv_vars.10658_0106_002.cdf') + TES(1132)%FILENAME = TRIM('retv_vars.10658_0106_003.cdf') + TES(1133)%FILENAME = TRIM('retv_vars.10658_0108_003.cdf') + TES(1134)%FILENAME = TRIM('retv_vars.10658_0108_004.cdf') + TES(1135)%FILENAME = TRIM('retv_vars.10658_0109_002.cdf') + TES(1136)%FILENAME = TRIM('retv_vars.10658_0109_003.cdf') + TES(1137)%FILENAME = TRIM('retv_vars.10658_0112_004.cdf') + TES(1138)%FILENAME = TRIM('retv_vars.10658_0114_004.cdf') + TES(1139)%FILENAME = TRIM('retv_vars.10658_0115_004.cdf') + TES(1140)%FILENAME = TRIM('retv_vars.10658_0116_003.cdf') + TES(1141)%FILENAME = TRIM('retv_vars.10658_0117_003.cdf') + TES(1142)%FILENAME = TRIM('retv_vars.10658_0232_004.cdf') + TES(1143)%FILENAME = TRIM('retv_vars.10658_0234_003.cdf') + TES(1144)%FILENAME = TRIM('retv_vars.10658_0235_004.cdf') + TES(1145)%FILENAME = TRIM('retv_vars.10658_0237_003.cdf') + TES(1146)%FILENAME = TRIM('retv_vars.10658_0247_002.cdf') + TES(1147)%FILENAME = TRIM('retv_vars.10658_0247_003.cdf') + TES(1148)%FILENAME = TRIM('retv_vars.10658_0247_004.cdf') + TES(1149)%FILENAME = TRIM('retv_vars.10658_0248_002.cdf') + TES(1150)%FILENAME = TRIM('retv_vars.10658_0248_003.cdf') + TES(1151)%FILENAME = TRIM('retv_vars.10658_0248_004.cdf') + TES(1152)%FILENAME = TRIM('retv_vars.10658_0249_002.cdf') + TES(1153)%FILENAME = TRIM('retv_vars.10658_0249_003.cdf') + TES(1154)%FILENAME = TRIM('retv_vars.10658_0249_004.cdf') + TES(1155)%FILENAME = TRIM('retv_vars.10658_0250_002.cdf') + TES(1156)%FILENAME = TRIM('retv_vars.10658_0250_003.cdf') + TES(1157)%FILENAME = TRIM('retv_vars.10658_0250_004.cdf') + TES(1158)%FILENAME = TRIM('retv_vars.10658_0251_002.cdf') + TES(1159)%FILENAME = TRIM('retv_vars.10658_0251_003.cdf') + TES(1160)%FILENAME = TRIM('retv_vars.10658_0251_004.cdf') + TES(1161)%FILENAME = TRIM('retv_vars.10658_0260_003.cdf') + TES(1162)%FILENAME = TRIM('retv_vars.10658_0260_004.cdf') + TES(1163)%FILENAME = TRIM('retv_vars.10658_0262_004.cdf') + TES(1164)%FILENAME = TRIM('retv_vars.10658_0267_004.cdf') + TES(1165)%FILENAME = TRIM('retv_vars.10658_0268_002.cdf') + TES(1166)%FILENAME = TRIM('retv_vars.10658_0268_004.cdf') + TES(1167)%FILENAME = TRIM('retv_vars.10658_0269_003.cdf') + TES(1168)%FILENAME = TRIM('retv_vars.10658_0269_004.cdf') + TES(1169)%FILENAME = TRIM('retv_vars.10658_0270_002.cdf') + TES(1170)%FILENAME = TRIM('retv_vars.10658_0271_002.cdf') + TES(1171)%FILENAME = TRIM('retv_vars.10658_0273_003.cdf') + TES(1172)%FILENAME = TRIM('retv_vars.10658_0278_003.cdf') + TES(1173)%FILENAME = TRIM('retv_vars.10658_0278_004.cdf') + TES(1174)%FILENAME = TRIM('retv_vars.10658_0279_002.cdf') + TES(1175)%FILENAME = TRIM('retv_vars.10658_0279_003.cdf') + TES(1176)%FILENAME = TRIM('retv_vars.10658_0280_004.cdf') + TES(1177)%FILENAME = TRIM('retv_vars.10658_0291_002.cdf') + TES(1178)%FILENAME = TRIM('retv_vars.10658_0291_003.cdf') + TES(1179)%FILENAME = TRIM('retv_vars.10658_0292_002.cdf') + TES(1180)%FILENAME = TRIM('retv_vars.10658_0293_002.cdf') + TES(1181)%FILENAME = TRIM('retv_vars.10658_0296_002.cdf') + TES(1182)%FILENAME = TRIM('retv_vars.10658_0297_003.cdf') + TES(1183)%FILENAME = TRIM('retv_vars.10658_0297_004.cdf') + TES(1184)%FILENAME = TRIM('retv_vars.10658_0298_002.cdf') + TES(1185)%FILENAME = TRIM('retv_vars.10658_0298_003.cdf') + TES(1186)%FILENAME = TRIM('retv_vars.10658_0298_004.cdf') + TES(1187)%FILENAME = TRIM('retv_vars.10658_0299_002.cdf') + TES(1188)%FILENAME = TRIM('retv_vars.10658_0299_003.cdf') + TES(1189)%FILENAME = TRIM('retv_vars.10658_0303_004.cdf') + TES(1190)%FILENAME = TRIM('retv_vars.10658_0305_004.cdf') + TES(1191)%FILENAME = TRIM('retv_vars.10658_0307_003.cdf') + TES(1192)%FILENAME = TRIM('retv_vars.10658_0308_003.cdf') + TES(1193)%FILENAME = TRIM('retv_vars.10658_0309_002.cdf') + TES(1194)%FILENAME = TRIM('retv_vars.10658_0309_003.cdf') + TES(1195)%FILENAME = TRIM('retv_vars.10658_0315_002.cdf') + TES(1196)%FILENAME = TRIM('retv_vars.10658_0315_004.cdf') + TES(1197)%FILENAME = TRIM('retv_vars.10658_0316_003.cdf') + TES(1198)%FILENAME = TRIM('retv_vars.10658_0316_004.cdf') + TES(1199)%FILENAME = TRIM('retv_vars.10658_0317_004.cdf') + TES(1200)%FILENAME = TRIM('retv_vars.10658_0322_002.cdf') + TES(1201)%FILENAME = TRIM('retv_vars.10658_0322_003.cdf') + TES(1202)%FILENAME = TRIM('retv_vars.10658_0323_002.cdf') + TES(1203)%FILENAME = TRIM('retv_vars.10658_0324_004.cdf') + TES(1204)%FILENAME = TRIM('retv_vars.10658_0325_002.cdf') + TES(1205)%FILENAME = TRIM('retv_vars.10658_0353_002.cdf') + TES(1206)%FILENAME = TRIM('retv_vars.10658_0353_003.cdf') + TES(1207)%FILENAME = TRIM('retv_vars.10658_0354_002.cdf') + TES(1208)%FILENAME = TRIM('retv_vars.10658_0354_004.cdf') + TES(1209)%FILENAME = TRIM('retv_vars.10658_0355_004.cdf') + TES(1210)%FILENAME = TRIM('retv_vars.10658_0357_002.cdf') + TES(1211)%FILENAME = TRIM('retv_vars.10658_0357_003.cdf') + TES(1212)%FILENAME = TRIM('retv_vars.10658_0358_002.cdf') + TES(1213)%FILENAME = TRIM('retv_vars.10658_0359_002.cdf') + TES(1214)%FILENAME = TRIM('retv_vars.10658_0359_003.cdf') + TES(1215)%FILENAME = TRIM('retv_vars.10658_0363_003.cdf') + TES(1216)%FILENAME = TRIM('retv_vars.10658_0364_002.cdf') + TES(1217)%FILENAME = TRIM('retv_vars.10658_0365_002.cdf') + TES(1218)%FILENAME = TRIM('retv_vars.10658_0366_002.cdf') + TES(1219)%FILENAME = TRIM('retv_vars.10658_0366_004.cdf') + TES(1220)%FILENAME = TRIM('retv_vars.10658_0368_002.cdf') + TES(1221)%FILENAME = TRIM('retv_vars.10658_0368_004.cdf') + TES(1222)%FILENAME = TRIM('retv_vars.10658_0369_002.cdf') + TES(1223)%FILENAME = TRIM('retv_vars.10658_0371_002.cdf') + TES(1224)%FILENAME = TRIM('retv_vars.10658_0411_002.cdf') + TES(1225)%FILENAME = TRIM('retv_vars.10658_0411_003.cdf') + TES(1226)%FILENAME = TRIM('retv_vars.10658_0411_004.cdf') + TES(1227)%FILENAME = TRIM('retv_vars.10658_0412_002.cdf') + TES(1228)%FILENAME = TRIM('retv_vars.10658_0412_003.cdf') + TES(1229)%FILENAME = TRIM('retv_vars.10658_0412_004.cdf') + TES(1230)%FILENAME = TRIM('retv_vars.10658_0418_002.cdf') + TES(1231)%FILENAME = TRIM('retv_vars.10658_0418_004.cdf') + TES(1232)%FILENAME = TRIM('retv_vars.10658_0419_002.cdf') + TES(1233)%FILENAME = TRIM('retv_vars.10658_0419_004.cdf') + TES(1234)%FILENAME = TRIM('retv_vars.10658_0421_004.cdf') + TES(1235)%FILENAME = TRIM('retv_vars.10658_0422_002.cdf') + TES(1236)%FILENAME = TRIM('retv_vars.10658_0422_003.cdf') + TES(1237)%FILENAME = TRIM('retv_vars.10658_0423_003.cdf') + TES(1238)%FILENAME = TRIM('retv_vars.10658_0423_004.cdf') + TES(1239)%FILENAME = TRIM('retv_vars.10658_0424_003.cdf') + TES(1240)%FILENAME = TRIM('retv_vars.10658_0424_004.cdf') + TES(1241)%FILENAME = TRIM('retv_vars.10658_0425_002.cdf') + TES(1242)%FILENAME = TRIM('retv_vars.10658_0425_003.cdf') + TES(1243)%FILENAME = TRIM('retv_vars.10658_0426_002.cdf') + TES(1244)%FILENAME = TRIM('retv_vars.10658_0426_003.cdf') + TES(1245)%FILENAME = TRIM('retv_vars.10658_0426_004.cdf') + TES(1246)%FILENAME = TRIM('retv_vars.10658_0427_004.cdf') + TES(1247)%FILENAME = TRIM('retv_vars.10658_0459_002.cdf') + TES(1248)%FILENAME = TRIM('retv_vars.10658_0459_003.cdf') + TES(1249)%FILENAME = TRIM('retv_vars.10658_0459_004.cdf') + TES(1250)%FILENAME = TRIM('retv_vars.10658_0460_002.cdf') + TES(1251)%FILENAME = TRIM('retv_vars.10658_0460_004.cdf') + TES(1252)%FILENAME = TRIM('retv_vars.10658_0461_002.cdf') + TES(1253)%FILENAME = TRIM('retv_vars.10658_0462_003.cdf') + TES(1254)%FILENAME = TRIM('retv_vars.10658_0462_004.cdf') + TES(1255)%FILENAME = TRIM('retv_vars.10658_0465_003.cdf') + TES(1256)%FILENAME = TRIM('retv_vars.10658_0465_004.cdf') + TES(1257)%FILENAME = TRIM('retv_vars.10658_0466_002.cdf') + TES(1258)%FILENAME = TRIM('retv_vars.10658_0466_003.cdf') + TES(1259)%FILENAME = TRIM('retv_vars.10658_0467_002.cdf') + TES(1260)%FILENAME = TRIM('retv_vars.10658_0469_003.cdf') + TES(1261)%FILENAME = TRIM('retv_vars.10658_0469_004.cdf') + TES(1262)%FILENAME = TRIM('retv_vars.10658_0470_002.cdf') + TES(1263)%FILENAME = TRIM('retv_vars.10658_0472_002.cdf') + TES(1264)%FILENAME = TRIM('retv_vars.10658_0473_002.cdf') + TES(1265)%FILENAME = TRIM('retv_vars.10658_0473_004.cdf') + TES(1266)%FILENAME = TRIM('retv_vars.10658_0474_002.cdf') + TES(1267)%FILENAME = TRIM('retv_vars.10658_0474_003.cdf') + TES(1268)%FILENAME = TRIM('retv_vars.10658_0507_002.cdf') + TES(1269)%FILENAME = TRIM('retv_vars.10658_0509_004.cdf') + TES(1270)%FILENAME = TRIM('retv_vars.10658_0510_002.cdf') + TES(1271)%FILENAME = TRIM('retv_vars.10658_0512_002.cdf') + TES(1272)%FILENAME = TRIM('retv_vars.10658_0513_002.cdf') + TES(1273)%FILENAME = TRIM('retv_vars.10658_0518_002.cdf') + TES(1274)%FILENAME = TRIM('retv_vars.10658_0535_003.cdf') + TES(1275)%FILENAME = TRIM('retv_vars.10658_0569_002.cdf') + TES(1276)%FILENAME = TRIM('retv_vars.10658_0579_002.cdf') + TES(1277)%FILENAME = TRIM('retv_vars.10658_0582_003.cdf') + TES(1278)%FILENAME = TRIM('retv_vars.10658_0582_004.cdf') + TES(1279)%FILENAME = TRIM('retv_vars.10658_0583_002.cdf') + TES(1280)%FILENAME = TRIM('retv_vars.10658_0583_003.cdf') + TES(1281)%FILENAME = TRIM('retv_vars.10658_0584_003.cdf') + TES(1282)%FILENAME = TRIM('retv_vars.10658_0596_003.cdf') + TES(1283)%FILENAME = TRIM('retv_vars.10658_0599_002.cdf') + TES(1284)%FILENAME = TRIM('retv_vars.10658_0614_002.cdf') + TES(1285)%FILENAME = TRIM('retv_vars.10658_0614_003.cdf') + TES(1286)%FILENAME = TRIM('retv_vars.10658_0614_004.cdf') + TES(1287)%FILENAME = TRIM('retv_vars.10658_0615_002.cdf') + TES(1288)%FILENAME = TRIM('retv_vars.10658_0615_003.cdf') + TES(1289)%FILENAME = TRIM('retv_vars.10658_0615_004.cdf') + TES(1290)%FILENAME = TRIM('retv_vars.10658_0616_002.cdf') + TES(1291)%FILENAME = TRIM('retv_vars.10658_0616_003.cdf') + TES(1292)%FILENAME = TRIM('retv_vars.10658_0616_004.cdf') + TES(1293)%FILENAME = TRIM('retv_vars.10658_0617_002.cdf') + TES(1294)%FILENAME = TRIM('retv_vars.10658_0617_004.cdf') + TES(1295)%FILENAME = TRIM('retv_vars.10658_0618_004.cdf') + TES(1296)%FILENAME = TRIM('retv_vars.10658_0620_004.cdf') + TES(1297)%FILENAME = TRIM('retv_vars.10658_0621_002.cdf') + TES(1298)%FILENAME = TRIM('retv_vars.10658_0621_003.cdf') + TES(1299)%FILENAME = TRIM('retv_vars.10658_0621_004.cdf') + TES(1300)%FILENAME = TRIM('retv_vars.10658_0622_002.cdf') + TES(1301)%FILENAME = TRIM('retv_vars.10658_0622_003.cdf') + TES(1302)%FILENAME = TRIM('retv_vars.10658_0622_004.cdf') + TES(1303)%FILENAME = TRIM('retv_vars.10658_0623_003.cdf') + TES(1304)%FILENAME = TRIM('retv_vars.10658_0623_004.cdf') + TES(1305)%FILENAME = TRIM('retv_vars.10658_0624_002.cdf') + TES(1306)%FILENAME = TRIM('retv_vars.10658_0624_003.cdf') + TES(1307)%FILENAME = TRIM('retv_vars.10658_0628_002.cdf') + TES(1308)%FILENAME = TRIM('retv_vars.10658_0628_003.cdf') + TES(1309)%FILENAME = TRIM('retv_vars.10658_0628_004.cdf') + TES(1310)%FILENAME = TRIM('retv_vars.10658_0629_002.cdf') + TES(1311)%FILENAME = TRIM('retv_vars.10658_0629_003.cdf') + TES(1312)%FILENAME = TRIM('retv_vars.10658_0630_002.cdf') + TES(1313)%FILENAME = TRIM('retv_vars.10658_0630_003.cdf') + TES(1314)%FILENAME = TRIM('retv_vars.10658_0634_004.cdf') + TES(1315)%FILENAME = TRIM('retv_vars.10658_0635_002.cdf') + TES(1316)%FILENAME = TRIM('retv_vars.10658_0637_004.cdf') + TES(1317)%FILENAME = TRIM('retv_vars.10658_0639_004.cdf') + TES(1318)%FILENAME = TRIM('retv_vars.10658_0640_002.cdf') + TES(1319)%FILENAME = TRIM('retv_vars.10658_0640_003.cdf') + TES(1320)%FILENAME = TRIM('retv_vars.10658_0641_002.cdf') + TES(1321)%FILENAME = TRIM('retv_vars.10658_0644_004.cdf') + TES(1322)%FILENAME = TRIM('retv_vars.10658_0645_002.cdf') + TES(1323)%FILENAME = TRIM('retv_vars.10658_0645_003.cdf') + TES(1324)%FILENAME = TRIM('retv_vars.10658_0645_004.cdf') + TES(1325)%FILENAME = TRIM('retv_vars.10658_0646_002.cdf') + TES(1326)%FILENAME = TRIM('retv_vars.10658_0646_003.cdf') + TES(1327)%FILENAME = TRIM('retv_vars.10658_0646_004.cdf') + TES(1328)%FILENAME = TRIM('retv_vars.10658_0647_002.cdf') + TES(1329)%FILENAME = TRIM('retv_vars.10658_0654_004.cdf') + TES(1330)%FILENAME = TRIM('retv_vars.10658_0658_002.cdf') + TES(1331)%FILENAME = TRIM('retv_vars.10658_0658_004.cdf') + TES(1332)%FILENAME = TRIM('retv_vars.10658_0687_004.cdf') + TES(1333)%FILENAME = TRIM('retv_vars.10658_0688_002.cdf') + TES(1334)%FILENAME = TRIM('retv_vars.10658_0688_004.cdf') + TES(1335)%FILENAME = TRIM('retv_vars.10658_0689_002.cdf') + TES(1336)%FILENAME = TRIM('retv_vars.10658_0691_003.cdf') + TES(1337)%FILENAME = TRIM('retv_vars.10658_0691_004.cdf') + TES(1338)%FILENAME = TRIM('retv_vars.10658_0692_003.cdf') + TES(1339)%FILENAME = TRIM('retv_vars.10658_0693_002.cdf') + TES(1340)%FILENAME = TRIM('retv_vars.10658_0693_003.cdf') + TES(1341)%FILENAME = TRIM('retv_vars.10658_0694_004.cdf') + TES(1342)%FILENAME = TRIM('retv_vars.10658_0695_002.cdf') + TES(1343)%FILENAME = TRIM('retv_vars.10658_0700_003.cdf') + TES(1344)%FILENAME = TRIM('retv_vars.10658_0700_004.cdf') + TES(1345)%FILENAME = TRIM('retv_vars.10658_0701_002.cdf') + TES(1346)%FILENAME = TRIM('retv_vars.10658_0702_002.cdf') + TES(1347)%FILENAME = TRIM('retv_vars.10658_0702_004.cdf') + TES(1348)%FILENAME = TRIM('retv_vars.10658_0704_002.cdf') + TES(1349)%FILENAME = TRIM('retv_vars.10658_0704_003.cdf') + TES(1350)%FILENAME = TRIM('retv_vars.10658_0704_004.cdf') + TES(1351)%FILENAME = TRIM('retv_vars.10658_0705_003.cdf') + TES(1352)%FILENAME = TRIM('retv_vars.10658_0705_004.cdf') + TES(1353)%FILENAME = TRIM('retv_vars.10658_0706_002.cdf') + TES(1354)%FILENAME = TRIM('retv_vars.10658_0706_003.cdf') + TES(1355)%FILENAME = TRIM('retv_vars.10658_0706_004.cdf') + TES(1356)%FILENAME = TRIM('retv_vars.10658_0741_003.cdf') + TES(1357)%FILENAME = TRIM('retv_vars.10658_0741_004.cdf') + TES(1358)%FILENAME = TRIM('retv_vars.10658_0742_002.cdf') + TES(1359)%FILENAME = TRIM('retv_vars.10658_0742_004.cdf') + TES(1360)%FILENAME = TRIM('retv_vars.10658_0743_002.cdf') + TES(1361)%FILENAME = TRIM('retv_vars.10658_0747_003.cdf') + TES(1362)%FILENAME = TRIM('retv_vars.10658_0747_004.cdf') + TES(1363)%FILENAME = TRIM('retv_vars.10658_0748_002.cdf') + TES(1364)%FILENAME = TRIM('retv_vars.10658_0748_003.cdf') + TES(1365)%FILENAME = TRIM('retv_vars.10658_0748_004.cdf') + TES(1366)%FILENAME = TRIM('retv_vars.10658_0749_002.cdf') + TES(1367)%FILENAME = TRIM('retv_vars.10658_0749_004.cdf') + TES(1368)%FILENAME = TRIM('retv_vars.10658_0750_002.cdf') + TES(1369)%FILENAME = TRIM('retv_vars.10658_0750_003.cdf') + TES(1370)%FILENAME = TRIM('retv_vars.10658_0750_004.cdf') + TES(1371)%FILENAME = TRIM('retv_vars.10658_0751_002.cdf') + TES(1372)%FILENAME = TRIM('retv_vars.10658_0751_003.cdf') + TES(1373)%FILENAME = TRIM('retv_vars.10666_0012_003.cdf') + TES(1374)%FILENAME = TRIM('retv_vars.10666_0013_002.cdf') + TES(1375)%FILENAME = TRIM('retv_vars.10666_0020_004.cdf') + TES(1376)%FILENAME = TRIM('retv_vars.10666_0021_003.cdf') + TES(1377)%FILENAME = TRIM('retv_vars.10666_0021_004.cdf') + TES(1378)%FILENAME = TRIM('retv_vars.10666_0022_003.cdf') + TES(1379)%FILENAME = TRIM('retv_vars.10666_0027_004.cdf') + TES(1380)%FILENAME = TRIM('retv_vars.10666_0028_002.cdf') + TES(1381)%FILENAME = TRIM('retv_vars.10666_0053_002.cdf') + TES(1382)%FILENAME = TRIM('retv_vars.10666_0053_003.cdf') + TES(1383)%FILENAME = TRIM('retv_vars.10666_0053_004.cdf') + TES(1384)%FILENAME = TRIM('retv_vars.10666_0054_002.cdf') + TES(1385)%FILENAME = TRIM('retv_vars.10666_0054_003.cdf') + TES(1386)%FILENAME = TRIM('retv_vars.10666_0054_004.cdf') + TES(1387)%FILENAME = TRIM('retv_vars.10666_0055_003.cdf') + TES(1388)%FILENAME = TRIM('retv_vars.10666_0055_004.cdf') + TES(1389)%FILENAME = TRIM('retv_vars.10666_0056_002.cdf') + TES(1390)%FILENAME = TRIM('retv_vars.10666_0056_003.cdf') + TES(1391)%FILENAME = TRIM('retv_vars.10666_0057_004.cdf') + TES(1392)%FILENAME = TRIM('retv_vars.10666_0059_002.cdf') + TES(1393)%FILENAME = TRIM('retv_vars.10666_0059_004.cdf') + TES(1394)%FILENAME = TRIM('retv_vars.10666_0060_003.cdf') + TES(1395)%FILENAME = TRIM('retv_vars.10666_0067_003.cdf') + TES(1396)%FILENAME = TRIM('retv_vars.10666_0067_004.cdf') + TES(1397)%FILENAME = TRIM('retv_vars.10666_0068_004.cdf') + TES(1398)%FILENAME = TRIM('retv_vars.10666_0069_003.cdf') + TES(1399)%FILENAME = TRIM('retv_vars.10666_0069_004.cdf') + TES(1400)%FILENAME = TRIM('retv_vars.10666_0070_003.cdf') + TES(1401)%FILENAME = TRIM('retv_vars.10666_0109_003.cdf') + TES(1402)%FILENAME = TRIM('retv_vars.10666_0110_003.cdf') + TES(1403)%FILENAME = TRIM('retv_vars.10666_0113_004.cdf') + TES(1404)%FILENAME = TRIM('retv_vars.10666_0133_004.cdf') + TES(1405)%FILENAME = TRIM('retv_vars.10666_0171_003.cdf') + TES(1406)%FILENAME = TRIM('retv_vars.10666_0172_002.cdf') + TES(1407)%FILENAME = TRIM('retv_vars.10666_0172_003.cdf') + TES(1408)%FILENAME = TRIM('retv_vars.10666_0172_004.cdf') + TES(1409)%FILENAME = TRIM('retv_vars.10666_0184_004.cdf') + TES(1410)%FILENAME = TRIM('retv_vars.10666_0185_002.cdf') + TES(1411)%FILENAME = TRIM('retv_vars.10666_0186_004.cdf') + TES(1412)%FILENAME = TRIM('retv_vars.10666_0187_002.cdf') + TES(1413)%FILENAME = TRIM('retv_vars.10666_0187_003.cdf') + TES(1414)%FILENAME = TRIM('retv_vars.10666_0187_004.cdf') + TES(1415)%FILENAME = TRIM('retv_vars.10666_0190_002.cdf') + TES(1416)%FILENAME = TRIM('retv_vars.10666_0198_003.cdf') + TES(1417)%FILENAME = TRIM('retv_vars.10666_0198_004.cdf') + TES(1418)%FILENAME = TRIM('retv_vars.10666_0199_002.cdf') + TES(1419)%FILENAME = TRIM('retv_vars.10666_0199_003.cdf') + TES(1420)%FILENAME = TRIM('retv_vars.10666_0199_004.cdf') + TES(1421)%FILENAME = TRIM('retv_vars.10666_0201_002.cdf') + TES(1422)%FILENAME = TRIM('retv_vars.10666_0201_004.cdf') + TES(1423)%FILENAME = TRIM('retv_vars.10666_0202_002.cdf') + TES(1424)%FILENAME = TRIM('retv_vars.10666_0202_003.cdf') + TES(1425)%FILENAME = TRIM('retv_vars.10666_0202_004.cdf') + TES(1426)%FILENAME = TRIM('retv_vars.10666_0212_002.cdf') + TES(1427)%FILENAME = TRIM('retv_vars.10666_0213_004.cdf') + TES(1428)%FILENAME = TRIM('retv_vars.10666_0219_002.cdf') + TES(1429)%FILENAME = TRIM('retv_vars.10666_0219_003.cdf') + TES(1430)%FILENAME = TRIM('retv_vars.10666_0221_003.cdf') + TES(1431)%FILENAME = TRIM('retv_vars.10666_0222_003.cdf') + TES(1432)%FILENAME = TRIM('retv_vars.10666_0230_004.cdf') + TES(1433)%FILENAME = TRIM('retv_vars.10666_0232_004.cdf') + TES(1434)%FILENAME = TRIM('retv_vars.10666_0242_003.cdf') + TES(1435)%FILENAME = TRIM('retv_vars.10666_0243_002.cdf') + TES(1436)%FILENAME = TRIM('retv_vars.10666_0243_003.cdf') + TES(1437)%FILENAME = TRIM('retv_vars.10666_0243_004.cdf') + TES(1438)%FILENAME = TRIM('retv_vars.10666_0244_002.cdf') + TES(1439)%FILENAME = TRIM('retv_vars.10666_0244_003.cdf') + TES(1440)%FILENAME = TRIM('retv_vars.10666_0244_004.cdf') + TES(1441)%FILENAME = TRIM('retv_vars.10666_0247_004.cdf') + TES(1442)%FILENAME = TRIM('retv_vars.10666_0248_002.cdf') + TES(1443)%FILENAME = TRIM('retv_vars.10666_0249_003.cdf') + TES(1444)%FILENAME = TRIM('retv_vars.10666_0249_004.cdf') + TES(1445)%FILENAME = TRIM('retv_vars.10666_0250_004.cdf') + TES(1446)%FILENAME = TRIM('retv_vars.10666_0251_003.cdf') + TES(1447)%FILENAME = TRIM('retv_vars.10666_0251_004.cdf') + TES(1448)%FILENAME = TRIM('retv_vars.10666_0252_004.cdf') + TES(1449)%FILENAME = TRIM('retv_vars.10666_0256_003.cdf') + TES(1450)%FILENAME = TRIM('retv_vars.10666_0256_004.cdf') + TES(1451)%FILENAME = TRIM('retv_vars.10666_0257_002.cdf') + TES(1452)%FILENAME = TRIM('retv_vars.10666_0258_004.cdf') + TES(1453)%FILENAME = TRIM('retv_vars.10666_0259_002.cdf') + TES(1454)%FILENAME = TRIM('retv_vars.10666_0259_004.cdf') + TES(1455)%FILENAME = TRIM('retv_vars.10666_0260_002.cdf') + TES(1456)%FILENAME = TRIM('retv_vars.10666_0260_003.cdf') + TES(1457)%FILENAME = TRIM('retv_vars.10666_0261_002.cdf') + TES(1458)%FILENAME = TRIM('retv_vars.10666_0261_003.cdf') + TES(1459)%FILENAME = TRIM('retv_vars.10666_0261_004.cdf') + TES(1460)%FILENAME = TRIM('retv_vars.10666_0262_002.cdf') + TES(1461)%FILENAME = TRIM('retv_vars.10666_0262_003.cdf') + TES(1462)%FILENAME = TRIM('retv_vars.10666_0267_004.cdf') + TES(1463)%FILENAME = TRIM('retv_vars.10666_0268_003.cdf') + TES(1464)%FILENAME = TRIM('retv_vars.10666_0268_004.cdf') + TES(1465)%FILENAME = TRIM('retv_vars.10666_0269_002.cdf') + TES(1466)%FILENAME = TRIM('retv_vars.10666_0269_003.cdf') + TES(1467)%FILENAME = TRIM('retv_vars.10666_0272_002.cdf') + TES(1468)%FILENAME = TRIM('retv_vars.10666_0272_004.cdf') + TES(1469)%FILENAME = TRIM('retv_vars.10666_0273_002.cdf') + TES(1470)%FILENAME = TRIM('retv_vars.10666_0273_003.cdf') + TES(1471)%FILENAME = TRIM('retv_vars.10666_0274_002.cdf') + TES(1472)%FILENAME = TRIM('retv_vars.10666_0274_004.cdf') + TES(1473)%FILENAME = TRIM('retv_vars.10666_0275_002.cdf') + TES(1474)%FILENAME = TRIM('retv_vars.10666_0303_002.cdf') + TES(1475)%FILENAME = TRIM('retv_vars.10666_0303_003.cdf') + TES(1476)%FILENAME = TRIM('retv_vars.10666_0303_004.cdf') + TES(1477)%FILENAME = TRIM('retv_vars.10666_0305_002.cdf') + TES(1478)%FILENAME = TRIM('retv_vars.10666_0306_002.cdf') + TES(1479)%FILENAME = TRIM('retv_vars.10666_0306_004.cdf') + TES(1480)%FILENAME = TRIM('retv_vars.10666_0307_003.cdf') + TES(1481)%FILENAME = TRIM('retv_vars.10666_0309_004.cdf') + TES(1482)%FILENAME = TRIM('retv_vars.10666_0310_002.cdf') + TES(1483)%FILENAME = TRIM('retv_vars.10666_0315_004.cdf') + TES(1484)%FILENAME = TRIM('retv_vars.10666_0316_004.cdf') + TES(1485)%FILENAME = TRIM('retv_vars.10666_0317_003.cdf') + TES(1486)%FILENAME = TRIM('retv_vars.10666_0319_002.cdf') + TES(1487)%FILENAME = TRIM('retv_vars.10666_0320_004.cdf') + TES(1488)%FILENAME = TRIM('retv_vars.10666_0322_003.cdf') + TES(1489)%FILENAME = TRIM('retv_vars.10666_0363_003.cdf') + TES(1490)%FILENAME = TRIM('retv_vars.10666_0363_004.cdf') + TES(1491)%FILENAME = TRIM('retv_vars.10666_0364_002.cdf') + TES(1492)%FILENAME = TRIM('retv_vars.10666_0364_003.cdf') + TES(1493)%FILENAME = TRIM('retv_vars.10666_0364_004.cdf') + TES(1494)%FILENAME = TRIM('retv_vars.10666_0365_003.cdf') + TES(1495)%FILENAME = TRIM('retv_vars.10666_0366_004.cdf') + TES(1496)%FILENAME = TRIM('retv_vars.10666_0369_002.cdf') + TES(1497)%FILENAME = TRIM('retv_vars.10666_0370_003.cdf') + TES(1498)%FILENAME = TRIM('retv_vars.10666_0370_004.cdf') + TES(1499)%FILENAME = TRIM('retv_vars.10666_0372_003.cdf') + TES(1500)%FILENAME = TRIM('retv_vars.10666_0374_004.cdf') + TES(1501)%FILENAME = TRIM('retv_vars.10666_0375_002.cdf') + TES(1502)%FILENAME = TRIM('retv_vars.10666_0378_003.cdf') + TES(1503)%FILENAME = TRIM('retv_vars.10666_0406_002.cdf') + TES(1504)%FILENAME = TRIM('retv_vars.10666_0412_003.cdf') + TES(1505)%FILENAME = TRIM('retv_vars.10666_0415_002.cdf') + TES(1506)%FILENAME = TRIM('retv_vars.10666_0415_003.cdf') + TES(1507)%FILENAME = TRIM('retv_vars.10666_0417_004.cdf') + TES(1508)%FILENAME = TRIM('retv_vars.10666_0418_002.cdf') + TES(1509)%FILENAME = TRIM('retv_vars.10666_0418_003.cdf') + TES(1510)%FILENAME = TRIM('retv_vars.10666_0419_002.cdf') + TES(1511)%FILENAME = TRIM('retv_vars.10666_0420_004.cdf') + TES(1512)%FILENAME = TRIM('retv_vars.10666_0421_002.cdf') + TES(1513)%FILENAME = TRIM('retv_vars.10666_0421_003.cdf') + TES(1514)%FILENAME = TRIM('retv_vars.10666_0421_004.cdf') + TES(1515)%FILENAME = TRIM('retv_vars.10666_0423_002.cdf') + TES(1516)%FILENAME = TRIM('retv_vars.10666_0423_003.cdf') + TES(1517)%FILENAME = TRIM('retv_vars.10666_0423_004.cdf') + TES(1518)%FILENAME = TRIM('retv_vars.10666_0424_003.cdf') + TES(1519)%FILENAME = TRIM('retv_vars.10666_0424_004.cdf') + TES(1520)%FILENAME = TRIM('retv_vars.10666_0425_002.cdf') + TES(1521)%FILENAME = TRIM('retv_vars.10666_0426_004.cdf') + TES(1522)%FILENAME = TRIM('retv_vars.10666_0427_002.cdf') + TES(1523)%FILENAME = TRIM('retv_vars.10666_0459_002.cdf') + TES(1524)%FILENAME = TRIM('retv_vars.10666_0460_002.cdf') + TES(1525)%FILENAME = TRIM('retv_vars.10666_0460_004.cdf') + TES(1526)%FILENAME = TRIM('retv_vars.10666_0462_002.cdf') + TES(1527)%FILENAME = TRIM('retv_vars.10666_0466_003.cdf') + TES(1528)%FILENAME = TRIM('retv_vars.10666_0466_004.cdf') + TES(1529)%FILENAME = TRIM('retv_vars.10666_0467_003.cdf') + TES(1530)%FILENAME = TRIM('retv_vars.10666_0469_002.cdf') + TES(1531)%FILENAME = TRIM('retv_vars.10666_0469_003.cdf') + TES(1532)%FILENAME = TRIM('retv_vars.10666_0469_004.cdf') + TES(1533)%FILENAME = TRIM('retv_vars.10666_0482_003.cdf') + TES(1534)%FILENAME = TRIM('retv_vars.10666_0500_003.cdf') + TES(1535)%FILENAME = TRIM('retv_vars.10666_0530_003.cdf') + TES(1536)%FILENAME = TRIM('retv_vars.10666_0530_004.cdf') + TES(1537)%FILENAME = TRIM('retv_vars.10666_0532_002.cdf') + TES(1538)%FILENAME = TRIM('retv_vars.10666_0532_003.cdf') + TES(1539)%FILENAME = TRIM('retv_vars.10666_0532_004.cdf') + TES(1540)%FILENAME = TRIM('retv_vars.10666_0533_002.cdf') + TES(1541)%FILENAME = TRIM('retv_vars.10666_0534_003.cdf') + TES(1542)%FILENAME = TRIM('retv_vars.10666_0535_002.cdf') + TES(1543)%FILENAME = TRIM('retv_vars.10666_0535_003.cdf') + TES(1544)%FILENAME = TRIM('retv_vars.10666_0537_004.cdf') + TES(1545)%FILENAME = TRIM('retv_vars.10666_0546_002.cdf') + TES(1546)%FILENAME = TRIM('retv_vars.10666_0546_003.cdf') + TES(1547)%FILENAME = TRIM('retv_vars.10666_0550_004.cdf') + TES(1548)%FILENAME = TRIM('retv_vars.10666_0566_003.cdf') + TES(1549)%FILENAME = TRIM('retv_vars.10666_0567_002.cdf') + TES(1550)%FILENAME = TRIM('retv_vars.10666_0567_003.cdf') + TES(1551)%FILENAME = TRIM('retv_vars.10666_0567_004.cdf') + TES(1552)%FILENAME = TRIM('retv_vars.10666_0568_004.cdf') + TES(1553)%FILENAME = TRIM('retv_vars.10666_0569_002.cdf') + TES(1554)%FILENAME = TRIM('retv_vars.10666_0569_004.cdf') + TES(1555)%FILENAME = TRIM('retv_vars.10666_0571_002.cdf') + TES(1556)%FILENAME = TRIM('retv_vars.10666_0572_002.cdf') + TES(1557)%FILENAME = TRIM('retv_vars.10666_0572_003.cdf') + TES(1558)%FILENAME = TRIM('retv_vars.10666_0572_004.cdf') + TES(1559)%FILENAME = TRIM('retv_vars.10666_0573_002.cdf') + TES(1560)%FILENAME = TRIM('retv_vars.10666_0573_004.cdf') + TES(1561)%FILENAME = TRIM('retv_vars.10666_0574_002.cdf') + TES(1562)%FILENAME = TRIM('retv_vars.10666_0574_003.cdf') + TES(1563)%FILENAME = TRIM('retv_vars.10666_0574_004.cdf') + TES(1564)%FILENAME = TRIM('retv_vars.10666_0575_002.cdf') + TES(1565)%FILENAME = TRIM('retv_vars.10666_0575_003.cdf') + TES(1566)%FILENAME = TRIM('retv_vars.10666_0575_004.cdf') + TES(1567)%FILENAME = TRIM('retv_vars.10666_0576_003.cdf') + TES(1568)%FILENAME = TRIM('retv_vars.10666_0580_002.cdf') + TES(1569)%FILENAME = TRIM('retv_vars.10666_0581_003.cdf') + TES(1570)%FILENAME = TRIM('retv_vars.10666_0582_003.cdf') + TES(1571)%FILENAME = TRIM('retv_vars.10666_0582_004.cdf') + TES(1572)%FILENAME = TRIM('retv_vars.10666_0586_003.cdf') + TES(1573)%FILENAME = TRIM('retv_vars.10666_0586_004.cdf') + TES(1574)%FILENAME = TRIM('retv_vars.10666_0587_003.cdf') + TES(1575)%FILENAME = TRIM('retv_vars.10666_0591_004.cdf') + TES(1576)%FILENAME = TRIM('retv_vars.10666_0592_002.cdf') + TES(1577)%FILENAME = TRIM('retv_vars.10666_0592_003.cdf') + TES(1578)%FILENAME = TRIM('retv_vars.10666_0592_004.cdf') + TES(1579)%FILENAME = TRIM('retv_vars.10666_0594_003.cdf') + TES(1580)%FILENAME = TRIM('retv_vars.10666_0596_002.cdf') + TES(1581)%FILENAME = TRIM('retv_vars.10666_0597_003.cdf') + TES(1582)%FILENAME = TRIM('retv_vars.10666_0598_002.cdf') + TES(1583)%FILENAME = TRIM('retv_vars.10666_0598_003.cdf') + TES(1584)%FILENAME = TRIM('retv_vars.10666_0598_004.cdf') + TES(1585)%FILENAME = TRIM('retv_vars.10666_0599_002.cdf') + TES(1586)%FILENAME = TRIM('retv_vars.10666_0605_004.cdf') + TES(1587)%FILENAME = TRIM('retv_vars.10666_0606_002.cdf') + TES(1588)%FILENAME = TRIM('retv_vars.10666_0610_003.cdf') + TES(1589)%FILENAME = TRIM('retv_vars.10666_0613_003.cdf') + TES(1590)%FILENAME = TRIM('retv_vars.10666_0615_002.cdf') + TES(1591)%FILENAME = TRIM('retv_vars.10666_0615_003.cdf') + TES(1592)%FILENAME = TRIM('retv_vars.10666_0616_002.cdf') + TES(1593)%FILENAME = TRIM('retv_vars.10666_0639_004.cdf') + TES(1594)%FILENAME = TRIM('retv_vars.10666_0640_002.cdf') + TES(1595)%FILENAME = TRIM('retv_vars.10666_0640_004.cdf') + TES(1596)%FILENAME = TRIM('retv_vars.10666_0642_002.cdf') + TES(1597)%FILENAME = TRIM('retv_vars.10666_0644_002.cdf') + TES(1598)%FILENAME = TRIM('retv_vars.10666_0644_003.cdf') + TES(1599)%FILENAME = TRIM('retv_vars.10666_0644_004.cdf') + TES(1600)%FILENAME = TRIM('retv_vars.10666_0645_002.cdf') + TES(1601)%FILENAME = TRIM('retv_vars.10666_0645_003.cdf') + TES(1602)%FILENAME = TRIM('retv_vars.10666_0646_004.cdf') + TES(1603)%FILENAME = TRIM('retv_vars.10666_0647_002.cdf') + TES(1604)%FILENAME = TRIM('retv_vars.10666_0651_004.cdf') + TES(1605)%FILENAME = TRIM('retv_vars.10666_0652_002.cdf') + TES(1606)%FILENAME = TRIM('retv_vars.10666_0652_003.cdf') + TES(1607)%FILENAME = TRIM('retv_vars.10666_0653_002.cdf') + TES(1608)%FILENAME = TRIM('retv_vars.10666_0653_003.cdf') + TES(1609)%FILENAME = TRIM('retv_vars.10666_0655_004.cdf') + TES(1610)%FILENAME = TRIM('retv_vars.10666_0656_003.cdf') + TES(1611)%FILENAME = TRIM('retv_vars.10666_0657_002.cdf') + TES(1612)%FILENAME = TRIM('retv_vars.10666_0657_003.cdf') + TES(1613)%FILENAME = TRIM('retv_vars.10666_0657_004.cdf') + TES(1614)%FILENAME = TRIM('retv_vars.10666_0658_003.cdf') + TES(1615)%FILENAME = TRIM('retv_vars.10666_0658_004.cdf') + TES(1616)%FILENAME = TRIM('retv_vars.10666_0690_003.cdf') + TES(1617)%FILENAME = TRIM('retv_vars.10666_0694_004.cdf') + TES(1618)%FILENAME = TRIM('retv_vars.10666_0695_002.cdf') + TES(1619)%FILENAME = TRIM('retv_vars.10666_0699_002.cdf') + TES(1620)%FILENAME = TRIM('retv_vars.10666_0699_003.cdf') + TES(1621)%FILENAME = TRIM('retv_vars.10666_0701_002.cdf') + TES(1622)%FILENAME = TRIM('retv_vars.10666_0701_004.cdf') + TES(1623)%FILENAME = TRIM('retv_vars.10666_0702_003.cdf') + TES(1624)%FILENAME = TRIM('retv_vars.10666_0702_004.cdf') + TES(1625)%FILENAME = TRIM('retv_vars.10666_0703_004.cdf') + TES(1626)%FILENAME = TRIM('retv_vars.10666_0704_002.cdf') + TES(1627)%FILENAME = TRIM('retv_vars.10666_0731_003.cdf') + TES(1628)%FILENAME = TRIM('retv_vars.10666_0731_004.cdf') + TES(1629)%FILENAME = TRIM('retv_vars.10666_0732_002.cdf') + TES(1630)%FILENAME = TRIM('retv_vars.10666_0733_002.cdf') + TES(1631)%FILENAME = TRIM('retv_vars.10666_0733_004.cdf') + TES(1632)%FILENAME = TRIM('retv_vars.10666_0734_002.cdf') + TES(1633)%FILENAME = TRIM('retv_vars.10666_0737_003.cdf') + TES(1634)%FILENAME = TRIM('retv_vars.10666_0738_004.cdf') + TES(1635)%FILENAME = TRIM('retv_vars.10666_0740_003.cdf') + TES(1636)%FILENAME = TRIM('retv_vars.10666_0740_004.cdf') + TES(1637)%FILENAME = TRIM('retv_vars.10666_0741_002.cdf') + TES(1638)%FILENAME = TRIM('retv_vars.10666_0741_003.cdf') + TES(1639)%FILENAME = TRIM('retv_vars.10666_0741_004.cdf') + TES(1640)%FILENAME = TRIM('retv_vars.10666_0742_003.cdf') + TES(1641)%FILENAME = TRIM('retv_vars.10666_0742_004.cdf') + TES(1642)%FILENAME = TRIM('retv_vars.10666_0747_003.cdf') + TES(1643)%FILENAME = TRIM('retv_vars.10674_0020_002.cdf') + TES(1644)%FILENAME = TRIM('retv_vars.10674_0020_003.cdf') + TES(1645)%FILENAME = TRIM('retv_vars.10674_0020_004.cdf') + TES(1646)%FILENAME = TRIM('retv_vars.10674_0021_002.cdf') + TES(1647)%FILENAME = TRIM('retv_vars.10674_0021_004.cdf') + TES(1648)%FILENAME = TRIM('retv_vars.10674_0022_004.cdf') + TES(1649)%FILENAME = TRIM('retv_vars.10674_0023_002.cdf') + TES(1650)%FILENAME = TRIM('retv_vars.10674_0027_002.cdf') + TES(1651)%FILENAME = TRIM('retv_vars.10674_0027_003.cdf') + TES(1652)%FILENAME = TRIM('retv_vars.10674_0027_004.cdf') + TES(1653)%FILENAME = TRIM('retv_vars.10674_0028_002.cdf') + TES(1654)%FILENAME = TRIM('retv_vars.10674_0028_003.cdf') + TES(1655)%FILENAME = TRIM('retv_vars.10674_0028_004.cdf') + TES(1656)%FILENAME = TRIM('retv_vars.10674_0055_002.cdf') + TES(1657)%FILENAME = TRIM('retv_vars.10674_0055_003.cdf') + TES(1658)%FILENAME = TRIM('retv_vars.10674_0056_002.cdf') + TES(1659)%FILENAME = TRIM('retv_vars.10674_0056_003.cdf') + TES(1660)%FILENAME = TRIM('retv_vars.10674_0057_002.cdf') + TES(1661)%FILENAME = TRIM('retv_vars.10674_0057_003.cdf') + TES(1662)%FILENAME = TRIM('retv_vars.10674_0057_004.cdf') + TES(1663)%FILENAME = TRIM('retv_vars.10674_0059_004.cdf') + TES(1664)%FILENAME = TRIM('retv_vars.10674_0060_003.cdf') + TES(1665)%FILENAME = TRIM('retv_vars.10674_0061_002.cdf') + TES(1666)%FILENAME = TRIM('retv_vars.10674_0061_004.cdf') + TES(1667)%FILENAME = TRIM('retv_vars.10674_0062_004.cdf') + TES(1668)%FILENAME = TRIM('retv_vars.10674_0063_004.cdf') + TES(1669)%FILENAME = TRIM('retv_vars.10674_0064_003.cdf') + TES(1670)%FILENAME = TRIM('retv_vars.10674_0067_004.cdf') + TES(1671)%FILENAME = TRIM('retv_vars.10674_0068_002.cdf') + TES(1672)%FILENAME = TRIM('retv_vars.10674_0068_003.cdf') + TES(1673)%FILENAME = TRIM('retv_vars.10674_0068_004.cdf') + TES(1674)%FILENAME = TRIM('retv_vars.10674_0069_002.cdf') + TES(1675)%FILENAME = TRIM('retv_vars.10674_0069_003.cdf') + TES(1676)%FILENAME = TRIM('retv_vars.10674_0108_003.cdf') + TES(1677)%FILENAME = TRIM('retv_vars.10674_0110_002.cdf') + TES(1678)%FILENAME = TRIM('retv_vars.10674_0110_004.cdf') + TES(1679)%FILENAME = TRIM('retv_vars.10674_0114_003.cdf') + TES(1680)%FILENAME = TRIM('retv_vars.10674_0115_004.cdf') + TES(1681)%FILENAME = TRIM('retv_vars.10674_0171_004.cdf') + TES(1682)%FILENAME = TRIM('retv_vars.10674_0172_002.cdf') + TES(1683)%FILENAME = TRIM('retv_vars.10674_0185_004.cdf') + TES(1684)%FILENAME = TRIM('retv_vars.10674_0186_004.cdf') + TES(1685)%FILENAME = TRIM('retv_vars.10674_0189_004.cdf') + TES(1686)%FILENAME = TRIM('retv_vars.10674_0190_003.cdf') + TES(1687)%FILENAME = TRIM('retv_vars.10674_0199_002.cdf') + TES(1688)%FILENAME = TRIM('retv_vars.10674_0199_003.cdf') + TES(1689)%FILENAME = TRIM('retv_vars.10674_0199_004.cdf') + TES(1690)%FILENAME = TRIM('retv_vars.10674_0200_002.cdf') + TES(1691)%FILENAME = TRIM('retv_vars.10674_0200_003.cdf') + TES(1692)%FILENAME = TRIM('retv_vars.10674_0200_004.cdf') + TES(1693)%FILENAME = TRIM('retv_vars.10674_0201_003.cdf') + TES(1694)%FILENAME = TRIM('retv_vars.10674_0202_003.cdf') + TES(1695)%FILENAME = TRIM('retv_vars.10674_0213_002.cdf') + TES(1696)%FILENAME = TRIM('retv_vars.10674_0214_002.cdf') + TES(1697)%FILENAME = TRIM('retv_vars.10674_0219_002.cdf') + TES(1698)%FILENAME = TRIM('retv_vars.10674_0219_003.cdf') + TES(1699)%FILENAME = TRIM('retv_vars.10674_0221_003.cdf') + TES(1700)%FILENAME = TRIM('retv_vars.10674_0221_004.cdf') + TES(1701)%FILENAME = TRIM('retv_vars.10674_0222_002.cdf') + TES(1702)%FILENAME = TRIM('retv_vars.10674_0222_003.cdf') + TES(1703)%FILENAME = TRIM('retv_vars.10674_0225_004.cdf') + TES(1704)%FILENAME = TRIM('retv_vars.10674_0231_003.cdf') + TES(1705)%FILENAME = TRIM('retv_vars.10674_0231_004.cdf') + TES(1706)%FILENAME = TRIM('retv_vars.10674_0232_002.cdf') + TES(1707)%FILENAME = TRIM('retv_vars.10674_0235_003.cdf') + TES(1708)%FILENAME = TRIM('retv_vars.10674_0235_004.cdf') + TES(1709)%FILENAME = TRIM('retv_vars.10674_0243_002.cdf') + TES(1710)%FILENAME = TRIM('retv_vars.10674_0243_003.cdf') + TES(1711)%FILENAME = TRIM('retv_vars.10674_0243_004.cdf') + TES(1712)%FILENAME = TRIM('retv_vars.10674_0244_004.cdf') + TES(1713)%FILENAME = TRIM('retv_vars.10674_0245_002.cdf') + TES(1714)%FILENAME = TRIM('retv_vars.10674_0245_004.cdf') + TES(1715)%FILENAME = TRIM('retv_vars.10674_0248_003.cdf') + TES(1716)%FILENAME = TRIM('retv_vars.10674_0248_004.cdf') + TES(1717)%FILENAME = TRIM('retv_vars.10674_0249_002.cdf') + TES(1718)%FILENAME = TRIM('retv_vars.10674_0249_003.cdf') + TES(1719)%FILENAME = TRIM('retv_vars.10674_0249_004.cdf') + TES(1720)%FILENAME = TRIM('retv_vars.10674_0250_002.cdf') + TES(1721)%FILENAME = TRIM('retv_vars.10674_0250_003.cdf') + TES(1722)%FILENAME = TRIM('retv_vars.10674_0250_004.cdf') + TES(1723)%FILENAME = TRIM('retv_vars.10674_0252_004.cdf') + TES(1724)%FILENAME = TRIM('retv_vars.10674_0253_002.cdf') + TES(1725)%FILENAME = TRIM('retv_vars.10674_0255_002.cdf') + TES(1726)%FILENAME = TRIM('retv_vars.10674_0256_003.cdf') + TES(1727)%FILENAME = TRIM('retv_vars.10674_0257_004.cdf') + TES(1728)%FILENAME = TRIM('retv_vars.10674_0258_003.cdf') + TES(1729)%FILENAME = TRIM('retv_vars.10674_0259_003.cdf') + TES(1730)%FILENAME = TRIM('retv_vars.10674_0260_004.cdf') + TES(1731)%FILENAME = TRIM('retv_vars.10674_0261_002.cdf') + TES(1732)%FILENAME = TRIM('retv_vars.10674_0262_003.cdf') + TES(1733)%FILENAME = TRIM('retv_vars.10674_0267_002.cdf') + TES(1734)%FILENAME = TRIM('retv_vars.10674_0267_003.cdf') + TES(1735)%FILENAME = TRIM('retv_vars.10674_0267_004.cdf') + TES(1736)%FILENAME = TRIM('retv_vars.10674_0268_002.cdf') + TES(1737)%FILENAME = TRIM('retv_vars.10674_0268_003.cdf') + TES(1738)%FILENAME = TRIM('retv_vars.10674_0268_004.cdf') + TES(1739)%FILENAME = TRIM('retv_vars.10674_0269_002.cdf') + TES(1740)%FILENAME = TRIM('retv_vars.10674_0269_003.cdf') + TES(1741)%FILENAME = TRIM('retv_vars.10674_0271_004.cdf') + TES(1742)%FILENAME = TRIM('retv_vars.10674_0272_004.cdf') + TES(1743)%FILENAME = TRIM('retv_vars.10674_0302_004.cdf') + TES(1744)%FILENAME = TRIM('retv_vars.10674_0303_002.cdf') + TES(1745)%FILENAME = TRIM('retv_vars.10674_0303_004.cdf') + TES(1746)%FILENAME = TRIM('retv_vars.10674_0304_002.cdf') + TES(1747)%FILENAME = TRIM('retv_vars.10674_0306_004.cdf') + TES(1748)%FILENAME = TRIM('retv_vars.10674_0307_003.cdf') + TES(1749)%FILENAME = TRIM('retv_vars.10674_0308_002.cdf') + TES(1750)%FILENAME = TRIM('retv_vars.10674_0308_003.cdf') + TES(1751)%FILENAME = TRIM('retv_vars.10674_0308_004.cdf') + TES(1752)%FILENAME = TRIM('retv_vars.10674_0309_002.cdf') + TES(1753)%FILENAME = TRIM('retv_vars.10674_0309_004.cdf') + TES(1754)%FILENAME = TRIM('retv_vars.10674_0310_002.cdf') + TES(1755)%FILENAME = TRIM('retv_vars.10674_0310_003.cdf') + TES(1756)%FILENAME = TRIM('retv_vars.10674_0310_004.cdf') + TES(1757)%FILENAME = TRIM('retv_vars.10674_0311_002.cdf') + TES(1758)%FILENAME = TRIM('retv_vars.10674_0315_002.cdf') + TES(1759)%FILENAME = TRIM('retv_vars.10674_0315_003.cdf') + TES(1760)%FILENAME = TRIM('retv_vars.10674_0315_004.cdf') + TES(1761)%FILENAME = TRIM('retv_vars.10674_0316_002.cdf') + TES(1762)%FILENAME = TRIM('retv_vars.10674_0316_004.cdf') + TES(1763)%FILENAME = TRIM('retv_vars.10674_0317_002.cdf') + TES(1764)%FILENAME = TRIM('retv_vars.10674_0317_003.cdf') + TES(1765)%FILENAME = TRIM('retv_vars.10674_0318_002.cdf') + TES(1766)%FILENAME = TRIM('retv_vars.10674_0318_003.cdf') + TES(1767)%FILENAME = TRIM('retv_vars.10674_0318_004.cdf') + TES(1768)%FILENAME = TRIM('retv_vars.10674_0320_004.cdf') + TES(1769)%FILENAME = TRIM('retv_vars.10674_0321_004.cdf') + TES(1770)%FILENAME = TRIM('retv_vars.10674_0322_002.cdf') + TES(1771)%FILENAME = TRIM('retv_vars.10674_0363_003.cdf') + TES(1772)%FILENAME = TRIM('retv_vars.10674_0363_004.cdf') + TES(1773)%FILENAME = TRIM('retv_vars.10674_0364_003.cdf') + TES(1774)%FILENAME = TRIM('retv_vars.10674_0364_004.cdf') + TES(1775)%FILENAME = TRIM('retv_vars.10674_0365_002.cdf') + TES(1776)%FILENAME = TRIM('retv_vars.10674_0365_003.cdf') + TES(1777)%FILENAME = TRIM('retv_vars.10674_0365_004.cdf') + TES(1778)%FILENAME = TRIM('retv_vars.10674_0366_002.cdf') + TES(1779)%FILENAME = TRIM('retv_vars.10674_0366_003.cdf') + TES(1780)%FILENAME = TRIM('retv_vars.10674_0366_004.cdf') + TES(1781)%FILENAME = TRIM('retv_vars.10674_0367_003.cdf') + TES(1782)%FILENAME = TRIM('retv_vars.10674_0369_003.cdf') + TES(1783)%FILENAME = TRIM('retv_vars.10674_0373_004.cdf') + TES(1784)%FILENAME = TRIM('retv_vars.10674_0374_003.cdf') + TES(1785)%FILENAME = TRIM('retv_vars.10674_0411_002.cdf') + TES(1786)%FILENAME = TRIM('retv_vars.10674_0411_003.cdf') + TES(1787)%FILENAME = TRIM('retv_vars.10674_0412_003.cdf') + TES(1788)%FILENAME = TRIM('retv_vars.10674_0412_004.cdf') + TES(1789)%FILENAME = TRIM('retv_vars.10674_0413_002.cdf') + TES(1790)%FILENAME = TRIM('retv_vars.10674_0413_003.cdf') + TES(1791)%FILENAME = TRIM('retv_vars.10674_0413_004.cdf') + TES(1792)%FILENAME = TRIM('retv_vars.10674_0415_002.cdf') + TES(1793)%FILENAME = TRIM('retv_vars.10674_0417_002.cdf') + TES(1794)%FILENAME = TRIM('retv_vars.10674_0417_003.cdf') + TES(1795)%FILENAME = TRIM('retv_vars.10674_0418_003.cdf') + TES(1796)%FILENAME = TRIM('retv_vars.10674_0420_002.cdf') + TES(1797)%FILENAME = TRIM('retv_vars.10674_0421_002.cdf') + TES(1798)%FILENAME = TRIM('retv_vars.10674_0421_004.cdf') + TES(1799)%FILENAME = TRIM('retv_vars.10674_0422_002.cdf') + TES(1800)%FILENAME = TRIM('retv_vars.10674_0422_004.cdf') + TES(1801)%FILENAME = TRIM('retv_vars.10674_0423_002.cdf') + TES(1802)%FILENAME = TRIM('retv_vars.10674_0423_003.cdf') + TES(1803)%FILENAME = TRIM('retv_vars.10674_0423_004.cdf') + TES(1804)%FILENAME = TRIM('retv_vars.10674_0424_003.cdf') + TES(1805)%FILENAME = TRIM('retv_vars.10674_0425_002.cdf') + TES(1806)%FILENAME = TRIM('retv_vars.10674_0425_003.cdf') + TES(1807)%FILENAME = TRIM('retv_vars.10674_0427_003.cdf') + TES(1808)%FILENAME = TRIM('retv_vars.10674_0427_004.cdf') + TES(1809)%FILENAME = TRIM('retv_vars.10674_0428_002.cdf') + TES(1810)%FILENAME = TRIM('retv_vars.10674_0428_004.cdf') + TES(1811)%FILENAME = TRIM('retv_vars.10674_0459_002.cdf') + TES(1812)%FILENAME = TRIM('retv_vars.10674_0459_003.cdf') + TES(1813)%FILENAME = TRIM('retv_vars.10674_0460_002.cdf') + TES(1814)%FILENAME = TRIM('retv_vars.10674_0460_003.cdf') + TES(1815)%FILENAME = TRIM('retv_vars.10674_0460_004.cdf') + TES(1816)%FILENAME = TRIM('retv_vars.10674_0461_002.cdf') + TES(1817)%FILENAME = TRIM('retv_vars.10674_0463_004.cdf') + TES(1818)%FILENAME = TRIM('retv_vars.10674_0467_003.cdf') + TES(1819)%FILENAME = TRIM('retv_vars.10674_0469_002.cdf') + TES(1820)%FILENAME = TRIM('retv_vars.10674_0469_004.cdf') + TES(1821)%FILENAME = TRIM('retv_vars.10674_0532_002.cdf') + TES(1822)%FILENAME = TRIM('retv_vars.10674_0532_003.cdf') + TES(1823)%FILENAME = TRIM('retv_vars.10674_0532_004.cdf') + TES(1824)%FILENAME = TRIM('retv_vars.10674_0533_003.cdf') + TES(1825)%FILENAME = TRIM('retv_vars.10674_0534_002.cdf') + TES(1826)%FILENAME = TRIM('retv_vars.10674_0534_004.cdf') + TES(1827)%FILENAME = TRIM('retv_vars.10674_0535_002.cdf') + TES(1828)%FILENAME = TRIM('retv_vars.10674_0535_003.cdf') + TES(1829)%FILENAME = TRIM('retv_vars.10674_0535_004.cdf') + TES(1830)%FILENAME = TRIM('retv_vars.10674_0536_002.cdf') + TES(1831)%FILENAME = TRIM('retv_vars.10674_0536_003.cdf') + TES(1832)%FILENAME = TRIM('retv_vars.10674_0536_004.cdf') + TES(1833)%FILENAME = TRIM('retv_vars.10674_0538_002.cdf') + TES(1834)%FILENAME = TRIM('retv_vars.10674_0538_003.cdf') + TES(1835)%FILENAME = TRIM('retv_vars.10674_0547_004.cdf') + TES(1836)%FILENAME = TRIM('retv_vars.10674_0548_002.cdf') + TES(1837)%FILENAME = TRIM('retv_vars.10674_0550_003.cdf') + TES(1838)%FILENAME = TRIM('retv_vars.10674_0551_002.cdf') + TES(1839)%FILENAME = TRIM('retv_vars.10674_0567_003.cdf') + TES(1840)%FILENAME = TRIM('retv_vars.10674_0568_003.cdf') + TES(1841)%FILENAME = TRIM('retv_vars.10674_0569_002.cdf') + TES(1842)%FILENAME = TRIM('retv_vars.10674_0569_003.cdf') + TES(1843)%FILENAME = TRIM('retv_vars.10674_0569_004.cdf') + TES(1844)%FILENAME = TRIM('retv_vars.10674_0570_002.cdf') + TES(1845)%FILENAME = TRIM('retv_vars.10674_0570_003.cdf') + TES(1846)%FILENAME = TRIM('retv_vars.10674_0570_004.cdf') + TES(1847)%FILENAME = TRIM('retv_vars.10674_0571_002.cdf') + TES(1848)%FILENAME = TRIM('retv_vars.10674_0571_003.cdf') + TES(1849)%FILENAME = TRIM('retv_vars.10674_0571_004.cdf') + TES(1850)%FILENAME = TRIM('retv_vars.10674_0573_002.cdf') + TES(1851)%FILENAME = TRIM('retv_vars.10674_0573_003.cdf') + TES(1852)%FILENAME = TRIM('retv_vars.10674_0581_002.cdf') + TES(1853)%FILENAME = TRIM('retv_vars.10674_0585_002.cdf') + TES(1854)%FILENAME = TRIM('retv_vars.10674_0586_003.cdf') + TES(1855)%FILENAME = TRIM('retv_vars.10674_0586_004.cdf') + TES(1856)%FILENAME = TRIM('retv_vars.10674_0587_003.cdf') + TES(1857)%FILENAME = TRIM('retv_vars.10674_0587_004.cdf') + TES(1858)%FILENAME = TRIM('retv_vars.10674_0592_002.cdf') + TES(1859)%FILENAME = TRIM('retv_vars.10674_0592_004.cdf') + TES(1860)%FILENAME = TRIM('retv_vars.10674_0593_003.cdf') + TES(1861)%FILENAME = TRIM('retv_vars.10674_0597_002.cdf') + TES(1862)%FILENAME = TRIM('retv_vars.10674_0597_003.cdf') + TES(1863)%FILENAME = TRIM('retv_vars.10674_0597_004.cdf') + TES(1864)%FILENAME = TRIM('retv_vars.10674_0598_002.cdf') + TES(1865)%FILENAME = TRIM('retv_vars.10674_0598_003.cdf') + TES(1866)%FILENAME = TRIM('retv_vars.10674_0604_003.cdf') + TES(1867)%FILENAME = TRIM('retv_vars.10674_0604_004.cdf') + TES(1868)%FILENAME = TRIM('retv_vars.10674_0605_004.cdf') + TES(1869)%FILENAME = TRIM('retv_vars.10674_0611_002.cdf') + TES(1870)%FILENAME = TRIM('retv_vars.10674_0613_002.cdf') + TES(1871)%FILENAME = TRIM('retv_vars.10674_0613_003.cdf') + TES(1872)%FILENAME = TRIM('retv_vars.10674_0613_004.cdf') + TES(1873)%FILENAME = TRIM('retv_vars.10674_0614_002.cdf') + TES(1874)%FILENAME = TRIM('retv_vars.10674_0614_003.cdf') + TES(1875)%FILENAME = TRIM('retv_vars.10674_0639_002.cdf') + TES(1876)%FILENAME = TRIM('retv_vars.10674_0640_003.cdf') + TES(1877)%FILENAME = TRIM('retv_vars.10674_0643_003.cdf') + TES(1878)%FILENAME = TRIM('retv_vars.10674_0644_003.cdf') + TES(1879)%FILENAME = TRIM('retv_vars.10674_0645_003.cdf') + TES(1880)%FILENAME = TRIM('retv_vars.10674_0645_004.cdf') + TES(1881)%FILENAME = TRIM('retv_vars.10674_0646_003.cdf') + TES(1882)%FILENAME = TRIM('retv_vars.10674_0646_004.cdf') + TES(1883)%FILENAME = TRIM('retv_vars.10674_0647_002.cdf') + TES(1884)%FILENAME = TRIM('retv_vars.10674_0654_002.cdf') + TES(1885)%FILENAME = TRIM('retv_vars.10674_0654_003.cdf') + TES(1886)%FILENAME = TRIM('retv_vars.10674_0654_004.cdf') + TES(1887)%FILENAME = TRIM('retv_vars.10674_0655_002.cdf') + TES(1888)%FILENAME = TRIM('retv_vars.10674_0656_002.cdf') + TES(1889)%FILENAME = TRIM('retv_vars.10674_0656_003.cdf') + TES(1890)%FILENAME = TRIM('retv_vars.10674_0656_004.cdf') + TES(1891)%FILENAME = TRIM('retv_vars.10674_0657_002.cdf') + TES(1892)%FILENAME = TRIM('retv_vars.10674_0659_002.cdf') + TES(1893)%FILENAME = TRIM('retv_vars.10674_0659_003.cdf') + TES(1894)%FILENAME = TRIM('retv_vars.10674_0659_004.cdf') + TES(1895)%FILENAME = TRIM('retv_vars.10674_0690_003.cdf') + TES(1896)%FILENAME = TRIM('retv_vars.10674_0691_004.cdf') + TES(1897)%FILENAME = TRIM('retv_vars.10674_0693_004.cdf') + TES(1898)%FILENAME = TRIM('retv_vars.10674_0694_004.cdf') + TES(1899)%FILENAME = TRIM('retv_vars.10674_0695_002.cdf') + TES(1900)%FILENAME = TRIM('retv_vars.10674_0699_002.cdf') + TES(1901)%FILENAME = TRIM('retv_vars.10674_0699_003.cdf') + TES(1902)%FILENAME = TRIM('retv_vars.10674_0699_004.cdf') + TES(1903)%FILENAME = TRIM('retv_vars.10674_0700_002.cdf') + TES(1904)%FILENAME = TRIM('retv_vars.10674_0700_003.cdf') + TES(1905)%FILENAME = TRIM('retv_vars.10674_0700_004.cdf') + TES(1906)%FILENAME = TRIM('retv_vars.10674_0701_002.cdf') + TES(1907)%FILENAME = TRIM('retv_vars.10674_0701_003.cdf') + TES(1908)%FILENAME = TRIM('retv_vars.10674_0701_004.cdf') + TES(1909)%FILENAME = TRIM('retv_vars.10674_0702_002.cdf') + TES(1910)%FILENAME = TRIM('retv_vars.10674_0702_003.cdf') + TES(1911)%FILENAME = TRIM('retv_vars.10674_0702_004.cdf') + TES(1912)%FILENAME = TRIM('retv_vars.10674_0703_002.cdf') + TES(1913)%FILENAME = TRIM('retv_vars.10674_0703_003.cdf') + TES(1914)%FILENAME = TRIM('retv_vars.10674_0704_003.cdf') + TES(1915)%FILENAME = TRIM('retv_vars.10674_0727_002.cdf') + TES(1916)%FILENAME = TRIM('retv_vars.10674_0731_003.cdf') + TES(1917)%FILENAME = TRIM('retv_vars.10674_0731_004.cdf') + TES(1918)%FILENAME = TRIM('retv_vars.10674_0732_002.cdf') + TES(1919)%FILENAME = TRIM('retv_vars.10674_0734_002.cdf') + TES(1920)%FILENAME = TRIM('retv_vars.10674_0734_003.cdf') + TES(1921)%FILENAME = TRIM('retv_vars.10674_0740_004.cdf') + TES(1922)%FILENAME = TRIM('retv_vars.10674_0741_003.cdf') + TES(1923)%FILENAME = TRIM('retv_vars.10674_0742_002.cdf') + TES(1924)%FILENAME = TRIM('retv_vars.10674_0743_002.cdf') + TES(1925)%FILENAME = TRIM('retv_vars.10674_0743_003.cdf') + TES(1926)%FILENAME = TRIM('retv_vars.10679_0019_002.cdf') + TES(1927)%FILENAME = TRIM('retv_vars.10679_0019_004.cdf') + TES(1928)%FILENAME = TRIM('retv_vars.10679_0021_003.cdf') + TES(1929)%FILENAME = TRIM('retv_vars.10679_0021_004.cdf') + TES(1930)%FILENAME = TRIM('retv_vars.10679_0022_002.cdf') + TES(1931)%FILENAME = TRIM('retv_vars.10679_0022_003.cdf') + TES(1932)%FILENAME = TRIM('retv_vars.10679_0022_004.cdf') + TES(1933)%FILENAME = TRIM('retv_vars.10679_0023_002.cdf') + TES(1934)%FILENAME = TRIM('retv_vars.10679_0027_003.cdf') + TES(1935)%FILENAME = TRIM('retv_vars.10679_0027_004.cdf') + TES(1936)%FILENAME = TRIM('retv_vars.10679_0028_002.cdf') + TES(1937)%FILENAME = TRIM('retv_vars.10679_0028_003.cdf') + TES(1938)%FILENAME = TRIM('retv_vars.10679_0028_004.cdf') + TES(1939)%FILENAME = TRIM('retv_vars.10679_0029_002.cdf') + TES(1940)%FILENAME = TRIM('retv_vars.10679_0054_003.cdf') + TES(1941)%FILENAME = TRIM('retv_vars.10679_0054_004.cdf') + TES(1942)%FILENAME = TRIM('retv_vars.10679_0055_002.cdf') + TES(1943)%FILENAME = TRIM('retv_vars.10679_0056_002.cdf') + TES(1944)%FILENAME = TRIM('retv_vars.10679_0056_003.cdf') + TES(1945)%FILENAME = TRIM('retv_vars.10679_0057_002.cdf') + TES(1946)%FILENAME = TRIM('retv_vars.10679_0058_003.cdf') + TES(1947)%FILENAME = TRIM('retv_vars.10679_0058_004.cdf') + TES(1948)%FILENAME = TRIM('retv_vars.10679_0059_002.cdf') + TES(1949)%FILENAME = TRIM('retv_vars.10679_0060_003.cdf') + TES(1950)%FILENAME = TRIM('retv_vars.10679_0061_002.cdf') + TES(1951)%FILENAME = TRIM('retv_vars.10679_0062_003.cdf') + TES(1952)%FILENAME = TRIM('retv_vars.10679_0066_003.cdf') + TES(1953)%FILENAME = TRIM('retv_vars.10679_0066_004.cdf') + TES(1954)%FILENAME = TRIM('retv_vars.10679_0067_002.cdf') + TES(1955)%FILENAME = TRIM('retv_vars.10679_0067_003.cdf') + TES(1956)%FILENAME = TRIM('retv_vars.10679_0067_004.cdf') + TES(1957)%FILENAME = TRIM('retv_vars.10679_0068_003.cdf') + TES(1958)%FILENAME = TRIM('retv_vars.10679_0069_002.cdf') + TES(1959)%FILENAME = TRIM('retv_vars.10679_0069_004.cdf') + TES(1960)%FILENAME = TRIM('retv_vars.10679_0070_003.cdf') + TES(1961)%FILENAME = TRIM('retv_vars.10679_0070_004.cdf') + TES(1962)%FILENAME = TRIM('retv_vars.10679_0071_002.cdf') + TES(1963)%FILENAME = TRIM('retv_vars.10679_0108_004.cdf') + TES(1964)%FILENAME = TRIM('retv_vars.10679_0109_002.cdf') + TES(1965)%FILENAME = TRIM('retv_vars.10679_0109_004.cdf') + TES(1966)%FILENAME = TRIM('retv_vars.10679_0112_003.cdf') + TES(1967)%FILENAME = TRIM('retv_vars.10679_0115_003.cdf') + TES(1968)%FILENAME = TRIM('retv_vars.10679_0115_004.cdf') + TES(1969)%FILENAME = TRIM('retv_vars.10679_0117_004.cdf') + TES(1970)%FILENAME = TRIM('retv_vars.10679_0118_002.cdf') + TES(1971)%FILENAME = TRIM('retv_vars.10679_0187_004.cdf') + TES(1972)%FILENAME = TRIM('retv_vars.10679_0190_002.cdf') + TES(1973)%FILENAME = TRIM('retv_vars.10679_0190_003.cdf') + TES(1974)%FILENAME = TRIM('retv_vars.10679_0213_003.cdf') + TES(1975)%FILENAME = TRIM('retv_vars.10679_0221_002.cdf') + TES(1976)%FILENAME = TRIM('retv_vars.10679_0221_004.cdf') + TES(1977)%FILENAME = TRIM('retv_vars.10679_0224_003.cdf') + TES(1978)%FILENAME = TRIM('retv_vars.10679_0235_003.cdf') + TES(1979)%FILENAME = TRIM('retv_vars.10679_0236_004.cdf') + TES(1980)%FILENAME = TRIM('retv_vars.10679_0237_002.cdf') + TES(1981)%FILENAME = TRIM('retv_vars.10679_0237_004.cdf') + TES(1982)%FILENAME = TRIM('retv_vars.10679_0238_002.cdf') + TES(1983)%FILENAME = TRIM('retv_vars.10679_0244_004.cdf') + TES(1984)%FILENAME = TRIM('retv_vars.10679_0245_002.cdf') + TES(1985)%FILENAME = TRIM('retv_vars.10679_0246_003.cdf') + TES(1986)%FILENAME = TRIM('retv_vars.10679_0247_002.cdf') + TES(1987)%FILENAME = TRIM('retv_vars.10679_0247_003.cdf') + TES(1988)%FILENAME = TRIM('retv_vars.10679_0247_004.cdf') + TES(1989)%FILENAME = TRIM('retv_vars.10679_0248_003.cdf') + TES(1990)%FILENAME = TRIM('retv_vars.10679_0249_002.cdf') + TES(1991)%FILENAME = TRIM('retv_vars.10679_0249_003.cdf') + TES(1992)%FILENAME = TRIM('retv_vars.10679_0249_004.cdf') + TES(1993)%FILENAME = TRIM('retv_vars.10679_0250_002.cdf') + TES(1994)%FILENAME = TRIM('retv_vars.10679_0250_003.cdf') + TES(1995)%FILENAME = TRIM('retv_vars.10679_0250_004.cdf') + TES(1996)%FILENAME = TRIM('retv_vars.10679_0251_003.cdf') + TES(1997)%FILENAME = TRIM('retv_vars.10679_0252_003.cdf') + TES(1998)%FILENAME = TRIM('retv_vars.10679_0254_004.cdf') + TES(1999)%FILENAME = TRIM('retv_vars.10679_0261_003.cdf') + TES(2000)%FILENAME = TRIM('retv_vars.10679_0261_004.cdf') + TES(2001)%FILENAME = TRIM('retv_vars.10679_0262_002.cdf') + TES(2002)%FILENAME = TRIM('retv_vars.10679_0267_002.cdf') + TES(2003)%FILENAME = TRIM('retv_vars.10679_0267_003.cdf') + TES(2004)%FILENAME = TRIM('retv_vars.10679_0267_004.cdf') + TES(2005)%FILENAME = TRIM('retv_vars.10679_0268_002.cdf') + TES(2006)%FILENAME = TRIM('retv_vars.10679_0268_003.cdf') + TES(2007)%FILENAME = TRIM('retv_vars.10679_0268_004.cdf') + TES(2008)%FILENAME = TRIM('retv_vars.10679_0270_004.cdf') + TES(2009)%FILENAME = TRIM('retv_vars.10679_0273_003.cdf') + TES(2010)%FILENAME = TRIM('retv_vars.10679_0273_004.cdf') + TES(2011)%FILENAME = TRIM('retv_vars.10679_0274_002.cdf') + TES(2012)%FILENAME = TRIM('retv_vars.10679_0274_003.cdf') + TES(2013)%FILENAME = TRIM('retv_vars.10679_0278_004.cdf') + TES(2014)%FILENAME = TRIM('retv_vars.10679_0279_002.cdf') + TES(2015)%FILENAME = TRIM('retv_vars.10679_0279_003.cdf') + TES(2016)%FILENAME = TRIM('retv_vars.10679_0302_003.cdf') + TES(2017)%FILENAME = TRIM('retv_vars.10679_0302_004.cdf') + TES(2018)%FILENAME = TRIM('retv_vars.10679_0303_003.cdf') + TES(2019)%FILENAME = TRIM('retv_vars.10679_0304_004.cdf') + TES(2020)%FILENAME = TRIM('retv_vars.10679_0305_004.cdf') + TES(2021)%FILENAME = TRIM('retv_vars.10679_0306_003.cdf') + TES(2022)%FILENAME = TRIM('retv_vars.10679_0306_004.cdf') + TES(2023)%FILENAME = TRIM('retv_vars.10679_0307_002.cdf') + TES(2024)%FILENAME = TRIM('retv_vars.10679_0308_002.cdf') + TES(2025)%FILENAME = TRIM('retv_vars.10679_0309_002.cdf') + TES(2026)%FILENAME = TRIM('retv_vars.10679_0309_004.cdf') + TES(2027)%FILENAME = TRIM('retv_vars.10679_0310_002.cdf') + TES(2028)%FILENAME = TRIM('retv_vars.10679_0310_003.cdf') + TES(2029)%FILENAME = TRIM('retv_vars.10679_0310_004.cdf') + TES(2030)%FILENAME = TRIM('retv_vars.10679_0311_002.cdf') + TES(2031)%FILENAME = TRIM('retv_vars.10679_0315_002.cdf') + TES(2032)%FILENAME = TRIM('retv_vars.10679_0315_004.cdf') + TES(2033)%FILENAME = TRIM('retv_vars.10679_0316_003.cdf') + TES(2034)%FILENAME = TRIM('retv_vars.10679_0316_004.cdf') + TES(2035)%FILENAME = TRIM('retv_vars.10679_0317_004.cdf') + TES(2036)%FILENAME = TRIM('retv_vars.10679_0318_002.cdf') + TES(2037)%FILENAME = TRIM('retv_vars.10679_0318_003.cdf') + TES(2038)%FILENAME = TRIM('retv_vars.10679_0318_004.cdf') + TES(2039)%FILENAME = TRIM('retv_vars.10679_0319_004.cdf') + TES(2040)%FILENAME = TRIM('retv_vars.10679_0321_003.cdf') + TES(2041)%FILENAME = TRIM('retv_vars.10679_0321_004.cdf') + TES(2042)%FILENAME = TRIM('retv_vars.10679_0322_002.cdf') + TES(2043)%FILENAME = TRIM('retv_vars.10679_0323_002.cdf') + TES(2044)%FILENAME = TRIM('retv_vars.10679_0324_002.cdf') + TES(2045)%FILENAME = TRIM('retv_vars.10679_0358_003.cdf') + TES(2046)%FILENAME = TRIM('retv_vars.10679_0363_003.cdf') + TES(2047)%FILENAME = TRIM('retv_vars.10679_0363_004.cdf') + TES(2048)%FILENAME = TRIM('retv_vars.10679_0364_002.cdf') + TES(2049)%FILENAME = TRIM('retv_vars.10679_0364_003.cdf') + TES(2050)%FILENAME = TRIM('retv_vars.10679_0364_004.cdf') + TES(2051)%FILENAME = TRIM('retv_vars.10679_0365_002.cdf') + TES(2052)%FILENAME = TRIM('retv_vars.10679_0365_003.cdf') + TES(2053)%FILENAME = TRIM('retv_vars.10679_0366_003.cdf') + TES(2054)%FILENAME = TRIM('retv_vars.10679_0367_004.cdf') + TES(2055)%FILENAME = TRIM('retv_vars.10679_0369_004.cdf') + TES(2056)%FILENAME = TRIM('retv_vars.10679_0370_003.cdf') + TES(2057)%FILENAME = TRIM('retv_vars.10679_0370_004.cdf') + TES(2058)%FILENAME = TRIM('retv_vars.10679_0378_004.cdf') + TES(2059)%FILENAME = TRIM('retv_vars.10679_0379_002.cdf') + TES(2060)%FILENAME = TRIM('retv_vars.10679_0379_003.cdf') + TES(2061)%FILENAME = TRIM('retv_vars.10679_0379_004.cdf') + TES(2062)%FILENAME = TRIM('retv_vars.10679_0380_002.cdf') + TES(2063)%FILENAME = TRIM('retv_vars.10679_0380_003.cdf') + TES(2064)%FILENAME = TRIM('retv_vars.10679_0406_003.cdf') + TES(2065)%FILENAME = TRIM('retv_vars.10679_0411_002.cdf') + TES(2066)%FILENAME = TRIM('retv_vars.10679_0411_003.cdf') + TES(2067)%FILENAME = TRIM('retv_vars.10679_0412_002.cdf') + TES(2068)%FILENAME = TRIM('retv_vars.10679_0412_003.cdf') + TES(2069)%FILENAME = TRIM('retv_vars.10679_0415_002.cdf') + TES(2070)%FILENAME = TRIM('retv_vars.10679_0415_003.cdf') + TES(2071)%FILENAME = TRIM('retv_vars.10679_0416_004.cdf') + TES(2072)%FILENAME = TRIM('retv_vars.10679_0417_004.cdf') + TES(2073)%FILENAME = TRIM('retv_vars.10679_0418_003.cdf') + TES(2074)%FILENAME = TRIM('retv_vars.10679_0418_004.cdf') + TES(2075)%FILENAME = TRIM('retv_vars.10679_0419_002.cdf') + TES(2076)%FILENAME = TRIM('retv_vars.10679_0419_003.cdf') + TES(2077)%FILENAME = TRIM('retv_vars.10679_0419_004.cdf') + TES(2078)%FILENAME = TRIM('retv_vars.10679_0422_002.cdf') + TES(2079)%FILENAME = TRIM('retv_vars.10679_0422_003.cdf') + TES(2080)%FILENAME = TRIM('retv_vars.10679_0423_002.cdf') + TES(2081)%FILENAME = TRIM('retv_vars.10679_0423_003.cdf') + TES(2082)%FILENAME = TRIM('retv_vars.10679_0423_004.cdf') + TES(2083)%FILENAME = TRIM('retv_vars.10679_0424_002.cdf') + TES(2084)%FILENAME = TRIM('retv_vars.10679_0424_004.cdf') + TES(2085)%FILENAME = TRIM('retv_vars.10679_0425_004.cdf') + TES(2086)%FILENAME = TRIM('retv_vars.10679_0427_002.cdf') + TES(2087)%FILENAME = TRIM('retv_vars.10679_0428_004.cdf') + TES(2088)%FILENAME = TRIM('retv_vars.10679_0459_002.cdf') + TES(2089)%FILENAME = TRIM('retv_vars.10679_0461_002.cdf') + TES(2090)%FILENAME = TRIM('retv_vars.10679_0462_003.cdf') + TES(2091)%FILENAME = TRIM('retv_vars.10679_0463_004.cdf') + TES(2092)%FILENAME = TRIM('retv_vars.10679_0464_003.cdf') + TES(2093)%FILENAME = TRIM('retv_vars.10679_0467_003.cdf') + TES(2094)%FILENAME = TRIM('retv_vars.10679_0468_004.cdf') + TES(2095)%FILENAME = TRIM('retv_vars.10679_0493_003.cdf') + TES(2096)%FILENAME = TRIM('retv_vars.10679_0532_003.cdf') + TES(2097)%FILENAME = TRIM('retv_vars.10679_0532_004.cdf') + TES(2098)%FILENAME = TRIM('retv_vars.10679_0533_002.cdf') + TES(2099)%FILENAME = TRIM('retv_vars.10679_0533_003.cdf') + TES(2100)%FILENAME = TRIM('retv_vars.10679_0534_004.cdf') + TES(2101)%FILENAME = TRIM('retv_vars.10679_0548_004.cdf') + TES(2102)%FILENAME = TRIM('retv_vars.10679_0549_002.cdf') + TES(2103)%FILENAME = TRIM('retv_vars.10679_0567_003.cdf') + TES(2104)%FILENAME = TRIM('retv_vars.10679_0568_004.cdf') + TES(2105)%FILENAME = TRIM('retv_vars.10679_0569_002.cdf') + TES(2106)%FILENAME = TRIM('retv_vars.10679_0569_003.cdf') + TES(2107)%FILENAME = TRIM('retv_vars.10679_0569_004.cdf') + TES(2108)%FILENAME = TRIM('retv_vars.10679_0570_002.cdf') + TES(2109)%FILENAME = TRIM('retv_vars.10679_0571_002.cdf') + TES(2110)%FILENAME = TRIM('retv_vars.10679_0571_004.cdf') + TES(2111)%FILENAME = TRIM('retv_vars.10679_0572_002.cdf') + TES(2112)%FILENAME = TRIM('retv_vars.10679_0572_004.cdf') + TES(2113)%FILENAME = TRIM('retv_vars.10679_0573_002.cdf') + TES(2114)%FILENAME = TRIM('retv_vars.10679_0573_004.cdf') + TES(2115)%FILENAME = TRIM('retv_vars.10679_0580_003.cdf') + TES(2116)%FILENAME = TRIM('retv_vars.10679_0580_004.cdf') + TES(2117)%FILENAME = TRIM('retv_vars.10679_0583_003.cdf') + TES(2118)%FILENAME = TRIM('retv_vars.10679_0585_004.cdf') + TES(2119)%FILENAME = TRIM('retv_vars.10679_0586_003.cdf') + TES(2120)%FILENAME = TRIM('retv_vars.10679_0587_002.cdf') + TES(2121)%FILENAME = TRIM('retv_vars.10679_0587_004.cdf') + TES(2122)%FILENAME = TRIM('retv_vars.10679_0588_002.cdf') + TES(2123)%FILENAME = TRIM('retv_vars.10679_0591_004.cdf') + TES(2124)%FILENAME = TRIM('retv_vars.10679_0592_003.cdf') + TES(2125)%FILENAME = TRIM('retv_vars.10679_0594_002.cdf') + TES(2126)%FILENAME = TRIM('retv_vars.10679_0594_003.cdf') + TES(2127)%FILENAME = TRIM('retv_vars.10679_0596_003.cdf') + TES(2128)%FILENAME = TRIM('retv_vars.10679_0596_004.cdf') + TES(2129)%FILENAME = TRIM('retv_vars.10679_0614_002.cdf') + TES(2130)%FILENAME = TRIM('retv_vars.10679_0615_002.cdf') + TES(2131)%FILENAME = TRIM('retv_vars.10679_0615_003.cdf') + TES(2132)%FILENAME = TRIM('retv_vars.10679_0616_002.cdf') + TES(2133)%FILENAME = TRIM('retv_vars.10679_0616_003.cdf') + TES(2134)%FILENAME = TRIM('retv_vars.10679_0617_002.cdf') + TES(2135)%FILENAME = TRIM('retv_vars.10679_0617_003.cdf') + TES(2136)%FILENAME = TRIM('retv_vars.10679_0639_003.cdf') + TES(2137)%FILENAME = TRIM('retv_vars.10679_0639_004.cdf') + TES(2138)%FILENAME = TRIM('retv_vars.10679_0640_002.cdf') + TES(2139)%FILENAME = TRIM('retv_vars.10679_0643_004.cdf') + TES(2140)%FILENAME = TRIM('retv_vars.10679_0644_003.cdf') + TES(2141)%FILENAME = TRIM('retv_vars.10679_0644_004.cdf') + TES(2142)%FILENAME = TRIM('retv_vars.10679_0645_002.cdf') + TES(2143)%FILENAME = TRIM('retv_vars.10679_0645_003.cdf') + TES(2144)%FILENAME = TRIM('retv_vars.10679_0646_002.cdf') + TES(2145)%FILENAME = TRIM('retv_vars.10679_0646_004.cdf') + TES(2146)%FILENAME = TRIM('retv_vars.10679_0647_002.cdf') + TES(2147)%FILENAME = TRIM('retv_vars.10679_0651_002.cdf') + TES(2148)%FILENAME = TRIM('retv_vars.10679_0652_002.cdf') + TES(2149)%FILENAME = TRIM('retv_vars.10679_0652_003.cdf') + TES(2150)%FILENAME = TRIM('retv_vars.10679_0654_003.cdf') + TES(2151)%FILENAME = TRIM('retv_vars.10679_0655_004.cdf') + TES(2152)%FILENAME = TRIM('retv_vars.10679_0656_003.cdf') + TES(2153)%FILENAME = TRIM('retv_vars.10679_0689_003.cdf') + TES(2154)%FILENAME = TRIM('retv_vars.10679_0691_004.cdf') + TES(2155)%FILENAME = TRIM('retv_vars.10679_0692_002.cdf') + TES(2156)%FILENAME = TRIM('retv_vars.10679_0692_004.cdf') + TES(2157)%FILENAME = TRIM('retv_vars.10679_0693_004.cdf') + TES(2158)%FILENAME = TRIM('retv_vars.10679_0694_002.cdf') + TES(2159)%FILENAME = TRIM('retv_vars.10679_0694_003.cdf') + TES(2160)%FILENAME = TRIM('retv_vars.10679_0694_004.cdf') + TES(2161)%FILENAME = TRIM('retv_vars.10679_0695_002.cdf') + TES(2162)%FILENAME = TRIM('retv_vars.10679_0699_002.cdf') + TES(2163)%FILENAME = TRIM('retv_vars.10679_0699_003.cdf') + TES(2164)%FILENAME = TRIM('retv_vars.10679_0699_004.cdf') + TES(2165)%FILENAME = TRIM('retv_vars.10679_0700_002.cdf') + TES(2166)%FILENAME = TRIM('retv_vars.10679_0700_003.cdf') + TES(2167)%FILENAME = TRIM('retv_vars.10679_0701_003.cdf') + TES(2168)%FILENAME = TRIM('retv_vars.10679_0701_004.cdf') + TES(2169)%FILENAME = TRIM('retv_vars.10679_0702_002.cdf') + TES(2170)%FILENAME = TRIM('retv_vars.10679_0702_003.cdf') + TES(2171)%FILENAME = TRIM('retv_vars.10679_0703_003.cdf') + TES(2172)%FILENAME = TRIM('retv_vars.10679_0703_004.cdf') + TES(2173)%FILENAME = TRIM('retv_vars.10679_0727_003.cdf') + TES(2174)%FILENAME = TRIM('retv_vars.10679_0728_002.cdf') + TES(2175)%FILENAME = TRIM('retv_vars.10679_0731_004.cdf') + TES(2176)%FILENAME = TRIM('retv_vars.10679_0732_004.cdf') + TES(2177)%FILENAME = TRIM('retv_vars.10679_0738_003.cdf') + TES(2178)%FILENAME = TRIM('retv_vars.10679_0738_004.cdf') + TES(2179)%FILENAME = TRIM('retv_vars.10679_0739_002.cdf') + TES(2180)%FILENAME = TRIM('retv_vars.10679_0740_004.cdf') + TES(2181)%FILENAME = TRIM('retv_vars.10679_0741_002.cdf') + TES(2182)%FILENAME = TRIM('retv_vars.10679_0741_003.cdf') + TES(2183)%FILENAME = TRIM('retv_vars.10679_0742_002.cdf') + TES(2184)%FILENAME = TRIM('retv_vars.10679_0742_003.cdf') + TES(2185)%FILENAME = TRIM('retv_vars.10679_0742_004.cdf') + TES(2186)%FILENAME = TRIM('retv_vars.10679_0743_002.cdf') + TES(2187)%FILENAME = TRIM('retv_vars.10679_0747_004.cdf') + TES(2188)%FILENAME = TRIM('retv_vars.10679_0762_004.cdf') + TES(2189)%FILENAME = TRIM('retv_vars.10684_0018_003.cdf') + TES(2190)%FILENAME = TRIM('retv_vars.10684_0019_003.cdf') + TES(2191)%FILENAME = TRIM('retv_vars.10684_0021_002.cdf') + TES(2192)%FILENAME = TRIM('retv_vars.10684_0021_003.cdf') + TES(2193)%FILENAME = TRIM('retv_vars.10684_0021_004.cdf') + TES(2194)%FILENAME = TRIM('retv_vars.10684_0022_002.cdf') + TES(2195)%FILENAME = TRIM('retv_vars.10684_0022_003.cdf') + TES(2196)%FILENAME = TRIM('retv_vars.10684_0022_004.cdf') + TES(2197)%FILENAME = TRIM('retv_vars.10684_0023_002.cdf') + TES(2198)%FILENAME = TRIM('retv_vars.10684_0027_002.cdf') + TES(2199)%FILENAME = TRIM('retv_vars.10684_0027_003.cdf') + TES(2200)%FILENAME = TRIM('retv_vars.10684_0028_003.cdf') + TES(2201)%FILENAME = TRIM('retv_vars.10684_0028_004.cdf') + TES(2202)%FILENAME = TRIM('retv_vars.10684_0029_002.cdf') + TES(2203)%FILENAME = TRIM('retv_vars.10684_0029_004.cdf') + TES(2204)%FILENAME = TRIM('retv_vars.10684_0030_004.cdf') + TES(2205)%FILENAME = TRIM('retv_vars.10684_0055_004.cdf') + TES(2206)%FILENAME = TRIM('retv_vars.10684_0056_002.cdf') + TES(2207)%FILENAME = TRIM('retv_vars.10684_0057_003.cdf') + TES(2208)%FILENAME = TRIM('retv_vars.10684_0057_004.cdf') + TES(2209)%FILENAME = TRIM('retv_vars.10684_0058_002.cdf') + TES(2210)%FILENAME = TRIM('retv_vars.10684_0058_003.cdf') + TES(2211)%FILENAME = TRIM('retv_vars.10684_0058_004.cdf') + TES(2212)%FILENAME = TRIM('retv_vars.10684_0059_002.cdf') + TES(2213)%FILENAME = TRIM('retv_vars.10684_0059_004.cdf') + TES(2214)%FILENAME = TRIM('retv_vars.10684_0060_002.cdf') + TES(2215)%FILENAME = TRIM('retv_vars.10684_0061_003.cdf') + TES(2216)%FILENAME = TRIM('retv_vars.10684_0062_002.cdf') + TES(2217)%FILENAME = TRIM('retv_vars.10684_0063_004.cdf') + TES(2218)%FILENAME = TRIM('retv_vars.10684_0064_002.cdf') + TES(2219)%FILENAME = TRIM('retv_vars.10684_0067_002.cdf') + TES(2220)%FILENAME = TRIM('retv_vars.10684_0067_003.cdf') + TES(2221)%FILENAME = TRIM('retv_vars.10684_0068_002.cdf') + TES(2222)%FILENAME = TRIM('retv_vars.10684_0068_003.cdf') + TES(2223)%FILENAME = TRIM('retv_vars.10684_0106_004.cdf') + TES(2224)%FILENAME = TRIM('retv_vars.10684_0108_004.cdf') + TES(2225)%FILENAME = TRIM('retv_vars.10684_0115_004.cdf') + TES(2226)%FILENAME = TRIM('retv_vars.10684_0188_003.cdf') + TES(2227)%FILENAME = TRIM('retv_vars.10684_0188_004.cdf') + TES(2228)%FILENAME = TRIM('retv_vars.10684_0200_004.cdf') + TES(2229)%FILENAME = TRIM('retv_vars.10684_0202_002.cdf') + TES(2230)%FILENAME = TRIM('retv_vars.10684_0221_002.cdf') + TES(2231)%FILENAME = TRIM('retv_vars.10684_0231_002.cdf') + TES(2232)%FILENAME = TRIM('retv_vars.10684_0234_003.cdf') + TES(2233)%FILENAME = TRIM('retv_vars.10684_0236_004.cdf') + TES(2234)%FILENAME = TRIM('retv_vars.10684_0237_002.cdf') + TES(2235)%FILENAME = TRIM('retv_vars.10684_0237_003.cdf') + TES(2236)%FILENAME = TRIM('retv_vars.10684_0237_004.cdf') + TES(2237)%FILENAME = TRIM('retv_vars.10684_0244_004.cdf') + TES(2238)%FILENAME = TRIM('retv_vars.10684_0245_002.cdf') + TES(2239)%FILENAME = TRIM('retv_vars.10684_0246_003.cdf') + TES(2240)%FILENAME = TRIM('retv_vars.10684_0247_002.cdf') + TES(2241)%FILENAME = TRIM('retv_vars.10684_0247_003.cdf') + TES(2242)%FILENAME = TRIM('retv_vars.10684_0247_004.cdf') + TES(2243)%FILENAME = TRIM('retv_vars.10684_0248_002.cdf') + TES(2244)%FILENAME = TRIM('retv_vars.10684_0248_003.cdf') + TES(2245)%FILENAME = TRIM('retv_vars.10684_0248_004.cdf') + TES(2246)%FILENAME = TRIM('retv_vars.10684_0249_002.cdf') + TES(2247)%FILENAME = TRIM('retv_vars.10684_0249_003.cdf') + TES(2248)%FILENAME = TRIM('retv_vars.10684_0249_004.cdf') + TES(2249)%FILENAME = TRIM('retv_vars.10684_0250_002.cdf') + TES(2250)%FILENAME = TRIM('retv_vars.10684_0250_003.cdf') + TES(2251)%FILENAME = TRIM('retv_vars.10684_0250_004.cdf') + TES(2252)%FILENAME = TRIM('retv_vars.10684_0251_002.cdf') + TES(2253)%FILENAME = TRIM('retv_vars.10684_0252_003.cdf') + TES(2254)%FILENAME = TRIM('retv_vars.10684_0259_002.cdf') + TES(2255)%FILENAME = TRIM('retv_vars.10684_0259_003.cdf') + TES(2256)%FILENAME = TRIM('retv_vars.10684_0259_004.cdf') + TES(2257)%FILENAME = TRIM('retv_vars.10684_0260_002.cdf') + TES(2258)%FILENAME = TRIM('retv_vars.10684_0260_003.cdf') + TES(2259)%FILENAME = TRIM('retv_vars.10684_0260_004.cdf') + TES(2260)%FILENAME = TRIM('retv_vars.10684_0261_003.cdf') + TES(2261)%FILENAME = TRIM('retv_vars.10684_0267_002.cdf') + TES(2262)%FILENAME = TRIM('retv_vars.10684_0267_004.cdf') + TES(2263)%FILENAME = TRIM('retv_vars.10684_0268_002.cdf') + TES(2264)%FILENAME = TRIM('retv_vars.10684_0269_002.cdf') + TES(2265)%FILENAME = TRIM('retv_vars.10684_0269_003.cdf') + TES(2266)%FILENAME = TRIM('retv_vars.10684_0271_002.cdf') + TES(2267)%FILENAME = TRIM('retv_vars.10684_0272_003.cdf') + TES(2268)%FILENAME = TRIM('retv_vars.10684_0272_004.cdf') + TES(2269)%FILENAME = TRIM('retv_vars.10684_0273_002.cdf') + TES(2270)%FILENAME = TRIM('retv_vars.10684_0273_003.cdf') + TES(2271)%FILENAME = TRIM('retv_vars.10684_0276_003.cdf') + TES(2272)%FILENAME = TRIM('retv_vars.10684_0276_004.cdf') + TES(2273)%FILENAME = TRIM('retv_vars.10684_0277_002.cdf') + TES(2274)%FILENAME = TRIM('retv_vars.10684_0278_004.cdf') + TES(2275)%FILENAME = TRIM('retv_vars.10684_0279_003.cdf') + TES(2276)%FILENAME = TRIM('retv_vars.10684_0279_004.cdf') + TES(2277)%FILENAME = TRIM('retv_vars.10684_0305_004.cdf') + TES(2278)%FILENAME = TRIM('retv_vars.10684_0306_004.cdf') + TES(2279)%FILENAME = TRIM('retv_vars.10684_0308_003.cdf') + TES(2280)%FILENAME = TRIM('retv_vars.10684_0309_004.cdf') + TES(2281)%FILENAME = TRIM('retv_vars.10684_0310_002.cdf') + TES(2282)%FILENAME = TRIM('retv_vars.10684_0310_003.cdf') + TES(2283)%FILENAME = TRIM('retv_vars.10684_0315_003.cdf') + TES(2284)%FILENAME = TRIM('retv_vars.10684_0315_004.cdf') + TES(2285)%FILENAME = TRIM('retv_vars.10684_0316_002.cdf') + TES(2286)%FILENAME = TRIM('retv_vars.10684_0316_003.cdf') + TES(2287)%FILENAME = TRIM('retv_vars.10684_0316_004.cdf') + TES(2288)%FILENAME = TRIM('retv_vars.10684_0317_004.cdf') + TES(2289)%FILENAME = TRIM('retv_vars.10684_0320_002.cdf') + TES(2290)%FILENAME = TRIM('retv_vars.10684_0358_002.cdf') + TES(2291)%FILENAME = TRIM('retv_vars.10684_0363_004.cdf') + TES(2292)%FILENAME = TRIM('retv_vars.10684_0364_002.cdf') + TES(2293)%FILENAME = TRIM('retv_vars.10684_0364_003.cdf') + TES(2294)%FILENAME = TRIM('retv_vars.10684_0365_002.cdf') + TES(2295)%FILENAME = TRIM('retv_vars.10684_0365_004.cdf') + TES(2296)%FILENAME = TRIM('retv_vars.10684_0366_002.cdf') + TES(2297)%FILENAME = TRIM('retv_vars.10684_0367_004.cdf') + TES(2298)%FILENAME = TRIM('retv_vars.10684_0371_003.cdf') + TES(2299)%FILENAME = TRIM('retv_vars.10684_0378_004.cdf') + TES(2300)%FILENAME = TRIM('retv_vars.10684_0411_002.cdf') + TES(2301)%FILENAME = TRIM('retv_vars.10684_0411_003.cdf') + TES(2302)%FILENAME = TRIM('retv_vars.10684_0412_003.cdf') + TES(2303)%FILENAME = TRIM('retv_vars.10684_0413_002.cdf') + TES(2304)%FILENAME = TRIM('retv_vars.10684_0413_004.cdf') + TES(2305)%FILENAME = TRIM('retv_vars.10684_0414_002.cdf') + TES(2306)%FILENAME = TRIM('retv_vars.10684_0414_004.cdf') + TES(2307)%FILENAME = TRIM('retv_vars.10684_0415_002.cdf') + TES(2308)%FILENAME = TRIM('retv_vars.10684_0415_003.cdf') + TES(2309)%FILENAME = TRIM('retv_vars.10684_0415_004.cdf') + TES(2310)%FILENAME = TRIM('retv_vars.10684_0416_003.cdf') + TES(2311)%FILENAME = TRIM('retv_vars.10684_0419_004.cdf') + TES(2312)%FILENAME = TRIM('retv_vars.10684_0421_002.cdf') + TES(2313)%FILENAME = TRIM('retv_vars.10684_0421_003.cdf') + TES(2314)%FILENAME = TRIM('retv_vars.10684_0422_002.cdf') + TES(2315)%FILENAME = TRIM('retv_vars.10684_0422_003.cdf') + TES(2316)%FILENAME = TRIM('retv_vars.10684_0423_003.cdf') + TES(2317)%FILENAME = TRIM('retv_vars.10684_0423_004.cdf') + TES(2318)%FILENAME = TRIM('retv_vars.10684_0424_003.cdf') + TES(2319)%FILENAME = TRIM('retv_vars.10684_0424_004.cdf') + TES(2320)%FILENAME = TRIM('retv_vars.10684_0425_002.cdf') + TES(2321)%FILENAME = TRIM('retv_vars.10684_0425_003.cdf') + TES(2322)%FILENAME = TRIM('retv_vars.10684_0425_004.cdf') + TES(2323)%FILENAME = TRIM('retv_vars.10684_0426_002.cdf') + TES(2324)%FILENAME = TRIM('retv_vars.10684_0429_004.cdf') + TES(2325)%FILENAME = TRIM('retv_vars.10684_0460_004.cdf') + TES(2326)%FILENAME = TRIM('retv_vars.10684_0461_002.cdf') + TES(2327)%FILENAME = TRIM('retv_vars.10684_0461_003.cdf') + TES(2328)%FILENAME = TRIM('retv_vars.10684_0461_004.cdf') + TES(2329)%FILENAME = TRIM('retv_vars.10684_0462_002.cdf') + TES(2330)%FILENAME = TRIM('retv_vars.10684_0464_003.cdf') + TES(2331)%FILENAME = TRIM('retv_vars.10684_0465_003.cdf') + TES(2332)%FILENAME = TRIM('retv_vars.10684_0469_002.cdf') + TES(2333)%FILENAME = TRIM('retv_vars.10684_0501_004.cdf') + TES(2334)%FILENAME = TRIM('retv_vars.10684_0502_002.cdf') + TES(2335)%FILENAME = TRIM('retv_vars.10684_0507_003.cdf') + TES(2336)%FILENAME = TRIM('retv_vars.10684_0515_002.cdf') + TES(2337)%FILENAME = TRIM('retv_vars.10684_0533_003.cdf') + TES(2338)%FILENAME = TRIM('retv_vars.10684_0533_004.cdf') + TES(2339)%FILENAME = TRIM('retv_vars.10684_0534_002.cdf') + TES(2340)%FILENAME = TRIM('retv_vars.10684_0546_003.cdf') + TES(2341)%FILENAME = TRIM('retv_vars.10684_0548_002.cdf') + TES(2342)%FILENAME = TRIM('retv_vars.10684_0548_003.cdf') + TES(2343)%FILENAME = TRIM('retv_vars.10684_0548_004.cdf') + TES(2344)%FILENAME = TRIM('retv_vars.10684_0549_002.cdf') + TES(2345)%FILENAME = TRIM('retv_vars.10684_0551_002.cdf') + TES(2346)%FILENAME = TRIM('retv_vars.10684_0567_004.cdf') + TES(2347)%FILENAME = TRIM('retv_vars.10684_0568_004.cdf') + TES(2348)%FILENAME = TRIM('retv_vars.10684_0569_003.cdf') + TES(2349)%FILENAME = TRIM('retv_vars.10684_0569_004.cdf') + TES(2350)%FILENAME = TRIM('retv_vars.10684_0570_002.cdf') + TES(2351)%FILENAME = TRIM('retv_vars.10684_0570_003.cdf') + TES(2352)%FILENAME = TRIM('retv_vars.10684_0570_004.cdf') + TES(2353)%FILENAME = TRIM('retv_vars.10684_0571_002.cdf') + TES(2354)%FILENAME = TRIM('retv_vars.10684_0571_003.cdf') + TES(2355)%FILENAME = TRIM('retv_vars.10684_0571_004.cdf') + TES(2356)%FILENAME = TRIM('retv_vars.10684_0572_003.cdf') + TES(2357)%FILENAME = TRIM('retv_vars.10684_0573_002.cdf') + TES(2358)%FILENAME = TRIM('retv_vars.10684_0573_004.cdf') + TES(2359)%FILENAME = TRIM('retv_vars.10684_0580_004.cdf') + TES(2360)%FILENAME = TRIM('retv_vars.10684_0586_002.cdf') + TES(2361)%FILENAME = TRIM('retv_vars.10684_0591_004.cdf') + TES(2362)%FILENAME = TRIM('retv_vars.10684_0592_004.cdf') + TES(2363)%FILENAME = TRIM('retv_vars.10684_0593_003.cdf') + TES(2364)%FILENAME = TRIM('retv_vars.10684_0593_004.cdf') + TES(2365)%FILENAME = TRIM('retv_vars.10684_0594_003.cdf') + TES(2366)%FILENAME = TRIM('retv_vars.10684_0594_004.cdf') + TES(2367)%FILENAME = TRIM('retv_vars.10684_0595_002.cdf') + TES(2368)%FILENAME = TRIM('retv_vars.10684_0595_004.cdf') + TES(2369)%FILENAME = TRIM('retv_vars.10684_0596_003.cdf') + TES(2370)%FILENAME = TRIM('retv_vars.10684_0597_004.cdf') + TES(2371)%FILENAME = TRIM('retv_vars.10684_0598_002.cdf') + TES(2372)%FILENAME = TRIM('retv_vars.10684_0599_002.cdf') + TES(2373)%FILENAME = TRIM('retv_vars.10684_0604_003.cdf') + TES(2374)%FILENAME = TRIM('retv_vars.10684_0604_004.cdf') + TES(2375)%FILENAME = TRIM('retv_vars.10684_0611_003.cdf') + TES(2376)%FILENAME = TRIM('retv_vars.10684_0613_002.cdf') + TES(2377)%FILENAME = TRIM('retv_vars.10684_0613_003.cdf') + TES(2378)%FILENAME = TRIM('retv_vars.10684_0613_004.cdf') + TES(2379)%FILENAME = TRIM('retv_vars.10684_0614_003.cdf') + TES(2380)%FILENAME = TRIM('retv_vars.10684_0614_004.cdf') + TES(2381)%FILENAME = TRIM('retv_vars.10684_0615_003.cdf') + TES(2382)%FILENAME = TRIM('retv_vars.10684_0616_002.cdf') + TES(2383)%FILENAME = TRIM('retv_vars.10684_0616_003.cdf') + TES(2384)%FILENAME = TRIM('retv_vars.10684_0616_004.cdf') + TES(2385)%FILENAME = TRIM('retv_vars.10684_0617_002.cdf') + TES(2386)%FILENAME = TRIM('retv_vars.10684_0617_003.cdf') + TES(2387)%FILENAME = TRIM('retv_vars.10684_0639_003.cdf') + TES(2388)%FILENAME = TRIM('retv_vars.10684_0639_004.cdf') + TES(2389)%FILENAME = TRIM('retv_vars.10684_0640_002.cdf') + TES(2390)%FILENAME = TRIM('retv_vars.10684_0642_004.cdf') + TES(2391)%FILENAME = TRIM('retv_vars.10684_0643_004.cdf') + TES(2392)%FILENAME = TRIM('retv_vars.10684_0644_004.cdf') + TES(2393)%FILENAME = TRIM('retv_vars.10684_0645_002.cdf') + TES(2394)%FILENAME = TRIM('retv_vars.10684_0645_003.cdf') + TES(2395)%FILENAME = TRIM('retv_vars.10684_0645_004.cdf') + TES(2396)%FILENAME = TRIM('retv_vars.10684_0646_003.cdf') + TES(2397)%FILENAME = TRIM('retv_vars.10684_0646_004.cdf') + TES(2398)%FILENAME = TRIM('retv_vars.10684_0647_002.cdf') + TES(2399)%FILENAME = TRIM('retv_vars.10684_0651_004.cdf') + TES(2400)%FILENAME = TRIM('retv_vars.10684_0652_003.cdf') + TES(2401)%FILENAME = TRIM('retv_vars.10684_0652_004.cdf') + TES(2402)%FILENAME = TRIM('retv_vars.10684_0653_003.cdf') + TES(2403)%FILENAME = TRIM('retv_vars.10684_0654_002.cdf') + TES(2404)%FILENAME = TRIM('retv_vars.10684_0654_004.cdf') + TES(2405)%FILENAME = TRIM('retv_vars.10684_0655_002.cdf') + TES(2406)%FILENAME = TRIM('retv_vars.10684_0655_004.cdf') + TES(2407)%FILENAME = TRIM('retv_vars.10684_0656_002.cdf') + TES(2408)%FILENAME = TRIM('retv_vars.10684_0656_003.cdf') + TES(2409)%FILENAME = TRIM('retv_vars.10684_0656_004.cdf') + TES(2410)%FILENAME = TRIM('retv_vars.10684_0659_003.cdf') + TES(2411)%FILENAME = TRIM('retv_vars.10684_0659_004.cdf') + TES(2412)%FILENAME = TRIM('retv_vars.10684_0660_002.cdf') + TES(2413)%FILENAME = TRIM('retv_vars.10684_0693_004.cdf') + TES(2414)%FILENAME = TRIM('retv_vars.10684_0694_002.cdf') + TES(2415)%FILENAME = TRIM('retv_vars.10684_0699_003.cdf') + TES(2416)%FILENAME = TRIM('retv_vars.10684_0700_002.cdf') + TES(2417)%FILENAME = TRIM('retv_vars.10684_0700_003.cdf') + TES(2418)%FILENAME = TRIM('retv_vars.10684_0700_004.cdf') + TES(2419)%FILENAME = TRIM('retv_vars.10684_0701_002.cdf') + TES(2420)%FILENAME = TRIM('retv_vars.10684_0701_004.cdf') + TES(2421)%FILENAME = TRIM('retv_vars.10684_0702_003.cdf') + TES(2422)%FILENAME = TRIM('retv_vars.10684_0703_002.cdf') + TES(2423)%FILENAME = TRIM('retv_vars.10684_0703_004.cdf') + TES(2424)%FILENAME = TRIM('retv_vars.10684_0704_002.cdf') + TES(2425)%FILENAME = TRIM('retv_vars.10684_0704_003.cdf') + TES(2426)%FILENAME = TRIM('retv_vars.10684_0705_003.cdf') + TES(2427)%FILENAME = TRIM('retv_vars.10684_0732_002.cdf') + TES(2428)%FILENAME = TRIM('retv_vars.10684_0739_002.cdf') + TES(2429)%FILENAME = TRIM('retv_vars.10684_0742_003.cdf') + TES(2430)%FILENAME = TRIM('retv_vars.10684_0747_003.cdf') + TES(2431)%FILENAME = TRIM('retv_vars.10684_0747_004.cdf') + TES(2432)%FILENAME = TRIM('retv_vars.10686_0021_003.cdf') + TES(2433)%FILENAME = TRIM('retv_vars.10686_0027_002.cdf') + TES(2434)%FILENAME = TRIM('retv_vars.10686_0027_003.cdf') + TES(2435)%FILENAME = TRIM('retv_vars.10686_0027_004.cdf') + TES(2436)%FILENAME = TRIM('retv_vars.10686_0028_004.cdf') + TES(2437)%FILENAME = TRIM('retv_vars.10686_0029_002.cdf') + TES(2438)%FILENAME = TRIM('retv_vars.10686_0029_003.cdf') + TES(2439)%FILENAME = TRIM('retv_vars.10686_0030_004.cdf') + TES(2440)%FILENAME = TRIM('retv_vars.10686_0055_004.cdf') + TES(2441)%FILENAME = TRIM('retv_vars.10686_0056_003.cdf') + TES(2442)%FILENAME = TRIM('retv_vars.10686_0057_003.cdf') + TES(2443)%FILENAME = TRIM('retv_vars.10686_0057_004.cdf') + TES(2444)%FILENAME = TRIM('retv_vars.10686_0058_002.cdf') + TES(2445)%FILENAME = TRIM('retv_vars.10686_0058_003.cdf') + TES(2446)%FILENAME = TRIM('retv_vars.10686_0061_002.cdf') + TES(2447)%FILENAME = TRIM('retv_vars.10686_0061_003.cdf') + TES(2448)%FILENAME = TRIM('retv_vars.10686_0061_004.cdf') + TES(2449)%FILENAME = TRIM('retv_vars.10686_0063_003.cdf') + TES(2450)%FILENAME = TRIM('retv_vars.10686_0065_002.cdf') + TES(2451)%FILENAME = TRIM('retv_vars.10686_0066_003.cdf') + TES(2452)%FILENAME = TRIM('retv_vars.10686_0066_004.cdf') + TES(2453)%FILENAME = TRIM('retv_vars.10686_0067_002.cdf') + TES(2454)%FILENAME = TRIM('retv_vars.10686_0067_003.cdf') + TES(2455)%FILENAME = TRIM('retv_vars.10686_0067_004.cdf') + TES(2456)%FILENAME = TRIM('retv_vars.10686_0068_002.cdf') + TES(2457)%FILENAME = TRIM('retv_vars.10686_0068_003.cdf') + TES(2458)%FILENAME = TRIM('retv_vars.10686_0068_004.cdf') + TES(2459)%FILENAME = TRIM('retv_vars.10686_0069_002.cdf') + TES(2460)%FILENAME = TRIM('retv_vars.10686_0069_003.cdf') + TES(2461)%FILENAME = TRIM('retv_vars.10686_0071_002.cdf') + TES(2462)%FILENAME = TRIM('retv_vars.10686_0100_002.cdf') + TES(2463)%FILENAME = TRIM('retv_vars.10686_0100_004.cdf') + TES(2464)%FILENAME = TRIM('retv_vars.10686_0101_004.cdf') + TES(2465)%FILENAME = TRIM('retv_vars.10686_0102_003.cdf') + TES(2466)%FILENAME = TRIM('retv_vars.10686_0102_004.cdf') + TES(2467)%FILENAME = TRIM('retv_vars.10686_0103_003.cdf') + TES(2468)%FILENAME = TRIM('retv_vars.10686_0103_004.cdf') + TES(2469)%FILENAME = TRIM('retv_vars.10686_0104_003.cdf') + TES(2470)%FILENAME = TRIM('retv_vars.10686_0104_004.cdf') + TES(2471)%FILENAME = TRIM('retv_vars.10686_0105_003.cdf') + TES(2472)%FILENAME = TRIM('retv_vars.10686_0106_004.cdf') + TES(2473)%FILENAME = TRIM('retv_vars.10686_0107_003.cdf') + TES(2474)%FILENAME = TRIM('retv_vars.10686_0107_004.cdf') + TES(2475)%FILENAME = TRIM('retv_vars.10686_0108_002.cdf') + TES(2476)%FILENAME = TRIM('retv_vars.10686_0108_004.cdf') + TES(2477)%FILENAME = TRIM('retv_vars.10686_0109_002.cdf') + TES(2478)%FILENAME = TRIM('retv_vars.10686_0115_002.cdf') + TES(2479)%FILENAME = TRIM('retv_vars.10686_0115_004.cdf') + TES(2480)%FILENAME = TRIM('retv_vars.10686_0116_002.cdf') + TES(2481)%FILENAME = TRIM('retv_vars.10686_0116_003.cdf') + TES(2482)%FILENAME = TRIM('retv_vars.10686_0137_004.cdf') + TES(2483)%FILENAME = TRIM('retv_vars.10686_0144_004.cdf') + TES(2484)%FILENAME = TRIM('retv_vars.10686_0188_002.cdf') + TES(2485)%FILENAME = TRIM('retv_vars.10686_0188_003.cdf') + TES(2486)%FILENAME = TRIM('retv_vars.10686_0188_004.cdf') + TES(2487)%FILENAME = TRIM('retv_vars.10686_0190_004.cdf') + TES(2488)%FILENAME = TRIM('retv_vars.10686_0191_004.cdf') + TES(2489)%FILENAME = TRIM('retv_vars.10686_0231_002.cdf') + TES(2490)%FILENAME = TRIM('retv_vars.10686_0234_002.cdf') + TES(2491)%FILENAME = TRIM('retv_vars.10686_0235_002.cdf') + TES(2492)%FILENAME = TRIM('retv_vars.10686_0237_003.cdf') + TES(2493)%FILENAME = TRIM('retv_vars.10686_0237_004.cdf') + TES(2494)%FILENAME = TRIM('retv_vars.10686_0246_002.cdf') + TES(2495)%FILENAME = TRIM('retv_vars.10686_0246_003.cdf') + TES(2496)%FILENAME = TRIM('retv_vars.10686_0247_003.cdf') + TES(2497)%FILENAME = TRIM('retv_vars.10686_0247_004.cdf') + TES(2498)%FILENAME = TRIM('retv_vars.10686_0248_003.cdf') + TES(2499)%FILENAME = TRIM('retv_vars.10686_0248_004.cdf') + TES(2500)%FILENAME = TRIM('retv_vars.10686_0249_004.cdf') + TES(2501)%FILENAME = TRIM('retv_vars.10686_0250_003.cdf') + TES(2502)%FILENAME = TRIM('retv_vars.10686_0250_004.cdf') + TES(2503)%FILENAME = TRIM('retv_vars.10686_0251_002.cdf') + TES(2504)%FILENAME = TRIM('retv_vars.10686_0251_003.cdf') + TES(2505)%FILENAME = TRIM('retv_vars.10686_0251_004.cdf') + TES(2506)%FILENAME = TRIM('retv_vars.10686_0252_002.cdf') + TES(2507)%FILENAME = TRIM('retv_vars.10686_0252_003.cdf') + TES(2508)%FILENAME = TRIM('retv_vars.10686_0252_004.cdf') + TES(2509)%FILENAME = TRIM('retv_vars.10686_0253_002.cdf') + TES(2510)%FILENAME = TRIM('retv_vars.10686_0260_002.cdf') + TES(2511)%FILENAME = TRIM('retv_vars.10686_0260_003.cdf') + TES(2512)%FILENAME = TRIM('retv_vars.10686_0260_004.cdf') + TES(2513)%FILENAME = TRIM('retv_vars.10686_0261_002.cdf') + TES(2514)%FILENAME = TRIM('retv_vars.10686_0261_003.cdf') + TES(2515)%FILENAME = TRIM('retv_vars.10686_0261_004.cdf') + TES(2516)%FILENAME = TRIM('retv_vars.10686_0262_002.cdf') + TES(2517)%FILENAME = TRIM('retv_vars.10686_0267_003.cdf') + TES(2518)%FILENAME = TRIM('retv_vars.10686_0267_004.cdf') + TES(2519)%FILENAME = TRIM('retv_vars.10686_0268_002.cdf') + TES(2520)%FILENAME = TRIM('retv_vars.10686_0268_003.cdf') + TES(2521)%FILENAME = TRIM('retv_vars.10686_0268_004.cdf') + TES(2522)%FILENAME = TRIM('retv_vars.10686_0269_002.cdf') + TES(2523)%FILENAME = TRIM('retv_vars.10686_0269_004.cdf') + TES(2524)%FILENAME = TRIM('retv_vars.10686_0270_004.cdf') + TES(2525)%FILENAME = TRIM('retv_vars.10686_0271_002.cdf') + TES(2526)%FILENAME = TRIM('retv_vars.10686_0271_003.cdf') + TES(2527)%FILENAME = TRIM('retv_vars.10686_0271_004.cdf') + TES(2528)%FILENAME = TRIM('retv_vars.10686_0273_003.cdf') + TES(2529)%FILENAME = TRIM('retv_vars.10686_0273_004.cdf') + TES(2530)%FILENAME = TRIM('retv_vars.10686_0274_002.cdf') + TES(2531)%FILENAME = TRIM('retv_vars.10686_0274_003.cdf') + TES(2532)%FILENAME = TRIM('retv_vars.10686_0274_004.cdf') + TES(2533)%FILENAME = TRIM('retv_vars.10686_0275_002.cdf') + TES(2534)%FILENAME = TRIM('retv_vars.10686_0275_003.cdf') + TES(2535)%FILENAME = TRIM('retv_vars.10686_0276_002.cdf') + TES(2536)%FILENAME = TRIM('retv_vars.10686_0289_002.cdf') + TES(2537)%FILENAME = TRIM('retv_vars.10686_0289_003.cdf') + TES(2538)%FILENAME = TRIM('retv_vars.10686_0302_002.cdf') + TES(2539)%FILENAME = TRIM('retv_vars.10686_0302_003.cdf') + TES(2540)%FILENAME = TRIM('retv_vars.10686_0302_004.cdf') + TES(2541)%FILENAME = TRIM('retv_vars.10686_0306_002.cdf') + TES(2542)%FILENAME = TRIM('retv_vars.10686_0306_003.cdf') + TES(2543)%FILENAME = TRIM('retv_vars.10686_0308_002.cdf') + TES(2544)%FILENAME = TRIM('retv_vars.10686_0308_003.cdf') + TES(2545)%FILENAME = TRIM('retv_vars.10686_0308_004.cdf') + TES(2546)%FILENAME = TRIM('retv_vars.10686_0309_003.cdf') + TES(2547)%FILENAME = TRIM('retv_vars.10686_0315_003.cdf') + TES(2548)%FILENAME = TRIM('retv_vars.10686_0315_004.cdf') + TES(2549)%FILENAME = TRIM('retv_vars.10686_0316_002.cdf') + TES(2550)%FILENAME = TRIM('retv_vars.10686_0316_003.cdf') + TES(2551)%FILENAME = TRIM('retv_vars.10686_0316_004.cdf') + TES(2552)%FILENAME = TRIM('retv_vars.10686_0318_003.cdf') + TES(2553)%FILENAME = TRIM('retv_vars.10686_0319_002.cdf') + TES(2554)%FILENAME = TRIM('retv_vars.10686_0319_003.cdf') + TES(2555)%FILENAME = TRIM('retv_vars.10686_0319_004.cdf') + TES(2556)%FILENAME = TRIM('retv_vars.10686_0320_003.cdf') + TES(2557)%FILENAME = TRIM('retv_vars.10686_0320_004.cdf') + TES(2558)%FILENAME = TRIM('retv_vars.10686_0321_004.cdf') + TES(2559)%FILENAME = TRIM('retv_vars.10686_0354_002.cdf') + TES(2560)%FILENAME = TRIM('retv_vars.10686_0354_003.cdf') + TES(2561)%FILENAME = TRIM('retv_vars.10686_0356_004.cdf') + TES(2562)%FILENAME = TRIM('retv_vars.10686_0357_003.cdf') + TES(2563)%FILENAME = TRIM('retv_vars.10686_0358_002.cdf') + TES(2564)%FILENAME = TRIM('retv_vars.10686_0358_004.cdf') + TES(2565)%FILENAME = TRIM('retv_vars.10686_0359_002.cdf') + TES(2566)%FILENAME = TRIM('retv_vars.10686_0363_004.cdf') + TES(2567)%FILENAME = TRIM('retv_vars.10686_0364_002.cdf') + TES(2568)%FILENAME = TRIM('retv_vars.10686_0364_003.cdf') + TES(2569)%FILENAME = TRIM('retv_vars.10686_0364_004.cdf') + TES(2570)%FILENAME = TRIM('retv_vars.10686_0365_002.cdf') + TES(2571)%FILENAME = TRIM('retv_vars.10686_0365_003.cdf') + TES(2572)%FILENAME = TRIM('retv_vars.10686_0366_002.cdf') + TES(2573)%FILENAME = TRIM('retv_vars.10686_0366_004.cdf') + TES(2574)%FILENAME = TRIM('retv_vars.10686_0367_002.cdf') + TES(2575)%FILENAME = TRIM('retv_vars.10686_0367_003.cdf') + TES(2576)%FILENAME = TRIM('retv_vars.10686_0367_004.cdf') + TES(2577)%FILENAME = TRIM('retv_vars.10686_0369_004.cdf') + TES(2578)%FILENAME = TRIM('retv_vars.10686_0370_002.cdf') + TES(2579)%FILENAME = TRIM('retv_vars.10686_0413_002.cdf') + TES(2580)%FILENAME = TRIM('retv_vars.10686_0413_003.cdf') + TES(2581)%FILENAME = TRIM('retv_vars.10686_0413_004.cdf') + TES(2582)%FILENAME = TRIM('retv_vars.10686_0414_002.cdf') + TES(2583)%FILENAME = TRIM('retv_vars.10686_0414_003.cdf') + TES(2584)%FILENAME = TRIM('retv_vars.10686_0415_002.cdf') + TES(2585)%FILENAME = TRIM('retv_vars.10686_0415_003.cdf') + TES(2586)%FILENAME = TRIM('retv_vars.10686_0420_002.cdf') + TES(2587)%FILENAME = TRIM('retv_vars.10686_0420_004.cdf') + TES(2588)%FILENAME = TRIM('retv_vars.10686_0421_002.cdf') + TES(2589)%FILENAME = TRIM('retv_vars.10686_0421_003.cdf') + TES(2590)%FILENAME = TRIM('retv_vars.10686_0421_004.cdf') + TES(2591)%FILENAME = TRIM('retv_vars.10686_0422_002.cdf') + TES(2592)%FILENAME = TRIM('retv_vars.10686_0422_004.cdf') + TES(2593)%FILENAME = TRIM('retv_vars.10686_0423_003.cdf') + TES(2594)%FILENAME = TRIM('retv_vars.10686_0424_002.cdf') + TES(2595)%FILENAME = TRIM('retv_vars.10686_0424_004.cdf') + TES(2596)%FILENAME = TRIM('retv_vars.10686_0425_002.cdf') + TES(2597)%FILENAME = TRIM('retv_vars.10686_0426_003.cdf') + TES(2598)%FILENAME = TRIM('retv_vars.10686_0427_002.cdf') + TES(2599)%FILENAME = TRIM('retv_vars.10686_0427_003.cdf') + TES(2600)%FILENAME = TRIM('retv_vars.10686_0428_002.cdf') + TES(2601)%FILENAME = TRIM('retv_vars.10686_0429_002.cdf') + TES(2602)%FILENAME = TRIM('retv_vars.10686_0429_003.cdf') + TES(2603)%FILENAME = TRIM('retv_vars.10686_0429_004.cdf') + TES(2604)%FILENAME = TRIM('retv_vars.10686_0459_004.cdf') + TES(2605)%FILENAME = TRIM('retv_vars.10686_0460_004.cdf') + TES(2606)%FILENAME = TRIM('retv_vars.10686_0461_002.cdf') + TES(2607)%FILENAME = TRIM('retv_vars.10686_0461_003.cdf') + TES(2608)%FILENAME = TRIM('retv_vars.10686_0462_002.cdf') + TES(2609)%FILENAME = TRIM('retv_vars.10686_0463_002.cdf') + TES(2610)%FILENAME = TRIM('retv_vars.10686_0463_003.cdf') + TES(2611)%FILENAME = TRIM('retv_vars.10686_0466_003.cdf') + TES(2612)%FILENAME = TRIM('retv_vars.10686_0466_004.cdf') + TES(2613)%FILENAME = TRIM('retv_vars.10686_0467_002.cdf') + TES(2614)%FILENAME = TRIM('retv_vars.10686_0467_003.cdf') + TES(2615)%FILENAME = TRIM('retv_vars.10686_0467_004.cdf') + TES(2616)%FILENAME = TRIM('retv_vars.10686_0469_002.cdf') + TES(2617)%FILENAME = TRIM('retv_vars.10686_0469_003.cdf') + TES(2618)%FILENAME = TRIM('retv_vars.10686_0469_004.cdf') + TES(2619)%FILENAME = TRIM('retv_vars.10686_0471_002.cdf') + TES(2620)%FILENAME = TRIM('retv_vars.10686_0502_002.cdf') + TES(2621)%FILENAME = TRIM('retv_vars.10686_0502_003.cdf') + TES(2622)%FILENAME = TRIM('retv_vars.10686_0502_004.cdf') + TES(2623)%FILENAME = TRIM('retv_vars.10686_0508_003.cdf') + TES(2624)%FILENAME = TRIM('retv_vars.10686_0510_004.cdf') + TES(2625)%FILENAME = TRIM('retv_vars.10686_0511_002.cdf') + TES(2626)%FILENAME = TRIM('retv_vars.10686_0511_003.cdf') + TES(2627)%FILENAME = TRIM('retv_vars.10686_0515_003.cdf') + TES(2628)%FILENAME = TRIM('retv_vars.10686_0515_004.cdf') + TES(2629)%FILENAME = TRIM('retv_vars.10686_0516_002.cdf') + TES(2630)%FILENAME = TRIM('retv_vars.10686_0516_004.cdf') + TES(2631)%FILENAME = TRIM('retv_vars.10686_0542_003.cdf') + TES(2632)%FILENAME = TRIM('retv_vars.10686_0549_002.cdf') + TES(2633)%FILENAME = TRIM('retv_vars.10686_0549_003.cdf') + TES(2634)%FILENAME = TRIM('retv_vars.10686_0549_004.cdf') + TES(2635)%FILENAME = TRIM('retv_vars.10686_0550_002.cdf') + TES(2636)%FILENAME = TRIM('retv_vars.10686_0550_003.cdf') + TES(2637)%FILENAME = TRIM('retv_vars.10686_0551_002.cdf') + TES(2638)%FILENAME = TRIM('retv_vars.10686_0568_002.cdf') + TES(2639)%FILENAME = TRIM('retv_vars.10686_0568_004.cdf') + TES(2640)%FILENAME = TRIM('retv_vars.10686_0569_002.cdf') + TES(2641)%FILENAME = TRIM('retv_vars.10686_0569_004.cdf') + TES(2642)%FILENAME = TRIM('retv_vars.10686_0570_003.cdf') + TES(2643)%FILENAME = TRIM('retv_vars.10686_0570_004.cdf') + TES(2644)%FILENAME = TRIM('retv_vars.10686_0571_002.cdf') + TES(2645)%FILENAME = TRIM('retv_vars.10686_0571_003.cdf') + TES(2646)%FILENAME = TRIM('retv_vars.10686_0572_002.cdf') + TES(2647)%FILENAME = TRIM('retv_vars.10686_0572_003.cdf') + TES(2648)%FILENAME = TRIM('retv_vars.10686_0582_004.cdf') + TES(2649)%FILENAME = TRIM('retv_vars.10686_0583_002.cdf') + TES(2650)%FILENAME = TRIM('retv_vars.10686_0583_004.cdf') + TES(2651)%FILENAME = TRIM('retv_vars.10686_0587_002.cdf') + TES(2652)%FILENAME = TRIM('retv_vars.10686_0588_003.cdf') + TES(2653)%FILENAME = TRIM('retv_vars.10686_0589_002.cdf') + TES(2654)%FILENAME = TRIM('retv_vars.10686_0589_003.cdf') + TES(2655)%FILENAME = TRIM('retv_vars.10686_0590_002.cdf') + TES(2656)%FILENAME = TRIM('retv_vars.10686_0592_004.cdf') + TES(2657)%FILENAME = TRIM('retv_vars.10686_0594_002.cdf') + TES(2658)%FILENAME = TRIM('retv_vars.10686_0594_004.cdf') + TES(2659)%FILENAME = TRIM('retv_vars.10686_0595_004.cdf') + TES(2660)%FILENAME = TRIM('retv_vars.10686_0597_002.cdf') + TES(2661)%FILENAME = TRIM('retv_vars.10686_0598_003.cdf') + TES(2662)%FILENAME = TRIM('retv_vars.10686_0598_004.cdf') + TES(2663)%FILENAME = TRIM('retv_vars.10686_0599_002.cdf') + TES(2664)%FILENAME = TRIM('retv_vars.10686_0605_002.cdf') + TES(2665)%FILENAME = TRIM('retv_vars.10686_0613_004.cdf') + TES(2666)%FILENAME = TRIM('retv_vars.10686_0614_002.cdf') + TES(2667)%FILENAME = TRIM('retv_vars.10686_0615_002.cdf') + TES(2668)%FILENAME = TRIM('retv_vars.10686_0616_003.cdf') + TES(2669)%FILENAME = TRIM('retv_vars.10686_0617_002.cdf') + TES(2670)%FILENAME = TRIM('retv_vars.10686_0617_003.cdf') + TES(2671)%FILENAME = TRIM('retv_vars.10686_0618_002.cdf') + TES(2672)%FILENAME = TRIM('retv_vars.10686_0618_003.cdf') + TES(2673)%FILENAME = TRIM('retv_vars.10686_0635_003.cdf') + TES(2674)%FILENAME = TRIM('retv_vars.10686_0639_004.cdf') + TES(2675)%FILENAME = TRIM('retv_vars.10686_0640_003.cdf') + TES(2676)%FILENAME = TRIM('retv_vars.10686_0640_004.cdf') + TES(2677)%FILENAME = TRIM('retv_vars.10686_0645_002.cdf') + TES(2678)%FILENAME = TRIM('retv_vars.10686_0645_003.cdf') + TES(2679)%FILENAME = TRIM('retv_vars.10686_0645_004.cdf') + TES(2680)%FILENAME = TRIM('retv_vars.10686_0651_002.cdf') + TES(2681)%FILENAME = TRIM('retv_vars.10686_0651_003.cdf') + TES(2682)%FILENAME = TRIM('retv_vars.10686_0651_004.cdf') + TES(2683)%FILENAME = TRIM('retv_vars.10686_0652_002.cdf') + TES(2684)%FILENAME = TRIM('retv_vars.10686_0652_004.cdf') + TES(2685)%FILENAME = TRIM('retv_vars.10686_0653_002.cdf') + TES(2686)%FILENAME = TRIM('retv_vars.10686_0653_003.cdf') + TES(2687)%FILENAME = TRIM('retv_vars.10686_0653_004.cdf') + TES(2688)%FILENAME = TRIM('retv_vars.10686_0654_002.cdf') + TES(2689)%FILENAME = TRIM('retv_vars.10686_0654_003.cdf') + TES(2690)%FILENAME = TRIM('retv_vars.10686_0655_004.cdf') + TES(2691)%FILENAME = TRIM('retv_vars.10686_0656_003.cdf') + TES(2692)%FILENAME = TRIM('retv_vars.10686_0656_004.cdf') + TES(2693)%FILENAME = TRIM('retv_vars.10686_0657_002.cdf') + TES(2694)%FILENAME = TRIM('retv_vars.10686_0659_003.cdf') + TES(2695)%FILENAME = TRIM('retv_vars.10686_0659_004.cdf') + TES(2696)%FILENAME = TRIM('retv_vars.10686_0660_002.cdf') + TES(2697)%FILENAME = TRIM('retv_vars.10686_0694_003.cdf') + TES(2698)%FILENAME = TRIM('retv_vars.10686_0694_004.cdf') + TES(2699)%FILENAME = TRIM('retv_vars.10686_0695_002.cdf') + TES(2700)%FILENAME = TRIM('retv_vars.10686_0700_004.cdf') + TES(2701)%FILENAME = TRIM('retv_vars.10686_0701_002.cdf') + TES(2702)%FILENAME = TRIM('retv_vars.10686_0701_003.cdf') + TES(2703)%FILENAME = TRIM('retv_vars.10686_0701_004.cdf') + TES(2704)%FILENAME = TRIM('retv_vars.10686_0702_002.cdf') + TES(2705)%FILENAME = TRIM('retv_vars.10686_0702_003.cdf') + TES(2706)%FILENAME = TRIM('retv_vars.10686_0703_002.cdf') + TES(2707)%FILENAME = TRIM('retv_vars.10686_0703_003.cdf') + TES(2708)%FILENAME = TRIM('retv_vars.10686_0703_004.cdf') + TES(2709)%FILENAME = TRIM('retv_vars.10686_0704_003.cdf') + TES(2710)%FILENAME = TRIM('retv_vars.10686_0704_004.cdf') + TES(2711)%FILENAME = TRIM('retv_vars.10686_0705_003.cdf') + TES(2712)%FILENAME = TRIM('retv_vars.10686_0706_002.cdf') + TES(2713)%FILENAME = TRIM('retv_vars.10686_0733_002.cdf') + TES(2714)%FILENAME = TRIM('retv_vars.10686_0739_003.cdf') + TES(2715)%FILENAME = TRIM('retv_vars.10686_0740_002.cdf') + TES(2716)%FILENAME = TRIM('retv_vars.10686_0740_004.cdf') + TES(2717)%FILENAME = TRIM('retv_vars.10686_0741_002.cdf') + TES(2718)%FILENAME = TRIM('retv_vars.10686_0741_003.cdf') + TES(2719)%FILENAME = TRIM('retv_vars.10686_0747_003.cdf') + TES(2720)%FILENAME = TRIM('retv_vars.10686_0748_002.cdf') + TES(2721)%FILENAME = TRIM('retv_vars.10686_0748_003.cdf') + TES(2722)%FILENAME = TRIM('retv_vars.10686_0748_004.cdf') + TES(2723)%FILENAME = TRIM('retv_vars.10686_0749_002.cdf') + TES(2724)%FILENAME = TRIM('retv_vars.10688_0016_004.cdf') + TES(2725)%FILENAME = TRIM('retv_vars.10688_0021_002.cdf') + TES(2726)%FILENAME = TRIM('retv_vars.10688_0021_003.cdf') + TES(2727)%FILENAME = TRIM('retv_vars.10688_0022_003.cdf') + TES(2728)%FILENAME = TRIM('retv_vars.10688_0027_003.cdf') + TES(2729)%FILENAME = TRIM('retv_vars.10688_0027_004.cdf') + TES(2730)%FILENAME = TRIM('retv_vars.10688_0028_003.cdf') + TES(2731)%FILENAME = TRIM('retv_vars.10688_0028_004.cdf') + TES(2732)%FILENAME = TRIM('retv_vars.10688_0029_002.cdf') + TES(2733)%FILENAME = TRIM('retv_vars.10688_0029_003.cdf') + TES(2734)%FILENAME = TRIM('retv_vars.10688_0030_002.cdf') + TES(2735)%FILENAME = TRIM('retv_vars.10688_0030_003.cdf') + TES(2736)%FILENAME = TRIM('retv_vars.10688_0030_004.cdf') + TES(2737)%FILENAME = TRIM('retv_vars.10688_0031_002.cdf') + TES(2738)%FILENAME = TRIM('retv_vars.10688_0054_004.cdf') + TES(2739)%FILENAME = TRIM('retv_vars.10688_0060_003.cdf') + TES(2740)%FILENAME = TRIM('retv_vars.10688_0060_004.cdf') + TES(2741)%FILENAME = TRIM('retv_vars.10688_0061_003.cdf') + TES(2742)%FILENAME = TRIM('retv_vars.10688_0068_002.cdf') + TES(2743)%FILENAME = TRIM('retv_vars.10688_0068_003.cdf') + TES(2744)%FILENAME = TRIM('retv_vars.10688_0068_004.cdf') + TES(2745)%FILENAME = TRIM('retv_vars.10688_0069_002.cdf') + TES(2746)%FILENAME = TRIM('retv_vars.10688_0069_003.cdf') + TES(2747)%FILENAME = TRIM('retv_vars.10688_0069_004.cdf') + TES(2748)%FILENAME = TRIM('retv_vars.10688_0070_003.cdf') + TES(2749)%FILENAME = TRIM('retv_vars.10688_0100_003.cdf') + TES(2750)%FILENAME = TRIM('retv_vars.10688_0100_004.cdf') + TES(2751)%FILENAME = TRIM('retv_vars.10688_0103_002.cdf') + TES(2752)%FILENAME = TRIM('retv_vars.10688_0103_004.cdf') + TES(2753)%FILENAME = TRIM('retv_vars.10688_0104_003.cdf') + TES(2754)%FILENAME = TRIM('retv_vars.10688_0104_004.cdf') + TES(2755)%FILENAME = TRIM('retv_vars.10688_0105_002.cdf') + TES(2756)%FILENAME = TRIM('retv_vars.10688_0105_003.cdf') + TES(2757)%FILENAME = TRIM('retv_vars.10688_0105_004.cdf') + TES(2758)%FILENAME = TRIM('retv_vars.10688_0106_003.cdf') + TES(2759)%FILENAME = TRIM('retv_vars.10688_0106_004.cdf') + TES(2760)%FILENAME = TRIM('retv_vars.10688_0108_003.cdf') + TES(2761)%FILENAME = TRIM('retv_vars.10688_0108_004.cdf') + TES(2762)%FILENAME = TRIM('retv_vars.10688_0110_003.cdf') + TES(2763)%FILENAME = TRIM('retv_vars.10688_0110_004.cdf') + TES(2764)%FILENAME = TRIM('retv_vars.10688_0117_002.cdf') + TES(2765)%FILENAME = TRIM('retv_vars.10688_0117_004.cdf') + TES(2766)%FILENAME = TRIM('retv_vars.10688_0118_002.cdf') + TES(2767)%FILENAME = TRIM('retv_vars.10688_0119_002.cdf') + TES(2768)%FILENAME = TRIM('retv_vars.10688_0124_002.cdf') + TES(2769)%FILENAME = TRIM('retv_vars.10688_0138_004.cdf') + TES(2770)%FILENAME = TRIM('retv_vars.10688_0157_002.cdf') + TES(2771)%FILENAME = TRIM('retv_vars.10688_0157_003.cdf') + TES(2772)%FILENAME = TRIM('retv_vars.10688_0158_004.cdf') + TES(2773)%FILENAME = TRIM('retv_vars.10688_0188_003.cdf') + TES(2774)%FILENAME = TRIM('retv_vars.10688_0189_002.cdf') + TES(2775)%FILENAME = TRIM('retv_vars.10688_0189_003.cdf') + TES(2776)%FILENAME = TRIM('retv_vars.10688_0189_004.cdf') + TES(2777)%FILENAME = TRIM('retv_vars.10688_0190_002.cdf') + TES(2778)%FILENAME = TRIM('retv_vars.10688_0190_003.cdf') + TES(2779)%FILENAME = TRIM('retv_vars.10688_0190_004.cdf') + TES(2780)%FILENAME = TRIM('retv_vars.10688_0191_004.cdf') + TES(2781)%FILENAME = TRIM('retv_vars.10688_0233_003.cdf') + TES(2782)%FILENAME = TRIM('retv_vars.10688_0234_002.cdf') + TES(2783)%FILENAME = TRIM('retv_vars.10688_0234_003.cdf') + TES(2784)%FILENAME = TRIM('retv_vars.10688_0234_004.cdf') + TES(2785)%FILENAME = TRIM('retv_vars.10688_0237_002.cdf') + TES(2786)%FILENAME = TRIM('retv_vars.10688_0237_003.cdf') + TES(2787)%FILENAME = TRIM('retv_vars.10688_0244_004.cdf') + TES(2788)%FILENAME = TRIM('retv_vars.10688_0245_003.cdf') + TES(2789)%FILENAME = TRIM('retv_vars.10688_0245_004.cdf') + TES(2790)%FILENAME = TRIM('retv_vars.10688_0246_002.cdf') + TES(2791)%FILENAME = TRIM('retv_vars.10688_0248_003.cdf') + TES(2792)%FILENAME = TRIM('retv_vars.10688_0249_002.cdf') + TES(2793)%FILENAME = TRIM('retv_vars.10688_0250_002.cdf') + TES(2794)%FILENAME = TRIM('retv_vars.10688_0250_003.cdf') + TES(2795)%FILENAME = TRIM('retv_vars.10688_0250_004.cdf') + TES(2796)%FILENAME = TRIM('retv_vars.10688_0251_004.cdf') + TES(2797)%FILENAME = TRIM('retv_vars.10688_0252_002.cdf') + TES(2798)%FILENAME = TRIM('retv_vars.10688_0252_003.cdf') + TES(2799)%FILENAME = TRIM('retv_vars.10688_0252_004.cdf') + TES(2800)%FILENAME = TRIM('retv_vars.10688_0253_002.cdf') + TES(2801)%FILENAME = TRIM('retv_vars.10688_0253_003.cdf') + TES(2802)%FILENAME = TRIM('retv_vars.10688_0260_002.cdf') + TES(2803)%FILENAME = TRIM('retv_vars.10688_0260_004.cdf') + TES(2804)%FILENAME = TRIM('retv_vars.10688_0261_002.cdf') + TES(2805)%FILENAME = TRIM('retv_vars.10688_0261_003.cdf') + TES(2806)%FILENAME = TRIM('retv_vars.10688_0261_004.cdf') + TES(2807)%FILENAME = TRIM('retv_vars.10688_0262_003.cdf') + TES(2808)%FILENAME = TRIM('retv_vars.10688_0262_004.cdf') + TES(2809)%FILENAME = TRIM('retv_vars.10688_0263_002.cdf') + TES(2810)%FILENAME = TRIM('retv_vars.10688_0268_004.cdf') + TES(2811)%FILENAME = TRIM('retv_vars.10688_0269_002.cdf') + TES(2812)%FILENAME = TRIM('retv_vars.10688_0269_004.cdf') + TES(2813)%FILENAME = TRIM('retv_vars.10688_0273_004.cdf') + TES(2814)%FILENAME = TRIM('retv_vars.10688_0274_003.cdf') + TES(2815)%FILENAME = TRIM('retv_vars.10688_0289_002.cdf') + TES(2816)%FILENAME = TRIM('retv_vars.10688_0289_004.cdf') + TES(2817)%FILENAME = TRIM('retv_vars.10688_0290_002.cdf') + TES(2818)%FILENAME = TRIM('retv_vars.10688_0301_003.cdf') + TES(2819)%FILENAME = TRIM('retv_vars.10688_0302_002.cdf') + TES(2820)%FILENAME = TRIM('retv_vars.10688_0303_002.cdf') + TES(2821)%FILENAME = TRIM('retv_vars.10688_0305_003.cdf') + TES(2822)%FILENAME = TRIM('retv_vars.10688_0305_004.cdf') + TES(2823)%FILENAME = TRIM('retv_vars.10688_0306_002.cdf') + TES(2824)%FILENAME = TRIM('retv_vars.10688_0306_004.cdf') + TES(2825)%FILENAME = TRIM('retv_vars.10688_0307_002.cdf') + TES(2826)%FILENAME = TRIM('retv_vars.10688_0307_004.cdf') + TES(2827)%FILENAME = TRIM('retv_vars.10688_0308_002.cdf') + TES(2828)%FILENAME = TRIM('retv_vars.10688_0308_004.cdf') + TES(2829)%FILENAME = TRIM('retv_vars.10688_0309_004.cdf') + TES(2830)%FILENAME = TRIM('retv_vars.10688_0311_002.cdf') + TES(2831)%FILENAME = TRIM('retv_vars.10688_0317_002.cdf') + TES(2832)%FILENAME = TRIM('retv_vars.10688_0318_003.cdf') + TES(2833)%FILENAME = TRIM('retv_vars.10688_0319_003.cdf') + TES(2834)%FILENAME = TRIM('retv_vars.10688_0319_004.cdf') + TES(2835)%FILENAME = TRIM('retv_vars.10688_0320_003.cdf') + TES(2836)%FILENAME = TRIM('retv_vars.10688_0321_002.cdf') + TES(2837)%FILENAME = TRIM('retv_vars.10688_0321_004.cdf') + TES(2838)%FILENAME = TRIM('retv_vars.10688_0322_002.cdf') + TES(2839)%FILENAME = TRIM('retv_vars.10688_0353_004.cdf') + TES(2840)%FILENAME = TRIM('retv_vars.10688_0354_004.cdf') + TES(2841)%FILENAME = TRIM('retv_vars.10688_0357_002.cdf') + TES(2842)%FILENAME = TRIM('retv_vars.10688_0358_003.cdf') + TES(2843)%FILENAME = TRIM('retv_vars.10688_0363_004.cdf') + TES(2844)%FILENAME = TRIM('retv_vars.10688_0364_003.cdf') + TES(2845)%FILENAME = TRIM('retv_vars.10688_0364_004.cdf') + TES(2846)%FILENAME = TRIM('retv_vars.10688_0365_002.cdf') + TES(2847)%FILENAME = TRIM('retv_vars.10688_0365_003.cdf') + TES(2848)%FILENAME = TRIM('retv_vars.10688_0366_002.cdf') + TES(2849)%FILENAME = TRIM('retv_vars.10688_0366_003.cdf') + TES(2850)%FILENAME = TRIM('retv_vars.10688_0367_003.cdf') + TES(2851)%FILENAME = TRIM('retv_vars.10688_0368_002.cdf') + TES(2852)%FILENAME = TRIM('retv_vars.10688_0411_003.cdf') + TES(2853)%FILENAME = TRIM('retv_vars.10688_0411_004.cdf') + TES(2854)%FILENAME = TRIM('retv_vars.10688_0412_003.cdf') + TES(2855)%FILENAME = TRIM('retv_vars.10688_0413_002.cdf') + TES(2856)%FILENAME = TRIM('retv_vars.10688_0414_002.cdf') + TES(2857)%FILENAME = TRIM('retv_vars.10688_0415_002.cdf') + TES(2858)%FILENAME = TRIM('retv_vars.10688_0415_004.cdf') + TES(2859)%FILENAME = TRIM('retv_vars.10688_0418_004.cdf') + TES(2860)%FILENAME = TRIM('retv_vars.10688_0420_002.cdf') + TES(2861)%FILENAME = TRIM('retv_vars.10688_0421_004.cdf') + TES(2862)%FILENAME = TRIM('retv_vars.10688_0422_002.cdf') + TES(2863)%FILENAME = TRIM('retv_vars.10688_0422_003.cdf') + TES(2864)%FILENAME = TRIM('retv_vars.10688_0422_004.cdf') + TES(2865)%FILENAME = TRIM('retv_vars.10688_0423_004.cdf') + TES(2866)%FILENAME = TRIM('retv_vars.10688_0424_002.cdf') + TES(2867)%FILENAME = TRIM('retv_vars.10688_0424_003.cdf') + TES(2868)%FILENAME = TRIM('retv_vars.10688_0424_004.cdf') + TES(2869)%FILENAME = TRIM('retv_vars.10688_0425_002.cdf') + TES(2870)%FILENAME = TRIM('retv_vars.10688_0425_003.cdf') + TES(2871)%FILENAME = TRIM('retv_vars.10688_0426_004.cdf') + TES(2872)%FILENAME = TRIM('retv_vars.10688_0427_002.cdf') + TES(2873)%FILENAME = TRIM('retv_vars.10688_0427_003.cdf') + TES(2874)%FILENAME = TRIM('retv_vars.10688_0427_004.cdf') + TES(2875)%FILENAME = TRIM('retv_vars.10688_0428_003.cdf') + TES(2876)%FILENAME = TRIM('retv_vars.10688_0429_002.cdf') + TES(2877)%FILENAME = TRIM('retv_vars.10688_0429_003.cdf') + TES(2878)%FILENAME = TRIM('retv_vars.10688_0429_004.cdf') + TES(2879)%FILENAME = TRIM('retv_vars.10688_0459_004.cdf') + TES(2880)%FILENAME = TRIM('retv_vars.10688_0460_002.cdf') + TES(2881)%FILENAME = TRIM('retv_vars.10688_0460_003.cdf') + TES(2882)%FILENAME = TRIM('retv_vars.10688_0461_002.cdf') + TES(2883)%FILENAME = TRIM('retv_vars.10688_0461_004.cdf') + TES(2884)%FILENAME = TRIM('retv_vars.10688_0462_002.cdf') + TES(2885)%FILENAME = TRIM('retv_vars.10688_0462_003.cdf') + TES(2886)%FILENAME = TRIM('retv_vars.10688_0465_004.cdf') + TES(2887)%FILENAME = TRIM('retv_vars.10688_0466_002.cdf') + TES(2888)%FILENAME = TRIM('retv_vars.10688_0466_003.cdf') + TES(2889)%FILENAME = TRIM('retv_vars.10688_0467_002.cdf') + TES(2890)%FILENAME = TRIM('retv_vars.10688_0470_002.cdf') + TES(2891)%FILENAME = TRIM('retv_vars.10688_0470_003.cdf') + TES(2892)%FILENAME = TRIM('retv_vars.10688_0471_002.cdf') + TES(2893)%FILENAME = TRIM('retv_vars.10688_0471_003.cdf') + TES(2894)%FILENAME = TRIM('retv_vars.10688_0502_004.cdf') + TES(2895)%FILENAME = TRIM('retv_vars.10688_0508_003.cdf') + TES(2896)%FILENAME = TRIM('retv_vars.10688_0508_004.cdf') + TES(2897)%FILENAME = TRIM('retv_vars.10688_0509_003.cdf') + TES(2898)%FILENAME = TRIM('retv_vars.10688_0510_004.cdf') + TES(2899)%FILENAME = TRIM('retv_vars.10688_0511_002.cdf') + TES(2900)%FILENAME = TRIM('retv_vars.10688_0511_003.cdf') + TES(2901)%FILENAME = TRIM('retv_vars.10688_0512_004.cdf') + TES(2902)%FILENAME = TRIM('retv_vars.10688_0515_002.cdf') + TES(2903)%FILENAME = TRIM('retv_vars.10688_0515_003.cdf') + TES(2904)%FILENAME = TRIM('retv_vars.10688_0515_004.cdf') + TES(2905)%FILENAME = TRIM('retv_vars.10688_0516_003.cdf') + TES(2906)%FILENAME = TRIM('retv_vars.10688_0516_004.cdf') + TES(2907)%FILENAME = TRIM('retv_vars.10688_0517_002.cdf') + TES(2908)%FILENAME = TRIM('retv_vars.10688_0517_003.cdf') + TES(2909)%FILENAME = TRIM('retv_vars.10688_0549_002.cdf') + TES(2910)%FILENAME = TRIM('retv_vars.10688_0549_004.cdf') + TES(2911)%FILENAME = TRIM('retv_vars.10688_0550_002.cdf') + TES(2912)%FILENAME = TRIM('retv_vars.10688_0568_002.cdf') + TES(2913)%FILENAME = TRIM('retv_vars.10688_0568_004.cdf') + TES(2914)%FILENAME = TRIM('retv_vars.10688_0569_004.cdf') + TES(2915)%FILENAME = TRIM('retv_vars.10688_0570_003.cdf') + TES(2916)%FILENAME = TRIM('retv_vars.10688_0571_002.cdf') + TES(2917)%FILENAME = TRIM('retv_vars.10688_0571_004.cdf') + TES(2918)%FILENAME = TRIM('retv_vars.10688_0580_003.cdf') + TES(2919)%FILENAME = TRIM('retv_vars.10688_0586_004.cdf') + TES(2920)%FILENAME = TRIM('retv_vars.10688_0589_003.cdf') + TES(2921)%FILENAME = TRIM('retv_vars.10688_0593_003.cdf') + TES(2922)%FILENAME = TRIM('retv_vars.10688_0594_002.cdf') + TES(2923)%FILENAME = TRIM('retv_vars.10688_0596_003.cdf') + TES(2924)%FILENAME = TRIM('retv_vars.10688_0596_004.cdf') + TES(2925)%FILENAME = TRIM('retv_vars.10688_0597_002.cdf') + TES(2926)%FILENAME = TRIM('retv_vars.10688_0597_003.cdf') + TES(2927)%FILENAME = TRIM('retv_vars.10688_0598_002.cdf') + TES(2928)%FILENAME = TRIM('retv_vars.10688_0599_002.cdf') + TES(2929)%FILENAME = TRIM('retv_vars.10688_0612_002.cdf') + TES(2930)%FILENAME = TRIM('retv_vars.10688_0613_002.cdf') + TES(2931)%FILENAME = TRIM('retv_vars.10688_0613_003.cdf') + TES(2932)%FILENAME = TRIM('retv_vars.10688_0613_004.cdf') + TES(2933)%FILENAME = TRIM('retv_vars.10688_0614_002.cdf') + TES(2934)%FILENAME = TRIM('retv_vars.10688_0614_003.cdf') + TES(2935)%FILENAME = TRIM('retv_vars.10688_0615_003.cdf') + TES(2936)%FILENAME = TRIM('retv_vars.10688_0615_004.cdf') + TES(2937)%FILENAME = TRIM('retv_vars.10688_0616_002.cdf') + TES(2938)%FILENAME = TRIM('retv_vars.10688_0617_004.cdf') + TES(2939)%FILENAME = TRIM('retv_vars.10688_0618_003.cdf') + TES(2940)%FILENAME = TRIM('retv_vars.10688_0619_002.cdf') + TES(2941)%FILENAME = TRIM('retv_vars.10688_0619_003.cdf') + TES(2942)%FILENAME = TRIM('retv_vars.10688_0619_004.cdf') + TES(2943)%FILENAME = TRIM('retv_vars.10688_0620_004.cdf') + TES(2944)%FILENAME = TRIM('retv_vars.10688_0621_002.cdf') + TES(2945)%FILENAME = TRIM('retv_vars.10688_0621_003.cdf') + TES(2946)%FILENAME = TRIM('retv_vars.10688_0634_002.cdf') + TES(2947)%FILENAME = TRIM('retv_vars.10688_0634_003.cdf') + TES(2948)%FILENAME = TRIM('retv_vars.10688_0635_003.cdf') + TES(2949)%FILENAME = TRIM('retv_vars.10688_0638_003.cdf') + TES(2950)%FILENAME = TRIM('retv_vars.10688_0638_004.cdf') + TES(2951)%FILENAME = TRIM('retv_vars.10688_0639_003.cdf') + TES(2952)%FILENAME = TRIM('retv_vars.10688_0640_003.cdf') + TES(2953)%FILENAME = TRIM('retv_vars.10688_0643_003.cdf') + TES(2954)%FILENAME = TRIM('retv_vars.10688_0644_003.cdf') + TES(2955)%FILENAME = TRIM('retv_vars.10688_0644_004.cdf') + TES(2956)%FILENAME = TRIM('retv_vars.10688_0645_003.cdf') + TES(2957)%FILENAME = TRIM('retv_vars.10688_0646_003.cdf') + TES(2958)%FILENAME = TRIM('retv_vars.10688_0651_002.cdf') + TES(2959)%FILENAME = TRIM('retv_vars.10688_0651_004.cdf') + TES(2960)%FILENAME = TRIM('retv_vars.10688_0654_002.cdf') + TES(2961)%FILENAME = TRIM('retv_vars.10688_0654_003.cdf') + TES(2962)%FILENAME = TRIM('retv_vars.10688_0654_004.cdf') + TES(2963)%FILENAME = TRIM('retv_vars.10688_0655_003.cdf') + TES(2964)%FILENAME = TRIM('retv_vars.10688_0655_004.cdf') + TES(2965)%FILENAME = TRIM('retv_vars.10688_0656_003.cdf') + TES(2966)%FILENAME = TRIM('retv_vars.10688_0656_004.cdf') + TES(2967)%FILENAME = TRIM('retv_vars.10688_0657_002.cdf') + TES(2968)%FILENAME = TRIM('retv_vars.10688_0658_004.cdf') + TES(2969)%FILENAME = TRIM('retv_vars.10688_0660_002.cdf') + TES(2970)%FILENAME = TRIM('retv_vars.10688_0660_003.cdf') + TES(2971)%FILENAME = TRIM('retv_vars.10688_0685_002.cdf') + TES(2972)%FILENAME = TRIM('retv_vars.10688_0685_004.cdf') + TES(2973)%FILENAME = TRIM('retv_vars.10688_0686_002.cdf') + TES(2974)%FILENAME = TRIM('retv_vars.10688_0686_004.cdf') + TES(2975)%FILENAME = TRIM('retv_vars.10688_0688_004.cdf') + TES(2976)%FILENAME = TRIM('retv_vars.10688_0689_002.cdf') + TES(2977)%FILENAME = TRIM('retv_vars.10688_0691_003.cdf') + TES(2978)%FILENAME = TRIM('retv_vars.10688_0695_002.cdf') + TES(2979)%FILENAME = TRIM('retv_vars.10688_0700_002.cdf') + TES(2980)%FILENAME = TRIM('retv_vars.10688_0700_003.cdf') + TES(2981)%FILENAME = TRIM('retv_vars.10688_0701_002.cdf') + TES(2982)%FILENAME = TRIM('retv_vars.10688_0701_003.cdf') + TES(2983)%FILENAME = TRIM('retv_vars.10688_0701_004.cdf') + TES(2984)%FILENAME = TRIM('retv_vars.10688_0702_002.cdf') + TES(2985)%FILENAME = TRIM('retv_vars.10688_0702_003.cdf') + TES(2986)%FILENAME = TRIM('retv_vars.10688_0703_002.cdf') + TES(2987)%FILENAME = TRIM('retv_vars.10688_0703_003.cdf') + TES(2988)%FILENAME = TRIM('retv_vars.10688_0703_004.cdf') + TES(2989)%FILENAME = TRIM('retv_vars.10688_0704_003.cdf') + TES(2990)%FILENAME = TRIM('retv_vars.10688_0704_004.cdf') + TES(2991)%FILENAME = TRIM('retv_vars.10688_0705_003.cdf') + TES(2992)%FILENAME = TRIM('retv_vars.10688_0734_003.cdf') + TES(2993)%FILENAME = TRIM('retv_vars.10688_0737_004.cdf') + TES(2994)%FILENAME = TRIM('retv_vars.10688_0738_004.cdf') + TES(2995)%FILENAME = TRIM('retv_vars.10688_0740_002.cdf') + TES(2996)%FILENAME = TRIM('retv_vars.10688_0741_003.cdf') + TES(2997)%FILENAME = TRIM('retv_vars.10688_0741_004.cdf') + TES(2998)%FILENAME = TRIM('retv_vars.10688_0742_002.cdf') + TES(2999)%FILENAME = TRIM('retv_vars.10688_0742_003.cdf') + TES(3000)%FILENAME = TRIM('retv_vars.10688_0742_004.cdf') + TES(3001)%FILENAME = TRIM('retv_vars.10688_0743_003.cdf') + TES(3002)%FILENAME = TRIM('retv_vars.10688_0747_004.cdf') + TES(3003)%FILENAME = TRIM('retv_vars.10688_0748_002.cdf') + TES(3004)%FILENAME = TRIM('retv_vars.10688_0748_003.cdf') + TES(3005)%FILENAME = TRIM('retv_vars.10688_0748_004.cdf') + TES(3006)%FILENAME = TRIM('retv_vars.10688_0749_002.cdf') + TES(3007)%FILENAME = TRIM('retv_vars.10693_0020_003.cdf') + TES(3008)%FILENAME = TRIM('retv_vars.10693_0021_003.cdf') + TES(3009)%FILENAME = TRIM('retv_vars.10693_0022_002.cdf') + TES(3010)%FILENAME = TRIM('retv_vars.10693_0022_003.cdf') + TES(3011)%FILENAME = TRIM('retv_vars.10693_0022_004.cdf') + TES(3012)%FILENAME = TRIM('retv_vars.10693_0023_002.cdf') + TES(3013)%FILENAME = TRIM('retv_vars.10693_0027_002.cdf') + TES(3014)%FILENAME = TRIM('retv_vars.10693_0027_003.cdf') + TES(3015)%FILENAME = TRIM('retv_vars.10693_0027_004.cdf') + TES(3016)%FILENAME = TRIM('retv_vars.10693_0028_002.cdf') + TES(3017)%FILENAME = TRIM('retv_vars.10693_0028_003.cdf') + TES(3018)%FILENAME = TRIM('retv_vars.10693_0028_004.cdf') + TES(3019)%FILENAME = TRIM('retv_vars.10693_0029_002.cdf') + TES(3020)%FILENAME = TRIM('retv_vars.10693_0029_003.cdf') + TES(3021)%FILENAME = TRIM('retv_vars.10693_0029_004.cdf') + TES(3022)%FILENAME = TRIM('retv_vars.10693_0030_002.cdf') + TES(3023)%FILENAME = TRIM('retv_vars.10693_0030_003.cdf') + TES(3024)%FILENAME = TRIM('retv_vars.10693_0031_002.cdf') + TES(3025)%FILENAME = TRIM('retv_vars.10693_0031_003.cdf') + TES(3026)%FILENAME = TRIM('retv_vars.10693_0031_004.cdf') + TES(3027)%FILENAME = TRIM('retv_vars.10693_0032_002.cdf') + TES(3028)%FILENAME = TRIM('retv_vars.10693_0032_003.cdf') + TES(3029)%FILENAME = TRIM('retv_vars.10693_0059_003.cdf') + TES(3030)%FILENAME = TRIM('retv_vars.10693_0060_002.cdf') + TES(3031)%FILENAME = TRIM('retv_vars.10693_0060_003.cdf') + TES(3032)%FILENAME = TRIM('retv_vars.10693_0067_003.cdf') + TES(3033)%FILENAME = TRIM('retv_vars.10693_0070_003.cdf') + TES(3034)%FILENAME = TRIM('retv_vars.10693_0071_002.cdf') + TES(3035)%FILENAME = TRIM('retv_vars.10693_0075_002.cdf') + TES(3036)%FILENAME = TRIM('retv_vars.10693_0075_003.cdf') + TES(3037)%FILENAME = TRIM('retv_vars.10693_0100_003.cdf') + TES(3038)%FILENAME = TRIM('retv_vars.10693_0100_004.cdf') + TES(3039)%FILENAME = TRIM('retv_vars.10693_0101_002.cdf') + TES(3040)%FILENAME = TRIM('retv_vars.10693_0101_003.cdf') + TES(3041)%FILENAME = TRIM('retv_vars.10693_0101_004.cdf') + TES(3042)%FILENAME = TRIM('retv_vars.10693_0102_002.cdf') + TES(3043)%FILENAME = TRIM('retv_vars.10693_0102_004.cdf') + TES(3044)%FILENAME = TRIM('retv_vars.10693_0103_002.cdf') + TES(3045)%FILENAME = TRIM('retv_vars.10693_0103_004.cdf') + TES(3046)%FILENAME = TRIM('retv_vars.10693_0104_003.cdf') + TES(3047)%FILENAME = TRIM('retv_vars.10693_0104_004.cdf') + TES(3048)%FILENAME = TRIM('retv_vars.10693_0105_002.cdf') + TES(3049)%FILENAME = TRIM('retv_vars.10693_0105_004.cdf') + TES(3050)%FILENAME = TRIM('retv_vars.10693_0106_002.cdf') + TES(3051)%FILENAME = TRIM('retv_vars.10693_0106_003.cdf') + TES(3052)%FILENAME = TRIM('retv_vars.10693_0107_004.cdf') + TES(3053)%FILENAME = TRIM('retv_vars.10693_0108_002.cdf') + TES(3054)%FILENAME = TRIM('retv_vars.10693_0108_003.cdf') + TES(3055)%FILENAME = TRIM('retv_vars.10693_0108_004.cdf') + TES(3056)%FILENAME = TRIM('retv_vars.10693_0109_002.cdf') + TES(3057)%FILENAME = TRIM('retv_vars.10693_0109_003.cdf') + TES(3058)%FILENAME = TRIM('retv_vars.10693_0110_004.cdf') + TES(3059)%FILENAME = TRIM('retv_vars.10693_0139_003.cdf') + TES(3060)%FILENAME = TRIM('retv_vars.10693_0143_002.cdf') + TES(3061)%FILENAME = TRIM('retv_vars.10693_0143_003.cdf') + TES(3062)%FILENAME = TRIM('retv_vars.10693_0156_002.cdf') + TES(3063)%FILENAME = TRIM('retv_vars.10693_0159_002.cdf') + TES(3064)%FILENAME = TRIM('retv_vars.10693_0231_004.cdf') + TES(3065)%FILENAME = TRIM('retv_vars.10693_0233_003.cdf') + TES(3066)%FILENAME = TRIM('retv_vars.10693_0233_004.cdf') + TES(3067)%FILENAME = TRIM('retv_vars.10693_0234_003.cdf') + TES(3068)%FILENAME = TRIM('retv_vars.10693_0237_003.cdf') + TES(3069)%FILENAME = TRIM('retv_vars.10693_0245_004.cdf') + TES(3070)%FILENAME = TRIM('retv_vars.10693_0247_002.cdf') + TES(3071)%FILENAME = TRIM('retv_vars.10693_0247_003.cdf') + TES(3072)%FILENAME = TRIM('retv_vars.10693_0247_004.cdf') + TES(3073)%FILENAME = TRIM('retv_vars.10693_0248_002.cdf') + TES(3074)%FILENAME = TRIM('retv_vars.10693_0248_003.cdf') + TES(3075)%FILENAME = TRIM('retv_vars.10693_0248_004.cdf') + TES(3076)%FILENAME = TRIM('retv_vars.10693_0249_002.cdf') + TES(3077)%FILENAME = TRIM('retv_vars.10693_0249_003.cdf') + TES(3078)%FILENAME = TRIM('retv_vars.10693_0250_004.cdf') + TES(3079)%FILENAME = TRIM('retv_vars.10693_0251_002.cdf') + TES(3080)%FILENAME = TRIM('retv_vars.10693_0251_003.cdf') + TES(3081)%FILENAME = TRIM('retv_vars.10693_0251_004.cdf') + TES(3082)%FILENAME = TRIM('retv_vars.10693_0261_003.cdf') + TES(3083)%FILENAME = TRIM('retv_vars.10693_0262_003.cdf') + TES(3084)%FILENAME = TRIM('retv_vars.10693_0262_004.cdf') + TES(3085)%FILENAME = TRIM('retv_vars.10693_0263_002.cdf') + TES(3086)%FILENAME = TRIM('retv_vars.10693_0267_002.cdf') + TES(3087)%FILENAME = TRIM('retv_vars.10693_0267_003.cdf') + TES(3088)%FILENAME = TRIM('retv_vars.10693_0267_004.cdf') + TES(3089)%FILENAME = TRIM('retv_vars.10693_0268_002.cdf') + TES(3090)%FILENAME = TRIM('retv_vars.10693_0268_003.cdf') + TES(3091)%FILENAME = TRIM('retv_vars.10693_0269_003.cdf') + TES(3092)%FILENAME = TRIM('retv_vars.10693_0271_003.cdf') + TES(3093)%FILENAME = TRIM('retv_vars.10693_0272_004.cdf') + TES(3094)%FILENAME = TRIM('retv_vars.10693_0273_002.cdf') + TES(3095)%FILENAME = TRIM('retv_vars.10693_0279_003.cdf') + TES(3096)%FILENAME = TRIM('retv_vars.10693_0279_004.cdf') + TES(3097)%FILENAME = TRIM('retv_vars.10693_0289_003.cdf') + TES(3098)%FILENAME = TRIM('retv_vars.10693_0289_004.cdf') + TES(3099)%FILENAME = TRIM('retv_vars.10693_0290_002.cdf') + TES(3100)%FILENAME = TRIM('retv_vars.10693_0290_003.cdf') + TES(3101)%FILENAME = TRIM('retv_vars.10693_0290_004.cdf') + TES(3102)%FILENAME = TRIM('retv_vars.10693_0291_002.cdf') + TES(3103)%FILENAME = TRIM('retv_vars.10693_0291_003.cdf') + TES(3104)%FILENAME = TRIM('retv_vars.10693_0291_004.cdf') + TES(3105)%FILENAME = TRIM('retv_vars.10693_0297_004.cdf') + TES(3106)%FILENAME = TRIM('retv_vars.10693_0298_002.cdf') + TES(3107)%FILENAME = TRIM('retv_vars.10693_0298_004.cdf') + TES(3108)%FILENAME = TRIM('retv_vars.10693_0300_004.cdf') + TES(3109)%FILENAME = TRIM('retv_vars.10693_0302_002.cdf') + TES(3110)%FILENAME = TRIM('retv_vars.10693_0305_003.cdf') + TES(3111)%FILENAME = TRIM('retv_vars.10693_0305_004.cdf') + TES(3112)%FILENAME = TRIM('retv_vars.10693_0307_003.cdf') + TES(3113)%FILENAME = TRIM('retv_vars.10693_0308_003.cdf') + TES(3114)%FILENAME = TRIM('retv_vars.10693_0309_003.cdf') + TES(3115)%FILENAME = TRIM('retv_vars.10693_0310_002.cdf') + TES(3116)%FILENAME = TRIM('retv_vars.10693_0310_003.cdf') + TES(3117)%FILENAME = TRIM('retv_vars.10693_0315_002.cdf') + TES(3118)%FILENAME = TRIM('retv_vars.10693_0316_004.cdf') + TES(3119)%FILENAME = TRIM('retv_vars.10693_0317_002.cdf') + TES(3120)%FILENAME = TRIM('retv_vars.10693_0317_003.cdf') + TES(3121)%FILENAME = TRIM('retv_vars.10693_0319_003.cdf') + TES(3122)%FILENAME = TRIM('retv_vars.10693_0320_002.cdf') + TES(3123)%FILENAME = TRIM('retv_vars.10693_0320_004.cdf') + TES(3124)%FILENAME = TRIM('retv_vars.10693_0321_002.cdf') + TES(3125)%FILENAME = TRIM('retv_vars.10693_0354_003.cdf') + TES(3126)%FILENAME = TRIM('retv_vars.10693_0354_004.cdf') + TES(3127)%FILENAME = TRIM('retv_vars.10693_0355_003.cdf') + TES(3128)%FILENAME = TRIM('retv_vars.10693_0356_004.cdf') + TES(3129)%FILENAME = TRIM('retv_vars.10693_0357_002.cdf') + TES(3130)%FILENAME = TRIM('retv_vars.10693_0357_003.cdf') + TES(3131)%FILENAME = TRIM('retv_vars.10693_0357_004.cdf') + TES(3132)%FILENAME = TRIM('retv_vars.10693_0358_002.cdf') + TES(3133)%FILENAME = TRIM('retv_vars.10693_0358_003.cdf') + TES(3134)%FILENAME = TRIM('retv_vars.10693_0363_003.cdf') + TES(3135)%FILENAME = TRIM('retv_vars.10693_0364_003.cdf') + TES(3136)%FILENAME = TRIM('retv_vars.10693_0365_002.cdf') + TES(3137)%FILENAME = TRIM('retv_vars.10693_0365_003.cdf') + TES(3138)%FILENAME = TRIM('retv_vars.10693_0365_004.cdf') + TES(3139)%FILENAME = TRIM('retv_vars.10693_0366_004.cdf') + TES(3140)%FILENAME = TRIM('retv_vars.10693_0367_004.cdf') + TES(3141)%FILENAME = TRIM('retv_vars.10693_0368_004.cdf') + TES(3142)%FILENAME = TRIM('retv_vars.10693_0369_003.cdf') + TES(3143)%FILENAME = TRIM('retv_vars.10693_0369_004.cdf') + TES(3144)%FILENAME = TRIM('retv_vars.10693_0370_003.cdf') + TES(3145)%FILENAME = TRIM('retv_vars.10693_0411_003.cdf') + TES(3146)%FILENAME = TRIM('retv_vars.10693_0412_002.cdf') + TES(3147)%FILENAME = TRIM('retv_vars.10693_0412_004.cdf') + TES(3148)%FILENAME = TRIM('retv_vars.10693_0413_002.cdf') + TES(3149)%FILENAME = TRIM('retv_vars.10693_0415_004.cdf') + TES(3150)%FILENAME = TRIM('retv_vars.10693_0421_002.cdf') + TES(3151)%FILENAME = TRIM('retv_vars.10693_0421_004.cdf') + TES(3152)%FILENAME = TRIM('retv_vars.10693_0422_003.cdf') + TES(3153)%FILENAME = TRIM('retv_vars.10693_0422_004.cdf') + TES(3154)%FILENAME = TRIM('retv_vars.10693_0423_002.cdf') + TES(3155)%FILENAME = TRIM('retv_vars.10693_0423_003.cdf') + TES(3156)%FILENAME = TRIM('retv_vars.10693_0423_004.cdf') + TES(3157)%FILENAME = TRIM('retv_vars.10693_0424_003.cdf') + TES(3158)%FILENAME = TRIM('retv_vars.10693_0425_003.cdf') + TES(3159)%FILENAME = TRIM('retv_vars.10693_0425_004.cdf') + TES(3160)%FILENAME = TRIM('retv_vars.10693_0426_002.cdf') + TES(3161)%FILENAME = TRIM('retv_vars.10693_0426_003.cdf') + TES(3162)%FILENAME = TRIM('retv_vars.10693_0426_004.cdf') + TES(3163)%FILENAME = TRIM('retv_vars.10693_0447_003.cdf') + TES(3164)%FILENAME = TRIM('retv_vars.10693_0459_003.cdf') + TES(3165)%FILENAME = TRIM('retv_vars.10693_0459_004.cdf') + TES(3166)%FILENAME = TRIM('retv_vars.10693_0461_002.cdf') + TES(3167)%FILENAME = TRIM('retv_vars.10693_0461_004.cdf') + TES(3168)%FILENAME = TRIM('retv_vars.10693_0462_003.cdf') + TES(3169)%FILENAME = TRIM('retv_vars.10693_0462_004.cdf') + TES(3170)%FILENAME = TRIM('retv_vars.10693_0463_002.cdf') + TES(3171)%FILENAME = TRIM('retv_vars.10693_0463_003.cdf') + TES(3172)%FILENAME = TRIM('retv_vars.10693_0465_003.cdf') + TES(3173)%FILENAME = TRIM('retv_vars.10693_0466_002.cdf') + TES(3174)%FILENAME = TRIM('retv_vars.10693_0466_003.cdf') + TES(3175)%FILENAME = TRIM('retv_vars.10693_0469_002.cdf') + TES(3176)%FILENAME = TRIM('retv_vars.10693_0469_003.cdf') + TES(3177)%FILENAME = TRIM('retv_vars.10693_0470_004.cdf') + TES(3178)%FILENAME = TRIM('retv_vars.10693_0471_002.cdf') + TES(3179)%FILENAME = TRIM('retv_vars.10693_0471_003.cdf') + TES(3180)%FILENAME = TRIM('retv_vars.10693_0471_004.cdf') + TES(3181)%FILENAME = TRIM('retv_vars.10693_0503_002.cdf') + TES(3182)%FILENAME = TRIM('retv_vars.10693_0509_002.cdf') + TES(3183)%FILENAME = TRIM('retv_vars.10693_0509_003.cdf') + TES(3184)%FILENAME = TRIM('retv_vars.10693_0512_004.cdf') + TES(3185)%FILENAME = TRIM('retv_vars.10693_0515_002.cdf') + TES(3186)%FILENAME = TRIM('retv_vars.10693_0516_003.cdf') + TES(3187)%FILENAME = TRIM('retv_vars.10693_0517_002.cdf') + TES(3188)%FILENAME = TRIM('retv_vars.10693_0517_003.cdf') + TES(3189)%FILENAME = TRIM('retv_vars.10693_0549_003.cdf') + TES(3190)%FILENAME = TRIM('retv_vars.10693_0568_004.cdf') + TES(3191)%FILENAME = TRIM('retv_vars.10693_0569_002.cdf') + TES(3192)%FILENAME = TRIM('retv_vars.10693_0569_003.cdf') + TES(3193)%FILENAME = TRIM('retv_vars.10693_0569_004.cdf') + TES(3194)%FILENAME = TRIM('retv_vars.10693_0570_003.cdf') + TES(3195)%FILENAME = TRIM('retv_vars.10693_0570_004.cdf') + TES(3196)%FILENAME = TRIM('retv_vars.10693_0571_002.cdf') + TES(3197)%FILENAME = TRIM('retv_vars.10693_0571_003.cdf') + TES(3198)%FILENAME = TRIM('retv_vars.10693_0571_004.cdf') + TES(3199)%FILENAME = TRIM('retv_vars.10693_0579_004.cdf') + TES(3200)%FILENAME = TRIM('retv_vars.10693_0580_002.cdf') + TES(3201)%FILENAME = TRIM('retv_vars.10693_0581_002.cdf') + TES(3202)%FILENAME = TRIM('retv_vars.10693_0584_002.cdf') + TES(3203)%FILENAME = TRIM('retv_vars.10693_0594_003.cdf') + TES(3204)%FILENAME = TRIM('retv_vars.10693_0594_004.cdf') + TES(3205)%FILENAME = TRIM('retv_vars.10693_0595_003.cdf') + TES(3206)%FILENAME = TRIM('retv_vars.10693_0596_004.cdf') + TES(3207)%FILENAME = TRIM('retv_vars.10693_0597_002.cdf') + TES(3208)%FILENAME = TRIM('retv_vars.10693_0597_003.cdf') + TES(3209)%FILENAME = TRIM('retv_vars.10693_0598_003.cdf') + TES(3210)%FILENAME = TRIM('retv_vars.10693_0613_003.cdf') + TES(3211)%FILENAME = TRIM('retv_vars.10693_0613_004.cdf') + TES(3212)%FILENAME = TRIM('retv_vars.10693_0614_002.cdf') + TES(3213)%FILENAME = TRIM('retv_vars.10693_0615_002.cdf') + TES(3214)%FILENAME = TRIM('retv_vars.10693_0616_004.cdf') + TES(3215)%FILENAME = TRIM('retv_vars.10693_0617_004.cdf') + TES(3216)%FILENAME = TRIM('retv_vars.10693_0618_003.cdf') + TES(3217)%FILENAME = TRIM('retv_vars.10693_0619_002.cdf') + TES(3218)%FILENAME = TRIM('retv_vars.10693_0620_004.cdf') + TES(3219)%FILENAME = TRIM('retv_vars.10693_0621_004.cdf') + TES(3220)%FILENAME = TRIM('retv_vars.10693_0622_002.cdf') + TES(3221)%FILENAME = TRIM('retv_vars.10693_0622_003.cdf') + TES(3222)%FILENAME = TRIM('retv_vars.10693_0622_004.cdf') + TES(3223)%FILENAME = TRIM('retv_vars.10693_0623_002.cdf') + TES(3224)%FILENAME = TRIM('retv_vars.10693_0623_003.cdf') + TES(3225)%FILENAME = TRIM('retv_vars.10693_0623_004.cdf') + TES(3226)%FILENAME = TRIM('retv_vars.10693_0624_002.cdf') + TES(3227)%FILENAME = TRIM('retv_vars.10693_0624_003.cdf') + TES(3228)%FILENAME = TRIM('retv_vars.10693_0624_004.cdf') + TES(3229)%FILENAME = TRIM('retv_vars.10693_0633_003.cdf') + TES(3230)%FILENAME = TRIM('retv_vars.10693_0637_004.cdf') + TES(3231)%FILENAME = TRIM('retv_vars.10693_0638_002.cdf') + TES(3232)%FILENAME = TRIM('retv_vars.10693_0639_004.cdf') + TES(3233)%FILENAME = TRIM('retv_vars.10693_0642_002.cdf') + TES(3234)%FILENAME = TRIM('retv_vars.10693_0642_004.cdf') + TES(3235)%FILENAME = TRIM('retv_vars.10693_0643_003.cdf') + TES(3236)%FILENAME = TRIM('retv_vars.10693_0643_004.cdf') + TES(3237)%FILENAME = TRIM('retv_vars.10693_0644_002.cdf') + TES(3238)%FILENAME = TRIM('retv_vars.10693_0644_003.cdf') + TES(3239)%FILENAME = TRIM('retv_vars.10693_0645_003.cdf') + TES(3240)%FILENAME = TRIM('retv_vars.10693_0645_004.cdf') + TES(3241)%FILENAME = TRIM('retv_vars.10693_0646_002.cdf') + TES(3242)%FILENAME = TRIM('retv_vars.10693_0646_004.cdf') + TES(3243)%FILENAME = TRIM('retv_vars.10693_0651_003.cdf') + TES(3244)%FILENAME = TRIM('retv_vars.10693_0651_004.cdf') + TES(3245)%FILENAME = TRIM('retv_vars.10693_0652_004.cdf') + TES(3246)%FILENAME = TRIM('retv_vars.10693_0653_002.cdf') + TES(3247)%FILENAME = TRIM('retv_vars.10693_0654_002.cdf') + TES(3248)%FILENAME = TRIM('retv_vars.10693_0655_002.cdf') + TES(3249)%FILENAME = TRIM('retv_vars.10693_0656_002.cdf') + TES(3250)%FILENAME = TRIM('retv_vars.10693_0657_004.cdf') + TES(3251)%FILENAME = TRIM('retv_vars.10693_0661_002.cdf') + TES(3252)%FILENAME = TRIM('retv_vars.10693_0684_003.cdf') + TES(3253)%FILENAME = TRIM('retv_vars.10693_0684_004.cdf') + TES(3254)%FILENAME = TRIM('retv_vars.10693_0685_004.cdf') + TES(3255)%FILENAME = TRIM('retv_vars.10693_0686_002.cdf') + TES(3256)%FILENAME = TRIM('retv_vars.10693_0687_002.cdf') + TES(3257)%FILENAME = TRIM('retv_vars.10693_0691_003.cdf') + TES(3258)%FILENAME = TRIM('retv_vars.10693_0691_004.cdf') + TES(3259)%FILENAME = TRIM('retv_vars.10693_0692_002.cdf') + TES(3260)%FILENAME = TRIM('retv_vars.10693_0693_002.cdf') + TES(3261)%FILENAME = TRIM('retv_vars.10693_0693_003.cdf') + TES(3262)%FILENAME = TRIM('retv_vars.10693_0694_003.cdf') + TES(3263)%FILENAME = TRIM('retv_vars.10693_0694_004.cdf') + TES(3264)%FILENAME = TRIM('retv_vars.10693_0695_002.cdf') + TES(3265)%FILENAME = TRIM('retv_vars.10693_0699_003.cdf') + TES(3266)%FILENAME = TRIM('retv_vars.10693_0700_002.cdf') + TES(3267)%FILENAME = TRIM('retv_vars.10693_0700_003.cdf') + TES(3268)%FILENAME = TRIM('retv_vars.10693_0700_004.cdf') + TES(3269)%FILENAME = TRIM('retv_vars.10693_0701_004.cdf') + TES(3270)%FILENAME = TRIM('retv_vars.10693_0702_004.cdf') + TES(3271)%FILENAME = TRIM('retv_vars.10693_0703_002.cdf') + TES(3272)%FILENAME = TRIM('retv_vars.10693_0705_002.cdf') + TES(3273)%FILENAME = TRIM('retv_vars.10693_0705_003.cdf') + TES(3274)%FILENAME = TRIM('retv_vars.10693_0705_004.cdf') + TES(3275)%FILENAME = TRIM('retv_vars.10693_0706_002.cdf') + TES(3276)%FILENAME = TRIM('retv_vars.10693_0706_003.cdf') + TES(3277)%FILENAME = TRIM('retv_vars.10693_0735_003.cdf') + TES(3278)%FILENAME = TRIM('retv_vars.10693_0737_004.cdf') + TES(3279)%FILENAME = TRIM('retv_vars.10693_0738_004.cdf') + TES(3280)%FILENAME = TRIM('retv_vars.10693_0741_003.cdf') + TES(3281)%FILENAME = TRIM('retv_vars.10693_0742_002.cdf') + TES(3282)%FILENAME = TRIM('retv_vars.10693_0742_003.cdf') + TES(3283)%FILENAME = TRIM('retv_vars.10693_0743_002.cdf') + TES(3284)%FILENAME = TRIM('retv_vars.10693_0747_003.cdf') + TES(3285)%FILENAME = TRIM('retv_vars.10693_0747_004.cdf') + TES(3286)%FILENAME = TRIM('retv_vars.10693_0748_002.cdf') + TES(3287)%FILENAME = TRIM('retv_vars.10693_0748_004.cdf') + TES(3288)%FILENAME = TRIM('retv_vars.10693_0749_002.cdf') + TES(3289)%FILENAME = TRIM('retv_vars.10693_0749_004.cdf') + TES(3290)%FILENAME = TRIM('retv_vars.10695_0021_004.cdf') + TES(3291)%FILENAME = TRIM('retv_vars.10695_0023_002.cdf') + TES(3292)%FILENAME = TRIM('retv_vars.10695_0027_003.cdf') + TES(3293)%FILENAME = TRIM('retv_vars.10695_0027_004.cdf') + TES(3294)%FILENAME = TRIM('retv_vars.10695_0030_002.cdf') + TES(3295)%FILENAME = TRIM('retv_vars.10695_0030_004.cdf') + TES(3296)%FILENAME = TRIM('retv_vars.10695_0031_003.cdf') + TES(3297)%FILENAME = TRIM('retv_vars.10695_0031_004.cdf') + TES(3298)%FILENAME = TRIM('retv_vars.10695_0059_003.cdf') + TES(3299)%FILENAME = TRIM('retv_vars.10695_0060_003.cdf') + TES(3300)%FILENAME = TRIM('retv_vars.10695_0060_004.cdf') + TES(3301)%FILENAME = TRIM('retv_vars.10695_0062_003.cdf') + TES(3302)%FILENAME = TRIM('retv_vars.10695_0067_002.cdf') + TES(3303)%FILENAME = TRIM('retv_vars.10695_0068_002.cdf') + TES(3304)%FILENAME = TRIM('retv_vars.10695_0068_003.cdf') + TES(3305)%FILENAME = TRIM('retv_vars.10695_0071_002.cdf') + TES(3306)%FILENAME = TRIM('retv_vars.10695_0075_002.cdf') + TES(3307)%FILENAME = TRIM('retv_vars.10695_0075_004.cdf') + TES(3308)%FILENAME = TRIM('retv_vars.10695_0100_004.cdf') + TES(3309)%FILENAME = TRIM('retv_vars.10695_0101_002.cdf') + TES(3310)%FILENAME = TRIM('retv_vars.10695_0101_003.cdf') + TES(3311)%FILENAME = TRIM('retv_vars.10695_0101_004.cdf') + TES(3312)%FILENAME = TRIM('retv_vars.10695_0102_003.cdf') + TES(3313)%FILENAME = TRIM('retv_vars.10695_0102_004.cdf') + TES(3314)%FILENAME = TRIM('retv_vars.10695_0103_004.cdf') + TES(3315)%FILENAME = TRIM('retv_vars.10695_0104_002.cdf') + TES(3316)%FILENAME = TRIM('retv_vars.10695_0104_003.cdf') + TES(3317)%FILENAME = TRIM('retv_vars.10695_0104_004.cdf') + TES(3318)%FILENAME = TRIM('retv_vars.10695_0105_003.cdf') + TES(3319)%FILENAME = TRIM('retv_vars.10695_0106_002.cdf') + TES(3320)%FILENAME = TRIM('retv_vars.10695_0106_003.cdf') + TES(3321)%FILENAME = TRIM('retv_vars.10695_0107_003.cdf') + TES(3322)%FILENAME = TRIM('retv_vars.10695_0107_004.cdf') + TES(3323)%FILENAME = TRIM('retv_vars.10695_0110_004.cdf') + TES(3324)%FILENAME = TRIM('retv_vars.10695_0112_003.cdf') + TES(3325)%FILENAME = TRIM('retv_vars.10695_0114_004.cdf') + TES(3326)%FILENAME = TRIM('retv_vars.10695_0116_002.cdf') + TES(3327)%FILENAME = TRIM('retv_vars.10695_0116_003.cdf') + TES(3328)%FILENAME = TRIM('retv_vars.10695_0116_004.cdf') + TES(3329)%FILENAME = TRIM('retv_vars.10695_0117_002.cdf') + TES(3330)%FILENAME = TRIM('retv_vars.10695_0117_003.cdf') + TES(3331)%FILENAME = TRIM('retv_vars.10695_0117_004.cdf') + TES(3332)%FILENAME = TRIM('retv_vars.10695_0156_004.cdf') + TES(3333)%FILENAME = TRIM('retv_vars.10695_0157_002.cdf') + TES(3334)%FILENAME = TRIM('retv_vars.10695_0157_003.cdf') + TES(3335)%FILENAME = TRIM('retv_vars.10695_0158_003.cdf') + TES(3336)%FILENAME = TRIM('retv_vars.10695_0181_002.cdf') + TES(3337)%FILENAME = TRIM('retv_vars.10695_0234_003.cdf') + TES(3338)%FILENAME = TRIM('retv_vars.10695_0234_004.cdf') + TES(3339)%FILENAME = TRIM('retv_vars.10695_0237_003.cdf') + TES(3340)%FILENAME = TRIM('retv_vars.10695_0247_002.cdf') + TES(3341)%FILENAME = TRIM('retv_vars.10695_0247_004.cdf') + TES(3342)%FILENAME = TRIM('retv_vars.10695_0248_003.cdf') + TES(3343)%FILENAME = TRIM('retv_vars.10695_0249_003.cdf') + TES(3344)%FILENAME = TRIM('retv_vars.10695_0249_004.cdf') + TES(3345)%FILENAME = TRIM('retv_vars.10695_0250_003.cdf') + TES(3346)%FILENAME = TRIM('retv_vars.10695_0251_002.cdf') + TES(3347)%FILENAME = TRIM('retv_vars.10695_0260_002.cdf') + TES(3348)%FILENAME = TRIM('retv_vars.10695_0262_004.cdf') + TES(3349)%FILENAME = TRIM('retv_vars.10695_0263_002.cdf') + TES(3350)%FILENAME = TRIM('retv_vars.10695_0267_004.cdf') + TES(3351)%FILENAME = TRIM('retv_vars.10695_0268_002.cdf') + TES(3352)%FILENAME = TRIM('retv_vars.10695_0268_003.cdf') + TES(3353)%FILENAME = TRIM('retv_vars.10695_0269_002.cdf') + TES(3354)%FILENAME = TRIM('retv_vars.10695_0269_003.cdf') + TES(3355)%FILENAME = TRIM('retv_vars.10695_0269_004.cdf') + TES(3356)%FILENAME = TRIM('retv_vars.10695_0270_003.cdf') + TES(3357)%FILENAME = TRIM('retv_vars.10695_0270_004.cdf') + TES(3358)%FILENAME = TRIM('retv_vars.10695_0271_002.cdf') + TES(3359)%FILENAME = TRIM('retv_vars.10695_0279_004.cdf') + TES(3360)%FILENAME = TRIM('retv_vars.10695_0280_004.cdf') + TES(3361)%FILENAME = TRIM('retv_vars.10695_0290_002.cdf') + TES(3362)%FILENAME = TRIM('retv_vars.10695_0290_003.cdf') + TES(3363)%FILENAME = TRIM('retv_vars.10695_0290_004.cdf') + TES(3364)%FILENAME = TRIM('retv_vars.10695_0291_002.cdf') + TES(3365)%FILENAME = TRIM('retv_vars.10695_0291_004.cdf') + TES(3366)%FILENAME = TRIM('retv_vars.10695_0292_002.cdf') + TES(3367)%FILENAME = TRIM('retv_vars.10695_0293_002.cdf') + TES(3368)%FILENAME = TRIM('retv_vars.10695_0296_003.cdf') + TES(3369)%FILENAME = TRIM('retv_vars.10695_0296_004.cdf') + TES(3370)%FILENAME = TRIM('retv_vars.10695_0297_004.cdf') + TES(3371)%FILENAME = TRIM('retv_vars.10695_0298_002.cdf') + TES(3372)%FILENAME = TRIM('retv_vars.10695_0298_003.cdf') + TES(3373)%FILENAME = TRIM('retv_vars.10695_0298_004.cdf') + TES(3374)%FILENAME = TRIM('retv_vars.10695_0306_002.cdf') + TES(3375)%FILENAME = TRIM('retv_vars.10695_0306_003.cdf') + TES(3376)%FILENAME = TRIM('retv_vars.10695_0306_004.cdf') + TES(3377)%FILENAME = TRIM('retv_vars.10695_0307_002.cdf') + TES(3378)%FILENAME = TRIM('retv_vars.10695_0307_004.cdf') + TES(3379)%FILENAME = TRIM('retv_vars.10695_0310_002.cdf') + TES(3380)%FILENAME = TRIM('retv_vars.10695_0310_004.cdf') + TES(3381)%FILENAME = TRIM('retv_vars.10695_0315_003.cdf') + TES(3382)%FILENAME = TRIM('retv_vars.10695_0315_004.cdf') + TES(3383)%FILENAME = TRIM('retv_vars.10695_0316_003.cdf') + TES(3384)%FILENAME = TRIM('retv_vars.10695_0316_004.cdf') + TES(3385)%FILENAME = TRIM('retv_vars.10695_0317_003.cdf') + TES(3386)%FILENAME = TRIM('retv_vars.10695_0317_004.cdf') + TES(3387)%FILENAME = TRIM('retv_vars.10695_0318_002.cdf') + TES(3388)%FILENAME = TRIM('retv_vars.10695_0319_003.cdf') + TES(3389)%FILENAME = TRIM('retv_vars.10695_0319_004.cdf') + TES(3390)%FILENAME = TRIM('retv_vars.10695_0320_002.cdf') + TES(3391)%FILENAME = TRIM('retv_vars.10695_0320_003.cdf') + TES(3392)%FILENAME = TRIM('retv_vars.10695_0325_002.cdf') + TES(3393)%FILENAME = TRIM('retv_vars.10695_0353_003.cdf') + TES(3394)%FILENAME = TRIM('retv_vars.10695_0354_003.cdf') + TES(3395)%FILENAME = TRIM('retv_vars.10695_0356_003.cdf') + TES(3396)%FILENAME = TRIM('retv_vars.10695_0356_004.cdf') + TES(3397)%FILENAME = TRIM('retv_vars.10695_0357_002.cdf') + TES(3398)%FILENAME = TRIM('retv_vars.10695_0357_003.cdf') + TES(3399)%FILENAME = TRIM('retv_vars.10695_0357_004.cdf') + TES(3400)%FILENAME = TRIM('retv_vars.10695_0358_002.cdf') + TES(3401)%FILENAME = TRIM('retv_vars.10695_0358_003.cdf') + TES(3402)%FILENAME = TRIM('retv_vars.10695_0359_002.cdf') + TES(3403)%FILENAME = TRIM('retv_vars.10695_0363_003.cdf') + TES(3404)%FILENAME = TRIM('retv_vars.10695_0363_004.cdf') + TES(3405)%FILENAME = TRIM('retv_vars.10695_0364_002.cdf') + TES(3406)%FILENAME = TRIM('retv_vars.10695_0364_003.cdf') + TES(3407)%FILENAME = TRIM('retv_vars.10695_0365_002.cdf') + TES(3408)%FILENAME = TRIM('retv_vars.10695_0365_003.cdf') + TES(3409)%FILENAME = TRIM('retv_vars.10695_0365_004.cdf') + TES(3410)%FILENAME = TRIM('retv_vars.10695_0366_002.cdf') + TES(3411)%FILENAME = TRIM('retv_vars.10695_0366_003.cdf') + TES(3412)%FILENAME = TRIM('retv_vars.10695_0367_002.cdf') + TES(3413)%FILENAME = TRIM('retv_vars.10695_0367_003.cdf') + TES(3414)%FILENAME = TRIM('retv_vars.10695_0368_004.cdf') + TES(3415)%FILENAME = TRIM('retv_vars.10695_0369_002.cdf') + TES(3416)%FILENAME = TRIM('retv_vars.10695_0369_004.cdf') + TES(3417)%FILENAME = TRIM('retv_vars.10695_0411_002.cdf') + TES(3418)%FILENAME = TRIM('retv_vars.10695_0411_003.cdf') + TES(3419)%FILENAME = TRIM('retv_vars.10695_0411_004.cdf') + TES(3420)%FILENAME = TRIM('retv_vars.10695_0412_002.cdf') + TES(3421)%FILENAME = TRIM('retv_vars.10695_0412_003.cdf') + TES(3422)%FILENAME = TRIM('retv_vars.10695_0415_004.cdf') + TES(3423)%FILENAME = TRIM('retv_vars.10695_0419_002.cdf') + TES(3424)%FILENAME = TRIM('retv_vars.10695_0419_003.cdf') + TES(3425)%FILENAME = TRIM('retv_vars.10695_0419_004.cdf') + TES(3426)%FILENAME = TRIM('retv_vars.10695_0420_004.cdf') + TES(3427)%FILENAME = TRIM('retv_vars.10695_0421_002.cdf') + TES(3428)%FILENAME = TRIM('retv_vars.10695_0421_003.cdf') + TES(3429)%FILENAME = TRIM('retv_vars.10695_0421_004.cdf') + TES(3430)%FILENAME = TRIM('retv_vars.10695_0422_002.cdf') + TES(3431)%FILENAME = TRIM('retv_vars.10695_0422_004.cdf') + TES(3432)%FILENAME = TRIM('retv_vars.10695_0423_002.cdf') + TES(3433)%FILENAME = TRIM('retv_vars.10695_0423_003.cdf') + TES(3434)%FILENAME = TRIM('retv_vars.10695_0423_004.cdf') + TES(3435)%FILENAME = TRIM('retv_vars.10695_0424_003.cdf') + TES(3436)%FILENAME = TRIM('retv_vars.10695_0424_004.cdf') + TES(3437)%FILENAME = TRIM('retv_vars.10695_0425_002.cdf') + TES(3438)%FILENAME = TRIM('retv_vars.10695_0425_003.cdf') + TES(3439)%FILENAME = TRIM('retv_vars.10695_0425_004.cdf') + TES(3440)%FILENAME = TRIM('retv_vars.10695_0426_002.cdf') + TES(3441)%FILENAME = TRIM('retv_vars.10695_0426_004.cdf') + TES(3442)%FILENAME = TRIM('retv_vars.10695_0427_004.cdf') + TES(3443)%FILENAME = TRIM('retv_vars.10695_0460_003.cdf') + TES(3444)%FILENAME = TRIM('retv_vars.10695_0460_004.cdf') + TES(3445)%FILENAME = TRIM('retv_vars.10695_0461_002.cdf') + TES(3446)%FILENAME = TRIM('retv_vars.10695_0461_003.cdf') + TES(3447)%FILENAME = TRIM('retv_vars.10695_0462_003.cdf') + TES(3448)%FILENAME = TRIM('retv_vars.10695_0462_004.cdf') + TES(3449)%FILENAME = TRIM('retv_vars.10695_0464_002.cdf') + TES(3450)%FILENAME = TRIM('retv_vars.10695_0465_003.cdf') + TES(3451)%FILENAME = TRIM('retv_vars.10695_0466_002.cdf') + TES(3452)%FILENAME = TRIM('retv_vars.10695_0466_004.cdf') + TES(3453)%FILENAME = TRIM('retv_vars.10695_0467_003.cdf') + TES(3454)%FILENAME = TRIM('retv_vars.10695_0469_002.cdf') + TES(3455)%FILENAME = TRIM('retv_vars.10695_0469_003.cdf') + TES(3456)%FILENAME = TRIM('retv_vars.10695_0470_004.cdf') + TES(3457)%FILENAME = TRIM('retv_vars.10695_0471_002.cdf') + TES(3458)%FILENAME = TRIM('retv_vars.10695_0471_004.cdf') + TES(3459)%FILENAME = TRIM('retv_vars.10695_0472_002.cdf') + TES(3460)%FILENAME = TRIM('retv_vars.10695_0472_003.cdf') + TES(3461)%FILENAME = TRIM('retv_vars.10695_0472_004.cdf') + TES(3462)%FILENAME = TRIM('retv_vars.10695_0474_002.cdf') + TES(3463)%FILENAME = TRIM('retv_vars.10695_0474_003.cdf') + TES(3464)%FILENAME = TRIM('retv_vars.10695_0507_002.cdf') + TES(3465)%FILENAME = TRIM('retv_vars.10695_0508_004.cdf') + TES(3466)%FILENAME = TRIM('retv_vars.10695_0509_002.cdf') + TES(3467)%FILENAME = TRIM('retv_vars.10695_0509_004.cdf') + TES(3468)%FILENAME = TRIM('retv_vars.10695_0510_002.cdf') + TES(3469)%FILENAME = TRIM('retv_vars.10695_0510_003.cdf') + TES(3470)%FILENAME = TRIM('retv_vars.10695_0510_004.cdf') + TES(3471)%FILENAME = TRIM('retv_vars.10695_0513_004.cdf') + TES(3472)%FILENAME = TRIM('retv_vars.10695_0514_003.cdf') + TES(3473)%FILENAME = TRIM('retv_vars.10695_0514_004.cdf') + TES(3474)%FILENAME = TRIM('retv_vars.10695_0516_002.cdf') + TES(3475)%FILENAME = TRIM('retv_vars.10695_0517_004.cdf') + TES(3476)%FILENAME = TRIM('retv_vars.10695_0530_002.cdf') + TES(3477)%FILENAME = TRIM('retv_vars.10695_0535_003.cdf') + TES(3478)%FILENAME = TRIM('retv_vars.10695_0568_004.cdf') + TES(3479)%FILENAME = TRIM('retv_vars.10695_0569_002.cdf') + TES(3480)%FILENAME = TRIM('retv_vars.10695_0579_003.cdf') + TES(3481)%FILENAME = TRIM('retv_vars.10695_0580_003.cdf') + TES(3482)%FILENAME = TRIM('retv_vars.10695_0582_003.cdf') + TES(3483)%FILENAME = TRIM('retv_vars.10695_0583_002.cdf') + TES(3484)%FILENAME = TRIM('retv_vars.10695_0583_003.cdf') + TES(3485)%FILENAME = TRIM('retv_vars.10695_0584_003.cdf') + TES(3486)%FILENAME = TRIM('retv_vars.10695_0586_003.cdf') + TES(3487)%FILENAME = TRIM('retv_vars.10695_0595_002.cdf') + TES(3488)%FILENAME = TRIM('retv_vars.10695_0595_003.cdf') + TES(3489)%FILENAME = TRIM('retv_vars.10695_0595_004.cdf') + TES(3490)%FILENAME = TRIM('retv_vars.10695_0596_002.cdf') + TES(3491)%FILENAME = TRIM('retv_vars.10695_0596_004.cdf') + TES(3492)%FILENAME = TRIM('retv_vars.10695_0597_002.cdf') + TES(3493)%FILENAME = TRIM('retv_vars.10695_0597_003.cdf') + TES(3494)%FILENAME = TRIM('retv_vars.10695_0597_004.cdf') + TES(3495)%FILENAME = TRIM('retv_vars.10695_0614_004.cdf') + TES(3496)%FILENAME = TRIM('retv_vars.10695_0615_002.cdf') + TES(3497)%FILENAME = TRIM('retv_vars.10695_0615_003.cdf') + TES(3498)%FILENAME = TRIM('retv_vars.10695_0615_004.cdf') + TES(3499)%FILENAME = TRIM('retv_vars.10695_0616_002.cdf') + TES(3500)%FILENAME = TRIM('retv_vars.10695_0616_004.cdf') + TES(3501)%FILENAME = TRIM('retv_vars.10695_0617_002.cdf') + TES(3502)%FILENAME = TRIM('retv_vars.10695_0617_003.cdf') + TES(3503)%FILENAME = TRIM('retv_vars.10695_0617_004.cdf') + TES(3504)%FILENAME = TRIM('retv_vars.10695_0618_002.cdf') + TES(3505)%FILENAME = TRIM('retv_vars.10695_0618_003.cdf') + TES(3506)%FILENAME = TRIM('retv_vars.10695_0621_002.cdf') + TES(3507)%FILENAME = TRIM('retv_vars.10695_0621_003.cdf') + TES(3508)%FILENAME = TRIM('retv_vars.10695_0622_002.cdf') + TES(3509)%FILENAME = TRIM('retv_vars.10695_0622_003.cdf') + TES(3510)%FILENAME = TRIM('retv_vars.10695_0622_004.cdf') + TES(3511)%FILENAME = TRIM('retv_vars.10695_0623_002.cdf') + TES(3512)%FILENAME = TRIM('retv_vars.10695_0623_003.cdf') + TES(3513)%FILENAME = TRIM('retv_vars.10695_0623_004.cdf') + TES(3514)%FILENAME = TRIM('retv_vars.10695_0624_002.cdf') + TES(3515)%FILENAME = TRIM('retv_vars.10695_0624_003.cdf') + TES(3516)%FILENAME = TRIM('retv_vars.10695_0628_002.cdf') + TES(3517)%FILENAME = TRIM('retv_vars.10695_0628_004.cdf') + TES(3518)%FILENAME = TRIM('retv_vars.10695_0629_002.cdf') + TES(3519)%FILENAME = TRIM('retv_vars.10695_0633_003.cdf') + TES(3520)%FILENAME = TRIM('retv_vars.10695_0634_004.cdf') + TES(3521)%FILENAME = TRIM('retv_vars.10695_0635_002.cdf') + TES(3522)%FILENAME = TRIM('retv_vars.10695_0640_002.cdf') + TES(3523)%FILENAME = TRIM('retv_vars.10695_0640_003.cdf') + TES(3524)%FILENAME = TRIM('retv_vars.10695_0640_004.cdf') + TES(3525)%FILENAME = TRIM('retv_vars.10695_0641_004.cdf') + TES(3526)%FILENAME = TRIM('retv_vars.10695_0642_003.cdf') + TES(3527)%FILENAME = TRIM('retv_vars.10695_0644_002.cdf') + TES(3528)%FILENAME = TRIM('retv_vars.10695_0644_004.cdf') + TES(3529)%FILENAME = TRIM('retv_vars.10695_0645_003.cdf') + TES(3530)%FILENAME = TRIM('retv_vars.10695_0646_003.cdf') + TES(3531)%FILENAME = TRIM('retv_vars.10695_0646_004.cdf') + TES(3532)%FILENAME = TRIM('retv_vars.10695_0647_002.cdf') + TES(3533)%FILENAME = TRIM('retv_vars.10695_0651_003.cdf') + TES(3534)%FILENAME = TRIM('retv_vars.10695_0652_002.cdf') + TES(3535)%FILENAME = TRIM('retv_vars.10695_0652_004.cdf') + TES(3536)%FILENAME = TRIM('retv_vars.10695_0653_002.cdf') + TES(3537)%FILENAME = TRIM('retv_vars.10695_0653_003.cdf') + TES(3538)%FILENAME = TRIM('retv_vars.10695_0654_002.cdf') + TES(3539)%FILENAME = TRIM('retv_vars.10695_0654_003.cdf') + TES(3540)%FILENAME = TRIM('retv_vars.10695_0654_004.cdf') + TES(3541)%FILENAME = TRIM('retv_vars.10695_0658_004.cdf') + TES(3542)%FILENAME = TRIM('retv_vars.10695_0660_003.cdf') + TES(3543)%FILENAME = TRIM('retv_vars.10695_0686_003.cdf') + TES(3544)%FILENAME = TRIM('retv_vars.10695_0687_003.cdf') + TES(3545)%FILENAME = TRIM('retv_vars.10695_0691_003.cdf') + TES(3546)%FILENAME = TRIM('retv_vars.10695_0692_002.cdf') + TES(3547)%FILENAME = TRIM('retv_vars.10695_0692_003.cdf') + TES(3548)%FILENAME = TRIM('retv_vars.10695_0693_002.cdf') + TES(3549)%FILENAME = TRIM('retv_vars.10695_0693_004.cdf') + TES(3550)%FILENAME = TRIM('retv_vars.10695_0694_002.cdf') + TES(3551)%FILENAME = TRIM('retv_vars.10695_0694_003.cdf') + TES(3552)%FILENAME = TRIM('retv_vars.10695_0694_004.cdf') + TES(3553)%FILENAME = TRIM('retv_vars.10695_0699_004.cdf') + TES(3554)%FILENAME = TRIM('retv_vars.10695_0700_002.cdf') + TES(3555)%FILENAME = TRIM('retv_vars.10695_0701_003.cdf') + TES(3556)%FILENAME = TRIM('retv_vars.10695_0701_004.cdf') + TES(3557)%FILENAME = TRIM('retv_vars.10695_0702_002.cdf') + TES(3558)%FILENAME = TRIM('retv_vars.10695_0702_003.cdf') + TES(3559)%FILENAME = TRIM('retv_vars.10695_0703_002.cdf') + TES(3560)%FILENAME = TRIM('retv_vars.10695_0703_003.cdf') + TES(3561)%FILENAME = TRIM('retv_vars.10695_0704_002.cdf') + TES(3562)%FILENAME = TRIM('retv_vars.10695_0704_003.cdf') + TES(3563)%FILENAME = TRIM('retv_vars.10695_0705_002.cdf') + TES(3564)%FILENAME = TRIM('retv_vars.10695_0705_003.cdf') + TES(3565)%FILENAME = TRIM('retv_vars.10695_0706_003.cdf') + TES(3566)%FILENAME = TRIM('retv_vars.10695_0706_004.cdf') + TES(3567)%FILENAME = TRIM('retv_vars.10695_0707_002.cdf') + TES(3568)%FILENAME = TRIM('retv_vars.10695_0743_002.cdf') + TES(3569)%FILENAME = TRIM('retv_vars.10695_0743_003.cdf') + TES(3570)%FILENAME = TRIM('retv_vars.10695_0747_003.cdf') + TES(3571)%FILENAME = TRIM('retv_vars.10695_0747_004.cdf') + TES(3572)%FILENAME = TRIM('retv_vars.10695_0748_002.cdf') + TES(3573)%FILENAME = TRIM('retv_vars.10695_0748_003.cdf') + TES(3574)%FILENAME = TRIM('retv_vars.10695_0748_004.cdf') + TES(3575)%FILENAME = TRIM('retv_vars.10703_0012_003.cdf') + TES(3576)%FILENAME = TRIM('retv_vars.10703_0013_002.cdf') + TES(3577)%FILENAME = TRIM('retv_vars.10703_0013_004.cdf') + TES(3578)%FILENAME = TRIM('retv_vars.10703_0019_002.cdf') + TES(3579)%FILENAME = TRIM('retv_vars.10703_0020_002.cdf') + TES(3580)%FILENAME = TRIM('retv_vars.10703_0021_004.cdf') + TES(3581)%FILENAME = TRIM('retv_vars.10703_0022_004.cdf') + TES(3582)%FILENAME = TRIM('retv_vars.10703_0027_004.cdf') + TES(3583)%FILENAME = TRIM('retv_vars.10703_0028_002.cdf') + TES(3584)%FILENAME = TRIM('retv_vars.10703_0053_002.cdf') + TES(3585)%FILENAME = TRIM('retv_vars.10703_0053_003.cdf') + TES(3586)%FILENAME = TRIM('retv_vars.10703_0054_002.cdf') + TES(3587)%FILENAME = TRIM('retv_vars.10703_0054_003.cdf') + TES(3588)%FILENAME = TRIM('retv_vars.10703_0054_004.cdf') + TES(3589)%FILENAME = TRIM('retv_vars.10703_0055_002.cdf') + TES(3590)%FILENAME = TRIM('retv_vars.10703_0055_004.cdf') + TES(3591)%FILENAME = TRIM('retv_vars.10703_0056_003.cdf') + TES(3592)%FILENAME = TRIM('retv_vars.10703_0057_003.cdf') + TES(3593)%FILENAME = TRIM('retv_vars.10703_0058_002.cdf') + TES(3594)%FILENAME = TRIM('retv_vars.10703_0058_003.cdf') + TES(3595)%FILENAME = TRIM('retv_vars.10703_0059_003.cdf') + TES(3596)%FILENAME = TRIM('retv_vars.10703_0059_004.cdf') + TES(3597)%FILENAME = TRIM('retv_vars.10703_0062_003.cdf') + TES(3598)%FILENAME = TRIM('retv_vars.10703_0067_003.cdf') + TES(3599)%FILENAME = TRIM('retv_vars.10703_0067_004.cdf') + TES(3600)%FILENAME = TRIM('retv_vars.10703_0068_003.cdf') + TES(3601)%FILENAME = TRIM('retv_vars.10703_0069_002.cdf') + TES(3602)%FILENAME = TRIM('retv_vars.10703_0069_004.cdf') + TES(3603)%FILENAME = TRIM('retv_vars.10703_0070_002.cdf') + TES(3604)%FILENAME = TRIM('retv_vars.10703_0108_003.cdf') + TES(3605)%FILENAME = TRIM('retv_vars.10703_0109_003.cdf') + TES(3606)%FILENAME = TRIM('retv_vars.10703_0110_003.cdf') + TES(3607)%FILENAME = TRIM('retv_vars.10703_0133_004.cdf') + TES(3608)%FILENAME = TRIM('retv_vars.10703_0172_002.cdf') + TES(3609)%FILENAME = TRIM('retv_vars.10703_0172_003.cdf') + TES(3610)%FILENAME = TRIM('retv_vars.10703_0172_004.cdf') + TES(3611)%FILENAME = TRIM('retv_vars.10703_0173_002.cdf') + TES(3612)%FILENAME = TRIM('retv_vars.10703_0186_004.cdf') + TES(3613)%FILENAME = TRIM('retv_vars.10703_0187_002.cdf') + TES(3614)%FILENAME = TRIM('retv_vars.10703_0187_003.cdf') + TES(3615)%FILENAME = TRIM('retv_vars.10703_0187_004.cdf') + TES(3616)%FILENAME = TRIM('retv_vars.10703_0190_002.cdf') + TES(3617)%FILENAME = TRIM('retv_vars.10703_0198_003.cdf') + TES(3618)%FILENAME = TRIM('retv_vars.10703_0198_004.cdf') + TES(3619)%FILENAME = TRIM('retv_vars.10703_0199_002.cdf') + TES(3620)%FILENAME = TRIM('retv_vars.10703_0199_003.cdf') + TES(3621)%FILENAME = TRIM('retv_vars.10703_0200_004.cdf') + TES(3622)%FILENAME = TRIM('retv_vars.10703_0201_004.cdf') + TES(3623)%FILENAME = TRIM('retv_vars.10703_0202_002.cdf') + TES(3624)%FILENAME = TRIM('retv_vars.10703_0202_004.cdf') + TES(3625)%FILENAME = TRIM('retv_vars.10703_0203_002.cdf') + TES(3626)%FILENAME = TRIM('retv_vars.10703_0212_002.cdf') + TES(3627)%FILENAME = TRIM('retv_vars.10703_0214_004.cdf') + TES(3628)%FILENAME = TRIM('retv_vars.10703_0220_002.cdf') + TES(3629)%FILENAME = TRIM('retv_vars.10703_0220_003.cdf') + TES(3630)%FILENAME = TRIM('retv_vars.10703_0220_004.cdf') + TES(3631)%FILENAME = TRIM('retv_vars.10703_0221_002.cdf') + TES(3632)%FILENAME = TRIM('retv_vars.10703_0221_004.cdf') + TES(3633)%FILENAME = TRIM('retv_vars.10703_0222_003.cdf') + TES(3634)%FILENAME = TRIM('retv_vars.10703_0222_004.cdf') + TES(3635)%FILENAME = TRIM('retv_vars.10703_0223_002.cdf') + TES(3636)%FILENAME = TRIM('retv_vars.10703_0223_003.cdf') + TES(3637)%FILENAME = TRIM('retv_vars.10703_0227_003.cdf') + TES(3638)%FILENAME = TRIM('retv_vars.10703_0228_002.cdf') + TES(3639)%FILENAME = TRIM('retv_vars.10703_0232_004.cdf') + TES(3640)%FILENAME = TRIM('retv_vars.10703_0242_003.cdf') + TES(3641)%FILENAME = TRIM('retv_vars.10703_0242_004.cdf') + TES(3642)%FILENAME = TRIM('retv_vars.10703_0243_002.cdf') + TES(3643)%FILENAME = TRIM('retv_vars.10703_0243_003.cdf') + TES(3644)%FILENAME = TRIM('retv_vars.10703_0244_002.cdf') + TES(3645)%FILENAME = TRIM('retv_vars.10703_0244_003.cdf') + TES(3646)%FILENAME = TRIM('retv_vars.10703_0244_004.cdf') + TES(3647)%FILENAME = TRIM('retv_vars.10703_0245_004.cdf') + TES(3648)%FILENAME = TRIM('retv_vars.10703_0246_002.cdf') + TES(3649)%FILENAME = TRIM('retv_vars.10703_0247_004.cdf') + TES(3650)%FILENAME = TRIM('retv_vars.10703_0249_002.cdf') + TES(3651)%FILENAME = TRIM('retv_vars.10703_0249_004.cdf') + TES(3652)%FILENAME = TRIM('retv_vars.10703_0250_004.cdf') + TES(3653)%FILENAME = TRIM('retv_vars.10703_0251_004.cdf') + TES(3654)%FILENAME = TRIM('retv_vars.10703_0255_003.cdf') + TES(3655)%FILENAME = TRIM('retv_vars.10703_0256_004.cdf') + TES(3656)%FILENAME = TRIM('retv_vars.10703_0257_002.cdf') + TES(3657)%FILENAME = TRIM('retv_vars.10703_0257_003.cdf') + TES(3658)%FILENAME = TRIM('retv_vars.10703_0258_004.cdf') + TES(3659)%FILENAME = TRIM('retv_vars.10703_0259_002.cdf') + TES(3660)%FILENAME = TRIM('retv_vars.10703_0259_004.cdf') + TES(3661)%FILENAME = TRIM('retv_vars.10703_0260_002.cdf') + TES(3662)%FILENAME = TRIM('retv_vars.10703_0260_003.cdf') + TES(3663)%FILENAME = TRIM('retv_vars.10703_0261_002.cdf') + TES(3664)%FILENAME = TRIM('retv_vars.10703_0261_003.cdf') + TES(3665)%FILENAME = TRIM('retv_vars.10703_0262_002.cdf') + TES(3666)%FILENAME = TRIM('retv_vars.10703_0262_003.cdf') + TES(3667)%FILENAME = TRIM('retv_vars.10703_0267_003.cdf') + TES(3668)%FILENAME = TRIM('retv_vars.10703_0269_002.cdf') + TES(3669)%FILENAME = TRIM('retv_vars.10703_0274_002.cdf') + TES(3670)%FILENAME = TRIM('retv_vars.10703_0274_003.cdf') + TES(3671)%FILENAME = TRIM('retv_vars.10703_0275_004.cdf') + TES(3672)%FILENAME = TRIM('retv_vars.10703_0303_002.cdf') + TES(3673)%FILENAME = TRIM('retv_vars.10703_0303_003.cdf') + TES(3674)%FILENAME = TRIM('retv_vars.10703_0303_004.cdf') + TES(3675)%FILENAME = TRIM('retv_vars.10703_0307_003.cdf') + TES(3676)%FILENAME = TRIM('retv_vars.10703_0307_004.cdf') + TES(3677)%FILENAME = TRIM('retv_vars.10703_0308_002.cdf') + TES(3678)%FILENAME = TRIM('retv_vars.10703_0309_002.cdf') + TES(3679)%FILENAME = TRIM('retv_vars.10703_0309_004.cdf') + TES(3680)%FILENAME = TRIM('retv_vars.10703_0310_002.cdf') + TES(3681)%FILENAME = TRIM('retv_vars.10703_0310_003.cdf') + TES(3682)%FILENAME = TRIM('retv_vars.10703_0310_004.cdf') + TES(3683)%FILENAME = TRIM('retv_vars.10703_0315_003.cdf') + TES(3684)%FILENAME = TRIM('retv_vars.10703_0316_002.cdf') + TES(3685)%FILENAME = TRIM('retv_vars.10703_0316_003.cdf') + TES(3686)%FILENAME = TRIM('retv_vars.10703_0316_004.cdf') + TES(3687)%FILENAME = TRIM('retv_vars.10703_0317_003.cdf') + TES(3688)%FILENAME = TRIM('retv_vars.10703_0318_002.cdf') + TES(3689)%FILENAME = TRIM('retv_vars.10703_0318_004.cdf') + TES(3690)%FILENAME = TRIM('retv_vars.10703_0319_004.cdf') + TES(3691)%FILENAME = TRIM('retv_vars.10703_0320_003.cdf') + TES(3692)%FILENAME = TRIM('retv_vars.10703_0322_003.cdf') + TES(3693)%FILENAME = TRIM('retv_vars.10703_0363_003.cdf') + TES(3694)%FILENAME = TRIM('retv_vars.10703_0363_004.cdf') + TES(3695)%FILENAME = TRIM('retv_vars.10703_0364_004.cdf') + TES(3696)%FILENAME = TRIM('retv_vars.10703_0365_002.cdf') + TES(3697)%FILENAME = TRIM('retv_vars.10703_0365_004.cdf') + TES(3698)%FILENAME = TRIM('retv_vars.10703_0369_002.cdf') + TES(3699)%FILENAME = TRIM('retv_vars.10703_0369_003.cdf') + TES(3700)%FILENAME = TRIM('retv_vars.10703_0371_003.cdf') + TES(3701)%FILENAME = TRIM('retv_vars.10703_0372_003.cdf') + TES(3702)%FILENAME = TRIM('retv_vars.10703_0374_004.cdf') + TES(3703)%FILENAME = TRIM('retv_vars.10703_0378_003.cdf') + TES(3704)%FILENAME = TRIM('retv_vars.10703_0406_002.cdf') + TES(3705)%FILENAME = TRIM('retv_vars.10703_0411_002.cdf') + TES(3706)%FILENAME = TRIM('retv_vars.10703_0411_003.cdf') + TES(3707)%FILENAME = TRIM('retv_vars.10703_0411_004.cdf') + TES(3708)%FILENAME = TRIM('retv_vars.10703_0414_004.cdf') + TES(3709)%FILENAME = TRIM('retv_vars.10703_0415_002.cdf') + TES(3710)%FILENAME = TRIM('retv_vars.10703_0415_003.cdf') + TES(3711)%FILENAME = TRIM('retv_vars.10703_0417_003.cdf') + TES(3712)%FILENAME = TRIM('retv_vars.10703_0417_004.cdf') + TES(3713)%FILENAME = TRIM('retv_vars.10703_0418_003.cdf') + TES(3714)%FILENAME = TRIM('retv_vars.10703_0422_003.cdf') + TES(3715)%FILENAME = TRIM('retv_vars.10703_0423_003.cdf') + TES(3716)%FILENAME = TRIM('retv_vars.10703_0423_004.cdf') + TES(3717)%FILENAME = TRIM('retv_vars.10703_0424_002.cdf') + TES(3718)%FILENAME = TRIM('retv_vars.10703_0424_003.cdf') + TES(3719)%FILENAME = TRIM('retv_vars.10703_0425_002.cdf') + TES(3720)%FILENAME = TRIM('retv_vars.10703_0425_004.cdf') + TES(3721)%FILENAME = TRIM('retv_vars.10703_0427_002.cdf') + TES(3722)%FILENAME = TRIM('retv_vars.10703_0427_003.cdf') + TES(3723)%FILENAME = TRIM('retv_vars.10703_0460_002.cdf') + TES(3724)%FILENAME = TRIM('retv_vars.10703_0461_002.cdf') + TES(3725)%FILENAME = TRIM('retv_vars.10703_0461_004.cdf') + TES(3726)%FILENAME = TRIM('retv_vars.10703_0462_002.cdf') + TES(3727)%FILENAME = TRIM('retv_vars.10703_0464_004.cdf') + TES(3728)%FILENAME = TRIM('retv_vars.10703_0466_002.cdf') + TES(3729)%FILENAME = TRIM('retv_vars.10703_0467_002.cdf') + TES(3730)%FILENAME = TRIM('retv_vars.10703_0467_003.cdf') + TES(3731)%FILENAME = TRIM('retv_vars.10703_0468_003.cdf') + TES(3732)%FILENAME = TRIM('retv_vars.10703_0469_002.cdf') + TES(3733)%FILENAME = TRIM('retv_vars.10703_0469_003.cdf') + TES(3734)%FILENAME = TRIM('retv_vars.10703_0469_004.cdf') + TES(3735)%FILENAME = TRIM('retv_vars.10703_0470_002.cdf') + TES(3736)%FILENAME = TRIM('retv_vars.10703_0482_003.cdf') + TES(3737)%FILENAME = TRIM('retv_vars.10703_0500_003.cdf') + TES(3738)%FILENAME = TRIM('retv_vars.10703_0530_004.cdf') + TES(3739)%FILENAME = TRIM('retv_vars.10703_0534_003.cdf') + TES(3740)%FILENAME = TRIM('retv_vars.10703_0534_004.cdf') + TES(3741)%FILENAME = TRIM('retv_vars.10703_0535_002.cdf') + TES(3742)%FILENAME = TRIM('retv_vars.10703_0535_003.cdf') + TES(3743)%FILENAME = TRIM('retv_vars.10703_0538_004.cdf') + TES(3744)%FILENAME = TRIM('retv_vars.10703_0546_002.cdf') + TES(3745)%FILENAME = TRIM('retv_vars.10703_0546_004.cdf') + TES(3746)%FILENAME = TRIM('retv_vars.10703_0547_003.cdf') + TES(3747)%FILENAME = TRIM('retv_vars.10703_0547_004.cdf') + TES(3748)%FILENAME = TRIM('retv_vars.10703_0548_003.cdf') + TES(3749)%FILENAME = TRIM('retv_vars.10703_0548_004.cdf') + TES(3750)%FILENAME = TRIM('retv_vars.10703_0549_003.cdf') + TES(3751)%FILENAME = TRIM('retv_vars.10703_0550_003.cdf') + TES(3752)%FILENAME = TRIM('retv_vars.10703_0550_004.cdf') + TES(3753)%FILENAME = TRIM('retv_vars.10703_0567_004.cdf') + TES(3754)%FILENAME = TRIM('retv_vars.10703_0568_002.cdf') + TES(3755)%FILENAME = TRIM('retv_vars.10703_0569_004.cdf') + TES(3756)%FILENAME = TRIM('retv_vars.10703_0570_002.cdf') + TES(3757)%FILENAME = TRIM('retv_vars.10703_0570_003.cdf') + TES(3758)%FILENAME = TRIM('retv_vars.10703_0571_003.cdf') + TES(3759)%FILENAME = TRIM('retv_vars.10703_0571_004.cdf') + TES(3760)%FILENAME = TRIM('retv_vars.10703_0572_002.cdf') + TES(3761)%FILENAME = TRIM('retv_vars.10703_0572_003.cdf') + TES(3762)%FILENAME = TRIM('retv_vars.10703_0572_004.cdf') + TES(3763)%FILENAME = TRIM('retv_vars.10703_0573_002.cdf') + TES(3764)%FILENAME = TRIM('retv_vars.10703_0574_002.cdf') + TES(3765)%FILENAME = TRIM('retv_vars.10703_0574_003.cdf') + TES(3766)%FILENAME = TRIM('retv_vars.10703_0574_004.cdf') + TES(3767)%FILENAME = TRIM('retv_vars.10703_0575_002.cdf') + TES(3768)%FILENAME = TRIM('retv_vars.10703_0575_003.cdf') + TES(3769)%FILENAME = TRIM('retv_vars.10703_0575_004.cdf') + TES(3770)%FILENAME = TRIM('retv_vars.10703_0576_002.cdf') + TES(3771)%FILENAME = TRIM('retv_vars.10703_0576_003.cdf') + TES(3772)%FILENAME = TRIM('retv_vars.10703_0580_002.cdf') + TES(3773)%FILENAME = TRIM('retv_vars.10703_0580_004.cdf') + TES(3774)%FILENAME = TRIM('retv_vars.10703_0582_004.cdf') + TES(3775)%FILENAME = TRIM('retv_vars.10703_0585_003.cdf') + TES(3776)%FILENAME = TRIM('retv_vars.10703_0586_003.cdf') + TES(3777)%FILENAME = TRIM('retv_vars.10703_0586_004.cdf') + TES(3778)%FILENAME = TRIM('retv_vars.10703_0587_002.cdf') + TES(3779)%FILENAME = TRIM('retv_vars.10703_0587_003.cdf') + TES(3780)%FILENAME = TRIM('retv_vars.10703_0591_003.cdf') + TES(3781)%FILENAME = TRIM('retv_vars.10703_0591_004.cdf') + TES(3782)%FILENAME = TRIM('retv_vars.10703_0592_004.cdf') + TES(3783)%FILENAME = TRIM('retv_vars.10703_0595_002.cdf') + TES(3784)%FILENAME = TRIM('retv_vars.10703_0598_003.cdf') + TES(3785)%FILENAME = TRIM('retv_vars.10703_0598_004.cdf') + TES(3786)%FILENAME = TRIM('retv_vars.10703_0599_002.cdf') + TES(3787)%FILENAME = TRIM('retv_vars.10703_0603_003.cdf') + TES(3788)%FILENAME = TRIM('retv_vars.10703_0603_004.cdf') + TES(3789)%FILENAME = TRIM('retv_vars.10703_0610_003.cdf') + TES(3790)%FILENAME = TRIM('retv_vars.10703_0613_003.cdf') + TES(3791)%FILENAME = TRIM('retv_vars.10703_0615_002.cdf') + TES(3792)%FILENAME = TRIM('retv_vars.10703_0615_003.cdf') + TES(3793)%FILENAME = TRIM('retv_vars.10703_0640_003.cdf') + TES(3794)%FILENAME = TRIM('retv_vars.10703_0643_003.cdf') + TES(3795)%FILENAME = TRIM('retv_vars.10703_0643_004.cdf') + TES(3796)%FILENAME = TRIM('retv_vars.10703_0644_004.cdf') + TES(3797)%FILENAME = TRIM('retv_vars.10703_0645_002.cdf') + TES(3798)%FILENAME = TRIM('retv_vars.10703_0645_004.cdf') + TES(3799)%FILENAME = TRIM('retv_vars.10703_0646_003.cdf') + TES(3800)%FILENAME = TRIM('retv_vars.10703_0647_002.cdf') + TES(3801)%FILENAME = TRIM('retv_vars.10703_0652_002.cdf') + TES(3802)%FILENAME = TRIM('retv_vars.10703_0652_003.cdf') + TES(3803)%FILENAME = TRIM('retv_vars.10703_0652_004.cdf') + TES(3804)%FILENAME = TRIM('retv_vars.10703_0653_003.cdf') + TES(3805)%FILENAME = TRIM('retv_vars.10703_0654_003.cdf') + TES(3806)%FILENAME = TRIM('retv_vars.10703_0656_004.cdf') + TES(3807)%FILENAME = TRIM('retv_vars.10703_0657_002.cdf') + TES(3808)%FILENAME = TRIM('retv_vars.10703_0657_004.cdf') + TES(3809)%FILENAME = TRIM('retv_vars.10703_0658_002.cdf') + TES(3810)%FILENAME = TRIM('retv_vars.10703_0658_003.cdf') + TES(3811)%FILENAME = TRIM('retv_vars.10703_0658_004.cdf') + TES(3812)%FILENAME = TRIM('retv_vars.10703_0659_002.cdf') + TES(3813)%FILENAME = TRIM('retv_vars.10703_0692_002.cdf') + TES(3814)%FILENAME = TRIM('retv_vars.10703_0693_003.cdf') + TES(3815)%FILENAME = TRIM('retv_vars.10703_0694_003.cdf') + TES(3816)%FILENAME = TRIM('retv_vars.10703_0694_004.cdf') + TES(3817)%FILENAME = TRIM('retv_vars.10703_0699_002.cdf') + TES(3818)%FILENAME = TRIM('retv_vars.10703_0700_003.cdf') + TES(3819)%FILENAME = TRIM('retv_vars.10703_0700_004.cdf') + TES(3820)%FILENAME = TRIM('retv_vars.10703_0701_002.cdf') + TES(3821)%FILENAME = TRIM('retv_vars.10703_0701_004.cdf') + TES(3822)%FILENAME = TRIM('retv_vars.10703_0702_002.cdf') + TES(3823)%FILENAME = TRIM('retv_vars.10703_0702_003.cdf') + TES(3824)%FILENAME = TRIM('retv_vars.10703_0702_004.cdf') + TES(3825)%FILENAME = TRIM('retv_vars.10703_0730_004.cdf') + TES(3826)%FILENAME = TRIM('retv_vars.10703_0731_002.cdf') + TES(3827)%FILENAME = TRIM('retv_vars.10703_0731_003.cdf') + TES(3828)%FILENAME = TRIM('retv_vars.10703_0731_004.cdf') + TES(3829)%FILENAME = TRIM('retv_vars.10703_0732_003.cdf') + TES(3830)%FILENAME = TRIM('retv_vars.10703_0732_004.cdf') + TES(3831)%FILENAME = TRIM('retv_vars.10703_0733_002.cdf') + TES(3832)%FILENAME = TRIM('retv_vars.10703_0733_004.cdf') + TES(3833)%FILENAME = TRIM('retv_vars.10703_0740_002.cdf') + TES(3834)%FILENAME = TRIM('retv_vars.10703_0740_003.cdf') + TES(3835)%FILENAME = TRIM('retv_vars.10703_0741_003.cdf') + TES(3836)%FILENAME = TRIM('retv_vars.10703_0741_004.cdf') + TES(3837)%FILENAME = TRIM('retv_vars.10703_0742_002.cdf') + TES(3838)%FILENAME = TRIM('retv_vars.10703_0742_003.cdf') + TES(3839)%FILENAME = TRIM('retv_vars.10703_0742_004.cdf') + TES(3840)%FILENAME = TRIM('retv_vars.10703_0747_003.cdf') + TES(3841)%FILENAME = TRIM('retv_vars.10708_0013_002.cdf') + TES(3842)%FILENAME = TRIM('retv_vars.10708_0016_002.cdf') + TES(3843)%FILENAME = TRIM('retv_vars.10708_0017_003.cdf') + TES(3844)%FILENAME = TRIM('retv_vars.10708_0017_004.cdf') + TES(3845)%FILENAME = TRIM('retv_vars.10708_0018_004.cdf') + TES(3846)%FILENAME = TRIM('retv_vars.10708_0020_002.cdf') + TES(3847)%FILENAME = TRIM('retv_vars.10708_0020_003.cdf') + TES(3848)%FILENAME = TRIM('retv_vars.10708_0020_004.cdf') + TES(3849)%FILENAME = TRIM('retv_vars.10708_0021_002.cdf') + TES(3850)%FILENAME = TRIM('retv_vars.10708_0021_003.cdf') + TES(3851)%FILENAME = TRIM('retv_vars.10708_0021_004.cdf') + TES(3852)%FILENAME = TRIM('retv_vars.10708_0022_002.cdf') + TES(3853)%FILENAME = TRIM('retv_vars.10708_0022_004.cdf') + TES(3854)%FILENAME = TRIM('retv_vars.10708_0023_002.cdf') + TES(3855)%FILENAME = TRIM('retv_vars.10708_0027_002.cdf') + TES(3856)%FILENAME = TRIM('retv_vars.10708_0027_003.cdf') + TES(3857)%FILENAME = TRIM('retv_vars.10708_0027_004.cdf') + TES(3858)%FILENAME = TRIM('retv_vars.10708_0028_002.cdf') + TES(3859)%FILENAME = TRIM('retv_vars.10708_0028_003.cdf') + TES(3860)%FILENAME = TRIM('retv_vars.10708_0028_004.cdf') + TES(3861)%FILENAME = TRIM('retv_vars.10708_0054_003.cdf') + TES(3862)%FILENAME = TRIM('retv_vars.10708_0054_004.cdf') + TES(3863)%FILENAME = TRIM('retv_vars.10708_0055_003.cdf') + TES(3864)%FILENAME = TRIM('retv_vars.10708_0055_004.cdf') + TES(3865)%FILENAME = TRIM('retv_vars.10708_0056_003.cdf') + TES(3866)%FILENAME = TRIM('retv_vars.10708_0057_002.cdf') + TES(3867)%FILENAME = TRIM('retv_vars.10708_0057_003.cdf') + TES(3868)%FILENAME = TRIM('retv_vars.10708_0057_004.cdf') + TES(3869)%FILENAME = TRIM('retv_vars.10708_0058_002.cdf') + TES(3870)%FILENAME = TRIM('retv_vars.10708_0058_003.cdf') + TES(3871)%FILENAME = TRIM('retv_vars.10708_0060_002.cdf') + TES(3872)%FILENAME = TRIM('retv_vars.10708_0060_003.cdf') + TES(3873)%FILENAME = TRIM('retv_vars.10708_0064_002.cdf') + TES(3874)%FILENAME = TRIM('retv_vars.10708_0064_003.cdf') + TES(3875)%FILENAME = TRIM('retv_vars.10708_0064_004.cdf') + TES(3876)%FILENAME = TRIM('retv_vars.10708_0067_004.cdf') + TES(3877)%FILENAME = TRIM('retv_vars.10708_0068_002.cdf') + TES(3878)%FILENAME = TRIM('retv_vars.10708_0068_003.cdf') + TES(3879)%FILENAME = TRIM('retv_vars.10708_0069_003.cdf') + TES(3880)%FILENAME = TRIM('retv_vars.10708_0069_004.cdf') + TES(3881)%FILENAME = TRIM('retv_vars.10708_0071_002.cdf') + TES(3882)%FILENAME = TRIM('retv_vars.10708_0108_003.cdf') + TES(3883)%FILENAME = TRIM('retv_vars.10708_0110_004.cdf') + TES(3884)%FILENAME = TRIM('retv_vars.10708_0111_002.cdf') + TES(3885)%FILENAME = TRIM('retv_vars.10708_0172_002.cdf') + TES(3886)%FILENAME = TRIM('retv_vars.10708_0186_002.cdf') + TES(3887)%FILENAME = TRIM('retv_vars.10708_0186_004.cdf') + TES(3888)%FILENAME = TRIM('retv_vars.10708_0187_002.cdf') + TES(3889)%FILENAME = TRIM('retv_vars.10708_0187_003.cdf') + TES(3890)%FILENAME = TRIM('retv_vars.10708_0187_004.cdf') + TES(3891)%FILENAME = TRIM('retv_vars.10708_0188_002.cdf') + TES(3892)%FILENAME = TRIM('retv_vars.10708_0190_002.cdf') + TES(3893)%FILENAME = TRIM('retv_vars.10708_0190_003.cdf') + TES(3894)%FILENAME = TRIM('retv_vars.10708_0198_004.cdf') + TES(3895)%FILENAME = TRIM('retv_vars.10708_0199_002.cdf') + TES(3896)%FILENAME = TRIM('retv_vars.10708_0199_003.cdf') + TES(3897)%FILENAME = TRIM('retv_vars.10708_0199_004.cdf') + TES(3898)%FILENAME = TRIM('retv_vars.10708_0200_002.cdf') + TES(3899)%FILENAME = TRIM('retv_vars.10708_0200_003.cdf') + TES(3900)%FILENAME = TRIM('retv_vars.10708_0200_004.cdf') + TES(3901)%FILENAME = TRIM('retv_vars.10708_0201_002.cdf') + TES(3902)%FILENAME = TRIM('retv_vars.10708_0201_003.cdf') + TES(3903)%FILENAME = TRIM('retv_vars.10708_0201_004.cdf') + TES(3904)%FILENAME = TRIM('retv_vars.10708_0202_002.cdf') + TES(3905)%FILENAME = TRIM('retv_vars.10708_0213_002.cdf') + TES(3906)%FILENAME = TRIM('retv_vars.10708_0213_003.cdf') + TES(3907)%FILENAME = TRIM('retv_vars.10708_0213_004.cdf') + TES(3908)%FILENAME = TRIM('retv_vars.10708_0214_003.cdf') + TES(3909)%FILENAME = TRIM('retv_vars.10708_0219_002.cdf') + TES(3910)%FILENAME = TRIM('retv_vars.10708_0220_002.cdf') + TES(3911)%FILENAME = TRIM('retv_vars.10708_0220_003.cdf') + TES(3912)%FILENAME = TRIM('retv_vars.10708_0220_004.cdf') + TES(3913)%FILENAME = TRIM('retv_vars.10708_0221_003.cdf') + TES(3914)%FILENAME = TRIM('retv_vars.10708_0222_003.cdf') + TES(3915)%FILENAME = TRIM('retv_vars.10708_0223_004.cdf') + TES(3916)%FILENAME = TRIM('retv_vars.10708_0231_003.cdf') + TES(3917)%FILENAME = TRIM('retv_vars.10708_0231_004.cdf') + TES(3918)%FILENAME = TRIM('retv_vars.10708_0235_003.cdf') + TES(3919)%FILENAME = TRIM('retv_vars.10708_0235_004.cdf') + TES(3920)%FILENAME = TRIM('retv_vars.10708_0244_002.cdf') + TES(3921)%FILENAME = TRIM('retv_vars.10708_0244_003.cdf') + TES(3922)%FILENAME = TRIM('retv_vars.10708_0244_004.cdf') + TES(3923)%FILENAME = TRIM('retv_vars.10708_0245_002.cdf') + TES(3924)%FILENAME = TRIM('retv_vars.10708_0245_003.cdf') + TES(3925)%FILENAME = TRIM('retv_vars.10708_0245_004.cdf') + TES(3926)%FILENAME = TRIM('retv_vars.10708_0246_003.cdf') + TES(3927)%FILENAME = TRIM('retv_vars.10708_0247_003.cdf') + TES(3928)%FILENAME = TRIM('retv_vars.10708_0248_003.cdf') + TES(3929)%FILENAME = TRIM('retv_vars.10708_0248_004.cdf') + TES(3930)%FILENAME = TRIM('retv_vars.10708_0249_002.cdf') + TES(3931)%FILENAME = TRIM('retv_vars.10708_0249_003.cdf') + TES(3932)%FILENAME = TRIM('retv_vars.10708_0249_004.cdf') + TES(3933)%FILENAME = TRIM('retv_vars.10708_0250_003.cdf') + TES(3934)%FILENAME = TRIM('retv_vars.10708_0250_004.cdf') + TES(3935)%FILENAME = TRIM('retv_vars.10708_0251_002.cdf') + TES(3936)%FILENAME = TRIM('retv_vars.10708_0252_004.cdf') + TES(3937)%FILENAME = TRIM('retv_vars.10708_0256_002.cdf') + TES(3938)%FILENAME = TRIM('retv_vars.10708_0256_003.cdf') + TES(3939)%FILENAME = TRIM('retv_vars.10708_0259_002.cdf') + TES(3940)%FILENAME = TRIM('retv_vars.10708_0259_003.cdf') + TES(3941)%FILENAME = TRIM('retv_vars.10708_0259_004.cdf') + TES(3942)%FILENAME = TRIM('retv_vars.10708_0260_002.cdf') + TES(3943)%FILENAME = TRIM('retv_vars.10708_0260_003.cdf') + TES(3944)%FILENAME = TRIM('retv_vars.10708_0260_004.cdf') + TES(3945)%FILENAME = TRIM('retv_vars.10708_0261_002.cdf') + TES(3946)%FILENAME = TRIM('retv_vars.10708_0262_002.cdf') + TES(3947)%FILENAME = TRIM('retv_vars.10708_0267_002.cdf') + TES(3948)%FILENAME = TRIM('retv_vars.10708_0267_003.cdf') + TES(3949)%FILENAME = TRIM('retv_vars.10708_0268_002.cdf') + TES(3950)%FILENAME = TRIM('retv_vars.10708_0268_003.cdf') + TES(3951)%FILENAME = TRIM('retv_vars.10708_0268_004.cdf') + TES(3952)%FILENAME = TRIM('retv_vars.10708_0269_003.cdf') + TES(3953)%FILENAME = TRIM('retv_vars.10708_0272_002.cdf') + TES(3954)%FILENAME = TRIM('retv_vars.10708_0278_003.cdf') + TES(3955)%FILENAME = TRIM('retv_vars.10708_0302_004.cdf') + TES(3956)%FILENAME = TRIM('retv_vars.10708_0303_003.cdf') + TES(3957)%FILENAME = TRIM('retv_vars.10708_0304_002.cdf') + TES(3958)%FILENAME = TRIM('retv_vars.10708_0304_003.cdf') + TES(3959)%FILENAME = TRIM('retv_vars.10708_0304_004.cdf') + TES(3960)%FILENAME = TRIM('retv_vars.10708_0305_002.cdf') + TES(3961)%FILENAME = TRIM('retv_vars.10708_0306_003.cdf') + TES(3962)%FILENAME = TRIM('retv_vars.10708_0307_004.cdf') + TES(3963)%FILENAME = TRIM('retv_vars.10708_0308_004.cdf') + TES(3964)%FILENAME = TRIM('retv_vars.10708_0310_002.cdf') + TES(3965)%FILENAME = TRIM('retv_vars.10708_0310_003.cdf') + TES(3966)%FILENAME = TRIM('retv_vars.10708_0310_004.cdf') + TES(3967)%FILENAME = TRIM('retv_vars.10708_0315_003.cdf') + TES(3968)%FILENAME = TRIM('retv_vars.10708_0315_004.cdf') + TES(3969)%FILENAME = TRIM('retv_vars.10708_0316_002.cdf') + TES(3970)%FILENAME = TRIM('retv_vars.10708_0316_003.cdf') + TES(3971)%FILENAME = TRIM('retv_vars.10708_0316_004.cdf') + TES(3972)%FILENAME = TRIM('retv_vars.10708_0317_002.cdf') + TES(3973)%FILENAME = TRIM('retv_vars.10708_0317_003.cdf') + TES(3974)%FILENAME = TRIM('retv_vars.10708_0318_002.cdf') + TES(3975)%FILENAME = TRIM('retv_vars.10708_0318_003.cdf') + TES(3976)%FILENAME = TRIM('retv_vars.10708_0318_004.cdf') + TES(3977)%FILENAME = TRIM('retv_vars.10708_0320_004.cdf') + TES(3978)%FILENAME = TRIM('retv_vars.10708_0322_002.cdf') + TES(3979)%FILENAME = TRIM('retv_vars.10708_0323_003.cdf') + TES(3980)%FILENAME = TRIM('retv_vars.10708_0323_004.cdf') + TES(3981)%FILENAME = TRIM('retv_vars.10708_0324_003.cdf') + TES(3982)%FILENAME = TRIM('retv_vars.10708_0359_003.cdf') + TES(3983)%FILENAME = TRIM('retv_vars.10708_0364_003.cdf') + TES(3984)%FILENAME = TRIM('retv_vars.10708_0365_003.cdf') + TES(3985)%FILENAME = TRIM('retv_vars.10708_0366_003.cdf') + TES(3986)%FILENAME = TRIM('retv_vars.10708_0366_004.cdf') + TES(3987)%FILENAME = TRIM('retv_vars.10708_0368_002.cdf') + TES(3988)%FILENAME = TRIM('retv_vars.10708_0369_003.cdf') + TES(3989)%FILENAME = TRIM('retv_vars.10708_0369_004.cdf') + TES(3990)%FILENAME = TRIM('retv_vars.10708_0373_003.cdf') + TES(3991)%FILENAME = TRIM('retv_vars.10708_0373_004.cdf') + + + ! for BLVMR: make date same as 2008 + !print*, ' subtract 1 year from TES date ' + !TES(:)%NYMD = TES(:)%NYMD - 10000 + + ! Return to calling program + END SUBROUTINE INIT_TES_NH3 +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TES_NH3 +! +!***************************************************************************** +! Subroutine CLEANUP_TES_NH3 deallocates all module arrays. (dkh, 02/15/09) +! +! NOTES: +! +!****************************************************************************** +! + + IF ( ALLOCATED( NH3_SAVE ) ) DEALLOCATE( NH3_SAVE ) + + + ! Return to calling program + END SUBROUTINE CLEANUP_TES_NH3 +!------------------------------------------------------------------------------ + + END MODULE TES_NH3_MOD diff --git a/code/obs_operators/tes_o3_irk_mod.f b/code/obs_operators/tes_o3_irk_mod.f new file mode 100644 index 0000000..b82e371 --- /dev/null +++ b/code/obs_operators/tes_o3_irk_mod.f @@ -0,0 +1,2871 @@ +!$Id: tes_o3_irk_mod.f,v 1.1 2012/04/13 22:29:08 nicolas Exp $ + MODULE TES_O3_IRK_MOD + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 67 + INTEGER, PARAMETER :: MAXTES = 2000 + + + ! Record to store data from each TES obs + TYPE TES_O3_OBS + INTEGER :: LTES(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: O3(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + REAL*8 :: IRK(MAXLEV) + REAL*8 :: TPAUSE(1) + ENDTYPE TES_O3_OBS + + TYPE(TES_O3_OBS) :: TES(MAXTES) + + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_O3_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine READ_TES_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) TES (TES_O3_OBS) : TES retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LTES + INTEGER :: NTES + INTEGER :: START0(1), COUNT0(1) + INTEGER :: START1(2), COUNT1(2) + INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, J + INTEGER :: NT_ID + INTEGER :: O3_ID + INTEGER :: PS_ID + INTEGER :: AK_ID + INTEGER :: OE_ID + INTEGER :: AP_ID + INTEGER :: LA_ID + INTEGER :: LO_ID + INTEGER :: DY_ID + ! for IRK - + INTEGER :: RF_ID + INTEGER :: TP_ID + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + LOGICAL :: IT_EXISTS + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + INTEGER :: NR, NS, ST,TMP2 + INTEGER, DIMENSION(2) :: DIMIDS + + CHARACTER(LEN=255) :: MY_DIR + + !================================================================= + ! READ_TES_O3_OBS begins here! + !================================================================= + + ! filename root + !READ_FILENAME = TRIM( 'tes_aura_nadir_YYYYMMDD_O3_v4.nc' ) + ! IRK files are v3 + READ_FILENAME = TRIM( 'tes_aura_nadir_YYYYMMDD_O3_v3.nc' ) + READ_FILENAME = TRIM('teso3irk.YYYYMMDD.nc') + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + + ! Construct complete filename + !READ_FILENAME = TRIM( DATA_DIR ) // TRIM( '../TES_O3/' ) // + READ_FILENAME = TRIM( DATA_DIR ) // TRIM( '../TES_O3_IRFK/' ) // + & TRIM( READ_FILENAME ) + + !tww, 20151029 + NTES = 0 + INQUIRE( FILE=TRIM( READ_FILENAME ), EXIST=IT_EXISTS ) + IF(IT_EXISTS) THEN + + WRITE(6,*) ' - READ_TES_O3_OBS: reading file: ', READ_FILENAME + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "targets", NT_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "ozone_vmr", O3_ID ), 102 ) +! CALL CHECK( NF90_INQ_VARID( FID, "species", O3_ID ), 102 ) +! CALL CHECK( NF90_INQ_VARID( FID, "averagingkernel", AK_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) +! CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", +! & OE_ID ), 106 ) +! CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "yyyymmdd", DY_ID ), 110 ) + ! IRK + CALL CHECK( NF90_INQ_VARID( FID, "O3IRK", RF_ID ), 111 ) + CALL CHECK( NF90_INQ_VARID( FID, "Tropopause_Pressure", + & TP_ID ), 112 ) +! CALL CHECK( NF90_INQ_VARID( FID, "irfkernel", RF_ID ), 111 ) +! CALL CHECK( NF90_INQ_VARID( FID, "tropopause", TP_ID ), 112 ) + + + ! READ number of retrievals, NTES + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NT_ID, TMP, NTES), 202 ) + + print*, ' NTES = ', NTES + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! define record size + START0 = (/1/) + COUNT0 = (/1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START0(1) = N + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LA_ID, + & TES(N)%LAT, START0, COUNT0 ), 301 ) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LO_ID, + & TES(N)%LON, START0, COUNT0 ), 302 ) + + ! READ date + CALL CHECK( NF90_GET_VAR ( FID, DY_ID, + & TES(N)%TIME, START0, COUNT0 ), 303 ) + + ! READ tropopause ( for IRK ) + CALL CHECK( NF90_GET_VAR ( FID, TP_ID, + & TES(N)%TPAUSE, START0, COUNT0 ), 304 ) + + + ENDDO + + !-------------------------------- + ! Find # of good levels for each + !-------------------------------- + + ! define record size + START1 = (/1, 1/) + COUNT1 = (/1, MAXLEV/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START1(1) = N + ST = NF90_INQUIRE_VARIABLE(FID, O3_ID, TMP,TMP2,TMP2,DIMIDS) + CALL CHECK(NF90_INQUIRE_DIMENSION(FID, DIMIDS(1), TMP, NR),305) + CALL CHECK(NF90_INQUIRE_DIMENSION(FID, DIMIDS(2), TMP, NS),306) + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:MAXLEV), START1, COUNT1 ), 401 ) + + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + J = 1 + DO WHILE ( J .le. MAXLEV ) + + ! check if the value is good + IF ( TES(N)%O3(J) > FILL ) THEN + + ! save the number of good levels as LTES + TES(N)%LTES = MAXLEV - J + 1 + + ! and now we can exit the while loop + J = MAXLEV + 1 + + ! otherwise this level is just filler + ELSE + + ! so proceed to the next one up + J = J + 1 + + ENDIF + + ENDDO + + ENDDO + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START1 = (/1, MAXLEV - J + 1/) + COUNT1 = (/1, J/) + + ! Update starting index + START1(1) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:J), START1, COUNT1 ), 402 ) + + + ! READ pressure levels, PRES + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES(N)%PRES(1:J), START1, COUNT1 ), 403 ) + +! ! READ apriori O3 column, PRIOR +! CALL CHECK( NF90_GET_VAR ( FID, AP_ID, +! & TES(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) + + ! READ instantaneous radiative forcing kernel, IRK + CALL CHECK( NF90_GET_VAR ( FID, RF_ID, + & TES(N)%IRK(1:J), START1, COUNT1 ), 404 ) + + + ENDDO + + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + +! READ_FILENAME = TRIM( 'tes_aura_nadir_irk_YYYYMMDD_O3_v4.nc' ) +! CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) +! READ_FILENAME = TRIM( MY_DIR ) // TRIM( READ_FILENAME ) +! WRITE(6,*) ' - READ_TES_O3_OBS: reading file: ', READ_FILENAME +! +! ! Open file and assign file id (FID) +! CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) +! +! !-------------------------------- +! ! Get data record IDs +! !-------------------------------- +! !CALL CHECK( NF90_INQ_DIMID( FID, "targets", NT_ID), 102 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "ozone_vmr", O3_ID ), 102 ) +! CALL CHECK( NF90_INQ_VARID( FID, "averagingkernel", AK_ID ), 104 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) +! CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", +! & OE_ID ), 106 ) +! CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "yyyymmdd", DY_ID ), 110 ) +! ! IRK +! !CALL CHECK( NF90_INQ_VARID( FID, "O3IRK", RF_ID ), 111 ) +! !CALL CHECK( NF90_INQ_VARID( FID, "tropopause", TP_ID ), 112 ) +! +! +! !-------------------------------- +! ! Read 1D Data +! !-------------------------------- +! +! ! loop over records +! DO N = 1, NTES +! +! ! J is number of good levels +! J = TES(N)%LTES(1) +! +! ! define record size +! START1 = (/MAXLEV - J + 1, 1/) +! COUNT1 = (/J, 1/) +! +! ! Update starting index +! START1(2) = N +! +! CALL CHECK( NF90_GET_VAR ( FID, AP_ID, +! & TES(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) +! +! ENDDO +! +! !-------------------------------- +! ! Read 2D Data +! !-------------------------------- +! +! ! loop over records +! DO N = 1, NTES +! +! ! J is number of good levels +! J = TES(N)%LTES(1) +! +! ! define record size +! START2 = (/MAXLEV - J + 1, MAXLEV - J + 1, 1/) +! COUNT2 = (/J, J, 1/) +! +! ! Update starting index +! START2(3) = N +! +! ! READ averaging kernal, AVG_KERNEL +! CALL CHECK( NF90_GET_VAR ( FID, AK_ID, +! & TES(N)%AVG_KERNEL(1:J,1:J), START2, COUNT2), 501 !) +!! +! ! READ observational error covariance +! CALL CHECK( NF90_GET_VAR ( FID, OE_ID, +! & TES(N)%S_OER(1:J,1:J), START2, COUNT2), 502 ) +! +! ENDDO +! +! +! CALL CHECK( NF90_CLOSE( FID ), 9999 ) +! +! +! !-------------------------------- +! ! Calculate S_OER_INV +! !-------------------------------- +! +! ! loop over records +! DO N = 1, NTES +! +! J = TES(N)%LTES(1) +! +! !print*, ' TES test ', TES(N)%O3 +! !print*, ' TES good ', TES(N)%LTES +! !print*, ' TES pres ', TES(N)%PRES(1:J) +! +! DO II=1,J +! TES(N)%S_OER(II,II) = TES(N)%S_OER(II,II)+ 0.001D0 +! ENDDO +! +! !CALL DGESVD_EXAMPLE +! +! CALL SVD( TES(N)%S_OER(1:J,1:J), J, +! & U(1:J,1:J), S(1:J), +! & VT(1:J,1:J) ) +! +! ! U = S^-1 * U^T +! DO I = 1, J +! DO II = 1, J +! TEST(I,II) = U(II,I) / S(I) +! ENDDO +! ENDDO +! U = TEST +! TEST = 0d0 +! +! ! S_OER_INV = V * S^-1 * U^T +! DO I = 1, J +! DO II = 1, J +! TMP1 = 0d0 +! DO III = 1, J +! TMP1 = TMP1 + VT(III,I) * U(III,II) +! ENDDO +! TES(N)%S_OER_INV(I,II) = TMP1 +! ENDDO +! ENDDO +! +! ! TEST: calculate 2-norm of I - S_OER_INV * S_OER +! DO I = 1, J +! DO II = 1, J +! TMP1 = 0d0 +! DO III = 1, J +! TMP1 = TMP1 +! & + TES(N)%S_OER_INV(III,I) * TES(N)%S_OER(III,II) +! ENDDO +! TEST(I,II) = - TMP1 +! ENDDO +! TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 +! ENDDO +! +! IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN +! print*, ' WARNING: inversion error for retv N = ', +! & SUM(TEST(1:J,1:J)), N +! print*, ' in TES obs ', READ_FILENAME +! ENDIF +! +! ENDDO ! N + + ELSE + + PRINT*, 'No IRK file on this date' + RETURN + + ENDIF + + ! Return to calling program + END SUBROUTINE READ_TES_O3_OBS +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_o3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_O3_IRK_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_O3_IRK_FORCE calculates the adjoint forcing from the TES +! O3 IRKs and updates the cost function. (dkh, 04/21/11) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : CSPEC, JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_NYMDb + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACERID_MOD, ONLY : IDO3 + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV) + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXTES) + INTEGER,SAVE :: NTES + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + REAL*8 :: O3_HAT_ADJ(MAXLEV) + REAL*8 :: O3_PERT_ADJ(MAXLEV) + REAL*8 :: GC_O3_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ(MAXLEV) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + ! for IRK + INTEGER, SAVE :: NTES_TOTAL = 0 + + REAL*8, PARAMETER :: AREA_TOTAL = 1.724593044429029E+019 + + !================================================================= + ! CALC_TES_O3_IRK_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_O3_IRK_FORCE ' + + ! Reset + NEW_COST = 0D0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + FILENAME = 'pres.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 233000 - GET_TS_CHEM() * 100 ) THEN + +! ! There are no IRKs on 08/24 or 08/31 +! IF ( GET_NYMD() == 20060824 .or. GET_NYMD() == 20060831 ) +! & RETURN + + ! Read the TES O3 file for this day + CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) + + IF ( NTES == 0 ) + & RETURN + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() + + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + +! need to update this in order to do i/o with this loop parallel +!! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_O3_IRK_FORCE: analyzing record ', NT + + ! Check IRK for NaN + ! A NaN value is by definition not equal to anything even itself + IF ( .NOT. TES(NT)%IRK(10) .GE. 0d0 .AND. + & .NOT. TES(NT)%IRK(10) .LE. 0d0 ) THEN + print*, ' - found NaN in IRK, continue... ' + CONTINUE + ENDIF + + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + O3_HAT_ADJ(:) = 0d0 + FORCE(:) = 0d0 + + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) + + ! Get O3 values at native model resolution + DO L = 1, LLPAR + + + ! check if in trop + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + ! get O3 from tropospheric array + IF ( JLOOP > 0 ) THEN + GC_O3_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDO3)) + + ELSE + + ! get O3 from climatology [#/cm2] + GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / + & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + ENDIF + + ELSE + + ! get O3 from climatology [#/cm2] + GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / + & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + ENDIF + + ! Convert from #/cm3 to v/v + GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / + & ( AIRDEN(L,I,J) * XNUMOLAIR ) + + ENDDO + + ! Interpolate GC O3 column to TES grid + DO LL = 1, LTES + GC_O3(LL) = 0d0 + DO L = 1, LLPAR + GC_O3(LL) = GC_O3(LL) + & + MAP(L,LL) * GC_O3_NATIVE(L) + ENDDO + ENDDO + +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) + + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + +! ! x_m - x_a +! DO L = 1, LTES +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO + +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! O3_HAT(L) = 0d0 +! DO LL = 1, LTES +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO + + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO + + !! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + !DO L = 1, LTES + !FORCE(L) = 0d0 + !DO LL = 1, LTES + !FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) + !ENDDO + !NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + !!ENDDO + + DO L = 1, LTES + + ! Only consider values in the tropopause + + ! using GC tropopause + !IF ( TES(NT)%PRES(L) > GC_PRES( GET_TPAUSE_LEVEL(I,J) ) ) + + ! using WMO tropopuase in the TES files + IF ( TES(NT)%PRES(L) >= TES(NT)%TPAUSE(1) ) THEN + + FORCE(L) = TES(NT)%IRK(L) + & * GET_AREA_CM2( J ) + & / AREA_TOTAL + + NEW_COST(NT) = NEW_COST(NT) + & + TES(NT)%IRK(L) * GC_O3(L) + & * GET_AREA_CM2( J ) + & / AREA_TOTAL + + ELSE + + FORCE(L) = 0d0 + + ENDIF + + ENDDO + + !print*,' NEW_COST=', NEW_COST(NT), NT + +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) + +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! O3_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LTES +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LTES +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * O3_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LTES +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO + + DO L = 1, LTES + GC_O3_ADJ(L) = FORCE(L) + ENDDO + +! ! dkh debug +! print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_O3_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_O3_ADJ(LL) + ENDDO + ENDDO + +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) + + DO L = 1, LLPAR + + ! Adjoint of unit conversion + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / + & ( AIRDEN(L,I,J) * XNUMOLAIR ) + + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + IF ( JLOOP > 0 ) THEN + + ! Pass adjoint back to adjoint tracer array + CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) = + & CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) + & + GC_O3_NATIVE_ADJ(L) + + ENDIF + + ENDIF + + ENDDO + +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) + + +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) + + + ENDDO ! NT +!!$OMP END PARALLEL DO + + ! Update cost function + !COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + ! for IRK we average the cost function and flip the sign + COST_FUNC = COST_FUNC - SUM(NEW_COST(NTSTOP:NTSTART)) + print*, ' dkh time debug ', GET_NHMS(), GET_NYMD(), GET_NYMDb() + print*, ' dkh N debug ', NTSTOP, NTES_TOTAL + !IF ( GET_NHMS() == 0 ) THEN + IF ( NTSTOP == 1 ) THEN + NTES_TOTAL = NTES_TOTAL + NTES + print*, ' NTES_TOTAL = ', NTES_TOTAL + ! include this in cost caculated above -- it comes out to 41510 + !IF ( GET_NYMD() == GET_NYMDb() ) THEN + ! print*, ' take average of COST_FUNC ' + ! COST_FUNC = COST_FUNC / REAL(NTES_TOTAL,8) + !ENDIF + ENDIF + + + IF ( FIRST ) FIRST = .FALSE. + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_TES_O3_IRK_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_O3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine CALC_TES_O3_FORCE_FD tests the adjoint of CALC_TES_O3_FORCE +!! (dkh, 05/05/10) +!! +!! Can be driven with: +!! PERT(:) = 1D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, 30 +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!! +!! +!! +!! Arguments as Input/Output: +!! ============================================================================ +!! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +!! +!! +!! NOTES: +!! (1 ) Updated to GCv8 (dkh, 10/07/09) +!! (1 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE +! USE DAO_MOD, ONLY : AD +! USE DAO_MOD, ONLY : AIRDEN +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : XNUMOLAIR +! USE TRACERID_MOD, ONLY : IDO3 +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +! +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LTES +! INTEGER :: JLOOP +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_O3_NATIVE(LLPAR) +! REAL*8 :: GC_O3(MAXLEV) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,MAXLEV) +! REAL*8 :: O3_HAT(MAXLEV) +! REAL*8 :: O3_PERT(MAXLEV) +! REAL*8 :: FORCE(MAXLEV) +! REAL*8 :: DIFF(MAXLEV) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! REAL*8, SAVE :: TIME_FRAC(MAXTES) +! INTEGER,SAVE :: NTES +! +! REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) +! REAL*8 :: O3_HAT_ADJ(MAXLEV) +! REAL*8 :: O3_PERT_ADJ(MAXLEV) +! REAL*8 :: GC_O3_ADJ(MAXLEV) +! REAL*8 :: DIFF_ADJ(MAXLEV) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_O3_FORCE_FD begins here! +! !================================================================= +! +! print*, ' - CALC_TES_O3_FORCE_FD ' +! +! NEW_COST = 0D0 +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_press.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_on_tes.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Check if it is the last hour of a day +!! IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN +! IF ( FIRST ) THEN +! +! ! Read the TES O3 file for this day +! CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +! FIRST = .FALSE. +! ENDIF +! +!! ! Get the range of TES retrievals for the current hour +!! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES O3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +!! & TIME_FRAC(NTSTOP) +!! print*, ' found record range: ', NTSTART, NTSTOP +! +! NTSTART = 1590 +! NTSTOP = 1590 +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT +! +! ! For safety, initialize these up to LLTES +! GC_O3(:) = 0d0 +! MAP(:,:) = 0d0 +! O3_HAT_ADJ(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LTES to make coding a bit cleaner +! LTES = TES(NT)%LTES(1) +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) +! I = IIJJ(1) +! J = IIJJ(2) +! +! print*, 'I,J = ', I, J +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LTES) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) +! +! +! ! Get O3 values at native model resolution +! DO L = 1, LLPAR +! +! +! ! check if in trop +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! ! get O3 from tropospheric array +! IF ( JLOOP > 0 ) THEN +! GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) * PERT(L) +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! ENDIF +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! +! ENDIF +! +! ! Convert from #/cm3 to v/v +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! ENDDO +! +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LTES +! GC_O3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_O3(LL) = GC_O3(LL) +! & + MAP(L,LL) * GC_O3_NATIVE(L) +! ENDDO +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LTES +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! O3_HAT(L) = 0d0 +! DO LL = 1, LTES +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !ADJ_DIFF(:) = 1d0 +! !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) +! !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) +! !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) +! +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! O3_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LTES +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LTES +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * O3_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LTES +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO +! +! ! dkh debug +! print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! GC_O3_NATIVE_ADJ(L) = 0d0 +! DO LL = 1, LTES +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) +! & + MAP(L,LL) * GC_O3_ADJ(LL) +! ENDDO +! ENDDO +! +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! DO L = 1, LLPAR +! +! ! Adjoint of unit conversion +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! IF ( JLOOP > 0 ) THEN +! +! ! Pass adjoint back to adjoint tracer array +! CSPEC_ADJ_FORCE(JLOOP,IDO3) = +! & CSPEC_ADJ_FORCE(JLOOP,IDO3) + GC_O3_NATIVE_ADJ(L) +! +! ADJ(L) = GC_O3_NATIVE_ADJ(L) * CSPEC(JLOOP,IDO3) +! +! ENDIF +! +! ENDIF +! +! ENDDO +! +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_O3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + + print*, ' GET_NT_RANGE for ', HHMMSS + print*, ' NTSAVE ', NTSAVE + print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where TES pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(:,LTM) = 0D0 + HINTERPZ(LTM,LTM) = 1D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ +! SUBROUTINE MAKE_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_O3_FILE saves O3 profiles that correspond to time and +!! place of TES O3 obs. (dkh, 03/01/09) +!! +!! Module variables as Input: +!! ============================================================================ +!! (1 ) O3_SAVE (REAL*8) : O3 profiles [ppmv] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE +! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J, I0, J0, L, NT +! CHARACTER(LEN=120) :: FILENAME +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! INTEGER, PARAMETER :: IUN = 88 +! +! ! For binary punch file, version 2.0 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! !================================================================= +! ! MAKE_O3_FILE begins here! +! !================================================================= +! +! FILENAME = TRIM( 'nh3.bpch' ) +! +! ! Append data directory prefix +! FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'O3 profile ' +! CATEGORY = 'IJ-AVE-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! UNIT = 'ppmv' +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the checkpoint file for output -- binary punch format +! !================================================================= +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_O3_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) +! +! ! Temporarily store data in DAT as REAL4 +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT ) +! DO NT = 1, MAXTES +! +! DAT(1,:,NT) = REAL(O3_SAVE(:,NT)) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, 1d0, 1d0, RESERVED, +! & 1, LLPAR, MAXTES, I0+1, +! & J0+1, 1, DAT ) +! +! ! Close file +! CLOSE( IUN ) +! +! print*, ' O3_SAVE sum write = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE MAKE_O3_FILE +! +!!------------------------------------------------------------------------------ +! SUBROUTINE READ_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine READ_O3_FILE reads the GC modeled O3 profiles that correspond +!! to the TES O3 times and locations. (dkh, 03/01/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( ADJTMP_DIR ) // +! & 'nh3.bpch' +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_O3_FILE: Reading ', a ) +! +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, +! & 1d0, 1, LLPAR, +! & MAXTES, DAT, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! O3_SAVE(:,:) = DAT(1,:,:) +! +! print*, ' O3_SAVE sum read = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE READ_O3_FILE +! +!!----------------------------------------------------------------------------- +! FUNCTION GET_DOUBLED_O3( NYMD, NHMS, LON, LAT ) RESULT( O3_DBL ) +!! +!!****************************************************************************** +!! Subroutine GET_DOUBLED_O3 reads and returns the nh3 profiles from +!! model run with doubled emissions. (dkh, 11/08/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TIME_MOD, ONLY : GET_TAU +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER :: NYMD, NHMS +! REAL*4 :: LON, LAT +! +! ! Function arg +! REAL*8 :: O3_DBL(LLPAR) +! +! ! Local variables +! REAL*4 :: DAT(144,91,20) +! CHARACTER(LEN=255) :: FILENAME +! INTEGER :: IIJJ(2) +! +! !================================================================= +! ! GET_DOUBLED_O3 begins here! +! !================================================================= +! +! ! filename +! FILENAME = 'nh3.YYYYMMDD.hhmm' +! +! ! Expand filename +! CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) +! +! ! Full path to file +! FILENAME = TRIM( DATA_DIR ) // +! & 'doubled_nh3/' // +! & TRIM( FILENAME ) // +! & TRIM( '00' ) +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - GET_DOUBLED_O3: Reading ', a ) +! +! ! dkh debug +! print*, ' GET_TAU() = ', GET_TAU() +! +! ! Get data +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, +! & GET_TAU(), 144, 91, +! & 20, DAT, QUIET=.FALSE. ) +! +! IIJJ = GET_IJ_2x25( LON, LAT ) +! +! print*, ' found doubled in I/J = ', IIJJ +! +! ! just the column for the present location, and convert ppb to ppm +! O3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 +! O3_DBL(21:LLPAR) = 0d0 +! +! print*, ' O3_DBL = ', O3_DBL +! +! ! Return to calling program +! END FUNCTION GET_DOUBLED_O3 +! +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!!----------------------------------------------------------------------------- +! SUBROUTINE INIT_TES_O3 +!! +!!***************************************************************************** +!! Subroutine INIT_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! IIPAR, JJPAR +! +! ! Local variables +! INTEGER :: AS +! +! !================================================================= +! ! INIT_TES_O3 begins here +! !================================================================= +! +! ! dkh debug +! print*, ' INIT_TES_O3' +! +! ALLOCATE( O3_SAVE( LLPAR, MAXTES ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_SAVE' ) +! O3_SAVE = 0d0 +! +! +! TES( 1 )%NYMD = 20050704 +! TES( 2 )%NYMD = 20050704 +! TES( 3 )%NYMD = 20050704 +! TES( 4 )%NYMD = 20050704 +! TES( 5 )%NYMD = 20050704 +! TES( 6 )%NYMD = 20050704 +! TES( 7 )%NYMD = 20050704 +! TES( 8 )%NYMD = 20050704 +! TES( 9 )%NYMD = 20050705 +! TES( 10 )%NYMD = 20050705 +! TES( 11 )%NYMD = 20050705 +! TES( 12 )%NYMD = 20050705 +! TES( 13 )%NYMD = 20050705 +! TES( 14 )%NYMD = 20050705 +! TES( 15 )%NYMD = 20050705 +! TES( 16 )%NYMD = 20050705 +! TES( 17 )%NYMD = 20050705 +! TES( 18 )%NYMD = 20050710 +! TES( 19 )%NYMD = 20050710 +! TES( 20 )%NYMD = 20050710 +! TES( 21 )%NYMD = 20050710 +! TES( 22 )%NYMD = 20050710 +! TES( 23 )%NYMD = 20050710 +! TES( 24 )%NYMD = 20050710 +! TES( 25 )%NYMD = 20050710 +! TES( 26 )%NYMD = 20050710 +! TES( 27 )%NYMD = 20050711 +! TES( 28 )%NYMD = 20050711 +! TES( 29 )%NYMD = 20050711 +! TES( 30 )%NYMD = 20050711 +! TES( 31 )%NYMD = 20050712 +! TES( 32 )%NYMD = 20050712 +! TES( 33 )%NYMD = 20050712 +! TES( 34 )%NYMD = 20050712 +! TES( 35 )%NYMD = 20050712 +! TES( 36 )%NYMD = 20050712 +! TES( 37 )%NYMD = 20050712 +! TES( 38 )%NYMD = 20050712 +! TES( 39 )%NYMD = 20050713 +! TES( 40 )%NYMD = 20050713 +! TES( 41 )%NYMD = 20050713 +! TES( 42 )%NYMD = 20050713 +! TES( 43 )%NYMD = 20050713 +! TES( 44 )%NYMD = 20050713 +! TES( 45 )%NYMD = 20050713 +! TES( 46 )%NYMD = 20050713 +! TES( 47 )%NYMD = 20050713 +! TES( 48 )%NYMD = 20050714 +! TES( 49 )%NYMD = 20050714 +! TES( 50 )%NYMD = 20050714 +! TES( 51 )%NYMD = 20050714 +! TES( 52 )%NYMD = 20050714 +! TES( 53 )%NYMD = 20050714 +! TES( 54 )%NYMD = 20050714 +! TES( 55 )%NYMD = 20050714 +! TES( 56 )%NYMD = 20050715 +! TES( 57 )%NYMD = 20050715 +! TES( 58 )%NYMD = 20050715 +! TES( 59 )%NYMD = 20050715 +! TES( 60 )%NYMD = 20050715 +! TES( 61 )%NYMD = 20050715 +! TES( 62 )%NYMD = 20050715 +! TES( 63 )%NYMD = 20050715 +! TES( 64 )%NYMD = 20050715 +! TES( 65 )%NYMD = 20050716 +! TES( 66 )%NYMD = 20050717 +! TES( 67 )%NYMD = 20050717 +! TES( 68 )%NYMD = 20050717 +! TES( 69 )%NYMD = 20050717 +! TES( 70 )%NYMD = 20050717 +! TES( 71 )%NYMD = 20050717 +! TES( 72 )%NYMD = 20050717 +! TES( 73 )%NYMD = 20050717 +! TES( 74 )%NYMD = 20050717 +! TES( 75 )%NYMD = 20050718 +! TES( 76 )%NYMD = 20050718 +! TES( 77 )%NYMD = 20050718 +! TES( 78 )%NYMD = 20050718 +! TES( 79 )%NYMD = 20050719 +! TES( 80 )%NYMD = 20050719 +! TES( 81 )%NYMD = 20050719 +! TES( 82 )%NYMD = 20050719 +! TES( 83 )%NYMD = 20050719 +! TES( 84 )%NYMD = 20050719 +! TES( 85 )%NYMD = 20050719 +! TES( 86 )%NYMD = 20050719 +! TES( 87 )%NYMD = 20050719 +! +! TES( 1 )%NHMS = 202000 +! TES( 2 )%NHMS = 202100 +! TES( 3 )%NHMS = 202100 +! TES( 4 )%NHMS = 202100 +! TES( 5 )%NHMS = 202200 +! TES( 6 )%NHMS = 202300 +! TES( 7 )%NHMS = 202300 +! TES( 8 )%NHMS = 202400 +! TES( 9 )%NHMS = 082100 +! TES( 10 )%NHMS = 082100 +! TES( 11 )%NHMS = 082200 +! TES( 12 )%NHMS = 082200 +! TES( 13 )%NHMS = 082300 +! TES( 14 )%NHMS = 082300 +! TES( 15 )%NHMS = 082400 +! TES( 16 )%NHMS = 082400 +! TES( 17 )%NHMS = 082500 +! TES( 18 )%NHMS = 194300 +! TES( 19 )%NHMS = 194300 +! TES( 20 )%NHMS = 194400 +! TES( 21 )%NHMS = 194400 +! TES( 22 )%NHMS = 194500 +! TES( 23 )%NHMS = 194500 +! TES( 24 )%NHMS = 194600 +! TES( 25 )%NHMS = 194600 +! TES( 26 )%NHMS = 194700 +! TES( 27 )%NHMS = 092300 +! TES( 28 )%NHMS = 092300 +! TES( 29 )%NHMS = 092400 +! TES( 30 )%NHMS = 092400 +! TES( 31 )%NHMS = 193000 +! TES( 32 )%NHMS = 193100 +! TES( 33 )%NHMS = 193100 +! TES( 34 )%NHMS = 193200 +! TES( 35 )%NHMS = 193300 +! TES( 36 )%NHMS = 193300 +! TES( 37 )%NHMS = 193400 +! TES( 38 )%NHMS = 193400 +! TES( 39 )%NHMS = 091000 +! TES( 40 )%NHMS = 091100 +! TES( 41 )%NHMS = 091100 +! TES( 42 )%NHMS = 091200 +! TES( 43 )%NHMS = 091200 +! TES( 44 )%NHMS = 091200 +! TES( 45 )%NHMS = 091300 +! TES( 46 )%NHMS = 091300 +! TES( 47 )%NHMS = 091400 +! TES( 48 )%NHMS = 191900 +! TES( 49 )%NHMS = 191900 +! TES( 50 )%NHMS = 191900 +! TES( 51 )%NHMS = 192000 +! TES( 52 )%NHMS = 192000 +! TES( 53 )%NHMS = 192100 +! TES( 54 )%NHMS = 192100 +! TES( 55 )%NHMS = 192200 +! TES( 56 )%NHMS = 085800 +! TES( 57 )%NHMS = 085800 +! TES( 58 )%NHMS = 085900 +! TES( 59 )%NHMS = 085900 +! TES( 60 )%NHMS = 090000 +! TES( 61 )%NHMS = 090000 +! TES( 62 )%NHMS = 090100 +! TES( 63 )%NHMS = 090100 +! TES( 64 )%NHMS = 090100 +! TES( 65 )%NHMS = 190900 +! TES( 66 )%NHMS = 084500 +! TES( 67 )%NHMS = 084600 +! TES( 68 )%NHMS = 084600 +! TES( 69 )%NHMS = 084700 +! TES( 70 )%NHMS = 084700 +! TES( 71 )%NHMS = 084800 +! TES( 72 )%NHMS = 084800 +! TES( 73 )%NHMS = 084900 +! TES( 74 )%NHMS = 084900 +! TES( 75 )%NHMS = 203200 +! TES( 76 )%NHMS = 203300 +! TES( 77 )%NHMS = 203300 +! TES( 78 )%NHMS = 203400 +! TES( 79 )%NHMS = 083300 +! TES( 80 )%NHMS = 083400 +! TES( 81 )%NHMS = 083400 +! TES( 82 )%NHMS = 083500 +! TES( 83 )%NHMS = 083500 +! TES( 84 )%NHMS = 083500 +! TES( 85 )%NHMS = 083600 +! TES( 86 )%NHMS = 083600 +! TES( 87 )%NHMS = 083700 +! +! TES( 1 )%LAT = 31.29 +! TES( 2 )%LAT = 33 +! TES( 3 )%LAT = 34.64 +! TES( 4 )%LAT = 36.2 +! TES( 5 )%LAT = 37.91 +! TES( 6 )%LAT = 41.1 +! TES( 7 )%LAT = 42.8 +! TES( 8 )%LAT = 44.43 +! TES( 9 )%LAT = 43.54 +! TES( 10 )%LAT = 41.84 +! TES( 11 )%LAT = 40.2 +! TES( 12 )%LAT = 38.65 +! TES( 13 )%LAT = 36.94 +! TES( 14 )%LAT = 35.3 +! TES( 15 )%LAT = 33.74 +! TES( 16 )%LAT = 32.03 +! TES( 17 )%LAT = 30.39 +! TES( 18 )%LAT = 31.28 +! TES( 19 )%LAT = 32.99 +! TES( 20 )%LAT = 34.63 +! TES( 21 )%LAT = 36.19 +! TES( 22 )%LAT = 37.9 +! TES( 23 )%LAT = 39.53 +! TES( 24 )%LAT = 41.09 +! TES( 25 )%LAT = 42.8 +! TES( 26 )%LAT = 44.42 +! TES( 27 )%LAT = 43.55 +! TES( 28 )%LAT = 41.85 +! TES( 29 )%LAT = 40.22 +! TES( 30 )%LAT = 38.66 +! TES( 31 )%LAT = 31.28 +! TES( 32 )%LAT = 32.99 +! TES( 33 )%LAT = 34.63 +! TES( 34 )%LAT = 36.19 +! TES( 35 )%LAT = 39.53 +! TES( 36 )%LAT = 41.09 +! TES( 37 )%LAT = 42.79 +! TES( 38 )%LAT = 44.42 +! TES( 39 )%LAT = 43.55 +! TES( 40 )%LAT = 41.85 +! TES( 41 )%LAT = 40.22 +! TES( 42 )%LAT = 38.66 +! TES( 43 )%LAT = 36.96 +! TES( 44 )%LAT = 35.32 +! TES( 45 )%LAT = 33.76 +! TES( 46 )%LAT = 32.04 +! TES( 47 )%LAT = 30.4 +! TES( 48 )%LAT = 32.99 +! TES( 49 )%LAT = 34.63 +! TES( 50 )%LAT = 36.2 +! TES( 51 )%LAT = 37.9 +! TES( 52 )%LAT = 39.54 +! TES( 53 )%LAT = 41.1 +! TES( 54 )%LAT = 42.8 +! TES( 55 )%LAT = 44.42 +! TES( 56 )%LAT = 43.55 +! TES( 57 )%LAT = 41.85 +! TES( 58 )%LAT = 40.22 +! TES( 59 )%LAT = 38.66 +! TES( 60 )%LAT = 36.95 +! TES( 61 )%LAT = 35.31 +! TES( 62 )%LAT = 33.75 +! TES( 63 )%LAT = 32.04 +! TES( 64 )%LAT = 30.4 +! TES( 65 )%LAT = 44.4 +! TES( 66 )%LAT = 43.59 +! TES( 67 )%LAT = 41.89 +! TES( 68 )%LAT = 40.26 +! TES( 69 )%LAT = 38.7 +! TES( 70 )%LAT = 37 +! TES( 71 )%LAT = 35.36 +! TES( 72 )%LAT = 33.8 +! TES( 73 )%LAT = 32.09 +! TES( 74 )%LAT = 30.45 +! TES( 75 )%LAT = 31.27 +! TES( 76 )%LAT = 32.98 +! TES( 77 )%LAT = 34.62 +! TES( 78 )%LAT = 36.18 +! TES( 79 )%LAT = 43.58 +! TES( 80 )%LAT = 41.88 +! TES( 81 )%LAT = 40.25 +! TES( 82 )%LAT = 38.69 +! TES( 83 )%LAT = 36.98 +! TES( 84 )%LAT = 35.34 +! TES( 85 )%LAT = 33.78 +! TES( 86 )%LAT = 32.07 +! TES( 87 )%LAT = 30.43 +! +! TES( 1 )%LON = -105.13 +! TES( 2 )%LON = -105.6 +! TES( 3 )%LON = -106.05 +! TES( 4 )%LON = -106.5 +! TES( 5 )%LON = -107 +! TES( 6 )%LON = -108 +! TES( 7 )%LON = -108.57 +! TES( 8 )%LON = -109.13 +! TES( 9 )%LON = -92.52 +! TES( 10 )%LON = -93.09 +! TES( 11 )%LON = -93.62 +! TES( 12 )%LON = -94.11 +! TES( 13 )%LON = -94.62 +! TES( 14 )%LON = -95.09 +! TES( 15 )%LON = -95.53 +! TES( 16 )%LON = -96 +! TES( 17 )%LON = -96.44 +! TES( 18 )%LON = -95.84 +! TES( 19 )%LON = -96.3 +! TES( 20 )%LON = -96.76 +! TES( 21 )%LON = -97.2 +! TES( 22 )%LON = -97.71 +! TES( 23 )%LON = -98.21 +! TES( 24 )%LON = -98.71 +! TES( 25 )%LON = -99.27 +! TES( 26 )%LON = -99.83 +! TES( 27 )%LON = -107.94 +! TES( 28 )%LON = -108.51 +! TES( 29 )%LON = -109.04 +! TES( 30 )%LON = -109.53 +! TES( 31 )%LON = -92.74 +! TES( 32 )%LON = -93.2 +! TES( 33 )%LON = -93.66 +! TES( 34 )%LON = -94.11 +! TES( 35 )%LON = -95.11 +! TES( 36 )%LON = -95.61 +! TES( 37 )%LON = -96.17 +! TES( 38 )%LON = -96.73 +! TES( 39 )%LON = -104.84 +! TES( 40 )%LON = -105.41 +! TES( 41 )%LON = -105.94 +! TES( 42 )%LON = -106.43 +! TES( 43 )%LON = -106.94 +! TES( 44 )%LON = -107.42 +! TES( 45 )%LON = -107.86 +! TES( 46 )%LON = -108.33 +! TES( 47 )%LON = -108.76 +! TES( 48 )%LON = -90.1 +! TES( 49 )%LON = -90.56 +! TES( 50 )%LON = -91.01 +! TES( 51 )%LON = -91.51 +! TES( 52 )%LON = -92.01 +! TES( 53 )%LON = -92.51 +! TES( 54 )%LON = -93.07 +! TES( 55 )%LON = -93.64 +! TES( 56 )%LON = -101.74 +! TES( 57 )%LON = -102.32 +! TES( 58 )%LON = -102.84 +! TES( 59 )%LON = -103.33 +! TES( 60 )%LON = -103.84 +! TES( 61 )%LON = -104.32 +! TES( 62 )%LON = -104.76 +! TES( 63 )%LON = -105.23 +! TES( 64 )%LON = -105.67 +! TES( 65 )%LON = -90.54 +! TES( 66 )%LON = -98.64 +! TES( 67 )%LON = -99.22 +! TES( 68 )%LON = -99.75 +! TES( 69 )%LON = -100.23 +! TES( 70 )%LON = -100.75 +! TES( 71 )%LON = -101.22 +! TES( 72 )%LON = -101.67 +! TES( 73 )%LON = -102.13 +! TES( 74 )%LON = -102.57 +! TES( 75 )%LON = -108.19 +! TES( 76 )%LON = -108.65 +! TES( 77 )%LON = -109.11 +! TES( 78 )%LON = -109.55 +! TES( 79 )%LON = -95.57 +! TES( 80 )%LON = -96.14 +! TES( 81 )%LON = -96.67 +! TES( 82 )%LON = -97.16 +! TES( 83 )%LON = -97.67 +! TES( 84 )%LON = -98.15 +! TES( 85 )%LON = -98.59 +! TES( 86 )%LON = -99.06 +! TES( 87 )%LON = -99.49 +! +! TES( 1 )%FILENAME = TRIM('retv_vars.02945_0457_002.cdf') +! TES( 2 )%FILENAME = TRIM('retv_vars.02945_0457_003.cdf') +! TES( 3 )%FILENAME = TRIM('retv_vars.02945_0457_004.cdf') +! TES( 4 )%FILENAME = TRIM('retv_vars.02945_0458_002.cdf') +! TES( 5 )%FILENAME = TRIM('retv_vars.02945_0458_003.cdf') +! TES( 6 )%FILENAME = TRIM('retv_vars.02945_0459_002.cdf') +! TES( 7 )%FILENAME = TRIM('retv_vars.02945_0459_003.cdf') +! TES( 8 )%FILENAME = TRIM('retv_vars.02945_0459_004.cdf') +! TES( 9 )%FILENAME = TRIM('retv_vars.02945_0982_002.cdf') +! TES( 10 )%FILENAME = TRIM('retv_vars.02945_0982_003.cdf') +! TES( 11 )%FILENAME = TRIM('retv_vars.02945_0982_004.cdf') +! TES( 12 )%FILENAME = TRIM('retv_vars.02945_0983_002.cdf') +! TES( 13 )%FILENAME = TRIM('retv_vars.02945_0983_003.cdf') +! TES( 14 )%FILENAME = TRIM('retv_vars.02945_0983_004.cdf') +! TES( 15 )%FILENAME = TRIM('retv_vars.02945_0984_002.cdf') +! TES( 16 )%FILENAME = TRIM('retv_vars.02945_0984_003.cdf') +! TES( 17 )%FILENAME = TRIM('retv_vars.02945_0984_004.cdf') +! TES( 18 )%FILENAME = TRIM('retv_vars.02956_0457_002.cdf') +! TES( 19 )%FILENAME = TRIM('retv_vars.02956_0457_003.cdf') +! TES( 20 )%FILENAME = TRIM('retv_vars.02956_0457_004.cdf') +! TES( 21 )%FILENAME = TRIM('retv_vars.02956_0458_002.cdf') +! TES( 22 )%FILENAME = TRIM('retv_vars.02956_0458_003.cdf') +! TES( 23 )%FILENAME = TRIM('retv_vars.02956_0458_004.cdf') +! TES( 24 )%FILENAME = TRIM('retv_vars.02956_0459_002.cdf') +! TES( 25 )%FILENAME = TRIM('retv_vars.02956_0459_003.cdf') +! TES( 26 )%FILENAME = TRIM('retv_vars.02956_0459_004.cdf') +! TES( 27 )%FILENAME = TRIM('retv_vars.02956_1054_002.cdf') +! TES( 28 )%FILENAME = TRIM('retv_vars.02956_1054_003.cdf') +! TES( 29 )%FILENAME = TRIM('retv_vars.02956_1054_004.cdf') +! TES( 30 )%FILENAME = TRIM('retv_vars.02956_1055_002.cdf') +! TES( 31 )%FILENAME = TRIM('retv_vars.02960_0457_002.cdf') +! TES( 32 )%FILENAME = TRIM('retv_vars.02960_0457_003.cdf') +! TES( 33 )%FILENAME = TRIM('retv_vars.02960_0457_004.cdf') +! TES( 34 )%FILENAME = TRIM('retv_vars.02960_0458_002.cdf') +! TES( 35 )%FILENAME = TRIM('retv_vars.02960_0458_004.cdf') +! TES( 36 )%FILENAME = TRIM('retv_vars.02960_0459_002.cdf') +! TES( 37 )%FILENAME = TRIM('retv_vars.02960_0459_003.cdf') +! TES( 38 )%FILENAME = TRIM('retv_vars.02960_0459_004.cdf') +! TES( 39 )%FILENAME = TRIM('retv_vars.02960_1054_002.cdf') +! TES( 40 )%FILENAME = TRIM('retv_vars.02960_1054_003.cdf') +! TES( 41 )%FILENAME = TRIM('retv_vars.02960_1054_004.cdf') +! TES( 42 )%FILENAME = TRIM('retv_vars.02960_1055_002.cdf') +! TES( 43 )%FILENAME = TRIM('retv_vars.02960_1055_003.cdf') +! TES( 44 )%FILENAME = TRIM('retv_vars.02960_1055_004.cdf') +! TES( 45 )%FILENAME = TRIM('retv_vars.02960_1056_002.cdf') +! TES( 46 )%FILENAME = TRIM('retv_vars.02960_1056_003.cdf') +! TES( 47 )%FILENAME = TRIM('retv_vars.02960_1056_004.cdf') +! TES( 48 )%FILENAME = TRIM('retv_vars.02963_0457_003.cdf') +! TES( 49 )%FILENAME = TRIM('retv_vars.02963_0457_004.cdf') +! TES( 50 )%FILENAME = TRIM('retv_vars.02963_0458_002.cdf') +! TES( 51 )%FILENAME = TRIM('retv_vars.02963_0458_003.cdf') +! TES( 52 )%FILENAME = TRIM('retv_vars.02963_0458_004.cdf') +! TES( 53 )%FILENAME = TRIM('retv_vars.02963_0459_002.cdf') +! TES( 54 )%FILENAME = TRIM('retv_vars.02963_0459_003.cdf') +! TES( 55 )%FILENAME = TRIM('retv_vars.02963_0459_004.cdf') +! TES( 56 )%FILENAME = TRIM('retv_vars.02963_1054_002.cdf') +! TES( 57 )%FILENAME = TRIM('retv_vars.02963_1054_003.cdf') +! TES( 58 )%FILENAME = TRIM('retv_vars.02963_1054_004.cdf') +! TES( 59 )%FILENAME = TRIM('retv_vars.02963_1055_002.cdf') +! TES( 60 )%FILENAME = TRIM('retv_vars.02963_1055_003.cdf') +! TES( 61 )%FILENAME = TRIM('retv_vars.02963_1055_004.cdf') +! TES( 62 )%FILENAME = TRIM('retv_vars.02963_1056_002.cdf') +! TES( 63 )%FILENAME = TRIM('retv_vars.02963_1056_003.cdf') +! TES( 64 )%FILENAME = TRIM('retv_vars.02963_1056_004.cdf') +! TES( 65 )%FILENAME = TRIM('retv_vars.02967_0459_004.cdf') +! TES( 66 )%FILENAME = TRIM('retv_vars.02967_1054_002.cdf') +! TES( 67 )%FILENAME = TRIM('retv_vars.02967_1054_003.cdf') +! TES( 68 )%FILENAME = TRIM('retv_vars.02967_1054_004.cdf') +! TES( 69 )%FILENAME = TRIM('retv_vars.02967_1055_002.cdf') +! TES( 70 )%FILENAME = TRIM('retv_vars.02967_1055_003.cdf') +! TES( 71 )%FILENAME = TRIM('retv_vars.02967_1055_004.cdf') +! TES( 72 )%FILENAME = TRIM('retv_vars.02967_1056_002.cdf') +! TES( 73 )%FILENAME = TRIM('retv_vars.02967_1056_003.cdf') +! TES( 74 )%FILENAME = TRIM('retv_vars.02967_1056_004.cdf') +! TES( 75 )%FILENAME = TRIM('retv_vars.02971_0457_002.cdf') +! TES( 76 )%FILENAME = TRIM('retv_vars.02971_0457_003.cdf') +! TES( 77 )%FILENAME = TRIM('retv_vars.02971_0457_004.cdf') +! TES( 78 )%FILENAME = TRIM('retv_vars.02971_0458_002.cdf') +! TES( 79 )%FILENAME = TRIM('retv_vars.02971_0982_002.cdf') +! TES( 80 )%FILENAME = TRIM('retv_vars.02971_0982_003.cdf') +! TES( 81 )%FILENAME = TRIM('retv_vars.02971_0982_004.cdf') +! TES( 82 )%FILENAME = TRIM('retv_vars.02971_0983_002.cdf') +! TES( 83 )%FILENAME = TRIM('retv_vars.02971_0983_003.cdf') +! TES( 84 )%FILENAME = TRIM('retv_vars.02971_0983_004.cdf') +! TES( 85 )%FILENAME = TRIM('retv_vars.02971_0984_002.cdf') +! TES( 86 )%FILENAME = TRIM('retv_vars.02971_0984_003.cdf') +! TES( 87 )%FILENAME = TRIM('retv_vars.02971_0984_004.cdf') +! +! ! Return to calling program +! END SUBROUTINE INIT_TES_O3 +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CLEANUP_TES_O3 +!! +!!***************************************************************************** +!! Subroutine CLEANUP_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! +! IF ( ALLOCATED( O3_SAVE ) ) DEALLOCATE( O3_SAVE ) +! +! +! ! Return to calling program +! END SUBROUTINE CLEANUP_TES_O3 +!!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ + + SUBROUTINE SVD(A,N,U,S,VT) +! +!****************************************************************************** +! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) A (REAL*8) : N x N matrix to decompose +! (2 ) N (INTEGER) : N is dimension of A +! +! Arguments as Output: +! ============================================================================ +! (1 ) U (REAL*8) : Array of left singular vectors +! (2 ) S (REAL*8) : Vector of singular values +! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +! +! +! NOTES: +! +* Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +* The information and material ("Material") provided below is owned by Intel +* Corporation or its suppliers or licensors, and title to such Material remains +* with Intel Corporation or its suppliers or licensors. The Material contains +* proprietary information of Intel or its suppliers and licensors. The Material +* is protected by worldwide copyright laws and treaty provisions. No part of +* the Material may be copied, reproduced, published, uploaded, posted, +* transmitted, or distributed in any way without Intel's prior express written +* permission. No license under any patent, copyright or other intellectual +* property rights in the Material is granted to or conferred upon you, either +* expressly, by implication, inducement, estoppel or otherwise. Any license +* under such intellectual property rights must be express and approved by Intel +* in writing. +* ============================================================================= +* +* DGESVD Example. +* ============== +* +* Program computes the singular value decomposition of a general +* rectangular matrix A: +* +* 8.79 9.93 9.83 5.45 3.16 +* 6.11 6.91 5.04 -0.27 7.98 +* -9.15 -7.93 4.86 4.85 3.01 +* 9.57 1.64 8.83 0.74 5.80 +* -3.49 4.02 9.80 10.00 4.27 +* 9.84 0.15 -8.99 -6.02 -5.31 +* +* Description. +* ============ +* +* The routine computes the singular value decomposition (SVD) of a real +* m-by-n matrix A, optionally computing the left and/or right singular +* vectors. The SVD is written as +* +* A = U*SIGMA*VT +* +* where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +* diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +* is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +* are the singular values of A; they are real and non-negative, and are +* returned in descending order. The first min(m, n) columns of U and V are +* the left and right singular vectors of A. +* +* Note that the routine returns VT, not V. +* +* Example Program Results. +* ======================== +* +* DGESVD Example Program Results +* +* Singular values +* 27.47 22.64 8.56 5.99 2.01 +* +* Left singular vectors (stored columnwise) +* -0.59 0.26 0.36 0.31 0.23 +* -0.40 0.24 -0.22 -0.75 -0.36 +* -0.03 -0.60 -0.45 0.23 -0.31 +* -0.43 0.24 -0.69 0.33 0.16 +* -0.47 -0.35 0.39 0.16 -0.52 +* 0.29 0.58 -0.02 0.38 -0.65 +* +* Right singular vectors (stored rowwise) +* -0.25 -0.40 -0.69 -0.37 -0.41 +* 0.81 0.36 -0.25 -0.37 -0.10 +* -0.26 0.70 -0.22 0.39 -0.49 +* 0.40 -0.45 0.25 0.43 -0.62 +* -0.22 0.14 0.59 -0.63 -0.44 +* ============================================================================= +!****************************************************************************** +! + ! Arguements + INTEGER,INTENT(IN) :: N + REAL*8, INTENT(IN) :: A(N,N) + REAL*8, INTENT(OUT) :: U(N,N) + REAL*8, INTENT(OUT) :: S(N) + REAL*8, INTENT(OUT) :: VT(N,N) + + ! Local variables + INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 + INTEGER :: INFO, LWORK + DOUBLE PRECISION :: WORK( LWMAX ) + +* .. External Subroutines .. + EXTERNAL :: DGESVD + +* .. Intrinsic Functions .. + INTRINSIC :: INT, MIN + + !================================================================= + ! SVD begins here! + !================================================================= + +* .. Executable Statements .. + !WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + !print*, ' dkh debug N = ', N + LWORK = -1 + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF + +! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +!! +!! Print singular values. +!! +! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!! +!! Print left singular vectors. +!! +! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +! $ N, N, U, N ) +!! +!! Print right singular vectors. +!! +! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +! $ N, N, VT, N ) + + ! Return to calling program + END SUBROUTINE SVD +!------------------------------------------------------------------------------ + SUBROUTINE DGESVD_EXAMPLE + +* .. Parameters .. + INTEGER M, N + PARAMETER ( M = 6, N = 5 ) + INTEGER LDA, LDU, LDVT + PARAMETER ( LDA = M, LDU = M, LDVT = N ) + INTEGER LWMAX + PARAMETER ( LWMAX = 1000 ) +* +* .. Local Scalars .. + INTEGER INFO, LWORK +* +* .. Local Arrays .. + DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), + $ WORK( LWMAX ) + DATA A/ + $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, + $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, + $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, + $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, + $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 + $ / +* +* .. External Subroutines .. + EXTERNAL DGESVD + !EXTERNAL PRINT_MATRIX +* +* .. Intrinsic Functions .. + INTRINSIC INT, MIN +* +* .. Executable Statements .. + WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF +* +* Print singular values. +* + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +* +* Print left singular vectors. +* + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ M, N, U, LDU ) +* +* Print right singular vectors. +* + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, LDVT ) + +* +* End of DGESVD Example. + END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +* +* Auxiliary routine: printing a matrix. +* + SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) + CHARACTER*(*) DESC + INTEGER M, N, LDA + DOUBLE PRECISION A( LDA, * ) +* + INTEGER I, J +* + WRITE(*,*) + WRITE(*,*) DESC + DO I = 1, M + WRITE(*,9998) ( A( I, J ), J = 1, N ) + END DO +* +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) + 9998 FORMAT( 11(:,1X,E14.8) ) + RETURN + + END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + END MODULE TES_O3_IRK_MOD diff --git a/code/obs_operators/tes_o3_mod.f b/code/obs_operators/tes_o3_mod.f new file mode 100644 index 0000000..f97fb8d --- /dev/null +++ b/code/obs_operators/tes_o3_mod.f @@ -0,0 +1,3443 @@ +!$Id: tes_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ + MODULE TES_O3_MOD + + IMPLICIT NONE + +!mkeller +#include "CMN_SIZE" +!#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_TES_O3_OBS + PUBLIC CALC_TES_O3_FORCE + PUBLIC MAKE_TES_BIAS_FILE_HDF5 + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 67 + INTEGER, PARAMETER :: MAXTES = 2000 + + + ! Record to store data from each TES obs + TYPE TES_O3_OBS + INTEGER :: LTES(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: O3(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + !mkeller: TES retrieval quality flag + INTEGER :: QUALITY_FLAG(1) + ENDTYPE TES_O3_OBS + + TYPE(TES_O3_OBS) :: TES(MAXTES) + + !mkeller: arrays for saving diagnostics + + TYPE FLEX_REAL_1D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:) + ENDTYPE FLEX_REAL_1D + + TYPE FLEX_REAL_2D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:,:) + ENDTYPE FLEX_REAL_2D + + REAL*4 :: TES_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_GC_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS_COUNT(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_PRESSURE(MAXLEV) + ! mkeller: flex arrays to store satellite diagnostics sequentially + TYPE(FLEX_REAL_1D) :: FLEX_LON, FLEX_LAT, FLEX_TIME + TYPE(FLEX_REAL_2D) :: FLEX_TES_O3, FLEX_GC_O3 + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_O3_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine READ_TES_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) TES (TES_O3_OBS) : TES retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LTES + INTEGER :: NTES + INTEGER :: START0(1), COUNT0(1) + INTEGER :: START1(2), COUNT1(2) + INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, J + INTEGER :: NT_ID + INTEGER :: O3_ID + INTEGER :: PS_ID + INTEGER :: AK_ID + INTEGER :: OE_ID + INTEGER :: AP_ID + INTEGER :: LA_ID + INTEGER :: LO_ID + INTEGER :: DY_ID + + !mkeller: additional variables for quality flag + INTEGER :: QU_ID + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: DIR_TES + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_TES_O3_OBS begins here! + !================================================================= + + ! filename root + DIR_TES = '/users/jk/16/xzhang/TES_O3/' + READ_FILENAME = TRIM( 'tes_aura_nadir_YYYYMMDD_O3_v6.nc' ) + DIR_MONTH = 'YYYY/MM/' + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 9999 ) + + ! Construct complete filename + READ_FILENAME = TRIM( DIR_TES ) // TRIM( DIR_MONTH ) // + & TRIM( READ_FILENAME ) + + WRITE(6,*) ' - READ_TES_O3_OBS: reading file: ', READ_FILENAME + + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"TES file '", TRIM(READ_FILENAME), " not found, "// + & "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"TES file found!" + ENDIF + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "targets", NT_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "species", O3_ID ), 103 ) + CALL CHECK( NF90_INQ_VARID( FID, "averagingkernel", AK_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) + CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", + & OE_ID ), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "yyyymmdd", DY_ID ), 110 ) + CALL CHECK( NF90_INQ_VARID( FID, "speciesretrievalconverged", + & QU_ID ), 111 ) + + ! READ number of retrievals, NTES + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NT_ID, TMP, NTES), 202 ) + + !print*, ' NTES = ', NTES + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! mkeller: read in TES pressure levels for satellite diagnostics + ! this only needs to be done once, add logical flag here + ! the TES retrieval pressure grid can vary near the surface, there shouldn't be any + ! data reported on those levels in the diagnostic output. + ! not sure what the proper way to do this is for Level3 data... + ! for Level2 data, should all individual retrieval grids be written out? + + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES_PRESSURE, (/1,1/), (/MAXLEV,1/)), 402 ) + + !PRINT *, "TES_PRESSURE", TES_PRESSURE + ! define record size + START0 = (/1/) + COUNT0 = (/1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START0(1) = N + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LA_ID, + & TES(N)%LAT, START0, COUNT0 ), 301 ) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LO_ID, + & TES(N)%LON, START0, COUNT0 ), 302 ) + + ! READ date + CALL CHECK( NF90_GET_VAR ( FID, DY_ID, + & TES(N)%TIME, START0, COUNT0 ), 303 ) + + ! READ quality flag + CALL CHECK( NF90_GET_VAR ( FID, QU_ID, + & TES(N)%QUALITY_FLAG, START0, COUNT0 ), 304 ) + + ENDDO + + !-------------------------------- + ! Find # of good levels for each + !-------------------------------- + + ! define record size + START1 = (/1, 1/) + COUNT1 = (/MAXLEV, 1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:MAXLEV), START1, COUNT1 ), 401 ) + + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + + J = 1 + DO WHILE ( J .le. MAXLEV ) + + ! check if the value is good + IF ( TES(N)%O3(J) > FILL ) THEN + + ! save the number of good levels as LTES + TES(N)%LTES = MAXLEV - J + 1 + + ! and now we can exit the while loop + J = MAXLEV + 1 + + ! otherwise this level is just filler + ELSE + + ! so proceed to the next one up + J = J + 1 + + ENDIF + + ENDDO + + ENDDO + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START1 = (/MAXLEV - J + 1, 1/) + COUNT1 = (/J, 1/) + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:J), START1, COUNT1 ), 401 ) + + ! READ pressure levels, PRES + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES(N)%PRES(1:J), START1, COUNT1 ), 402 ) + + ! READ apriori O3 column, PRIOR + CALL CHECK( NF90_GET_VAR ( FID, AP_ID, + & TES(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) + + + ENDDO + + + !-------------------------------- + ! Read 2D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START2 = (/MAXLEV - J + 1, MAXLEV - J + 1, 1/) + COUNT2 = (/J, J, 1/) + + ! Update starting index + START2(3) = N + + ! READ averaging kernal, AVG_KERNEL + CALL CHECK( NF90_GET_VAR ( FID, AK_ID, + & TES(N)%AVG_KERNEL(1:J,1:J), START2, COUNT2), 501 ) + + ! READ observational error covariance + CALL CHECK( NF90_GET_VAR ( FID, OE_ID, + & TES(N)%S_OER(1:J,1:J), START2, COUNT2), 502 ) + ENDDO + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + J = TES(N)%LTES(1) + !print*, ' TES test ', TES(N)%O3 + !print*, ' TES good ', TES(N)%LTES + !print*, ' TES pres ', TES(N)%PRES(1:J) + + ! Add a bit to the diagonal to regularize the inversion + ! (ks, ml, dkh, 11/18/10) + ! mkeller: this makes no sense to me. + !DO II=1,J + ! TES(N)%S_OER(II,II) = TES(N)%S_OER(II,II)+ 0.001D0 + !ENDDO + + CALL SVD( TES(N)%S_OER(1:J,1:J), J, + & U(1:J,1:J), S(1:J), + & VT(1:J,1:J) ) + + ! U = S^-1 * U^T + TEST = 0d0 + DO I = 1, J + + ! mkeller: regularize matrix inverse by ignoring all singular values below a certain cutoff. + ! This is horrendously inefficient, but should work for now. In the + ! future, Thikonov regularization should be implemented instead. + ! xzhang: svd test critical value changes from 1e-2 to 5e-2 + IF ( S(I)/S(1) < 1e-2 ) THEN + S(I) = 1e-2 * S(1) + ENDIF + DO II = 1, J + TEST(I,II) = U(II,I) / S(I) + ENDDO + ENDDO + + !TEST = 0d0 + U = TEST + TEST = 0d0 + + + ! S_OER_INV = V * S^-1 * U^T + DO I = 1, J + DO II = 1, J + TMP1 = 0d0 + DO III = 1, J + TMP1 = TMP1 + VT(III,I) * U(III,II) + ENDDO + TES(N)%S_OER_INV(I,II) = TMP1 + ENDDO + ENDDO + + ! TEST: calculate 2-norm of I - S_OER_INV * S_OER + ! mkeller: comment this out for now; pointless given the regularization + ! performed above. + ! Need to come up with an alternative test in the future. + !DO I = 1, J + ! DO II = 1, J + ! TMP1 = 0d0 + ! DO III = 1, J + ! TMP1 = TMP1 + !& + TES(N)%S_OER_INV(III,I) * TES(N)%S_OER(III,II) + !ENDDO + !TEST(I,II) = - TMP1 + !ENDDO + !TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 + !ENDDO + + !IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN + ! print*, ' WARNING: inversion error for retv N = ', + !& SUM(TEST(1:J,1:J)), N + ! print*, ' in TES obs ', READ_FILENAME + ! ENDIF + + ENDDO ! N + + ! Return to calling program + END SUBROUTINE READ_TES_O3_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_nh3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_O3_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_O3_FORCE calculates the adjoint forcing from the TES +! O3 observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV) + REAL*8 :: DIFF_V(MAXLEV) + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXTES) + INTEGER,SAVE :: NTES + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + REAL*8 :: O3_HAT_ADJ(MAXLEV) + REAL*8 :: O3_PERT_ADJ(MAXLEV) + REAL*8 :: GC_O3_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ(MAXLEV) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + !mkeller + REAL*8 :: TEMP_BIAS_TES(MAXLEV) + REAL*8 :: TEMP_BIAS_GC(LLPAR) + + + + !================================================================= + ! CALC_TES_O3_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_O3_FORCE ' + + ! Reset + NEW_COST = 0D0 + GC_ADJ_COUNT = 0d0 + GC_ADJ_TEMP = 0d0 + GC_ADJ_TEMP_COST = 0d0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + FILENAME = 'pres_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'o3_pert_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_o3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_teso3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 115, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! mkeller: initialize flex arrays + + CALL INIT_FLEX_REAL_1D(FLEX_LON) + CALL INIT_FLEX_REAL_1D(FLEX_LAT) + CALL INIT_FLEX_REAL_1D(FLEX_TIME) + CALL INIT_FLEX_REAL_2D(FLEX_TES_O3) + CALL INIT_FLEX_REAL_2D(FLEX_GC_O3) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the TES O3 file for this day + CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() + + ENDIF + + IF(.NOT. DATA_PRESENT) THEN + PRINT *,"No TES data present for this day, nothing to do here." + RETURN + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + +! need to update this in order to do i/o with this loop parallel +! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT + + PRINT *,"TES quality flag:", TES(NT)%QUALITY_FLAG(1) + + IF( TES(NT)%QUALITY_FLAG(1) == 0 ) THEN + PRINT *,"TES retrieval didn't converge; skipping record" + CYCLE + ENDIF + + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + O3_HAT_ADJ(:) = 0d0 + FORCE(:) = 0d0 + DIFF(:) = 0d0 + DIFF_V(:) = 0d0 + + !TEMP_BIAS_TES(:) = 0d0 + !TEMP_BIAS_GC(:) = 0d0 + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + PRINT *, "TES_LAT", REAL(TES(NT)%LAT(1)) + + ! dkh debug + !print*, 'I,J = ', I, J + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) + + + !mkeller: store TES pressure in diagnostic array. Should only be done once, as retrieval pressures don't vary between retrievals. + ! needs to be fixed. + !TES_PRESSURE = TES(NT)%PRES + + ! Get O3 values at native model resolution + DO L = 1, LLPAR + + ! check if in trop + !IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + !JLOOP = JLOP(I,J,L) + + ! get O3 from tropospheric array + !IF ( JLOOP > 0 ) THEN + + !GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) + !GC_O3_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDO3)) + + ! Convert from #/cm3 to v/v + !GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + ! mkeller: use LINOZ Ox from stored from forward run instead + ! kg -> v/v + !GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & !TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + !ELSE + + ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) + + ENDDO + + + ! Interpolate GC O3 column to TES grid + DO LL = 1, LTES + GC_O3(LL) = 0d0 + DO L = 1, LLPAR + GC_O3(LL) = GC_O3(LL) + & + MAP(L,LL) * GC_O3_NATIVE(L) + ENDDO + ENDDO + + ! dkh debug: compare profiles: + !print*, ' GC_PRES, GC_native_O3 [ppb] ' + !WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) + !print*, ' TES_PRES, GC_O3 ' + !WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) + 100 FORMAT(1X,F16.8,1X,F16.8) + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_O3(L) = MAX(GC_O3(L), 1d-10) + O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LTES + O3_HAT(L) = 0d0 + DO LL = 1, LTES + O3_HAT(L) = O3_HAT(L) + & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) + ENDDO + O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + + ! mkeller: diagnostics need an OMP CRITICAL directive +!!$OMP CRITICAL + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 11d-9 ) THEN + IF ( REAL(TES(NT)%LAT(1)) > 56.6 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 6.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-6.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > 35.0 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) -5.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-5.9d-9) + ELSEIF ( REAL(TES(NT)%LAT(1)) > 15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 7.5d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-7.5d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.2d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.2d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 9.2d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 9.2d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 2.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 2.9d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -47.7 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.7d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.7d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) < -61.9 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.6d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.6d-9) + ENDIF + ENDIF + + !mkeller: store difference in VMR on retrieval grid + TES_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_O3_MEAN(I,J,MAXLEV-LTES + L) + TES(NT)%O3(L) + TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) + exp(O3_HAT(L)) + TES_BIAS(I,J,MAXLEV-LTES + L) = + & TES_BIAS(I,J,MAXLEV-LTES + L) + + & exp(O3_HAT(L)) - TES(NT)%O3(L) + TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) = + & TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) + 1 + + ELSE + DIFF(L) = 0d0 + DIFF_V(L) = 0d0 + ENDIF + ENDDO + + ! store current information in flexible arrays + + CALL PUSH_FLEX_REAL_1D(FLEX_LON, TES(NT)%LON(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_LAT, TES(NT)%LAT(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_TIME, TES(NT)%TIME(1)) + + CALL PUSH_FLEX_REAL_2D(FLEX_TES_O3, TES(NT)%O3, LTES) + CALL PUSH_FLEX_REAL_2D(FLEX_GC_O3, exp(O3_HAT),LTES) +!!$OMP END CRITICAL + + ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + DO L = 1, LTES + FORCE(L) = 0d0 + DO LL = 1, LTES + FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) + ENDDO + NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + ENDDO + ! dkh debug: compare profiles: +!mkeller: comment this out for now, not needed + !print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' + !WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) + + !print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' + !WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) + 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) + 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !mkeller: discard observations that yield negative cost function contributions + + IF (NEW_COST(NT) < 0d0) THEN + PRINT *,"TES_DEBUG: DISCARD OBSERVATIONS FOR NT=",NT + NEW_COST(NT) = 0d0 + DIFF = 0d0 + FORCE = 0d0 + CYCLE + ENDIF + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug + !print*, 'DIFF , FORCE ' + !WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) + 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) + + ! Adjoint of difference + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 0d0 ) THEN + O3_HAT_ADJ(L) = DIFF_ADJ(L) + ENDIF + ENDDO + + ! adjoint of TES operator + DO L = 1, LTES + O3_PERT_ADJ(L) = 0d0 + DO LL = 1, LTES + O3_PERT_ADJ(L) = O3_PERT_ADJ(L) + & + TES(NT)%AVG_KERNEL(LL,L) + & * O3_HAT_ADJ(LL) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO L = 1, LTES + ! fwd code: + !GC_O3(L) = MAX(GC_O3(L), 1d-10) + !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ! adj code: + IF ( GC_O3(L) > 1d-10 ) THEN + GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) + ELSE + GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) + ENDIF + ENDDO + + ! dkh debug + !print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' + !WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) + 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_O3_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_O3_ADJ(LL) + + ENDDO + ENDDO + + !WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! mkeller: OMP critical directive needed here +!!$OMP CRITICAL + DO L = 1, LLPAR + + ! Adjoint of unit conversion + !GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * TCVV(IDTOX) / + & AD(I,J,L) + + ! mkeller: OMP critical directive needed here + + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1d0 + + GC_ADJ_TEMP(I,J,L) = GC_ADJ_TEMP(I,J,L)+GC_O3_NATIVE_ADJ(L) + + ENDDO +!!$OMP END CRITICAL + + + !GC_ADJ_TEMP_COST(I,J) = GC_ADJ_TEMP_COST(I,J) + NEW_COST(NT) + + ! dkh debug + ! mkeller: comment this out for now + !print*, 'GC_O3_NATIVE_ADJ conv ' + !WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + 104 FORMAT(1X,d14.6) + + !WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) + !WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) + !WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) + !WRITE(105,110) ( 1d9 * DIFF_V(LL), LL=LTES,1,-1) + !WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) + !WRITE(107,111) NT, LTES + !WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) + !WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) + !WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) + !WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) + !WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) + !WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(115,110) ( REAL(TES(NT)%LAT(1))) + 110 FORMAT(F18.6,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + ENDDO ! NT +!!$OMP END PARALLEL DO + + DO L=1,LLPAR + DO J=1,JJPAR + DO I=1,IIPAR + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + IF ( JLOOP > 0 ) THEN + + IF(GC_ADJ_COUNT(I,J,L)>0d0) THEN + + ! Pass adjoint back to adjoint tracer array + ! this formulation allows for aggregating the TES retrievals that fall into + ! a particular grid box into a super observation. This functionality has been + ! disabled for now. + + !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) = + & !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) + & !+ GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + + & GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDIF + + ENDIF + + ENDDO + + ! don't bin TES retrievals into a super observation for now. + + !IF( MAXVAL(GC_ADJ_COUNT(I,J,:) > 0d0) ) THEN + !COST_FUNC = COST_FUNC + + !& GC_ADJ_TEMP_COST(I,J)/MAXVAL(GC_ADJ_COUNT(I,J,:)) + !ENDIF + + ENDDO + ENDDO + + IF ( FIRST ) FIRST = .FALSE. + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_TES_O3_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_O3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine CALC_TES_O3_FORCE_FD tests the adjoint of CALC_TES_O3_FORCE +!! (dkh, 05/05/10) +!! +!! Can be driven with: +!! PERT(:) = 1D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, 30 +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!! +!! +!! +!! Arguments as Input/Output: +!! ============================================================================ +!! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +!! +!! +!! NOTES: +!! (1 ) Updated to GCv8 (dkh, 10/07/09) +!! (1 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE +! USE DAO_MOD, ONLY : AD +! USE DAO_MOD, ONLY : AIRDEN +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : XNUMOLAIR +! USE TRACERID_MOD, ONLY : IDO3 +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +! +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LTES +! INTEGER :: JLOOP +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_O3_NATIVE(LLPAR) +! REAL*8 :: GC_O3(MAXLEV) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,MAXLEV) +! REAL*8 :: O3_HAT(MAXLEV) +! REAL*8 :: O3_PERT(MAXLEV) +! REAL*8 :: FORCE(MAXLEV) +! REAL*8 :: DIFF(MAXLEV) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! REAL*8, SAVE :: TIME_FRAC(MAXTES) +! INTEGER,SAVE :: NTES +! +! REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) +! REAL*8 :: O3_HAT_ADJ(MAXLEV) +! REAL*8 :: O3_PERT_ADJ(MAXLEV) +! REAL*8 :: GC_O3_ADJ(MAXLEV) +! REAL*8 :: DIFF_ADJ(MAXLEV) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_O3_FORCE_FD begins here! +! !================================================================= +! +! print*, ' - CALC_TES_O3_FORCE_FD ' +! +! NEW_COST = 0D0 +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_press.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_on_tes.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Check if it is the last hour of a day +!! IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN +! IF ( FIRST ) THEN +! +! ! Read the TES O3 file for this day +! CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +! FIRST = .FALSE. +! ENDIF +! +!! ! Get the range of TES retrievals for the current hour +!! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES O3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +!! & TIME_FRAC(NTSTOP) +!! print*, ' found record range: ', NTSTART, NTSTOP +! +! NTSTART = 1590 +! NTSTOP = 1590 +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT +! +! ! For safety, initialize these up to LLTES +! GC_O3(:) = 0d0 +! MAP(:,:) = 0d0 +! O3_HAT_ADJ(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LTES to make coding a bit cleaner +! LTES = TES(NT)%LTES(1) +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) +! I = IIJJ(1) +! J = IIJJ(2) +! +! print*, 'I,J = ', I, J +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LTES) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) +! +! +! ! Get O3 values at native model resolution +! DO L = 1, LLPAR +! +! +! ! check if in trop +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! ! get O3 from tropospheric array +! IF ( JLOOP > 0 ) THEN +! GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) * PERT(L) +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! ENDIF +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! +! ENDIF +! +! ! Convert from #/cm3 to v/v +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! ENDDO +! +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LTES +! GC_O3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_O3(LL) = GC_O3(LL) +! & + MAP(L,LL) * GC_O3_NATIVE(L) +! ENDDO +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LTES +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! O3_HAT(L) = 0d0 +! DO LL = 1, LTES +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !ADJ_DIFF(:) = 1d0 +! !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) +! !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) +! !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) +! +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! O3_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LTES +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LTES +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * O3_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LTES +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO +! +! ! dkh debug +! print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! GC_O3_NATIVE_ADJ(L) = 0d0 +! DO LL = 1, LTES +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) +! & + MAP(L,LL) * GC_O3_ADJ(LL) +! ENDDO +! ENDDO +! +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! DO L = 1, LLPAR +! +! ! Adjoint of unit conversion +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! IF ( JLOOP > 0 ) THEN +! +! ! Pass adjoint back to adjoint tracer array +! CSPEC_ADJ_FORCE(JLOOP,IDO3) = +! & CSPEC_ADJ_FORCE(JLOOP,IDO3) + GC_O3_NATIVE_ADJ(L) +! +! ADJ(L) = GC_O3_NATIVE_ADJ(L) * CSPEC(JLOOP,IDO3) +! +! ENDIF +! +! ENDIF +! +! ENDDO +! +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_O3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', + & !TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', + & !TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where TES pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(:,LTM) = 0D0 + HINTERPZ(LTM,LTM) = 1D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ +! SUBROUTINE MAKE_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_O3_FILE saves O3 profiles that correspond to time and +!! place of TES O3 obs. (dkh, 03/01/09) +!! +!! Module variables as Input: +!! ============================================================================ +!! (1 ) O3_SAVE (REAL*8) : O3 profiles [ppmv] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE +! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J, I0, J0, L, NT +! CHARACTER(LEN=120) :: FILENAME +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! INTEGER, PARAMETER :: IUN = 88 +! +! ! For binary punch file, version 2.0 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! !================================================================= +! ! MAKE_O3_FILE begins here! +! !================================================================= +! +! FILENAME = TRIM( 'nh3.bpch' ) +! +! ! Append data directory prefix +! FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'O3 profile ' +! CATEGORY = 'IJ-AVE-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! UNIT = 'ppmv' +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the checkpoint file for output -- binary punch format +! !================================================================= +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_O3_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) +! +! ! Temporarily store data in DAT as REAL4 +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT ) +! DO NT = 1, MAXTES +! +! DAT(1,:,NT) = REAL(O3_SAVE(:,NT)) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, 1d0, 1d0, RESERVED, +! & 1, LLPAR, MAXTES, I0+1, +! & J0+1, 1, DAT ) +! +! ! Close file +! CLOSE( IUN ) +! +! print*, ' O3_SAVE sum write = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE MAKE_O3_FILE +! +!!------------------------------------------------------------------------------ +! SUBROUTINE READ_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine READ_O3_FILE reads the GC modeled O3 profiles that correspond +!! to the TES O3 times and locations. (dkh, 03/01/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( ADJTMP_DIR ) // +! & 'nh3.bpch' +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_O3_FILE: Reading ', a ) +! +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, +! & 1d0, 1, LLPAR, +! & MAXTES, DAT, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! O3_SAVE(:,:) = DAT(1,:,:) +! +! print*, ' O3_SAVE sum read = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE READ_O3_FILE +! +!!----------------------------------------------------------------------------- +! FUNCTION GET_DOUBLED_O3( NYMD, NHMS, LON, LAT ) RESULT( O3_DBL ) +!! +!!****************************************************************************** +!! Subroutine GET_DOUBLED_O3 reads and returns the nh3 profiles from +!! model run with doubled emissions. (dkh, 11/08/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TIME_MOD, ONLY : GET_TAU +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER :: NYMD, NHMS +! REAL*4 :: LON, LAT +! +! ! Function arg +! REAL*8 :: O3_DBL(LLPAR) +! +! ! Local variables +! REAL*4 :: DAT(144,91,20) +! CHARACTER(LEN=255) :: FILENAME +! INTEGER :: IIJJ(2) +! +! !================================================================= +! ! GET_DOUBLED_O3 begins here! +! !================================================================= +! +! ! filename +! FILENAME = 'nh3.YYYYMMDD.hhmm' +! +! ! Expand filename +! CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) +! +! ! Full path to file +! FILENAME = TRIM( DATA_DIR ) // +! & 'doubled_nh3/' // +! & TRIM( FILENAME ) // +! & TRIM( '00' ) +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - GET_DOUBLED_O3: Reading ', a ) +! +! ! dkh debug +! print*, ' GET_TAU() = ', GET_TAU() +! +! ! Get data +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, +! & GET_TAU(), 144, 91, +! & 20, DAT, QUIET=.FALSE. ) +! +! IIJJ = GET_IJ_2x25( LON, LAT ) +! +! print*, ' found doubled in I/J = ', IIJJ +! +! ! just the column for the present location, and convert ppb to ppm +! O3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 +! O3_DBL(21:LLPAR) = 0d0 +! +! print*, ' O3_DBL = ', O3_DBL +! +! ! Return to calling program +! END FUNCTION GET_DOUBLED_O3 +! +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!!----------------------------------------------------------------------------- +! SUBROUTINE INIT_TES_O3 +!! +!!***************************************************************************** +!! Subroutine INIT_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! IIPAR, JJPAR +! +! ! Local variables +! INTEGER :: AS +! +! !================================================================= +! ! INIT_TES_O3 begins here +! !================================================================= +! +! ! dkh debug +! print*, ' INIT_TES_O3' +! +! ALLOCATE( O3_SAVE( LLPAR, MAXTES ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_SAVE' ) +! O3_SAVE = 0d0 +! +! +! TES( 1 )%NYMD = 20050704 +! TES( 2 )%NYMD = 20050704 +! TES( 3 )%NYMD = 20050704 +! TES( 4 )%NYMD = 20050704 +! TES( 5 )%NYMD = 20050704 +! TES( 6 )%NYMD = 20050704 +! TES( 7 )%NYMD = 20050704 +! TES( 8 )%NYMD = 20050704 +! TES( 9 )%NYMD = 20050705 +! TES( 10 )%NYMD = 20050705 +! TES( 11 )%NYMD = 20050705 +! TES( 12 )%NYMD = 20050705 +! TES( 13 )%NYMD = 20050705 +! TES( 14 )%NYMD = 20050705 +! TES( 15 )%NYMD = 20050705 +! TES( 16 )%NYMD = 20050705 +! TES( 17 )%NYMD = 20050705 +! TES( 18 )%NYMD = 20050710 +! TES( 19 )%NYMD = 20050710 +! TES( 20 )%NYMD = 20050710 +! TES( 21 )%NYMD = 20050710 +! TES( 22 )%NYMD = 20050710 +! TES( 23 )%NYMD = 20050710 +! TES( 24 )%NYMD = 20050710 +! TES( 25 )%NYMD = 20050710 +! TES( 26 )%NYMD = 20050710 +! TES( 27 )%NYMD = 20050711 +! TES( 28 )%NYMD = 20050711 +! TES( 29 )%NYMD = 20050711 +! TES( 30 )%NYMD = 20050711 +! TES( 31 )%NYMD = 20050712 +! TES( 32 )%NYMD = 20050712 +! TES( 33 )%NYMD = 20050712 +! TES( 34 )%NYMD = 20050712 +! TES( 35 )%NYMD = 20050712 +! TES( 36 )%NYMD = 20050712 +! TES( 37 )%NYMD = 20050712 +! TES( 38 )%NYMD = 20050712 +! TES( 39 )%NYMD = 20050713 +! TES( 40 )%NYMD = 20050713 +! TES( 41 )%NYMD = 20050713 +! TES( 42 )%NYMD = 20050713 +! TES( 43 )%NYMD = 20050713 +! TES( 44 )%NYMD = 20050713 +! TES( 45 )%NYMD = 20050713 +! TES( 46 )%NYMD = 20050713 +! TES( 47 )%NYMD = 20050713 +! TES( 48 )%NYMD = 20050714 +! TES( 49 )%NYMD = 20050714 +! TES( 50 )%NYMD = 20050714 +! TES( 51 )%NYMD = 20050714 +! TES( 52 )%NYMD = 20050714 +! TES( 53 )%NYMD = 20050714 +! TES( 54 )%NYMD = 20050714 +! TES( 55 )%NYMD = 20050714 +! TES( 56 )%NYMD = 20050715 +! TES( 57 )%NYMD = 20050715 +! TES( 58 )%NYMD = 20050715 +! TES( 59 )%NYMD = 20050715 +! TES( 60 )%NYMD = 20050715 +! TES( 61 )%NYMD = 20050715 +! TES( 62 )%NYMD = 20050715 +! TES( 63 )%NYMD = 20050715 +! TES( 64 )%NYMD = 20050715 +! TES( 65 )%NYMD = 20050716 +! TES( 66 )%NYMD = 20050717 +! TES( 67 )%NYMD = 20050717 +! TES( 68 )%NYMD = 20050717 +! TES( 69 )%NYMD = 20050717 +! TES( 70 )%NYMD = 20050717 +! TES( 71 )%NYMD = 20050717 +! TES( 72 )%NYMD = 20050717 +! TES( 73 )%NYMD = 20050717 +! TES( 74 )%NYMD = 20050717 +! TES( 75 )%NYMD = 20050718 +! TES( 76 )%NYMD = 20050718 +! TES( 77 )%NYMD = 20050718 +! TES( 78 )%NYMD = 20050718 +! TES( 79 )%NYMD = 20050719 +! TES( 80 )%NYMD = 20050719 +! TES( 81 )%NYMD = 20050719 +! TES( 82 )%NYMD = 20050719 +! TES( 83 )%NYMD = 20050719 +! TES( 84 )%NYMD = 20050719 +! TES( 85 )%NYMD = 20050719 +! TES( 86 )%NYMD = 20050719 +! TES( 87 )%NYMD = 20050719 +! +! TES( 1 )%NHMS = 202000 +! TES( 2 )%NHMS = 202100 +! TES( 3 )%NHMS = 202100 +! TES( 4 )%NHMS = 202100 +! TES( 5 )%NHMS = 202200 +! TES( 6 )%NHMS = 202300 +! TES( 7 )%NHMS = 202300 +! TES( 8 )%NHMS = 202400 +! TES( 9 )%NHMS = 082100 +! TES( 10 )%NHMS = 082100 +! TES( 11 )%NHMS = 082200 +! TES( 12 )%NHMS = 082200 +! TES( 13 )%NHMS = 082300 +! TES( 14 )%NHMS = 082300 +! TES( 15 )%NHMS = 082400 +! TES( 16 )%NHMS = 082400 +! TES( 17 )%NHMS = 082500 +! TES( 18 )%NHMS = 194300 +! TES( 19 )%NHMS = 194300 +! TES( 20 )%NHMS = 194400 +! TES( 21 )%NHMS = 194400 +! TES( 22 )%NHMS = 194500 +! TES( 23 )%NHMS = 194500 +! TES( 24 )%NHMS = 194600 +! TES( 25 )%NHMS = 194600 +! TES( 26 )%NHMS = 194700 +! TES( 27 )%NHMS = 092300 +! TES( 28 )%NHMS = 092300 +! TES( 29 )%NHMS = 092400 +! TES( 30 )%NHMS = 092400 +! TES( 31 )%NHMS = 193000 +! TES( 32 )%NHMS = 193100 +! TES( 33 )%NHMS = 193100 +! TES( 34 )%NHMS = 193200 +! TES( 35 )%NHMS = 193300 +! TES( 36 )%NHMS = 193300 +! TES( 37 )%NHMS = 193400 +! TES( 38 )%NHMS = 193400 +! TES( 39 )%NHMS = 091000 +! TES( 40 )%NHMS = 091100 +! TES( 41 )%NHMS = 091100 +! TES( 42 )%NHMS = 091200 +! TES( 43 )%NHMS = 091200 +! TES( 44 )%NHMS = 091200 +! TES( 45 )%NHMS = 091300 +! TES( 46 )%NHMS = 091300 +! TES( 47 )%NHMS = 091400 +! TES( 48 )%NHMS = 191900 +! TES( 49 )%NHMS = 191900 +! TES( 50 )%NHMS = 191900 +! TES( 51 )%NHMS = 192000 +! TES( 52 )%NHMS = 192000 +! TES( 53 )%NHMS = 192100 +! TES( 54 )%NHMS = 192100 +! TES( 55 )%NHMS = 192200 +! TES( 56 )%NHMS = 085800 +! TES( 57 )%NHMS = 085800 +! TES( 58 )%NHMS = 085900 +! TES( 59 )%NHMS = 085900 +! TES( 60 )%NHMS = 090000 +! TES( 61 )%NHMS = 090000 +! TES( 62 )%NHMS = 090100 +! TES( 63 )%NHMS = 090100 +! TES( 64 )%NHMS = 090100 +! TES( 65 )%NHMS = 190900 +! TES( 66 )%NHMS = 084500 +! TES( 67 )%NHMS = 084600 +! TES( 68 )%NHMS = 084600 +! TES( 69 )%NHMS = 084700 +! TES( 70 )%NHMS = 084700 +! TES( 71 )%NHMS = 084800 +! TES( 72 )%NHMS = 084800 +! TES( 73 )%NHMS = 084900 +! TES( 74 )%NHMS = 084900 +! TES( 75 )%NHMS = 203200 +! TES( 76 )%NHMS = 203300 +! TES( 77 )%NHMS = 203300 +! TES( 78 )%NHMS = 203400 +! TES( 79 )%NHMS = 083300 +! TES( 80 )%NHMS = 083400 +! TES( 81 )%NHMS = 083400 +! TES( 82 )%NHMS = 083500 +! TES( 83 )%NHMS = 083500 +! TES( 84 )%NHMS = 083500 +! TES( 85 )%NHMS = 083600 +! TES( 86 )%NHMS = 083600 +! TES( 87 )%NHMS = 083700 +! +! TES( 1 )%LAT = 31.29 +! TES( 2 )%LAT = 33 +! TES( 3 )%LAT = 34.64 +! TES( 4 )%LAT = 36.2 +! TES( 5 )%LAT = 37.91 +! TES( 6 )%LAT = 41.1 +! TES( 7 )%LAT = 42.8 +! TES( 8 )%LAT = 44.43 +! TES( 9 )%LAT = 43.54 +! TES( 10 )%LAT = 41.84 +! TES( 11 )%LAT = 40.2 +! TES( 12 )%LAT = 38.65 +! TES( 13 )%LAT = 36.94 +! TES( 14 )%LAT = 35.3 +! TES( 15 )%LAT = 33.74 +! TES( 16 )%LAT = 32.03 +! TES( 17 )%LAT = 30.39 +! TES( 18 )%LAT = 31.28 +! TES( 19 )%LAT = 32.99 +! TES( 20 )%LAT = 34.63 +! TES( 21 )%LAT = 36.19 +! TES( 22 )%LAT = 37.9 +! TES( 23 )%LAT = 39.53 +! TES( 24 )%LAT = 41.09 +! TES( 25 )%LAT = 42.8 +! TES( 26 )%LAT = 44.42 +! TES( 27 )%LAT = 43.55 +! TES( 28 )%LAT = 41.85 +! TES( 29 )%LAT = 40.22 +! TES( 30 )%LAT = 38.66 +! TES( 31 )%LAT = 31.28 +! TES( 32 )%LAT = 32.99 +! TES( 33 )%LAT = 34.63 +! TES( 34 )%LAT = 36.19 +! TES( 35 )%LAT = 39.53 +! TES( 36 )%LAT = 41.09 +! TES( 37 )%LAT = 42.79 +! TES( 38 )%LAT = 44.42 +! TES( 39 )%LAT = 43.55 +! TES( 40 )%LAT = 41.85 +! TES( 41 )%LAT = 40.22 +! TES( 42 )%LAT = 38.66 +! TES( 43 )%LAT = 36.96 +! TES( 44 )%LAT = 35.32 +! TES( 45 )%LAT = 33.76 +! TES( 46 )%LAT = 32.04 +! TES( 47 )%LAT = 30.4 +! TES( 48 )%LAT = 32.99 +! TES( 49 )%LAT = 34.63 +! TES( 50 )%LAT = 36.2 +! TES( 51 )%LAT = 37.9 +! TES( 52 )%LAT = 39.54 +! TES( 53 )%LAT = 41.1 +! TES( 54 )%LAT = 42.8 +! TES( 55 )%LAT = 44.42 +! TES( 56 )%LAT = 43.55 +! TES( 57 )%LAT = 41.85 +! TES( 58 )%LAT = 40.22 +! TES( 59 )%LAT = 38.66 +! TES( 60 )%LAT = 36.95 +! TES( 61 )%LAT = 35.31 +! TES( 62 )%LAT = 33.75 +! TES( 63 )%LAT = 32.04 +! TES( 64 )%LAT = 30.4 +! TES( 65 )%LAT = 44.4 +! TES( 66 )%LAT = 43.59 +! TES( 67 )%LAT = 41.89 +! TES( 68 )%LAT = 40.26 +! TES( 69 )%LAT = 38.7 +! TES( 70 )%LAT = 37 +! TES( 71 )%LAT = 35.36 +! TES( 72 )%LAT = 33.8 +! TES( 73 )%LAT = 32.09 +! TES( 74 )%LAT = 30.45 +! TES( 75 )%LAT = 31.27 +! TES( 76 )%LAT = 32.98 +! TES( 77 )%LAT = 34.62 +! TES( 78 )%LAT = 36.18 +! TES( 79 )%LAT = 43.58 +! TES( 80 )%LAT = 41.88 +! TES( 81 )%LAT = 40.25 +! TES( 82 )%LAT = 38.69 +! TES( 83 )%LAT = 36.98 +! TES( 84 )%LAT = 35.34 +! TES( 85 )%LAT = 33.78 +! TES( 86 )%LAT = 32.07 +! TES( 87 )%LAT = 30.43 +! +! TES( 1 )%LON = -105.13 +! TES( 2 )%LON = -105.6 +! TES( 3 )%LON = -106.05 +! TES( 4 )%LON = -106.5 +! TES( 5 )%LON = -107 +! TES( 6 )%LON = -108 +! TES( 7 )%LON = -108.57 +! TES( 8 )%LON = -109.13 +! TES( 9 )%LON = -92.52 +! TES( 10 )%LON = -93.09 +! TES( 11 )%LON = -93.62 +! TES( 12 )%LON = -94.11 +! TES( 13 )%LON = -94.62 +! TES( 14 )%LON = -95.09 +! TES( 15 )%LON = -95.53 +! TES( 16 )%LON = -96 +! TES( 17 )%LON = -96.44 +! TES( 18 )%LON = -95.84 +! TES( 19 )%LON = -96.3 +! TES( 20 )%LON = -96.76 +! TES( 21 )%LON = -97.2 +! TES( 22 )%LON = -97.71 +! TES( 23 )%LON = -98.21 +! TES( 24 )%LON = -98.71 +! TES( 25 )%LON = -99.27 +! TES( 26 )%LON = -99.83 +! TES( 27 )%LON = -107.94 +! TES( 28 )%LON = -108.51 +! TES( 29 )%LON = -109.04 +! TES( 30 )%LON = -109.53 +! TES( 31 )%LON = -92.74 +! TES( 32 )%LON = -93.2 +! TES( 33 )%LON = -93.66 +! TES( 34 )%LON = -94.11 +! TES( 35 )%LON = -95.11 +! TES( 36 )%LON = -95.61 +! TES( 37 )%LON = -96.17 +! TES( 38 )%LON = -96.73 +! TES( 39 )%LON = -104.84 +! TES( 40 )%LON = -105.41 +! TES( 41 )%LON = -105.94 +! TES( 42 )%LON = -106.43 +! TES( 43 )%LON = -106.94 +! TES( 44 )%LON = -107.42 +! TES( 45 )%LON = -107.86 +! TES( 46 )%LON = -108.33 +! TES( 47 )%LON = -108.76 +! TES( 48 )%LON = -90.1 +! TES( 49 )%LON = -90.56 +! TES( 50 )%LON = -91.01 +! TES( 51 )%LON = -91.51 +! TES( 52 )%LON = -92.01 +! TES( 53 )%LON = -92.51 +! TES( 54 )%LON = -93.07 +! TES( 55 )%LON = -93.64 +! TES( 56 )%LON = -101.74 +! TES( 57 )%LON = -102.32 +! TES( 58 )%LON = -102.84 +! TES( 59 )%LON = -103.33 +! TES( 60 )%LON = -103.84 +! TES( 61 )%LON = -104.32 +! TES( 62 )%LON = -104.76 +! TES( 63 )%LON = -105.23 +! TES( 64 )%LON = -105.67 +! TES( 65 )%LON = -90.54 +! TES( 66 )%LON = -98.64 +! TES( 67 )%LON = -99.22 +! TES( 68 )%LON = -99.75 +! TES( 69 )%LON = -100.23 +! TES( 70 )%LON = -100.75 +! TES( 71 )%LON = -101.22 +! TES( 72 )%LON = -101.67 +! TES( 73 )%LON = -102.13 +! TES( 74 )%LON = -102.57 +! TES( 75 )%LON = -108.19 +! TES( 76 )%LON = -108.65 +! TES( 77 )%LON = -109.11 +! TES( 78 )%LON = -109.55 +! TES( 79 )%LON = -95.57 +! TES( 80 )%LON = -96.14 +! TES( 81 )%LON = -96.67 +! TES( 82 )%LON = -97.16 +! TES( 83 )%LON = -97.67 +! TES( 84 )%LON = -98.15 +! TES( 85 )%LON = -98.59 +! TES( 86 )%LON = -99.06 +! TES( 87 )%LON = -99.49 +! +! TES( 1 )%FILENAME = TRIM('retv_vars.02945_0457_002.cdf') +! TES( 2 )%FILENAME = TRIM('retv_vars.02945_0457_003.cdf') +! TES( 3 )%FILENAME = TRIM('retv_vars.02945_0457_004.cdf') +! TES( 4 )%FILENAME = TRIM('retv_vars.02945_0458_002.cdf') +! TES( 5 )%FILENAME = TRIM('retv_vars.02945_0458_003.cdf') +! TES( 6 )%FILENAME = TRIM('retv_vars.02945_0459_002.cdf') +! TES( 7 )%FILENAME = TRIM('retv_vars.02945_0459_003.cdf') +! TES( 8 )%FILENAME = TRIM('retv_vars.02945_0459_004.cdf') +! TES( 9 )%FILENAME = TRIM('retv_vars.02945_0982_002.cdf') +! TES( 10 )%FILENAME = TRIM('retv_vars.02945_0982_003.cdf') +! TES( 11 )%FILENAME = TRIM('retv_vars.02945_0982_004.cdf') +! TES( 12 )%FILENAME = TRIM('retv_vars.02945_0983_002.cdf') +! TES( 13 )%FILENAME = TRIM('retv_vars.02945_0983_003.cdf') +! TES( 14 )%FILENAME = TRIM('retv_vars.02945_0983_004.cdf') +! TES( 15 )%FILENAME = TRIM('retv_vars.02945_0984_002.cdf') +! TES( 16 )%FILENAME = TRIM('retv_vars.02945_0984_003.cdf') +! TES( 17 )%FILENAME = TRIM('retv_vars.02945_0984_004.cdf') +! TES( 18 )%FILENAME = TRIM('retv_vars.02956_0457_002.cdf') +! TES( 19 )%FILENAME = TRIM('retv_vars.02956_0457_003.cdf') +! TES( 20 )%FILENAME = TRIM('retv_vars.02956_0457_004.cdf') +! TES( 21 )%FILENAME = TRIM('retv_vars.02956_0458_002.cdf') +! TES( 22 )%FILENAME = TRIM('retv_vars.02956_0458_003.cdf') +! TES( 23 )%FILENAME = TRIM('retv_vars.02956_0458_004.cdf') +! TES( 24 )%FILENAME = TRIM('retv_vars.02956_0459_002.cdf') +! TES( 25 )%FILENAME = TRIM('retv_vars.02956_0459_003.cdf') +! TES( 26 )%FILENAME = TRIM('retv_vars.02956_0459_004.cdf') +! TES( 27 )%FILENAME = TRIM('retv_vars.02956_1054_002.cdf') +! TES( 28 )%FILENAME = TRIM('retv_vars.02956_1054_003.cdf') +! TES( 29 )%FILENAME = TRIM('retv_vars.02956_1054_004.cdf') +! TES( 30 )%FILENAME = TRIM('retv_vars.02956_1055_002.cdf') +! TES( 31 )%FILENAME = TRIM('retv_vars.02960_0457_002.cdf') +! TES( 32 )%FILENAME = TRIM('retv_vars.02960_0457_003.cdf') +! TES( 33 )%FILENAME = TRIM('retv_vars.02960_0457_004.cdf') +! TES( 34 )%FILENAME = TRIM('retv_vars.02960_0458_002.cdf') +! TES( 35 )%FILENAME = TRIM('retv_vars.02960_0458_004.cdf') +! TES( 36 )%FILENAME = TRIM('retv_vars.02960_0459_002.cdf') +! TES( 37 )%FILENAME = TRIM('retv_vars.02960_0459_003.cdf') +! TES( 38 )%FILENAME = TRIM('retv_vars.02960_0459_004.cdf') +! TES( 39 )%FILENAME = TRIM('retv_vars.02960_1054_002.cdf') +! TES( 40 )%FILENAME = TRIM('retv_vars.02960_1054_003.cdf') +! TES( 41 )%FILENAME = TRIM('retv_vars.02960_1054_004.cdf') +! TES( 42 )%FILENAME = TRIM('retv_vars.02960_1055_002.cdf') +! TES( 43 )%FILENAME = TRIM('retv_vars.02960_1055_003.cdf') +! TES( 44 )%FILENAME = TRIM('retv_vars.02960_1055_004.cdf') +! TES( 45 )%FILENAME = TRIM('retv_vars.02960_1056_002.cdf') +! TES( 46 )%FILENAME = TRIM('retv_vars.02960_1056_003.cdf') +! TES( 47 )%FILENAME = TRIM('retv_vars.02960_1056_004.cdf') +! TES( 48 )%FILENAME = TRIM('retv_vars.02963_0457_003.cdf') +! TES( 49 )%FILENAME = TRIM('retv_vars.02963_0457_004.cdf') +! TES( 50 )%FILENAME = TRIM('retv_vars.02963_0458_002.cdf') +! TES( 51 )%FILENAME = TRIM('retv_vars.02963_0458_003.cdf') +! TES( 52 )%FILENAME = TRIM('retv_vars.02963_0458_004.cdf') +! TES( 53 )%FILENAME = TRIM('retv_vars.02963_0459_002.cdf') +! TES( 54 )%FILENAME = TRIM('retv_vars.02963_0459_003.cdf') +! TES( 55 )%FILENAME = TRIM('retv_vars.02963_0459_004.cdf') +! TES( 56 )%FILENAME = TRIM('retv_vars.02963_1054_002.cdf') +! TES( 57 )%FILENAME = TRIM('retv_vars.02963_1054_003.cdf') +! TES( 58 )%FILENAME = TRIM('retv_vars.02963_1054_004.cdf') +! TES( 59 )%FILENAME = TRIM('retv_vars.02963_1055_002.cdf') +! TES( 60 )%FILENAME = TRIM('retv_vars.02963_1055_003.cdf') +! TES( 61 )%FILENAME = TRIM('retv_vars.02963_1055_004.cdf') +! TES( 62 )%FILENAME = TRIM('retv_vars.02963_1056_002.cdf') +! TES( 63 )%FILENAME = TRIM('retv_vars.02963_1056_003.cdf') +! TES( 64 )%FILENAME = TRIM('retv_vars.02963_1056_004.cdf') +! TES( 65 )%FILENAME = TRIM('retv_vars.02967_0459_004.cdf') +! TES( 66 )%FILENAME = TRIM('retv_vars.02967_1054_002.cdf') +! TES( 67 )%FILENAME = TRIM('retv_vars.02967_1054_003.cdf') +! TES( 68 )%FILENAME = TRIM('retv_vars.02967_1054_004.cdf') +! TES( 69 )%FILENAME = TRIM('retv_vars.02967_1055_002.cdf') +! TES( 70 )%FILENAME = TRIM('retv_vars.02967_1055_003.cdf') +! TES( 71 )%FILENAME = TRIM('retv_vars.02967_1055_004.cdf') +! TES( 72 )%FILENAME = TRIM('retv_vars.02967_1056_002.cdf') +! TES( 73 )%FILENAME = TRIM('retv_vars.02967_1056_003.cdf') +! TES( 74 )%FILENAME = TRIM('retv_vars.02967_1056_004.cdf') +! TES( 75 )%FILENAME = TRIM('retv_vars.02971_0457_002.cdf') +! TES( 76 )%FILENAME = TRIM('retv_vars.02971_0457_003.cdf') +! TES( 77 )%FILENAME = TRIM('retv_vars.02971_0457_004.cdf') +! TES( 78 )%FILENAME = TRIM('retv_vars.02971_0458_002.cdf') +! TES( 79 )%FILENAME = TRIM('retv_vars.02971_0982_002.cdf') +! TES( 80 )%FILENAME = TRIM('retv_vars.02971_0982_003.cdf') +! TES( 81 )%FILENAME = TRIM('retv_vars.02971_0982_004.cdf') +! TES( 82 )%FILENAME = TRIM('retv_vars.02971_0983_002.cdf') +! TES( 83 )%FILENAME = TRIM('retv_vars.02971_0983_003.cdf') +! TES( 84 )%FILENAME = TRIM('retv_vars.02971_0983_004.cdf') +! TES( 85 )%FILENAME = TRIM('retv_vars.02971_0984_002.cdf') +! TES( 86 )%FILENAME = TRIM('retv_vars.02971_0984_003.cdf') +! TES( 87 )%FILENAME = TRIM('retv_vars.02971_0984_004.cdf') +! +! ! Return to calling program +! END SUBROUTINE INIT_TES_O3 +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CLEANUP_TES_O3 +!! +!!***************************************************************************** +!! Subroutine CLEANUP_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! +! IF ( ALLOCATED( O3_SAVE ) ) DEALLOCATE( O3_SAVE ) +! +! +! ! Return to calling program +! END SUBROUTINE CLEANUP_TES_O3 +!!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ + + SUBROUTINE SVD(A,N,U,S,VT) +! +!****************************************************************************** +! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) A (REAL*8) : N x N matrix to decompose +! (2 ) N (INTEGER) : N is dimension of A +! +! Arguments as Output: +! ============================================================================ +! (1 ) U (REAL*8) : Array of left singular vectors +! (2 ) S (REAL*8) : Vector of singular values +! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +! +! +! NOTES: +! +* Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +* The information and material ("Material") provided below is owned by Intel +* Corporation or its suppliers or licensors, and title to such Material remains +* with Intel Corporation or its suppliers or licensors. The Material contains +* proprietary information of Intel or its suppliers and licensors. The Material +* is protected by worldwide copyright laws and treaty provisions. No part of +* the Material may be copied, reproduced, published, uploaded, posted, +* transmitted, or distributed in any way without Intel's prior express written +* permission. No license under any patent, copyright or other intellectual +* property rights in the Material is granted to or conferred upon you, either +* expressly, by implication, inducement, estoppel or otherwise. Any license +* under such intellectual property rights must be express and approved by Intel +* in writing. +* ============================================================================= +* +* DGESVD Example. +* ============== +* +* Program computes the singular value decomposition of a general +* rectangular matrix A: +* +* 8.79 9.93 9.83 5.45 3.16 +* 6.11 6.91 5.04 -0.27 7.98 +* -9.15 -7.93 4.86 4.85 3.01 +* 9.57 1.64 8.83 0.74 5.80 +* -3.49 4.02 9.80 10.00 4.27 +* 9.84 0.15 -8.99 -6.02 -5.31 +* +* Description. +* ============ +* +* The routine computes the singular value decomposition (SVD) of a real +* m-by-n matrix A, optionally computing the left and/or right singular +* vectors. The SVD is written as +* +* A = U*SIGMA*VT +* +* where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +* diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +* is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +* are the singular values of A; they are real and non-negative, and are +* returned in descending order. The first min(m, n) columns of U and V are +* the left and right singular vectors of A. +* +* Note that the routine returns VT, not V. +* +* Example Program Results. +* ======================== +* +* DGESVD Example Program Results +* +* Singular values +* 27.47 22.64 8.56 5.99 2.01 +* +* Left singular vectors (stored columnwise) +* -0.59 0.26 0.36 0.31 0.23 +* -0.40 0.24 -0.22 -0.75 -0.36 +* -0.03 -0.60 -0.45 0.23 -0.31 +* -0.43 0.24 -0.69 0.33 0.16 +* -0.47 -0.35 0.39 0.16 -0.52 +* 0.29 0.58 -0.02 0.38 -0.65 +* +* Right singular vectors (stored rowwise) +* -0.25 -0.40 -0.69 -0.37 -0.41 +* 0.81 0.36 -0.25 -0.37 -0.10 +* -0.26 0.70 -0.22 0.39 -0.49 +* 0.40 -0.45 0.25 0.43 -0.62 +* -0.22 0.14 0.59 -0.63 -0.44 +* ============================================================================= +!****************************************************************************** +! + ! Arguements + INTEGER,INTENT(IN) :: N + REAL*8, INTENT(IN) :: A(N,N) + REAL*8, INTENT(OUT) :: U(N,N) + REAL*8, INTENT(OUT) :: S(N) + REAL*8, INTENT(OUT) :: VT(N,N) + + ! Local variables + INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 + INTEGER :: INFO, LWORK + DOUBLE PRECISION :: WORK( LWMAX ) + +* .. External Subroutines .. + EXTERNAL :: DGESVD + +* .. Intrinsic Functions .. + INTRINSIC :: INT, MIN + + !================================================================= + ! SVD begins here! + !================================================================= + +* .. Executable Statements .. + !WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF + +! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +!! +!! Print singular values. +!! +! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!! +!! Print left singular vectors. +!! +! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +! $ N, N, U, N ) +!! +!! Print right singular vectors. +!! +! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +! $ N, N, VT, N ) + + ! Return to calling program + END SUBROUTINE SVD +!------------------------------------------------------------------------------ + SUBROUTINE DGESVD_EXAMPLE + +* .. Parameters .. + INTEGER M, N + PARAMETER ( M = 6, N = 5 ) + INTEGER LDA, LDU, LDVT + PARAMETER ( LDA = M, LDU = M, LDVT = N ) + INTEGER LWMAX + PARAMETER ( LWMAX = 1000 ) +* +* .. Local Scalars .. + INTEGER INFO, LWORK +* +* .. Local Arrays .. + DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), + $ WORK( LWMAX ) + DATA A/ + $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, + $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, + $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, + $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, + $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 + $ / +* +* .. External Subroutines .. + EXTERNAL DGESVD + !EXTERNAL PRINT_MATRIX +* +* .. Intrinsic Functions .. + INTRINSIC INT, MIN +* +* .. Executable Statements .. + WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF +* +* Print singular values. +* + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +* +* Print left singular vectors. +* + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ M, N, U, LDU ) +* +* Print right singular vectors. +* + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, LDVT ) + +* +* End of DGESVD Example. + END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +* +* Auxiliary routine: printing a matrix. +* + SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) + CHARACTER*(*) DESC + INTEGER M, N, LDA + DOUBLE PRECISION A( LDA, * ) +* + INTEGER I, J +* + WRITE(*,*) + WRITE(*,*) DESC + DO I = 1, M + WRITE(*,9998) ( A( I, J ), J = 1, N ) + END DO +* +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) + 9998 FORMAT( 11(:,1X,E14.8) ) + RETURN + + END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_TES_BIAS_FILE_HDF5(FILE_ID) + + USE HDF5 + + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + + INTEGER(HID_T) :: FILE_ID + + CHARACTER(LEN=255) :: LON_NAME, LAT_NAME, LEV_NAME + CHARACTER(LEN=255) :: TES_O3_NAME + CHARACTER(LEN=255) :: TES_GC_O3_NAME + CHARACTER(LEN=255) :: TES_BIAS_NAME + CHARACTER(LEN=255) :: TES_COUNT_NAME + CHARACTER(LEN=255) :: LON_RAW_NAME, LAT_RAW_NAME, TIME_RAW_NAME + CHARACTER(LEN=255) :: TES_O3_RAW_NAME, TES_GC_O3_RAW_NAME + + CHARACTER(LEN=255) :: TES_O3_LONGNAME + CHARACTER(LEN=255) :: TES_GC_O3_LONGNAME + CHARACTER(LEN=255) :: TES_BIAS_LONGNAME + CHARACTER(LEN=255) :: TES_COUNT_LONGNAME + CHARACTER(LEN=255) :: TES_O3_RAW_LONGNAME, TES_GC_O3_RAW_LONGNAME + + CHARACTER(LEN=255) :: TES_O3_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_UNIT + CHARACTER(LEN=255) :: TES_BIAS_UNIT + CHARACTER(LEN=255) :: TES_COUNT_UNIT + CHARACTER(LEN=255) :: TES_O3_RAW_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_RAW_UNIT + + CHARACTER(LEN=255) :: LON_LONGNAME, LAT_LONGNAME, LEV_LONGNAME + CHARACTER(LEN=255) :: LON_UNIT, LAT_UNIT, LEV_UNIT + CHARACTER(LEN=255) :: LON_RAW_LONGNAME, LAT_RAW_LONGNAME + CHARACTER(LEN=255) :: TIME_RAW_LONGNAME + CHARACTER(LEN=255) :: LON_RAW_UNIT, LAT_RAW_UNIT + CHARACTER(LEN=255) :: TIME_RAW_UNIT + + INTEGER(HID_T) :: SPACE_LON, SPACE_LAT, SPACE_LEV + INTEGER(HID_T) :: SPACE_RAW_1D, SPACE_RAW_2D + INTEGER(HID_T) :: LON_ID, LAT_ID, LEV_ID + INTEGER(HID_T) :: LON_RAW_ID, LAT_RAW_ID, TIME_RAW_ID + INTEGER(HID_T) :: SPACE_TES, DSET_TES_O3_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_ID + INTEGER(HID_T) :: DSET_TES_BIAS_ID + INTEGER(HID_T) :: DSET_TES_COUNT_ID + INTEGER(HID_T) :: DSET_TES_O3_RAW_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_RAW_ID + + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER(HID_T) :: TES_GROUP_ID, GRID_GROUP_ID + INTEGER(HID_T) :: GRID_DATA_GROUP_ID, RAW_DATA_GROUP_ID + INTEGER(HID_T) :: LEVEL3_GROUP_ID + + INTEGER(HSIZE_T) :: DIMS(3), DIM_LON(1), DIM_LAT(1), DIM_LEV(1) + INTEGER(HSIZE_T) :: DIM_RAW_1D(1), DIM_RAW_2D(2) + + INTEGER :: HDF_ERR + INTEGER :: RANK = 3 + + INTEGER :: I,J,L + REAL*4 :: MISS_VAL = -999.9 + REAL*4 :: LON_VALS(IIPAR), LAT_VALS(JJPAR), LEV_VALS(MAXLEV) + + ! populate lon & lat arrays + + DO I=1,IIPAR + LON_VALS(I)=GET_XMID(I) + ENDDO + + DO J=1,JJPAR + LAT_VALS(J)=GET_YMID(J) + ENDDO + + DO I=1,MAXLEV + LEV_VALS(I)=TES_PRESSURE(I) ! assume that TES retrieval grid doesn't change + ENDDO + + DO L=1,MAXLEV + DO J=1,JJPAR + DO I=1,IIPAR + + IF(TES_BIAS_COUNT(I,J,L)>0d0) THEN + TES_O3_MEAN(I,J,L) = + & REAL(TES_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_GC_O3_MEAN(I,J,L) = + & REAL(TES_GC_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_BIAS(I,J,L) = + & REAL(TES_BIAS(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + ELSE + TES_O3_MEAN(I,J,L) = MISS_VAL + TES_GC_O3_MEAN(I,J,L) = MISS_VAL + TES_BIAS(I,J,L) = MISS_VAL + !TES_CHI_SQUARED(I,J,L) = MISS_VAL + ENDIF + + ENDDO + ENDDO + ENDDO + + DIMS(1) = IIPAR + DIMS(2) = JJPAR + DIMS(3) = MAXLEV + + ADIMS(1) = 1 + + DIM_LON = IIPAR + DIM_LAT = JJPAR + DIM_LEV = MAXLEV + + DIM_RAW_1D = FLEX_LON%CURRENT_N + + DIM_RAW_2D(1) = MAXLEV + DIM_RAW_2D(2) = FLEX_LON%CURRENT_N + + ! open HDF5 interface + + CALL H5OPEN_F(HDF_ERR) + + ! create group structure in file + + CALL H5GCREATE_F(FILE_ID,"TES",TES_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level3",LEVEL3_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Data", + & GRID_DATA_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Grid",GRID_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level2",RAW_DATA_GROUP_ID,HDF_ERR) + + ! write Level3 grid information + + CALL H5SCREATE_SIMPLE_F(1,DIM_LON,SPACE_LON,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LAT,SPACE_LAT,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LEV,SPACE_LEV,HDF_ERR) + + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Longitude", + & H5T_IEEE_F32LE, SPACE_LON, LON_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Latitude", + & H5T_IEEE_F32LE, SPACE_LAT, LAT_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Level", + & H5T_IEEE_F32LE, SPACE_LEV, LEV_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_ID, H5T_NATIVE_REAL, LON_VALS, + & DIM_LON, HDF_ERR) + CALL H5DWRITE_F(LAT_ID, H5T_NATIVE_REAL, LAT_VALS, + & DIM_LAT, HDF_ERR) + CALL H5DWRITE_F(LEV_ID, H5T_NATIVE_REAL, LEV_VALS, + & DIM_LEV, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_ID,"Longitude","degrees") + CALL WRITE_ATTRIBUTES(LAT_ID,"Latitude","degrees") + CALL WRITE_ATTRIBUTES(LEV_ID,"Vertical level","hPa") + + CALL H5DCLOSE_F(LON_ID, HDF_ERR) + CALL H5DCLOSE_F(LAT_ID, HDF_ERR) + CALL H5DCLOSE_F(LEV_ID, HDF_ERR) + + CALL H5SCLOSE_F(SPACE_LON, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LAT, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LEV, HDF_ERR) + + ! create dataspace for TES diagnostics + + CALL H5SCREATE_SIMPLE_F(RANK,DIMS,SPACE_TES,HDF_ERR) + + ! write gridded (Level3) data + ! create all datasets as little-endian 32 bit IEEE float + + ! write TES O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_ID, H5T_NATIVE_REAL, + & TES_O3_MEAN, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_ID,"Mean TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_ID,HDF_ERR) + + ! write TES_GC O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_GC_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_ID, H5T_NATIVE_REAL, + & TES_GC_O3_MEAN, ADIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_ID, + & "Mean GC O3 profiles in TES observation space", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_ID,HDF_ERR) + + ! write TES_GC O3 bias + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_BIAS", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_BIAS_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_BIAS_ID, H5T_NATIVE_REAL, + & TES_BIAS, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_BIAS_ID,"Mean TES O3 bias profile", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_BIAS_ID,HDF_ERR) + + ! write TES_GC O3 count + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_COUNT", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_COUNT_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_COUNT_ID, H5T_NATIVE_REAL, + & TES_BIAS_COUNT, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_COUNT_ID,"TES data count", + & "1") + + CALL H5DCLOSE_F(DSET_TES_COUNT_ID,HDF_ERR) + + !----------------------------------------------------------------------------------------------------- + + ! create dataspace for raw 1D (Level2) diagnostics + + CALL H5SCREATE_SIMPLE_F(1,DIM_RAW_1D,SPACE_RAW_1D,HDF_ERR) + + ! write raw longitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Longitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LON_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LON%DATA(1:FLEX_LON%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_RAW_ID,"Longitude", "degrees") + + CALL H5DCLOSE_F(LON_RAW_ID,HDF_ERR) + + ! write raw latitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Latitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LAT_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LAT_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LAT%DATA(1:FLEX_LAT%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LAT_RAW_ID,"Latitude", "degrees") + + CALL H5DCLOSE_F(LAT_RAW_ID,HDF_ERR) + + ! write raw times + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Time", + & H5T_IEEE_F64LE, SPACE_RAW_1D, TIME_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(TIME_RAW_ID, H5T_NATIVE_DOUBLE, + & FLEX_TIME%DATA(1:FLEX_TIME%CURRENT_N), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(TIME_RAW_ID,"Time","YYYYMMDD.frac-of-day") + + CALL H5DCLOSE_F(TIME_RAW_ID,HDF_ERR) + + ! create dataspace for raw 2D diagnostics + + CALL H5SCREATE_SIMPLE_F(2,DIM_RAW_2D,SPACE_RAW_2D,HDF_ERR) + + ! write raw TES O3 profiles + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_TES_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_RAW_ID,"TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_RAW_ID,HDF_ERR) + + ! write raw GC O3 profiles as observed by GEOS-Chem + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_GC_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_GC_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_RAW_ID, + & "GEOS-Chem O3 profiles in TES observation space","ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_RAW_ID,HDF_ERR) + + !close data spaces and groups + + CALL H5SCLOSE_F(SPACE_TES,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_1D,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_2D,HDF_ERR) + + CALL H5GCLOSE_F(RAW_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(TES_GROUP_ID, HDF_ERR) + + ! close HDF5 interface + + CALL H5CLOSE_F(HDF_ERR) + + CALL H5EPRINT_F(HDF_ERR,"hdf_error") + + ! clear flexible arrays + + CALL CLEAR_FLEX_REAL_1D(FLEX_LON) + CALL CLEAR_FLEX_REAL_1D(FLEX_LAT) + CALL CLEAR_FLEX_REAL_1D(FLEX_TIME) + + CALL CLEAR_FLEX_REAL_2D(FLEX_TES_O3) + CALL CLEAR_FLEX_REAL_2D(FLEX_GC_O3) + + END SUBROUTINE MAKE_TES_BIAS_FILE_HDF5 + + SUBROUTINE WRITE_ATTRIBUTES(DSET_ID,LONGNAME,UNIT) + + USE HDF5 + + INTEGER(HID_T) :: DSET_ID + CHARACTER(LEN=*) :: LONGNAME + CHARACTER(LEN=*) :: UNIT + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER :: HDF_ERR + + ADIMS(1) = 1 + + ! create attribute "Long name" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(LONGNAME),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Long name", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,LONGNAME, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + ! create attribute "Unit" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(UNIT),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Unit", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,UNIT, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + END SUBROUTINE WRITE_ATTRIBUTES + + !-------------------------------------------------------------------------------- + + !mkeller: helper routines for managing flexible arrays + ! reinventing the wheel here, but hey... + + SUBROUTINE INIT_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_1D + + SUBROUTINE GROW_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:) + ALLOCATE(TEMP_ARRAY(INPUT%MAX_N * 2)) + TEMP_ARRAY(1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_1D + + SUBROUTINE PUSH_FLEX_REAL_1D(INPUT, NEW_VAL) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8 :: NEW_VAL + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_1D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(INPUT%CURRENT_N) = NEW_VAL + + END SUBROUTINE PUSH_FLEX_REAL_1D + + SUBROUTINE CLEAR_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_1D + + !-------------------------------------------------------------------------------- + + SUBROUTINE INIT_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_2D + + SUBROUTINE GROW_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:,:) + ALLOCATE(TEMP_ARRAY(MAXLEV,INPUT%MAX_N * 2)) + TEMP_ARRAY(:,1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_2D + + SUBROUTINE PUSH_FLEX_REAL_2D(INPUT, NEW_VAL, NLEV) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8 :: NEW_VAL(MAXLEV) + INTEGER :: NLEV + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_2D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(MAXLEV-NLEV+1:MAXLEV,INPUT%CURRENT_N) = NEW_VAL(1:NLEV) + + END SUBROUTINE PUSH_FLEX_REAL_2D + + SUBROUTINE CLEAR_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_2D + + END MODULE TES_O3_MOD diff --git a/code/obs_operators/tes_o3_mod.f90~ b/code/obs_operators/tes_o3_mod.f90~ new file mode 100644 index 0000000..a90e0d8 --- /dev/null +++ b/code/obs_operators/tes_o3_mod.f90~ @@ -0,0 +1,3444 @@ +!$Id: tes_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ + MODULE TES_O3_MOD + + IMPLICIT NONE + +!mkeller +#include "CMN_SIZE" +!#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_TES_O3_OBS + PUBLIC CALC_TES_O3_FORCE + PUBLIC MAKE_TES_BIAS_FILE_HDF5 + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 67 + INTEGER, PARAMETER :: MAXTES = 2000 + + + ! Record to store data from each TES obs + TYPE TES_O3_OBS + INTEGER :: LTES(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: O3(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + !mkeller: TES retrieval quality flag + INTEGER :: QUALITY_FLAG(1) + ENDTYPE TES_O3_OBS + + TYPE(TES_O3_OBS) :: TES(MAXTES) + + !mkeller: arrays for saving diagnostics + + TYPE FLEX_REAL_1D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:) + ENDTYPE FLEX_REAL_1D + + TYPE FLEX_REAL_2D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:,:) + ENDTYPE FLEX_REAL_2D + + REAL*4 :: TES_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_GC_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS_COUNT(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_PRESSURE(MAXLEV) + ! mkeller: flex arrays to store satellite diagnostics sequentially + TYPE(FLEX_REAL_1D) :: FLEX_LON, FLEX_LAT, FLEX_TIME + TYPE(FLEX_REAL_2D) :: FLEX_TES_O3, FLEX_GC_O3 + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_O3_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine READ_TES_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) TES (TES_O3_OBS) : TES retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LTES + INTEGER :: NTES + INTEGER :: START0(1), COUNT0(1) + INTEGER :: START1(2), COUNT1(2) + INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, J + INTEGER :: NT_ID + INTEGER :: O3_ID + INTEGER :: PS_ID + INTEGER :: AK_ID + INTEGER :: OE_ID + INTEGER :: AP_ID + INTEGER :: LA_ID + INTEGER :: LO_ID + INTEGER :: DY_ID + + !mkeller: additional variables for quality flag + INTEGER :: QU_ID + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: DIR_TES + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_TES_O3_OBS begins here! + !================================================================= + + ! filename root + DIR_TES = '/data/ctm/satellite/TES/TES_O3/' + READ_FILENAME = 'tes_aura_nadir_YYYYMMDD_O3_v4.nc' + DIR_MONTH = 'V7J/YYYY/MM/' + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 9999 ) + + + ! Construct complete filename + READ_FILENAME = TRIM( DIR_TES ) // TRIM( DIR_MONTH ) // + & TRIM( READ_FILENAME ) + + WRITE(6,*) ' - READ_TES_O3_OBS: reading file: ', READ_FILENAME + + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"TES file '", TRIM(READ_FILENAME), " not found, "// + & "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"TES file found!" + ENDIF + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "targets", NT_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "species", O3_ID ), 103 ) + CALL CHECK( NF90_INQ_VARID( FID, "averagingkernel", AK_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) + CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", + & OE_ID ), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "yyyymmdd", DY_ID ), 110 ) + CALL CHECK( NF90_INQ_VARID( FID, "speciesretrievalconverged", + & QU_ID ), 111 ) + + ! READ number of retrievals, NTES + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NT_ID, TMP, NTES), 202 ) + + print*, ' NTES = ', NTES + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! mkeller: read in TES pressure levels for satellite diagnostics + ! this only needs to be done once, add logical flag here + ! the TES retrieval pressure grid can vary near the surface, there shouldn't be any + ! data reported on those levels in the diagnostic output. + ! not sure what the proper way to do this is for Level3 data... + ! for Level2 data, should all individual retrieval grids be written out? + + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES_PRESSURE, (/1,1/), (/MAXLEV,1/)), 402 ) + + !PRINT *, "TES_PRESSURE", TES_PRESSURE + ! define record size + START0 = (/1/) + COUNT0 = (/1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START0(1) = N + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LA_ID, + & TES(N)%LAT, START0, COUNT0 ), 301 ) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LO_ID, + & TES(N)%LON, START0, COUNT0 ), 302 ) + + ! READ date + CALL CHECK( NF90_GET_VAR ( FID, DY_ID, + & TES(N)%TIME, START0, COUNT0 ), 303 ) + + ! READ quality flag + CALL CHECK( NF90_GET_VAR ( FID, QU_ID, + & TES(N)%QUALITY_FLAG, START0, COUNT0 ), 304 ) + + ENDDO + + !-------------------------------- + ! Find # of good levels for each + !-------------------------------- + + ! define record size + START1 = (/1, 1/) + COUNT1 = (/MAXLEV, 1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:MAXLEV), START1, COUNT1 ), 401 ) + + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + + J = 1 + DO WHILE ( J .le. MAXLEV ) + + ! check if the value is good + IF ( TES(N)%O3(J) > FILL ) THEN + + ! save the number of good levels as LTES + TES(N)%LTES = MAXLEV - J + 1 + + ! and now we can exit the while loop + J = MAXLEV + 1 + + ! otherwise this level is just filler + ELSE + + ! so proceed to the next one up + J = J + 1 + + ENDIF + + ENDDO + + ENDDO + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START1 = (/MAXLEV - J + 1, 1/) + COUNT1 = (/J, 1/) + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:J), START1, COUNT1 ), 401 ) + + ! READ pressure levels, PRES + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES(N)%PRES(1:J), START1, COUNT1 ), 402 ) + + ! READ apriori O3 column, PRIOR + CALL CHECK( NF90_GET_VAR ( FID, AP_ID, + & TES(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) + + + ENDDO + + + !-------------------------------- + ! Read 2D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START2 = (/MAXLEV - J + 1, MAXLEV - J + 1, 1/) + COUNT2 = (/J, J, 1/) + + ! Update starting index + START2(3) = N + + ! READ averaging kernal, AVG_KERNEL + CALL CHECK( NF90_GET_VAR ( FID, AK_ID, + & TES(N)%AVG_KERNEL(1:J,1:J), START2, COUNT2), 501 ) + + ! READ observational error covariance + CALL CHECK( NF90_GET_VAR ( FID, OE_ID, + & TES(N)%S_OER(1:J,1:J), START2, COUNT2), 502 ) + ENDDO + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + J = TES(N)%LTES(1) + !print*, ' TES test ', TES(N)%O3 + !print*, ' TES good ', TES(N)%LTES + !print*, ' TES pres ', TES(N)%PRES(1:J) + + ! Add a bit to the diagonal to regularize the inversion + ! (ks, ml, dkh, 11/18/10) + ! mkeller: this makes no sense to me. + !DO II=1,J + ! TES(N)%S_OER(II,II) = TES(N)%S_OER(II,II)+ 0.001D0 + !ENDDO + + CALL SVD( TES(N)%S_OER(1:J,1:J), J, + & U(1:J,1:J), S(1:J), + & VT(1:J,1:J) ) + + ! U = S^-1 * U^T + TEST = 0d0 + DO I = 1, J + + ! mkeller: regularize matrix inverse by ignoring all singular values below a certain cutoff. + ! This is horrendously inefficient, but should work for now. In the + ! future, Thikonov regularization should be implemented instead. + ! xzhang: svd test critical value changes from 1e-2 to 5e-2 + IF ( S(I)/S(1) < 1e-2 ) THEN + S(I) = 1e-2 * S(1) + ENDIF + DO II = 1, J + TEST(I,II) = U(II,I) / S(I) + ENDDO + ENDDO + + !TEST = 0d0 + U = TEST + TEST = 0d0 + + + ! S_OER_INV = V * S^-1 * U^T + DO I = 1, J + DO II = 1, J + TMP1 = 0d0 + DO III = 1, J + TMP1 = TMP1 + VT(III,I) * U(III,II) + ENDDO + TES(N)%S_OER_INV(I,II) = TMP1 + ENDDO + ENDDO + + ! TEST: calculate 2-norm of I - S_OER_INV * S_OER + ! mkeller: comment this out for now; pointless given the regularization + ! performed above. + ! Need to come up with an alternative test in the future. + !DO I = 1, J + ! DO II = 1, J + ! TMP1 = 0d0 + ! DO III = 1, J + ! TMP1 = TMP1 + !& + TES(N)%S_OER_INV(III,I) * TES(N)%S_OER(III,II) + !ENDDO + !TEST(I,II) = - TMP1 + !ENDDO + !TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 + !ENDDO + + !IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN + ! print*, ' WARNING: inversion error for retv N = ', + !& SUM(TEST(1:J,1:J)), N + ! print*, ' in TES obs ', READ_FILENAME + ! ENDIF + + ENDDO ! N + + ! Return to calling program + END SUBROUTINE READ_TES_O3_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_nh3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_O3_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_O3_FORCE calculates the adjoint forcing from the TES +! O3 observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV) + REAL*8 :: DIFF_V(MAXLEV) + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXTES) + INTEGER,SAVE :: NTES + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + REAL*8 :: O3_HAT_ADJ(MAXLEV) + REAL*8 :: O3_PERT_ADJ(MAXLEV) + REAL*8 :: GC_O3_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ(MAXLEV) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + !mkeller + REAL*8 :: TEMP_BIAS_TES(MAXLEV) + REAL*8 :: TEMP_BIAS_GC(LLPAR) + + + + !================================================================= + ! CALC_TES_O3_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_O3_FORCE ' + + ! Reset + NEW_COST = 0D0 + GC_ADJ_COUNT = 0d0 + GC_ADJ_TEMP = 0d0 + GC_ADJ_TEMP_COST = 0d0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + FILENAME = 'pres_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'o3_pert_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_o3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_teso3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 115, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! mkeller: initialize flex arrays + + CALL INIT_FLEX_REAL_1D(FLEX_LON) + CALL INIT_FLEX_REAL_1D(FLEX_LAT) + CALL INIT_FLEX_REAL_1D(FLEX_TIME) + CALL INIT_FLEX_REAL_2D(FLEX_TES_O3) + CALL INIT_FLEX_REAL_2D(FLEX_GC_O3) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the TES O3 file for this day + CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() + + ENDIF + + IF(.NOT. DATA_PRESENT) THEN + PRINT *,"No TES data present for this day, nothing to do here." + RETURN + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + +! need to update this in order to do i/o with this loop parallel +! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT + + PRINT *,"TES quality flag:", TES(NT)%QUALITY_FLAG(1) + + IF( TES(NT)%QUALITY_FLAG(1) == 0 ) THEN + PRINT *,"TES retrieval didn't converge; skipping record" + CYCLE + ENDIF + + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + O3_HAT_ADJ(:) = 0d0 + FORCE(:) = 0d0 + DIFF(:) = 0d0 + DIFF_V(:) = 0d0 + + !TEMP_BIAS_TES(:) = 0d0 + !TEMP_BIAS_GC(:) = 0d0 + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + !PRINT *, "TES_LAT", REAL(TES(NT)%LAT(1)) + + ! dkh debug + !print*, 'I,J = ', I, J + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) + + + !mkeller: store TES pressure in diagnostic array. Should only be done once, as retrieval pressures don't vary between retrievals. + ! needs to be fixed. + !TES_PRESSURE = TES(NT)%PRES + + ! Get O3 values at native model resolution + DO L = 1, LLPAR + + ! check if in trop + !IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + !JLOOP = JLOP(I,J,L) + + ! get O3 from tropospheric array + !IF ( JLOOP > 0 ) THEN + + !GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) + !GC_O3_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDO3)) + + ! Convert from #/cm3 to v/v + !GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + ! mkeller: use LINOZ Ox from stored from forward run instead + ! kg -> v/v + !GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & !TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + !ELSE + + ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) + + ENDDO + + + ! Interpolate GC O3 column to TES grid + DO LL = 1, LTES + GC_O3(LL) = 0d0 + DO L = 1, LLPAR + GC_O3(LL) = GC_O3(LL) + & + MAP(L,LL) * GC_O3_NATIVE(L) + ENDDO + ENDDO + + ! dkh debug: compare profiles: + !print*, ' GC_PRES, GC_native_O3 [ppb] ' + !WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) + !print*, ' TES_PRES, GC_O3 ' + !WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) + 100 FORMAT(1X,F16.8,1X,F16.8) + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_O3(L) = MAX(GC_O3(L), 1d-10) + O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LTES + O3_HAT(L) = 0d0 + DO LL = 1, LTES + O3_HAT(L) = O3_HAT(L) + & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) + ENDDO + O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + + ! mkeller: diagnostics need an OMP CRITICAL directive +!!$OMP CRITICAL + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 11d-9 ) THEN + IF ( REAL(TES(NT)%LAT(1)) > 56.6 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 6.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-6.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > 35.0 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) -5.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-5.9d-9) + ELSEIF ( REAL(TES(NT)%LAT(1)) > 15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 7.5d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-7.5d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.2d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.2d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 9.2d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 9.2d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 2.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 2.9d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -47.7 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.7d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.7d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) < -61.9 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.6d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.6d-9) + ENDIF + ENDIF + + !mkeller: store difference in VMR on retrieval grid + TES_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_O3_MEAN(I,J,MAXLEV-LTES + L) + TES(NT)%O3(L) + TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) + exp(O3_HAT(L)) + TES_BIAS(I,J,MAXLEV-LTES + L) = + & TES_BIAS(I,J,MAXLEV-LTES + L) + + & exp(O3_HAT(L)) - TES(NT)%O3(L) + TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) = + & TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) + 1 + + ELSE + DIFF(L) = 0d0 + DIFF_V(L) = 0d0 + ENDIF + ENDDO + + ! store current information in flexible arrays + + CALL PUSH_FLEX_REAL_1D(FLEX_LON, TES(NT)%LON(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_LAT, TES(NT)%LAT(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_TIME, TES(NT)%TIME(1)) + + CALL PUSH_FLEX_REAL_2D(FLEX_TES_O3, TES(NT)%O3, LTES) + CALL PUSH_FLEX_REAL_2D(FLEX_GC_O3, exp(O3_HAT),LTES) +!!$OMP END CRITICAL + + ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + DO L = 1, LTES + FORCE(L) = 0d0 + DO LL = 1, LTES + FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) + ENDDO + NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + ENDDO + ! dkh debug: compare profiles: +!mkeller: comment this out for now, not needed + !print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' + !WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) + + !print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' + !WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) + 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) + 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !mkeller: discard observations that yield negative cost function contributions + + IF (NEW_COST(NT) < 0d0) THEN + PRINT *,"TES_DEBUG: DISCARD OBSERVATIONS FOR NT=",NT + NEW_COST(NT) = 0d0 + DIFF = 0d0 + FORCE = 0d0 + CYCLE + ENDIF + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug + !print*, 'DIFF , FORCE ' + !WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) + 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) + + ! Adjoint of difference + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 0d0 ) THEN + O3_HAT_ADJ(L) = DIFF_ADJ(L) + ENDIF + ENDDO + + ! adjoint of TES operator + DO L = 1, LTES + O3_PERT_ADJ(L) = 0d0 + DO LL = 1, LTES + O3_PERT_ADJ(L) = O3_PERT_ADJ(L) + & + TES(NT)%AVG_KERNEL(LL,L) + & * O3_HAT_ADJ(LL) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO L = 1, LTES + ! fwd code: + !GC_O3(L) = MAX(GC_O3(L), 1d-10) + !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ! adj code: + IF ( GC_O3(L) > 1d-10 ) THEN + GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) + ELSE + GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) + ENDIF + ENDDO + + ! dkh debug + !print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' + !WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) + 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_O3_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_O3_ADJ(LL) + + ENDDO + ENDDO + + !WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! mkeller: OMP critical directive needed here +!!$OMP CRITICAL + DO L = 1, LLPAR + + ! Adjoint of unit conversion + !GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * TCVV(IDTOX) / + & AD(I,J,L) + + ! mkeller: OMP critical directive needed here + + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1d0 + + GC_ADJ_TEMP(I,J,L) = GC_ADJ_TEMP(I,J,L)+GC_O3_NATIVE_ADJ(L) + + ENDDO +!!$OMP END CRITICAL + + + !GC_ADJ_TEMP_COST(I,J) = GC_ADJ_TEMP_COST(I,J) + NEW_COST(NT) + + ! dkh debug + ! mkeller: comment this out for now + !print*, 'GC_O3_NATIVE_ADJ conv ' + !WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + 104 FORMAT(1X,d14.6) + + !WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) + !WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) + !WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) + !WRITE(105,110) ( 1d9 * DIFF_V(LL), LL=LTES,1,-1) + !WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) + !WRITE(107,111) NT, LTES + !WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) + !WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) + !WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) + !WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) + !WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) + !WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(115,110) ( REAL(TES(NT)%LAT(1))) + 110 FORMAT(F18.6,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + ENDDO ! NT +!!$OMP END PARALLEL DO + + DO L=1,LLPAR + DO J=1,JJPAR + DO I=1,IIPAR + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + IF ( JLOOP > 0 ) THEN + + IF(GC_ADJ_COUNT(I,J,L)>0d0) THEN + + ! Pass adjoint back to adjoint tracer array + ! this formulation allows for aggregating the TES retrievals that fall into + ! a particular grid box into a super observation. This functionality has been + ! disabled for now. + + !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) = + & !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) + & !+ GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + + & GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDIF + + ENDIF + + ENDDO + + ! don't bin TES retrievals into a super observation for now. + + !IF( MAXVAL(GC_ADJ_COUNT(I,J,:) > 0d0) ) THEN + !COST_FUNC = COST_FUNC + + !& GC_ADJ_TEMP_COST(I,J)/MAXVAL(GC_ADJ_COUNT(I,J,:)) + !ENDIF + + ENDDO + ENDDO + + IF ( FIRST ) FIRST = .FALSE. + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_TES_O3_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_O3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine CALC_TES_O3_FORCE_FD tests the adjoint of CALC_TES_O3_FORCE +!! (dkh, 05/05/10) +!! +!! Can be driven with: +!! PERT(:) = 1D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, 30 +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!! +!! +!! +!! Arguments as Input/Output: +!! ============================================================================ +!! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +!! +!! +!! NOTES: +!! (1 ) Updated to GCv8 (dkh, 10/07/09) +!! (1 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE +! USE DAO_MOD, ONLY : AD +! USE DAO_MOD, ONLY : AIRDEN +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : XNUMOLAIR +! USE TRACERID_MOD, ONLY : IDO3 +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +! +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LTES +! INTEGER :: JLOOP +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_O3_NATIVE(LLPAR) +! REAL*8 :: GC_O3(MAXLEV) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,MAXLEV) +! REAL*8 :: O3_HAT(MAXLEV) +! REAL*8 :: O3_PERT(MAXLEV) +! REAL*8 :: FORCE(MAXLEV) +! REAL*8 :: DIFF(MAXLEV) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! REAL*8, SAVE :: TIME_FRAC(MAXTES) +! INTEGER,SAVE :: NTES +! +! REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) +! REAL*8 :: O3_HAT_ADJ(MAXLEV) +! REAL*8 :: O3_PERT_ADJ(MAXLEV) +! REAL*8 :: GC_O3_ADJ(MAXLEV) +! REAL*8 :: DIFF_ADJ(MAXLEV) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_O3_FORCE_FD begins here! +! !================================================================= +! +! print*, ' - CALC_TES_O3_FORCE_FD ' +! +! NEW_COST = 0D0 +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_press.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_on_tes.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Check if it is the last hour of a day +!! IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN +! IF ( FIRST ) THEN +! +! ! Read the TES O3 file for this day +! CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +! FIRST = .FALSE. +! ENDIF +! +!! ! Get the range of TES retrievals for the current hour +!! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES O3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +!! & TIME_FRAC(NTSTOP) +!! print*, ' found record range: ', NTSTART, NTSTOP +! +! NTSTART = 1590 +! NTSTOP = 1590 +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT +! +! ! For safety, initialize these up to LLTES +! GC_O3(:) = 0d0 +! MAP(:,:) = 0d0 +! O3_HAT_ADJ(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LTES to make coding a bit cleaner +! LTES = TES(NT)%LTES(1) +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) +! I = IIJJ(1) +! J = IIJJ(2) +! +! print*, 'I,J = ', I, J +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LTES) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) +! +! +! ! Get O3 values at native model resolution +! DO L = 1, LLPAR +! +! +! ! check if in trop +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! ! get O3 from tropospheric array +! IF ( JLOOP > 0 ) THEN +! GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) * PERT(L) +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! ENDIF +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! +! ENDIF +! +! ! Convert from #/cm3 to v/v +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! ENDDO +! +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LTES +! GC_O3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_O3(LL) = GC_O3(LL) +! & + MAP(L,LL) * GC_O3_NATIVE(L) +! ENDDO +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LTES +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! O3_HAT(L) = 0d0 +! DO LL = 1, LTES +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !ADJ_DIFF(:) = 1d0 +! !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) +! !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) +! !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) +! +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! O3_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LTES +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LTES +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * O3_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LTES +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO +! +! ! dkh debug +! print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! GC_O3_NATIVE_ADJ(L) = 0d0 +! DO LL = 1, LTES +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) +! & + MAP(L,LL) * GC_O3_ADJ(LL) +! ENDDO +! ENDDO +! +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! DO L = 1, LLPAR +! +! ! Adjoint of unit conversion +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! IF ( JLOOP > 0 ) THEN +! +! ! Pass adjoint back to adjoint tracer array +! CSPEC_ADJ_FORCE(JLOOP,IDO3) = +! & CSPEC_ADJ_FORCE(JLOOP,IDO3) + GC_O3_NATIVE_ADJ(L) +! +! ADJ(L) = GC_O3_NATIVE_ADJ(L) * CSPEC(JLOOP,IDO3) +! +! ENDIF +! +! ENDIF +! +! ENDDO +! +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_O3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + + print*, ' GET_NT_RANGE for ', HHMMSS + print*, ' NTSAVE ', NTSAVE + print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + print*, ' Starting : TIME_FRAC(NTSTART) ', + & TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + print*, ' Testing : TIME_FRAC ', + & TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where TES pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(:,LTM) = 0D0 + HINTERPZ(LTM,LTM) = 1D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ +! SUBROUTINE MAKE_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_O3_FILE saves O3 profiles that correspond to time and +!! place of TES O3 obs. (dkh, 03/01/09) +!! +!! Module variables as Input: +!! ============================================================================ +!! (1 ) O3_SAVE (REAL*8) : O3 profiles [ppmv] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE +! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J, I0, J0, L, NT +! CHARACTER(LEN=120) :: FILENAME +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! INTEGER, PARAMETER :: IUN = 88 +! +! ! For binary punch file, version 2.0 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! !================================================================= +! ! MAKE_O3_FILE begins here! +! !================================================================= +! +! FILENAME = TRIM( 'nh3.bpch' ) +! +! ! Append data directory prefix +! FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'O3 profile ' +! CATEGORY = 'IJ-AVE-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! UNIT = 'ppmv' +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the checkpoint file for output -- binary punch format +! !================================================================= +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_O3_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) +! +! ! Temporarily store data in DAT as REAL4 +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT ) +! DO NT = 1, MAXTES +! +! DAT(1,:,NT) = REAL(O3_SAVE(:,NT)) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, 1d0, 1d0, RESERVED, +! & 1, LLPAR, MAXTES, I0+1, +! & J0+1, 1, DAT ) +! +! ! Close file +! CLOSE( IUN ) +! +! print*, ' O3_SAVE sum write = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE MAKE_O3_FILE +! +!!------------------------------------------------------------------------------ +! SUBROUTINE READ_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine READ_O3_FILE reads the GC modeled O3 profiles that correspond +!! to the TES O3 times and locations. (dkh, 03/01/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( ADJTMP_DIR ) // +! & 'nh3.bpch' +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_O3_FILE: Reading ', a ) +! +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, +! & 1d0, 1, LLPAR, +! & MAXTES, DAT, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! O3_SAVE(:,:) = DAT(1,:,:) +! +! print*, ' O3_SAVE sum read = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE READ_O3_FILE +! +!!----------------------------------------------------------------------------- +! FUNCTION GET_DOUBLED_O3( NYMD, NHMS, LON, LAT ) RESULT( O3_DBL ) +!! +!!****************************************************************************** +!! Subroutine GET_DOUBLED_O3 reads and returns the nh3 profiles from +!! model run with doubled emissions. (dkh, 11/08/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TIME_MOD, ONLY : GET_TAU +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER :: NYMD, NHMS +! REAL*4 :: LON, LAT +! +! ! Function arg +! REAL*8 :: O3_DBL(LLPAR) +! +! ! Local variables +! REAL*4 :: DAT(144,91,20) +! CHARACTER(LEN=255) :: FILENAME +! INTEGER :: IIJJ(2) +! +! !================================================================= +! ! GET_DOUBLED_O3 begins here! +! !================================================================= +! +! ! filename +! FILENAME = 'nh3.YYYYMMDD.hhmm' +! +! ! Expand filename +! CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) +! +! ! Full path to file +! FILENAME = TRIM( DATA_DIR ) // +! & 'doubled_nh3/' // +! & TRIM( FILENAME ) // +! & TRIM( '00' ) +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - GET_DOUBLED_O3: Reading ', a ) +! +! ! dkh debug +! print*, ' GET_TAU() = ', GET_TAU() +! +! ! Get data +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, +! & GET_TAU(), 144, 91, +! & 20, DAT, QUIET=.FALSE. ) +! +! IIJJ = GET_IJ_2x25( LON, LAT ) +! +! print*, ' found doubled in I/J = ', IIJJ +! +! ! just the column for the present location, and convert ppb to ppm +! O3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 +! O3_DBL(21:LLPAR) = 0d0 +! +! print*, ' O3_DBL = ', O3_DBL +! +! ! Return to calling program +! END FUNCTION GET_DOUBLED_O3 +! +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!!----------------------------------------------------------------------------- +! SUBROUTINE INIT_TES_O3 +!! +!!***************************************************************************** +!! Subroutine INIT_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! IIPAR, JJPAR +! +! ! Local variables +! INTEGER :: AS +! +! !================================================================= +! ! INIT_TES_O3 begins here +! !================================================================= +! +! ! dkh debug +! print*, ' INIT_TES_O3' +! +! ALLOCATE( O3_SAVE( LLPAR, MAXTES ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_SAVE' ) +! O3_SAVE = 0d0 +! +! +! TES( 1 )%NYMD = 20050704 +! TES( 2 )%NYMD = 20050704 +! TES( 3 )%NYMD = 20050704 +! TES( 4 )%NYMD = 20050704 +! TES( 5 )%NYMD = 20050704 +! TES( 6 )%NYMD = 20050704 +! TES( 7 )%NYMD = 20050704 +! TES( 8 )%NYMD = 20050704 +! TES( 9 )%NYMD = 20050705 +! TES( 10 )%NYMD = 20050705 +! TES( 11 )%NYMD = 20050705 +! TES( 12 )%NYMD = 20050705 +! TES( 13 )%NYMD = 20050705 +! TES( 14 )%NYMD = 20050705 +! TES( 15 )%NYMD = 20050705 +! TES( 16 )%NYMD = 20050705 +! TES( 17 )%NYMD = 20050705 +! TES( 18 )%NYMD = 20050710 +! TES( 19 )%NYMD = 20050710 +! TES( 20 )%NYMD = 20050710 +! TES( 21 )%NYMD = 20050710 +! TES( 22 )%NYMD = 20050710 +! TES( 23 )%NYMD = 20050710 +! TES( 24 )%NYMD = 20050710 +! TES( 25 )%NYMD = 20050710 +! TES( 26 )%NYMD = 20050710 +! TES( 27 )%NYMD = 20050711 +! TES( 28 )%NYMD = 20050711 +! TES( 29 )%NYMD = 20050711 +! TES( 30 )%NYMD = 20050711 +! TES( 31 )%NYMD = 20050712 +! TES( 32 )%NYMD = 20050712 +! TES( 33 )%NYMD = 20050712 +! TES( 34 )%NYMD = 20050712 +! TES( 35 )%NYMD = 20050712 +! TES( 36 )%NYMD = 20050712 +! TES( 37 )%NYMD = 20050712 +! TES( 38 )%NYMD = 20050712 +! TES( 39 )%NYMD = 20050713 +! TES( 40 )%NYMD = 20050713 +! TES( 41 )%NYMD = 20050713 +! TES( 42 )%NYMD = 20050713 +! TES( 43 )%NYMD = 20050713 +! TES( 44 )%NYMD = 20050713 +! TES( 45 )%NYMD = 20050713 +! TES( 46 )%NYMD = 20050713 +! TES( 47 )%NYMD = 20050713 +! TES( 48 )%NYMD = 20050714 +! TES( 49 )%NYMD = 20050714 +! TES( 50 )%NYMD = 20050714 +! TES( 51 )%NYMD = 20050714 +! TES( 52 )%NYMD = 20050714 +! TES( 53 )%NYMD = 20050714 +! TES( 54 )%NYMD = 20050714 +! TES( 55 )%NYMD = 20050714 +! TES( 56 )%NYMD = 20050715 +! TES( 57 )%NYMD = 20050715 +! TES( 58 )%NYMD = 20050715 +! TES( 59 )%NYMD = 20050715 +! TES( 60 )%NYMD = 20050715 +! TES( 61 )%NYMD = 20050715 +! TES( 62 )%NYMD = 20050715 +! TES( 63 )%NYMD = 20050715 +! TES( 64 )%NYMD = 20050715 +! TES( 65 )%NYMD = 20050716 +! TES( 66 )%NYMD = 20050717 +! TES( 67 )%NYMD = 20050717 +! TES( 68 )%NYMD = 20050717 +! TES( 69 )%NYMD = 20050717 +! TES( 70 )%NYMD = 20050717 +! TES( 71 )%NYMD = 20050717 +! TES( 72 )%NYMD = 20050717 +! TES( 73 )%NYMD = 20050717 +! TES( 74 )%NYMD = 20050717 +! TES( 75 )%NYMD = 20050718 +! TES( 76 )%NYMD = 20050718 +! TES( 77 )%NYMD = 20050718 +! TES( 78 )%NYMD = 20050718 +! TES( 79 )%NYMD = 20050719 +! TES( 80 )%NYMD = 20050719 +! TES( 81 )%NYMD = 20050719 +! TES( 82 )%NYMD = 20050719 +! TES( 83 )%NYMD = 20050719 +! TES( 84 )%NYMD = 20050719 +! TES( 85 )%NYMD = 20050719 +! TES( 86 )%NYMD = 20050719 +! TES( 87 )%NYMD = 20050719 +! +! TES( 1 )%NHMS = 202000 +! TES( 2 )%NHMS = 202100 +! TES( 3 )%NHMS = 202100 +! TES( 4 )%NHMS = 202100 +! TES( 5 )%NHMS = 202200 +! TES( 6 )%NHMS = 202300 +! TES( 7 )%NHMS = 202300 +! TES( 8 )%NHMS = 202400 +! TES( 9 )%NHMS = 082100 +! TES( 10 )%NHMS = 082100 +! TES( 11 )%NHMS = 082200 +! TES( 12 )%NHMS = 082200 +! TES( 13 )%NHMS = 082300 +! TES( 14 )%NHMS = 082300 +! TES( 15 )%NHMS = 082400 +! TES( 16 )%NHMS = 082400 +! TES( 17 )%NHMS = 082500 +! TES( 18 )%NHMS = 194300 +! TES( 19 )%NHMS = 194300 +! TES( 20 )%NHMS = 194400 +! TES( 21 )%NHMS = 194400 +! TES( 22 )%NHMS = 194500 +! TES( 23 )%NHMS = 194500 +! TES( 24 )%NHMS = 194600 +! TES( 25 )%NHMS = 194600 +! TES( 26 )%NHMS = 194700 +! TES( 27 )%NHMS = 092300 +! TES( 28 )%NHMS = 092300 +! TES( 29 )%NHMS = 092400 +! TES( 30 )%NHMS = 092400 +! TES( 31 )%NHMS = 193000 +! TES( 32 )%NHMS = 193100 +! TES( 33 )%NHMS = 193100 +! TES( 34 )%NHMS = 193200 +! TES( 35 )%NHMS = 193300 +! TES( 36 )%NHMS = 193300 +! TES( 37 )%NHMS = 193400 +! TES( 38 )%NHMS = 193400 +! TES( 39 )%NHMS = 091000 +! TES( 40 )%NHMS = 091100 +! TES( 41 )%NHMS = 091100 +! TES( 42 )%NHMS = 091200 +! TES( 43 )%NHMS = 091200 +! TES( 44 )%NHMS = 091200 +! TES( 45 )%NHMS = 091300 +! TES( 46 )%NHMS = 091300 +! TES( 47 )%NHMS = 091400 +! TES( 48 )%NHMS = 191900 +! TES( 49 )%NHMS = 191900 +! TES( 50 )%NHMS = 191900 +! TES( 51 )%NHMS = 192000 +! TES( 52 )%NHMS = 192000 +! TES( 53 )%NHMS = 192100 +! TES( 54 )%NHMS = 192100 +! TES( 55 )%NHMS = 192200 +! TES( 56 )%NHMS = 085800 +! TES( 57 )%NHMS = 085800 +! TES( 58 )%NHMS = 085900 +! TES( 59 )%NHMS = 085900 +! TES( 60 )%NHMS = 090000 +! TES( 61 )%NHMS = 090000 +! TES( 62 )%NHMS = 090100 +! TES( 63 )%NHMS = 090100 +! TES( 64 )%NHMS = 090100 +! TES( 65 )%NHMS = 190900 +! TES( 66 )%NHMS = 084500 +! TES( 67 )%NHMS = 084600 +! TES( 68 )%NHMS = 084600 +! TES( 69 )%NHMS = 084700 +! TES( 70 )%NHMS = 084700 +! TES( 71 )%NHMS = 084800 +! TES( 72 )%NHMS = 084800 +! TES( 73 )%NHMS = 084900 +! TES( 74 )%NHMS = 084900 +! TES( 75 )%NHMS = 203200 +! TES( 76 )%NHMS = 203300 +! TES( 77 )%NHMS = 203300 +! TES( 78 )%NHMS = 203400 +! TES( 79 )%NHMS = 083300 +! TES( 80 )%NHMS = 083400 +! TES( 81 )%NHMS = 083400 +! TES( 82 )%NHMS = 083500 +! TES( 83 )%NHMS = 083500 +! TES( 84 )%NHMS = 083500 +! TES( 85 )%NHMS = 083600 +! TES( 86 )%NHMS = 083600 +! TES( 87 )%NHMS = 083700 +! +! TES( 1 )%LAT = 31.29 +! TES( 2 )%LAT = 33 +! TES( 3 )%LAT = 34.64 +! TES( 4 )%LAT = 36.2 +! TES( 5 )%LAT = 37.91 +! TES( 6 )%LAT = 41.1 +! TES( 7 )%LAT = 42.8 +! TES( 8 )%LAT = 44.43 +! TES( 9 )%LAT = 43.54 +! TES( 10 )%LAT = 41.84 +! TES( 11 )%LAT = 40.2 +! TES( 12 )%LAT = 38.65 +! TES( 13 )%LAT = 36.94 +! TES( 14 )%LAT = 35.3 +! TES( 15 )%LAT = 33.74 +! TES( 16 )%LAT = 32.03 +! TES( 17 )%LAT = 30.39 +! TES( 18 )%LAT = 31.28 +! TES( 19 )%LAT = 32.99 +! TES( 20 )%LAT = 34.63 +! TES( 21 )%LAT = 36.19 +! TES( 22 )%LAT = 37.9 +! TES( 23 )%LAT = 39.53 +! TES( 24 )%LAT = 41.09 +! TES( 25 )%LAT = 42.8 +! TES( 26 )%LAT = 44.42 +! TES( 27 )%LAT = 43.55 +! TES( 28 )%LAT = 41.85 +! TES( 29 )%LAT = 40.22 +! TES( 30 )%LAT = 38.66 +! TES( 31 )%LAT = 31.28 +! TES( 32 )%LAT = 32.99 +! TES( 33 )%LAT = 34.63 +! TES( 34 )%LAT = 36.19 +! TES( 35 )%LAT = 39.53 +! TES( 36 )%LAT = 41.09 +! TES( 37 )%LAT = 42.79 +! TES( 38 )%LAT = 44.42 +! TES( 39 )%LAT = 43.55 +! TES( 40 )%LAT = 41.85 +! TES( 41 )%LAT = 40.22 +! TES( 42 )%LAT = 38.66 +! TES( 43 )%LAT = 36.96 +! TES( 44 )%LAT = 35.32 +! TES( 45 )%LAT = 33.76 +! TES( 46 )%LAT = 32.04 +! TES( 47 )%LAT = 30.4 +! TES( 48 )%LAT = 32.99 +! TES( 49 )%LAT = 34.63 +! TES( 50 )%LAT = 36.2 +! TES( 51 )%LAT = 37.9 +! TES( 52 )%LAT = 39.54 +! TES( 53 )%LAT = 41.1 +! TES( 54 )%LAT = 42.8 +! TES( 55 )%LAT = 44.42 +! TES( 56 )%LAT = 43.55 +! TES( 57 )%LAT = 41.85 +! TES( 58 )%LAT = 40.22 +! TES( 59 )%LAT = 38.66 +! TES( 60 )%LAT = 36.95 +! TES( 61 )%LAT = 35.31 +! TES( 62 )%LAT = 33.75 +! TES( 63 )%LAT = 32.04 +! TES( 64 )%LAT = 30.4 +! TES( 65 )%LAT = 44.4 +! TES( 66 )%LAT = 43.59 +! TES( 67 )%LAT = 41.89 +! TES( 68 )%LAT = 40.26 +! TES( 69 )%LAT = 38.7 +! TES( 70 )%LAT = 37 +! TES( 71 )%LAT = 35.36 +! TES( 72 )%LAT = 33.8 +! TES( 73 )%LAT = 32.09 +! TES( 74 )%LAT = 30.45 +! TES( 75 )%LAT = 31.27 +! TES( 76 )%LAT = 32.98 +! TES( 77 )%LAT = 34.62 +! TES( 78 )%LAT = 36.18 +! TES( 79 )%LAT = 43.58 +! TES( 80 )%LAT = 41.88 +! TES( 81 )%LAT = 40.25 +! TES( 82 )%LAT = 38.69 +! TES( 83 )%LAT = 36.98 +! TES( 84 )%LAT = 35.34 +! TES( 85 )%LAT = 33.78 +! TES( 86 )%LAT = 32.07 +! TES( 87 )%LAT = 30.43 +! +! TES( 1 )%LON = -105.13 +! TES( 2 )%LON = -105.6 +! TES( 3 )%LON = -106.05 +! TES( 4 )%LON = -106.5 +! TES( 5 )%LON = -107 +! TES( 6 )%LON = -108 +! TES( 7 )%LON = -108.57 +! TES( 8 )%LON = -109.13 +! TES( 9 )%LON = -92.52 +! TES( 10 )%LON = -93.09 +! TES( 11 )%LON = -93.62 +! TES( 12 )%LON = -94.11 +! TES( 13 )%LON = -94.62 +! TES( 14 )%LON = -95.09 +! TES( 15 )%LON = -95.53 +! TES( 16 )%LON = -96 +! TES( 17 )%LON = -96.44 +! TES( 18 )%LON = -95.84 +! TES( 19 )%LON = -96.3 +! TES( 20 )%LON = -96.76 +! TES( 21 )%LON = -97.2 +! TES( 22 )%LON = -97.71 +! TES( 23 )%LON = -98.21 +! TES( 24 )%LON = -98.71 +! TES( 25 )%LON = -99.27 +! TES( 26 )%LON = -99.83 +! TES( 27 )%LON = -107.94 +! TES( 28 )%LON = -108.51 +! TES( 29 )%LON = -109.04 +! TES( 30 )%LON = -109.53 +! TES( 31 )%LON = -92.74 +! TES( 32 )%LON = -93.2 +! TES( 33 )%LON = -93.66 +! TES( 34 )%LON = -94.11 +! TES( 35 )%LON = -95.11 +! TES( 36 )%LON = -95.61 +! TES( 37 )%LON = -96.17 +! TES( 38 )%LON = -96.73 +! TES( 39 )%LON = -104.84 +! TES( 40 )%LON = -105.41 +! TES( 41 )%LON = -105.94 +! TES( 42 )%LON = -106.43 +! TES( 43 )%LON = -106.94 +! TES( 44 )%LON = -107.42 +! TES( 45 )%LON = -107.86 +! TES( 46 )%LON = -108.33 +! TES( 47 )%LON = -108.76 +! TES( 48 )%LON = -90.1 +! TES( 49 )%LON = -90.56 +! TES( 50 )%LON = -91.01 +! TES( 51 )%LON = -91.51 +! TES( 52 )%LON = -92.01 +! TES( 53 )%LON = -92.51 +! TES( 54 )%LON = -93.07 +! TES( 55 )%LON = -93.64 +! TES( 56 )%LON = -101.74 +! TES( 57 )%LON = -102.32 +! TES( 58 )%LON = -102.84 +! TES( 59 )%LON = -103.33 +! TES( 60 )%LON = -103.84 +! TES( 61 )%LON = -104.32 +! TES( 62 )%LON = -104.76 +! TES( 63 )%LON = -105.23 +! TES( 64 )%LON = -105.67 +! TES( 65 )%LON = -90.54 +! TES( 66 )%LON = -98.64 +! TES( 67 )%LON = -99.22 +! TES( 68 )%LON = -99.75 +! TES( 69 )%LON = -100.23 +! TES( 70 )%LON = -100.75 +! TES( 71 )%LON = -101.22 +! TES( 72 )%LON = -101.67 +! TES( 73 )%LON = -102.13 +! TES( 74 )%LON = -102.57 +! TES( 75 )%LON = -108.19 +! TES( 76 )%LON = -108.65 +! TES( 77 )%LON = -109.11 +! TES( 78 )%LON = -109.55 +! TES( 79 )%LON = -95.57 +! TES( 80 )%LON = -96.14 +! TES( 81 )%LON = -96.67 +! TES( 82 )%LON = -97.16 +! TES( 83 )%LON = -97.67 +! TES( 84 )%LON = -98.15 +! TES( 85 )%LON = -98.59 +! TES( 86 )%LON = -99.06 +! TES( 87 )%LON = -99.49 +! +! TES( 1 )%FILENAME = TRIM('retv_vars.02945_0457_002.cdf') +! TES( 2 )%FILENAME = TRIM('retv_vars.02945_0457_003.cdf') +! TES( 3 )%FILENAME = TRIM('retv_vars.02945_0457_004.cdf') +! TES( 4 )%FILENAME = TRIM('retv_vars.02945_0458_002.cdf') +! TES( 5 )%FILENAME = TRIM('retv_vars.02945_0458_003.cdf') +! TES( 6 )%FILENAME = TRIM('retv_vars.02945_0459_002.cdf') +! TES( 7 )%FILENAME = TRIM('retv_vars.02945_0459_003.cdf') +! TES( 8 )%FILENAME = TRIM('retv_vars.02945_0459_004.cdf') +! TES( 9 )%FILENAME = TRIM('retv_vars.02945_0982_002.cdf') +! TES( 10 )%FILENAME = TRIM('retv_vars.02945_0982_003.cdf') +! TES( 11 )%FILENAME = TRIM('retv_vars.02945_0982_004.cdf') +! TES( 12 )%FILENAME = TRIM('retv_vars.02945_0983_002.cdf') +! TES( 13 )%FILENAME = TRIM('retv_vars.02945_0983_003.cdf') +! TES( 14 )%FILENAME = TRIM('retv_vars.02945_0983_004.cdf') +! TES( 15 )%FILENAME = TRIM('retv_vars.02945_0984_002.cdf') +! TES( 16 )%FILENAME = TRIM('retv_vars.02945_0984_003.cdf') +! TES( 17 )%FILENAME = TRIM('retv_vars.02945_0984_004.cdf') +! TES( 18 )%FILENAME = TRIM('retv_vars.02956_0457_002.cdf') +! TES( 19 )%FILENAME = TRIM('retv_vars.02956_0457_003.cdf') +! TES( 20 )%FILENAME = TRIM('retv_vars.02956_0457_004.cdf') +! TES( 21 )%FILENAME = TRIM('retv_vars.02956_0458_002.cdf') +! TES( 22 )%FILENAME = TRIM('retv_vars.02956_0458_003.cdf') +! TES( 23 )%FILENAME = TRIM('retv_vars.02956_0458_004.cdf') +! TES( 24 )%FILENAME = TRIM('retv_vars.02956_0459_002.cdf') +! TES( 25 )%FILENAME = TRIM('retv_vars.02956_0459_003.cdf') +! TES( 26 )%FILENAME = TRIM('retv_vars.02956_0459_004.cdf') +! TES( 27 )%FILENAME = TRIM('retv_vars.02956_1054_002.cdf') +! TES( 28 )%FILENAME = TRIM('retv_vars.02956_1054_003.cdf') +! TES( 29 )%FILENAME = TRIM('retv_vars.02956_1054_004.cdf') +! TES( 30 )%FILENAME = TRIM('retv_vars.02956_1055_002.cdf') +! TES( 31 )%FILENAME = TRIM('retv_vars.02960_0457_002.cdf') +! TES( 32 )%FILENAME = TRIM('retv_vars.02960_0457_003.cdf') +! TES( 33 )%FILENAME = TRIM('retv_vars.02960_0457_004.cdf') +! TES( 34 )%FILENAME = TRIM('retv_vars.02960_0458_002.cdf') +! TES( 35 )%FILENAME = TRIM('retv_vars.02960_0458_004.cdf') +! TES( 36 )%FILENAME = TRIM('retv_vars.02960_0459_002.cdf') +! TES( 37 )%FILENAME = TRIM('retv_vars.02960_0459_003.cdf') +! TES( 38 )%FILENAME = TRIM('retv_vars.02960_0459_004.cdf') +! TES( 39 )%FILENAME = TRIM('retv_vars.02960_1054_002.cdf') +! TES( 40 )%FILENAME = TRIM('retv_vars.02960_1054_003.cdf') +! TES( 41 )%FILENAME = TRIM('retv_vars.02960_1054_004.cdf') +! TES( 42 )%FILENAME = TRIM('retv_vars.02960_1055_002.cdf') +! TES( 43 )%FILENAME = TRIM('retv_vars.02960_1055_003.cdf') +! TES( 44 )%FILENAME = TRIM('retv_vars.02960_1055_004.cdf') +! TES( 45 )%FILENAME = TRIM('retv_vars.02960_1056_002.cdf') +! TES( 46 )%FILENAME = TRIM('retv_vars.02960_1056_003.cdf') +! TES( 47 )%FILENAME = TRIM('retv_vars.02960_1056_004.cdf') +! TES( 48 )%FILENAME = TRIM('retv_vars.02963_0457_003.cdf') +! TES( 49 )%FILENAME = TRIM('retv_vars.02963_0457_004.cdf') +! TES( 50 )%FILENAME = TRIM('retv_vars.02963_0458_002.cdf') +! TES( 51 )%FILENAME = TRIM('retv_vars.02963_0458_003.cdf') +! TES( 52 )%FILENAME = TRIM('retv_vars.02963_0458_004.cdf') +! TES( 53 )%FILENAME = TRIM('retv_vars.02963_0459_002.cdf') +! TES( 54 )%FILENAME = TRIM('retv_vars.02963_0459_003.cdf') +! TES( 55 )%FILENAME = TRIM('retv_vars.02963_0459_004.cdf') +! TES( 56 )%FILENAME = TRIM('retv_vars.02963_1054_002.cdf') +! TES( 57 )%FILENAME = TRIM('retv_vars.02963_1054_003.cdf') +! TES( 58 )%FILENAME = TRIM('retv_vars.02963_1054_004.cdf') +! TES( 59 )%FILENAME = TRIM('retv_vars.02963_1055_002.cdf') +! TES( 60 )%FILENAME = TRIM('retv_vars.02963_1055_003.cdf') +! TES( 61 )%FILENAME = TRIM('retv_vars.02963_1055_004.cdf') +! TES( 62 )%FILENAME = TRIM('retv_vars.02963_1056_002.cdf') +! TES( 63 )%FILENAME = TRIM('retv_vars.02963_1056_003.cdf') +! TES( 64 )%FILENAME = TRIM('retv_vars.02963_1056_004.cdf') +! TES( 65 )%FILENAME = TRIM('retv_vars.02967_0459_004.cdf') +! TES( 66 )%FILENAME = TRIM('retv_vars.02967_1054_002.cdf') +! TES( 67 )%FILENAME = TRIM('retv_vars.02967_1054_003.cdf') +! TES( 68 )%FILENAME = TRIM('retv_vars.02967_1054_004.cdf') +! TES( 69 )%FILENAME = TRIM('retv_vars.02967_1055_002.cdf') +! TES( 70 )%FILENAME = TRIM('retv_vars.02967_1055_003.cdf') +! TES( 71 )%FILENAME = TRIM('retv_vars.02967_1055_004.cdf') +! TES( 72 )%FILENAME = TRIM('retv_vars.02967_1056_002.cdf') +! TES( 73 )%FILENAME = TRIM('retv_vars.02967_1056_003.cdf') +! TES( 74 )%FILENAME = TRIM('retv_vars.02967_1056_004.cdf') +! TES( 75 )%FILENAME = TRIM('retv_vars.02971_0457_002.cdf') +! TES( 76 )%FILENAME = TRIM('retv_vars.02971_0457_003.cdf') +! TES( 77 )%FILENAME = TRIM('retv_vars.02971_0457_004.cdf') +! TES( 78 )%FILENAME = TRIM('retv_vars.02971_0458_002.cdf') +! TES( 79 )%FILENAME = TRIM('retv_vars.02971_0982_002.cdf') +! TES( 80 )%FILENAME = TRIM('retv_vars.02971_0982_003.cdf') +! TES( 81 )%FILENAME = TRIM('retv_vars.02971_0982_004.cdf') +! TES( 82 )%FILENAME = TRIM('retv_vars.02971_0983_002.cdf') +! TES( 83 )%FILENAME = TRIM('retv_vars.02971_0983_003.cdf') +! TES( 84 )%FILENAME = TRIM('retv_vars.02971_0983_004.cdf') +! TES( 85 )%FILENAME = TRIM('retv_vars.02971_0984_002.cdf') +! TES( 86 )%FILENAME = TRIM('retv_vars.02971_0984_003.cdf') +! TES( 87 )%FILENAME = TRIM('retv_vars.02971_0984_004.cdf') +! +! ! Return to calling program +! END SUBROUTINE INIT_TES_O3 +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CLEANUP_TES_O3 +!! +!!***************************************************************************** +!! Subroutine CLEANUP_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! +! IF ( ALLOCATED( O3_SAVE ) ) DEALLOCATE( O3_SAVE ) +! +! +! ! Return to calling program +! END SUBROUTINE CLEANUP_TES_O3 +!!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ + + SUBROUTINE SVD(A,N,U,S,VT) +! +!****************************************************************************** +! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) A (REAL*8) : N x N matrix to decompose +! (2 ) N (INTEGER) : N is dimension of A +! +! Arguments as Output: +! ============================================================================ +! (1 ) U (REAL*8) : Array of left singular vectors +! (2 ) S (REAL*8) : Vector of singular values +! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +! +! +! NOTES: +! +* Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +* The information and material ("Material") provided below is owned by Intel +* Corporation or its suppliers or licensors, and title to such Material remains +* with Intel Corporation or its suppliers or licensors. The Material contains +* proprietary information of Intel or its suppliers and licensors. The Material +* is protected by worldwide copyright laws and treaty provisions. No part of +* the Material may be copied, reproduced, published, uploaded, posted, +* transmitted, or distributed in any way without Intel's prior express written +* permission. No license under any patent, copyright or other intellectual +* property rights in the Material is granted to or conferred upon you, either +* expressly, by implication, inducement, estoppel or otherwise. Any license +* under such intellectual property rights must be express and approved by Intel +* in writing. +* ============================================================================= +* +* DGESVD Example. +* ============== +* +* Program computes the singular value decomposition of a general +* rectangular matrix A: +* +* 8.79 9.93 9.83 5.45 3.16 +* 6.11 6.91 5.04 -0.27 7.98 +* -9.15 -7.93 4.86 4.85 3.01 +* 9.57 1.64 8.83 0.74 5.80 +* -3.49 4.02 9.80 10.00 4.27 +* 9.84 0.15 -8.99 -6.02 -5.31 +* +* Description. +* ============ +* +* The routine computes the singular value decomposition (SVD) of a real +* m-by-n matrix A, optionally computing the left and/or right singular +* vectors. The SVD is written as +* +* A = U*SIGMA*VT +* +* where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +* diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +* is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +* are the singular values of A; they are real and non-negative, and are +* returned in descending order. The first min(m, n) columns of U and V are +* the left and right singular vectors of A. +* +* Note that the routine returns VT, not V. +* +* Example Program Results. +* ======================== +* +* DGESVD Example Program Results +* +* Singular values +* 27.47 22.64 8.56 5.99 2.01 +* +* Left singular vectors (stored columnwise) +* -0.59 0.26 0.36 0.31 0.23 +* -0.40 0.24 -0.22 -0.75 -0.36 +* -0.03 -0.60 -0.45 0.23 -0.31 +* -0.43 0.24 -0.69 0.33 0.16 +* -0.47 -0.35 0.39 0.16 -0.52 +* 0.29 0.58 -0.02 0.38 -0.65 +* +* Right singular vectors (stored rowwise) +* -0.25 -0.40 -0.69 -0.37 -0.41 +* 0.81 0.36 -0.25 -0.37 -0.10 +* -0.26 0.70 -0.22 0.39 -0.49 +* 0.40 -0.45 0.25 0.43 -0.62 +* -0.22 0.14 0.59 -0.63 -0.44 +* ============================================================================= +!****************************************************************************** +! + ! Arguements + INTEGER,INTENT(IN) :: N + REAL*8, INTENT(IN) :: A(N,N) + REAL*8, INTENT(OUT) :: U(N,N) + REAL*8, INTENT(OUT) :: S(N) + REAL*8, INTENT(OUT) :: VT(N,N) + + ! Local variables + INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 + INTEGER :: INFO, LWORK + DOUBLE PRECISION :: WORK( LWMAX ) + +* .. External Subroutines .. + EXTERNAL :: DGESVD + +* .. Intrinsic Functions .. + INTRINSIC :: INT, MIN + + !================================================================= + ! SVD begins here! + !================================================================= + +* .. Executable Statements .. + !WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF + +! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +!! +!! Print singular values. +!! +! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!! +!! Print left singular vectors. +!! +! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +! $ N, N, U, N ) +!! +!! Print right singular vectors. +!! +! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +! $ N, N, VT, N ) + + ! Return to calling program + END SUBROUTINE SVD +!------------------------------------------------------------------------------ + SUBROUTINE DGESVD_EXAMPLE + +* .. Parameters .. + INTEGER M, N + PARAMETER ( M = 6, N = 5 ) + INTEGER LDA, LDU, LDVT + PARAMETER ( LDA = M, LDU = M, LDVT = N ) + INTEGER LWMAX + PARAMETER ( LWMAX = 1000 ) +* +* .. Local Scalars .. + INTEGER INFO, LWORK +* +* .. Local Arrays .. + DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), + $ WORK( LWMAX ) + DATA A/ + $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, + $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, + $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, + $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, + $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 + $ / +* +* .. External Subroutines .. + EXTERNAL DGESVD + !EXTERNAL PRINT_MATRIX +* +* .. Intrinsic Functions .. + INTRINSIC INT, MIN +* +* .. Executable Statements .. + WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF +* +* Print singular values. +* + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +* +* Print left singular vectors. +* + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ M, N, U, LDU ) +* +* Print right singular vectors. +* + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, LDVT ) + +* +* End of DGESVD Example. + END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +* +* Auxiliary routine: printing a matrix. +* + SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) + CHARACTER*(*) DESC + INTEGER M, N, LDA + DOUBLE PRECISION A( LDA, * ) +* + INTEGER I, J +* + WRITE(*,*) + WRITE(*,*) DESC + DO I = 1, M + WRITE(*,9998) ( A( I, J ), J = 1, N ) + END DO +* +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) + 9998 FORMAT( 11(:,1X,E14.8) ) + RETURN + + END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_TES_BIAS_FILE_HDF5(FILE_ID) + + USE HDF5 + + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + + INTEGER(HID_T) :: FILE_ID + + CHARACTER(LEN=255) :: LON_NAME, LAT_NAME, LEV_NAME + CHARACTER(LEN=255) :: TES_O3_NAME + CHARACTER(LEN=255) :: TES_GC_O3_NAME + CHARACTER(LEN=255) :: TES_BIAS_NAME + CHARACTER(LEN=255) :: TES_COUNT_NAME + CHARACTER(LEN=255) :: LON_RAW_NAME, LAT_RAW_NAME, TIME_RAW_NAME + CHARACTER(LEN=255) :: TES_O3_RAW_NAME, TES_GC_O3_RAW_NAME + + CHARACTER(LEN=255) :: TES_O3_LONGNAME + CHARACTER(LEN=255) :: TES_GC_O3_LONGNAME + CHARACTER(LEN=255) :: TES_BIAS_LONGNAME + CHARACTER(LEN=255) :: TES_COUNT_LONGNAME + CHARACTER(LEN=255) :: TES_O3_RAW_LONGNAME, TES_GC_O3_RAW_LONGNAME + + CHARACTER(LEN=255) :: TES_O3_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_UNIT + CHARACTER(LEN=255) :: TES_BIAS_UNIT + CHARACTER(LEN=255) :: TES_COUNT_UNIT + CHARACTER(LEN=255) :: TES_O3_RAW_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_RAW_UNIT + + CHARACTER(LEN=255) :: LON_LONGNAME, LAT_LONGNAME, LEV_LONGNAME + CHARACTER(LEN=255) :: LON_UNIT, LAT_UNIT, LEV_UNIT + CHARACTER(LEN=255) :: LON_RAW_LONGNAME, LAT_RAW_LONGNAME + CHARACTER(LEN=255) :: TIME_RAW_LONGNAME + CHARACTER(LEN=255) :: LON_RAW_UNIT, LAT_RAW_UNIT + CHARACTER(LEN=255) :: TIME_RAW_UNIT + + INTEGER(HID_T) :: SPACE_LON, SPACE_LAT, SPACE_LEV + INTEGER(HID_T) :: SPACE_RAW_1D, SPACE_RAW_2D + INTEGER(HID_T) :: LON_ID, LAT_ID, LEV_ID + INTEGER(HID_T) :: LON_RAW_ID, LAT_RAW_ID, TIME_RAW_ID + INTEGER(HID_T) :: SPACE_TES, DSET_TES_O3_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_ID + INTEGER(HID_T) :: DSET_TES_BIAS_ID + INTEGER(HID_T) :: DSET_TES_COUNT_ID + INTEGER(HID_T) :: DSET_TES_O3_RAW_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_RAW_ID + + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER(HID_T) :: TES_GROUP_ID, GRID_GROUP_ID + INTEGER(HID_T) :: GRID_DATA_GROUP_ID, RAW_DATA_GROUP_ID + INTEGER(HID_T) :: LEVEL3_GROUP_ID + + INTEGER(HSIZE_T) :: DIMS(3), DIM_LON(1), DIM_LAT(1), DIM_LEV(1) + INTEGER(HSIZE_T) :: DIM_RAW_1D(1), DIM_RAW_2D(2) + + INTEGER :: HDF_ERR + INTEGER :: RANK = 3 + + INTEGER :: I,J,L + REAL*4 :: MISS_VAL = -999.9 + REAL*4 :: LON_VALS(IIPAR), LAT_VALS(JJPAR), LEV_VALS(MAXLEV) + + ! populate lon & lat arrays + + DO I=1,IIPAR + LON_VALS(I)=GET_XMID(I) + ENDDO + + DO J=1,JJPAR + LAT_VALS(J)=GET_YMID(J) + ENDDO + + DO I=1,MAXLEV + LEV_VALS(I)=TES_PRESSURE(I) ! assume that TES retrieval grid doesn't change + ENDDO + + DO L=1,MAXLEV + DO J=1,JJPAR + DO I=1,IIPAR + + IF(TES_BIAS_COUNT(I,J,L)>0d0) THEN + TES_O3_MEAN(I,J,L) = + & REAL(TES_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_GC_O3_MEAN(I,J,L) = + & REAL(TES_GC_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_BIAS(I,J,L) = + & REAL(TES_BIAS(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + ELSE + TES_O3_MEAN(I,J,L) = MISS_VAL + TES_GC_O3_MEAN(I,J,L) = MISS_VAL + TES_BIAS(I,J,L) = MISS_VAL + !TES_CHI_SQUARED(I,J,L) = MISS_VAL + ENDIF + + ENDDO + ENDDO + ENDDO + + DIMS(1) = IIPAR + DIMS(2) = JJPAR + DIMS(3) = MAXLEV + + ADIMS(1) = 1 + + DIM_LON = IIPAR + DIM_LAT = JJPAR + DIM_LEV = MAXLEV + + DIM_RAW_1D = FLEX_LON%CURRENT_N + + DIM_RAW_2D(1) = MAXLEV + DIM_RAW_2D(2) = FLEX_LON%CURRENT_N + + ! open HDF5 interface + + CALL H5OPEN_F(HDF_ERR) + + ! create group structure in file + + CALL H5GCREATE_F(FILE_ID,"TES",TES_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level3",LEVEL3_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Data", + & GRID_DATA_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Grid",GRID_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level2",RAW_DATA_GROUP_ID,HDF_ERR) + + ! write Level3 grid information + + CALL H5SCREATE_SIMPLE_F(1,DIM_LON,SPACE_LON,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LAT,SPACE_LAT,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LEV,SPACE_LEV,HDF_ERR) + + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Longitude", + & H5T_IEEE_F32LE, SPACE_LON, LON_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Latitude", + & H5T_IEEE_F32LE, SPACE_LAT, LAT_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Level", + & H5T_IEEE_F32LE, SPACE_LEV, LEV_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_ID, H5T_NATIVE_REAL, LON_VALS, + & DIM_LON, HDF_ERR) + CALL H5DWRITE_F(LAT_ID, H5T_NATIVE_REAL, LAT_VALS, + & DIM_LAT, HDF_ERR) + CALL H5DWRITE_F(LEV_ID, H5T_NATIVE_REAL, LEV_VALS, + & DIM_LEV, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_ID,"Longitude","degrees") + CALL WRITE_ATTRIBUTES(LAT_ID,"Latitude","degrees") + CALL WRITE_ATTRIBUTES(LEV_ID,"Vertical level","hPa") + + CALL H5DCLOSE_F(LON_ID, HDF_ERR) + CALL H5DCLOSE_F(LAT_ID, HDF_ERR) + CALL H5DCLOSE_F(LEV_ID, HDF_ERR) + + CALL H5SCLOSE_F(SPACE_LON, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LAT, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LEV, HDF_ERR) + + ! create dataspace for TES diagnostics + + CALL H5SCREATE_SIMPLE_F(RANK,DIMS,SPACE_TES,HDF_ERR) + + ! write gridded (Level3) data + ! create all datasets as little-endian 32 bit IEEE float + + ! write TES O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_ID, H5T_NATIVE_REAL, + & TES_O3_MEAN, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_ID,"Mean TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_ID,HDF_ERR) + + ! write TES_GC O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_GC_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_ID, H5T_NATIVE_REAL, + & TES_GC_O3_MEAN, ADIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_ID, + & "Mean GC O3 profiles in TES observation space", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_ID,HDF_ERR) + + ! write TES_GC O3 bias + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_BIAS", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_BIAS_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_BIAS_ID, H5T_NATIVE_REAL, + & TES_BIAS, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_BIAS_ID,"Mean TES O3 bias profile", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_BIAS_ID,HDF_ERR) + + ! write TES_GC O3 count + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_COUNT", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_COUNT_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_COUNT_ID, H5T_NATIVE_REAL, + & TES_BIAS_COUNT, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_COUNT_ID,"TES data count", + & "1") + + CALL H5DCLOSE_F(DSET_TES_COUNT_ID,HDF_ERR) + + !----------------------------------------------------------------------------------------------------- + + ! create dataspace for raw 1D (Level2) diagnostics + + CALL H5SCREATE_SIMPLE_F(1,DIM_RAW_1D,SPACE_RAW_1D,HDF_ERR) + + ! write raw longitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Longitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LON_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LON%DATA(1:FLEX_LON%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_RAW_ID,"Longitude", "degrees") + + CALL H5DCLOSE_F(LON_RAW_ID,HDF_ERR) + + ! write raw latitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Latitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LAT_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LAT_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LAT%DATA(1:FLEX_LAT%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LAT_RAW_ID,"Latitude", "degrees") + + CALL H5DCLOSE_F(LAT_RAW_ID,HDF_ERR) + + ! write raw times + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Time", + & H5T_IEEE_F64LE, SPACE_RAW_1D, TIME_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(TIME_RAW_ID, H5T_NATIVE_DOUBLE, + & FLEX_TIME%DATA(1:FLEX_TIME%CURRENT_N), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(TIME_RAW_ID,"Time","YYYYMMDD.frac-of-day") + + CALL H5DCLOSE_F(TIME_RAW_ID,HDF_ERR) + + ! create dataspace for raw 2D diagnostics + + CALL H5SCREATE_SIMPLE_F(2,DIM_RAW_2D,SPACE_RAW_2D,HDF_ERR) + + ! write raw TES O3 profiles + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_TES_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_RAW_ID,"TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_RAW_ID,HDF_ERR) + + ! write raw GC O3 profiles as observed by GEOS-Chem + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_GC_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_GC_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_RAW_ID, + & "GEOS-Chem O3 profiles in TES observation space","ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_RAW_ID,HDF_ERR) + + !close data spaces and groups + + CALL H5SCLOSE_F(SPACE_TES,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_1D,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_2D,HDF_ERR) + + CALL H5GCLOSE_F(RAW_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(TES_GROUP_ID, HDF_ERR) + + ! close HDF5 interface + + CALL H5CLOSE_F(HDF_ERR) + + CALL H5EPRINT_F(HDF_ERR,"hdf_error") + + ! clear flexible arrays + + CALL CLEAR_FLEX_REAL_1D(FLEX_LON) + CALL CLEAR_FLEX_REAL_1D(FLEX_LAT) + CALL CLEAR_FLEX_REAL_1D(FLEX_TIME) + + CALL CLEAR_FLEX_REAL_2D(FLEX_TES_O3) + CALL CLEAR_FLEX_REAL_2D(FLEX_GC_O3) + + END SUBROUTINE MAKE_TES_BIAS_FILE_HDF5 + + SUBROUTINE WRITE_ATTRIBUTES(DSET_ID,LONGNAME,UNIT) + + USE HDF5 + + INTEGER(HID_T) :: DSET_ID + CHARACTER(LEN=*) :: LONGNAME + CHARACTER(LEN=*) :: UNIT + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER :: HDF_ERR + + ADIMS(1) = 1 + + ! create attribute "Long name" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(LONGNAME),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Long name", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,LONGNAME, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + ! create attribute "Unit" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(UNIT),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Unit", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,UNIT, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + END SUBROUTINE WRITE_ATTRIBUTES + + !-------------------------------------------------------------------------------- + + !mkeller: helper routines for managing flexible arrays + ! reinventing the wheel here, but hey... + + SUBROUTINE INIT_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_1D + + SUBROUTINE GROW_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:) + ALLOCATE(TEMP_ARRAY(INPUT%MAX_N * 2)) + TEMP_ARRAY(1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_1D + + SUBROUTINE PUSH_FLEX_REAL_1D(INPUT, NEW_VAL) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8 :: NEW_VAL + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_1D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(INPUT%CURRENT_N) = NEW_VAL + + END SUBROUTINE PUSH_FLEX_REAL_1D + + SUBROUTINE CLEAR_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_1D + + !-------------------------------------------------------------------------------- + + SUBROUTINE INIT_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_2D + + SUBROUTINE GROW_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:,:) + ALLOCATE(TEMP_ARRAY(MAXLEV,INPUT%MAX_N * 2)) + TEMP_ARRAY(:,1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_2D + + SUBROUTINE PUSH_FLEX_REAL_2D(INPUT, NEW_VAL, NLEV) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8 :: NEW_VAL(MAXLEV) + INTEGER :: NLEV + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_2D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(MAXLEV-NLEV+1:MAXLEV,INPUT%CURRENT_N) = NEW_VAL(1:NLEV) + + END SUBROUTINE PUSH_FLEX_REAL_2D + + SUBROUTINE CLEAR_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_2D + + END MODULE TES_O3_MOD diff --git a/code/obs_operators/tes_o3_mod.f~ b/code/obs_operators/tes_o3_mod.f~ new file mode 100644 index 0000000..80c5ac9 --- /dev/null +++ b/code/obs_operators/tes_o3_mod.f~ @@ -0,0 +1,3443 @@ +!$Id: tes_o3_mod.f,v 1.3 2011/02/23 00:08:48 daven Exp $ + MODULE TES_O3_MOD + + IMPLICIT NONE + +!mkeller +#include "CMN_SIZE" +!#include 'netcdf.inc' + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + PRIVATE + + PUBLIC READ_TES_O3_OBS + PUBLIC CALC_TES_O3_FORCE + PUBLIC MAKE_TES_BIAS_FILE_HDF5 + + ! Parameters + INTEGER, PARAMETER :: MAXLEV = 67 + INTEGER, PARAMETER :: MAXTES = 2000 + + + ! Record to store data from each TES obs + TYPE TES_O3_OBS + INTEGER :: LTES(1) + REAL*8 :: LAT(1) + REAL*8 :: LON(1) + REAL*8 :: TIME(1) + REAL*8 :: O3(MAXLEV) + REAL*8 :: PRES(MAXLEV) + REAL*8 :: PRIOR(MAXLEV) + REAL*8 :: AVG_KERNEL(MAXLEV,MAXLEV) + REAL*8 :: S_OER(MAXLEV,MAXLEV) + REAL*8 :: S_OER_INV(MAXLEV,MAXLEV) + !mkeller: TES retrieval quality flag + INTEGER :: QUALITY_FLAG(1) + ENDTYPE TES_O3_OBS + + TYPE(TES_O3_OBS) :: TES(MAXTES) + + !mkeller: arrays for saving diagnostics + + TYPE FLEX_REAL_1D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:) + ENDTYPE FLEX_REAL_1D + + TYPE FLEX_REAL_2D + INTEGER :: CURRENT_N, MAX_N + REAL*8,ALLOCATABLE :: DATA(:,:) + ENDTYPE FLEX_REAL_2D + + REAL*4 :: TES_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_GC_O3_MEAN(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_BIAS_COUNT(IIPAR,JJPAR,MAXLEV)=0d0 + REAL*4 :: TES_PRESSURE(MAXLEV) + ! mkeller: flex arrays to store satellite diagnostics sequentially + TYPE(FLEX_REAL_1D) :: FLEX_LON, FLEX_LAT, FLEX_TIME + TYPE(FLEX_REAL_2D) :: FLEX_TES_O3, FLEX_GC_O3 + + ! mkeller: logical flag to check whether data is available for given day + LOGICAL :: DATA_PRESENT + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TES_O3_OBS( YYYYMMDD, NTES ) +! +!****************************************************************************** +! Subroutine READ_TES_O3_OBS reads the file and passes back info contained +! therein. (dkh, 02/19/09) +! +! Based on READ_TES_NH3 OBS (dkh, 04/26/10) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD INTEGER : Current year-month-day +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals for current day +! +! Module variable as Output: +! ============================================================================ +! (1 ) TES (TES_O3_OBS) : TES retrieval for current day +! +! NOTES: +! (1 ) Add calculation of S_OER_INV, though eventually we probably want to +! do this offline. (dkh, 05/04/10) +!****************************************************************************** +! + ! Reference to f90 modules + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE NETCDF + USE TIME_MOD, ONLY : EXPAND_DATE + + + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD + + ! local variables + INTEGER :: FID + INTEGER :: LTES + INTEGER :: NTES + INTEGER :: START0(1), COUNT0(1) + INTEGER :: START1(2), COUNT1(2) + INTEGER :: START2(3), COUNT2(3) + INTEGER :: N, J + INTEGER :: NT_ID + INTEGER :: O3_ID + INTEGER :: PS_ID + INTEGER :: AK_ID + INTEGER :: OE_ID + INTEGER :: AP_ID + INTEGER :: LA_ID + INTEGER :: LO_ID + INTEGER :: DY_ID + + !mkeller: additional variables for quality flag + INTEGER :: QU_ID + + CHARACTER(LEN=5) :: TMP + CHARACTER(LEN=255) :: READ_FILENAME + CHARACTER(LEN=255) :: DIR_MONTH + CHARACTER(LEN=255) :: DIR_TES + + REAL*8, PARAMETER :: FILL = -999.0D0 + REAL*8, PARAMETER :: TOL = 1d-04 + REAL*8 :: U(MAXLEV,MAXLEV) + REAL*8 :: VT(MAXLEV,MAXLEV) + REAL*8 :: S(MAXLEV) + REAL*8 :: TMP1 + REAL*8 :: TEST(MAXLEV,MAXLEV) + INTEGER :: I, II, III + + !================================================================= + ! READ_TES_O3_OBS begins here! + !================================================================= + + ! filename root + DIR_TES = '/users/jk/16/xzhang/TES_O3/' + READ_FILENAME = TRIM( 'tes_aura_nadir_YYYYMMDD_O3_v7.nc' ) + DIR_MONTH = 'YYYY/MM/' + + ! Expand date tokens in filename + CALL EXPAND_DATE( READ_FILENAME, YYYYMMDD, 9999 ) + CALL EXPAND_DATE( DIR_MONTH, YYYYMMDD, 9999 ) + + ! Construct complete filename + READ_FILENAME = TRIM( DIR_TES ) // TRIM( DIR_MONTH ) // + & TRIM( READ_FILENAME ) + + WRITE(6,*) ' - READ_TES_O3_OBS: reading file: ', READ_FILENAME + + ! mkeller: check to see if file exists + INQUIRE(FILE=READ_FILENAME, EXIST = DATA_PRESENT) + + IF (.NOT. DATA_PRESENT) THEN + PRINT *,"TES file '", TRIM(READ_FILENAME), " not found, "// + & "assuming that there is no data for this day." + RETURN + ELSE + PRINT *,"TES file found!" + ENDIF + + ! Open file and assign file id (FID) + CALL CHECK( NF90_OPEN( READ_FILENAME, NF90_NOWRITE, FID ), 0 ) + + !-------------------------------- + ! Get data record IDs + !-------------------------------- + CALL CHECK( NF90_INQ_DIMID( FID, "targets", NT_ID), 102 ) + CALL CHECK( NF90_INQ_VARID( FID, "species", O3_ID ), 103 ) + CALL CHECK( NF90_INQ_VARID( FID, "averagingkernel", AK_ID ), 104 ) + CALL CHECK( NF90_INQ_VARID( FID, "pressure", PS_ID ), 105 ) + CALL CHECK( NF90_INQ_VARID( FID, "observationerrorcovariance", + & OE_ID ), 106 ) + CALL CHECK( NF90_INQ_VARID( FID, "constraintvector",AP_ID ), 107 ) + CALL CHECK( NF90_INQ_VARID( FID, "latitude", LA_ID ), 108 ) + CALL CHECK( NF90_INQ_VARID( FID, "longitude", LO_ID ), 109 ) + CALL CHECK( NF90_INQ_VARID( FID, "yyyymmdd", DY_ID ), 110 ) + CALL CHECK( NF90_INQ_VARID( FID, "speciesretrievalconverged", + & QU_ID ), 111 ) + + ! READ number of retrievals, NTES + CALL CHECK( NF90_INQUIRE_DIMENSION( FID, NT_ID, TMP, NTES), 202 ) + + !print*, ' NTES = ', NTES + + !-------------------------------- + ! Read 0D Data + !-------------------------------- + + ! mkeller: read in TES pressure levels for satellite diagnostics + ! this only needs to be done once, add logical flag here + ! the TES retrieval pressure grid can vary near the surface, there shouldn't be any + ! data reported on those levels in the diagnostic output. + ! not sure what the proper way to do this is for Level3 data... + ! for Level2 data, should all individual retrieval grids be written out? + + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES_PRESSURE, (/1,1/), (/MAXLEV,1/)), 402 ) + + !PRINT *, "TES_PRESSURE", TES_PRESSURE + ! define record size + START0 = (/1/) + COUNT0 = (/1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START0(1) = N + + ! READ latitude + CALL CHECK( NF90_GET_VAR ( FID, LA_ID, + & TES(N)%LAT, START0, COUNT0 ), 301 ) + + ! READ longitude + CALL CHECK( NF90_GET_VAR ( FID, LO_ID, + & TES(N)%LON, START0, COUNT0 ), 302 ) + + ! READ date + CALL CHECK( NF90_GET_VAR ( FID, DY_ID, + & TES(N)%TIME, START0, COUNT0 ), 303 ) + + ! READ quality flag + CALL CHECK( NF90_GET_VAR ( FID, QU_ID, + & TES(N)%QUALITY_FLAG, START0, COUNT0 ), 304 ) + + ENDDO + + !-------------------------------- + ! Find # of good levels for each + !-------------------------------- + + ! define record size + START1 = (/1, 1/) + COUNT1 = (/MAXLEV, 1/) + + ! loop over records + DO N = 1, NTES + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:MAXLEV), START1, COUNT1 ), 401 ) + + ! Now determine how many of the levels in O3 are + ! 'good' and how many are just FILL. + + J = 1 + DO WHILE ( J .le. MAXLEV ) + + ! check if the value is good + IF ( TES(N)%O3(J) > FILL ) THEN + + ! save the number of good levels as LTES + TES(N)%LTES = MAXLEV - J + 1 + + ! and now we can exit the while loop + J = MAXLEV + 1 + + ! otherwise this level is just filler + ELSE + + ! so proceed to the next one up + J = J + 1 + + ENDIF + + ENDDO + + ENDDO + + !-------------------------------- + ! Read 1D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START1 = (/MAXLEV - J + 1, 1/) + COUNT1 = (/J, 1/) + + ! Update starting index + START1(2) = N + + ! READ O3 column, O3 + CALL CHECK( NF90_GET_VAR ( FID, O3_ID, + & TES(N)%O3(1:J), START1, COUNT1 ), 401 ) + + ! READ pressure levels, PRES + CALL CHECK( NF90_GET_VAR ( FID, PS_ID, + & TES(N)%PRES(1:J), START1, COUNT1 ), 402 ) + + ! READ apriori O3 column, PRIOR + CALL CHECK( NF90_GET_VAR ( FID, AP_ID, + & TES(N)%PRIOR(1:J), START1, COUNT1 ), 403 ) + + + ENDDO + + + !-------------------------------- + ! Read 2D Data + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + ! J is number of good levels + J = TES(N)%LTES(1) + + ! define record size + START2 = (/MAXLEV - J + 1, MAXLEV - J + 1, 1/) + COUNT2 = (/J, J, 1/) + + ! Update starting index + START2(3) = N + + ! READ averaging kernal, AVG_KERNEL + CALL CHECK( NF90_GET_VAR ( FID, AK_ID, + & TES(N)%AVG_KERNEL(1:J,1:J), START2, COUNT2), 501 ) + + ! READ observational error covariance + CALL CHECK( NF90_GET_VAR ( FID, OE_ID, + & TES(N)%S_OER(1:J,1:J), START2, COUNT2), 502 ) + ENDDO + + ! Close the file + CALL CHECK( NF90_CLOSE( FID ), 9999 ) + + !-------------------------------- + ! Calculate S_OER_INV + !-------------------------------- + + ! loop over records + DO N = 1, NTES + + J = TES(N)%LTES(1) + !print*, ' TES test ', TES(N)%O3 + !print*, ' TES good ', TES(N)%LTES + !print*, ' TES pres ', TES(N)%PRES(1:J) + + ! Add a bit to the diagonal to regularize the inversion + ! (ks, ml, dkh, 11/18/10) + ! mkeller: this makes no sense to me. + !DO II=1,J + ! TES(N)%S_OER(II,II) = TES(N)%S_OER(II,II)+ 0.001D0 + !ENDDO + + CALL SVD( TES(N)%S_OER(1:J,1:J), J, + & U(1:J,1:J), S(1:J), + & VT(1:J,1:J) ) + + ! U = S^-1 * U^T + TEST = 0d0 + DO I = 1, J + + ! mkeller: regularize matrix inverse by ignoring all singular values below a certain cutoff. + ! This is horrendously inefficient, but should work for now. In the + ! future, Thikonov regularization should be implemented instead. + ! xzhang: svd test critical value changes from 1e-2 to 5e-2 + IF ( S(I)/S(1) < 1e-2 ) THEN + S(I) = 1e-2 * S(1) + ENDIF + DO II = 1, J + TEST(I,II) = U(II,I) / S(I) + ENDDO + ENDDO + + !TEST = 0d0 + U = TEST + TEST = 0d0 + + + ! S_OER_INV = V * S^-1 * U^T + DO I = 1, J + DO II = 1, J + TMP1 = 0d0 + DO III = 1, J + TMP1 = TMP1 + VT(III,I) * U(III,II) + ENDDO + TES(N)%S_OER_INV(I,II) = TMP1 + ENDDO + ENDDO + + ! TEST: calculate 2-norm of I - S_OER_INV * S_OER + ! mkeller: comment this out for now; pointless given the regularization + ! performed above. + ! Need to come up with an alternative test in the future. + !DO I = 1, J + ! DO II = 1, J + ! TMP1 = 0d0 + ! DO III = 1, J + ! TMP1 = TMP1 + !& + TES(N)%S_OER_INV(III,I) * TES(N)%S_OER(III,II) + !ENDDO + !TEST(I,II) = - TMP1 + !ENDDO + !TEST(I,I) = ( TEST(I,I) + 1 ) ** 2 + !ENDDO + + !IF ( SUM(TEST(1:J,1:J)) > TOL ) THEN + ! print*, ' WARNING: inversion error for retv N = ', + !& SUM(TEST(1:J,1:J)), N + ! print*, ' in TES obs ', READ_FILENAME + ! ENDIF + + ENDDO ! N + + ! Return to calling program + END SUBROUTINE READ_TES_O3_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK( STATUS, LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK checks the status of calls to netCDF libraries routines +! (dkh, 02/15/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STATUS (INTEGER) : Completion status of netCDF library call +! (2 ) LOCATION (INTEGER) : Location at which netCDF library call was made +! +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE NETCDF + + ! Arguments + INTEGER, INTENT(IN) :: STATUS + INTEGER, INTENT(IN) :: LOCATION + + !================================================================= + ! CHECK begins here! + !================================================================= + + IF ( STATUS /= NF90_NOERR ) THEN + WRITE(6,*) TRIM( NF90_STRERROR( STATUS ) ) + WRITE(6,*) 'At location = ', LOCATION + CALL ERROR_STOP('netCDF error', 'tes_nh3_mod') + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_TES_O3_FORCE( COST_FUNC ) +! +!****************************************************************************** +! Subroutine CALC_TES_O3_FORCE calculates the adjoint forcing from the TES +! O3 observations and updates the cost function. (dkh, 02/15/09) +! +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +! +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/07/09) +! (2 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +! (3 ) Now use CSPEC_AFTER_CHEM and CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE CHECKPT_MOD, ONLY : CHK_STT + USE COMODE_MOD, ONLY : JLOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : AIRDEN + USE DAO_MOD, ONLY : BXHEIGHT + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE GRID_MOD, ONLY : GET_IJ + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3, IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size params + + ! Arguments + REAL*8, INTENT(INOUT) :: COST_FUNC + + ! Local variables + INTEGER :: NTSTART, NTSTOP, NT + INTEGER :: IIJJ(2), I, J + INTEGER :: L, LL, LTES + INTEGER :: JLOOP + REAL*8 :: GC_PRES(LLPAR) + REAL*8 :: GC_O3_NATIVE(LLPAR) + REAL*8 :: GC_O3(MAXLEV) + REAL*8 :: GC_PSURF + REAL*8 :: MAP(LLPAR,MAXLEV) + REAL*8 :: O3_HAT(MAXLEV) + REAL*8 :: O3_PERT(MAXLEV) + REAL*8 :: FORCE(MAXLEV) + REAL*8 :: DIFF(MAXLEV) + REAL*8 :: DIFF_V(MAXLEV) + REAL*8 :: NEW_COST(MAXTES) + REAL*8 :: OLD_COST + REAL*8, SAVE :: TIME_FRAC(MAXTES) + INTEGER,SAVE :: NTES + + REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) + REAL*8 :: O3_HAT_ADJ(MAXLEV) + REAL*8 :: O3_PERT_ADJ(MAXLEV) + REAL*8 :: GC_O3_ADJ(MAXLEV) + REAL*8 :: DIFF_ADJ(MAXLEV) + + REAL*8 :: GC_ADJ_TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: GC_ADJ_TEMP_COST(IIPAR,JJPAR) + REAL*8 :: GC_ADJ_COUNT(IIPAR,JJPAR,LLPAR) + + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + + !mkeller + REAL*8 :: TEMP_BIAS_TES(MAXLEV) + REAL*8 :: TEMP_BIAS_GC(LLPAR) + + + + !================================================================= + ! CALC_TES_O3_FORCE begins here! + !================================================================= + + print*, ' - CALC_TES_O3_FORCE ' + + ! Reset + NEW_COST = 0D0 + GC_ADJ_COUNT = 0d0 + GC_ADJ_TEMP = 0d0 + GC_ADJ_TEMP_COST = 0d0 + + ! Open files for diagnostic output + IF ( FIRST ) THEN + FILENAME = 'pres_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'tes_o3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'apriori.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'diff_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'force.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'nt_ll.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'o3_pert_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'exp_o3_hat.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_press_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_on_tes.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'gc_o3_native_adj.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + FILENAME = 'lat_orb_teso3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 115, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + + + ! mkeller: initialize flex arrays + + CALL INIT_FLEX_REAL_1D(FLEX_LON) + CALL INIT_FLEX_REAL_1D(FLEX_LAT) + CALL INIT_FLEX_REAL_1D(FLEX_TIME) + CALL INIT_FLEX_REAL_2D(FLEX_TES_O3) + CALL INIT_FLEX_REAL_2D(FLEX_GC_O3) + + ENDIF + + ! Save a value of the cost function first + OLD_COST = COST_FUNC + + ! Check if it is the last hour of a day + IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN + + ! Read the TES O3 file for this day + CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) + + ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction + TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() + + ENDIF + + IF(.NOT. DATA_PRESENT) THEN + PRINT *,"No TES data present for this day, nothing to do here." + RETURN + ENDIF + + ! Get the range of TES retrievals for the current hour + CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) + + IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN + + print*, ' No matching TES O3 obs for this hour' + RETURN + ENDIF + + print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), + & TIME_FRAC(NTSTOP) + print*, ' found record range: ', NTSTART, NTSTOP + +! need to update this in order to do i/o with this loop parallel +! ! Now do a parallel loop for analyzing data +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!$OMP+PRIVATE( DIFF_ADJ ) + + DO NT = NTSTART, NTSTOP, -1 + + print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT + + PRINT *,"TES quality flag:", TES(NT)%QUALITY_FLAG(1) + + IF( TES(NT)%QUALITY_FLAG(1) == 0 ) THEN + PRINT *,"TES retrieval didn't converge; skipping record" + CYCLE + ENDIF + + ! For safety, initialize these up to LLTES + GC_O3(:) = 0d0 + MAP(:,:) = 0d0 + O3_HAT_ADJ(:) = 0d0 + FORCE(:) = 0d0 + DIFF(:) = 0d0 + DIFF_V(:) = 0d0 + + !TEMP_BIAS_TES(:) = 0d0 + !TEMP_BIAS_GC(:) = 0d0 + + ! Copy LTES to make coding a bit cleaner + LTES = TES(NT)%LTES(1) + + ! Get grid box of current record + IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) + I = IIJJ(1) + J = IIJJ(2) + + PRINT *, "TES_LAT", REAL(TES(NT)%LAT(1)) + + ! dkh debug + !print*, 'I,J = ', I, J + + ! Get GC pressure levels (mbar) + DO L = 1, LLPAR + GC_PRES(L) = GET_PCENTER(I,J,L) + ENDDO + + ! Get GC surface pressure (mbar) + GC_PSURF = GET_PEDGE(I,J,1) + + ! Calculate the interpolation weight matrix + MAP(1:LLPAR,1:LTES) + & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, + & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) + + + !mkeller: store TES pressure in diagnostic array. Should only be done once, as retrieval pressures don't vary between retrievals. + ! needs to be fixed. + !TES_PRESSURE = TES(NT)%PRES + + ! Get O3 values at native model resolution + DO L = 1, LLPAR + + ! check if in trop + !IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + !JLOOP = JLOP(I,J,L) + + ! get O3 from tropospheric array + !IF ( JLOOP > 0 ) THEN + + !GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) + !GC_O3_NATIVE(L) = CSPEC_AFTER_CHEM(JLOOP,ID2C(IDO3)) + + ! Convert from #/cm3 to v/v + !GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + + !ELSE + +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + ! mkeller: use LINOZ Ox from stored from forward run instead + ! kg -> v/v + !GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & !TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + + !ELSE + + ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) + !GC_O3_NATIVE(L) = 1d0 + + GC_O3_NATIVE(L) = CHK_STT(I,J,L,IDTOX) * + & TCVV(IDTOX) / AD(I,J,L) + + !ENDIF + +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) + + ENDDO + + + ! Interpolate GC O3 column to TES grid + DO LL = 1, LTES + GC_O3(LL) = 0d0 + DO L = 1, LLPAR + GC_O3(LL) = GC_O3(LL) + & + MAP(L,LL) * GC_O3_NATIVE(L) + ENDDO + ENDDO + + ! dkh debug: compare profiles: + !print*, ' GC_PRES, GC_native_O3 [ppb] ' + !WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) + !print*, ' TES_PRES, GC_O3 ' + !WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) + 100 FORMAT(1X,F16.8,1X,F16.8) + + !-------------------------------------------------------------- + ! Apply TES observation operator + ! + ! x_hat = x_a + A_k ( x_m - x_a ) + ! + ! where + ! x_hat = GC modeled column as seen by TES [lnvmr] + ! x_a = TES apriori column [lnvmr] + ! x_m = GC modeled column [lnvmr] + ! A_k = TES averaging kernel + !-------------------------------------------------------------- + + ! x_m - x_a + DO L = 1, LTES + GC_O3(L) = MAX(GC_O3(L), 1d-10) + O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ENDDO + + ! x_a + A_k * ( x_m - x_a ) + DO L = 1, LTES + O3_HAT(L) = 0d0 + DO LL = 1, LTES + O3_HAT(L) = O3_HAT(L) + & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) + ENDDO + O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) + ENDDO + + !-------------------------------------------------------------- + ! Calculate cost function, given S is error on ln(vmr) + ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] + !-------------------------------------------------------------- + + ! Calculate difference between modeled and observed profile + + ! mkeller: diagnostics need an OMP CRITICAL directive +!!$OMP CRITICAL + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 11d-9 ) THEN + IF ( REAL(TES(NT)%LAT(1)) > 56.6 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 6.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-6.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > 35.0 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) -5.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-5.9d-9) + ELSEIF ( REAL(TES(NT)%LAT(1)) > 15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 7.5d-9 ) + DIFF_V(L) = exp(O3_HAT(L)) - (TES(NT)%O3(L)-7.5d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.2d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.2d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -15.0 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 9.2d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 9.2d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 2.9d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 2.9d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) > -47.7 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.7d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.7d-9) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 3.4d-9 ) + DIFF_V(L) = exp(O3_HAT(L))-(TES(NT)%O3(L) - 3.4d-9) + ENDIF + ELSEIF ( REAL(TES(NT)%LAT(1)) < -61.9 ) THEN + IF ( TES(NT)%PRES(L) > 500 ) THEN + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) + DIFF_V(L) = exp(O3_HAT(L)) - TES(NT)%O3(L) + ELSE + DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) - 10.6d-9) + DIFF_V(L) = exp(O3_HAT(L)) -(TES(NT)%O3(L)-10.6d-9) + ENDIF + ENDIF + + !mkeller: store difference in VMR on retrieval grid + TES_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_O3_MEAN(I,J,MAXLEV-LTES + L) + TES(NT)%O3(L) + TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) = + & TES_GC_O3_MEAN(I,J,MAXLEV-LTES + L) + exp(O3_HAT(L)) + TES_BIAS(I,J,MAXLEV-LTES + L) = + & TES_BIAS(I,J,MAXLEV-LTES + L) + + & exp(O3_HAT(L)) - TES(NT)%O3(L) + TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) = + & TES_BIAS_COUNT(I,J,MAXLEV-LTES + L) + 1 + + ELSE + DIFF(L) = 0d0 + DIFF_V(L) = 0d0 + ENDIF + ENDDO + + ! store current information in flexible arrays + + CALL PUSH_FLEX_REAL_1D(FLEX_LON, TES(NT)%LON(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_LAT, TES(NT)%LAT(1)) + CALL PUSH_FLEX_REAL_1D(FLEX_TIME, TES(NT)%TIME(1)) + + CALL PUSH_FLEX_REAL_2D(FLEX_TES_O3, TES(NT)%O3, LTES) + CALL PUSH_FLEX_REAL_2D(FLEX_GC_O3, exp(O3_HAT),LTES) +!!$OMP END CRITICAL + + ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF + DO L = 1, LTES + FORCE(L) = 0d0 + DO LL = 1, LTES + FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) + ENDDO + NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) + ENDDO + ! dkh debug: compare profiles: +!mkeller: comment this out for now, not needed + !print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' + !WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) + + !print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' + !WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) + 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) + 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) + + !mkeller: discard observations that yield negative cost function contributions + + IF (NEW_COST(NT) < 0d0) THEN + PRINT *,"TES_DEBUG: DISCARD OBSERVATIONS FOR NT=",NT + NEW_COST(NT) = 0d0 + DIFF = 0d0 + FORCE = 0d0 + CYCLE + ENDIF + + !-------------------------------------------------------------- + ! Begin adjoint calculations + !-------------------------------------------------------------- + + ! dkh debug + !print*, 'DIFF , FORCE ' + !WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) + 102 FORMAT(1X,d14.6,1X,d14.6) + + ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE + DIFF_ADJ(:) = FORCE(:) + + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !print*, ' FORCE with 1 for sensitivity ' + !ADJ_DIFF(:) = 1d0 + !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) + !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) + !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) + + ! Adjoint of difference + DO L = 1, LTES + IF ( TES(NT)%O3(L) > 0d0 ) THEN + O3_HAT_ADJ(L) = DIFF_ADJ(L) + ENDIF + ENDDO + + ! adjoint of TES operator + DO L = 1, LTES + O3_PERT_ADJ(L) = 0d0 + DO LL = 1, LTES + O3_PERT_ADJ(L) = O3_PERT_ADJ(L) + & + TES(NT)%AVG_KERNEL(LL,L) + & * O3_HAT_ADJ(LL) + ENDDO + ENDDO + + ! Adjoint of x_m - x_a + DO L = 1, LTES + ! fwd code: + !GC_O3(L) = MAX(GC_O3(L), 1d-10) + !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) + ! adj code: + IF ( GC_O3(L) > 1d-10 ) THEN + GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) + ELSE + GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) + ENDIF + ENDDO + + ! dkh debug + !print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' + !WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) + 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) + + ! adjoint of interpolation + DO L = 1, LLPAR + GC_O3_NATIVE_ADJ(L) = 0d0 + DO LL = 1, LTES + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) + & + MAP(L,LL) * GC_O3_ADJ(LL) + + ENDDO + ENDDO + + !WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! mkeller: OMP critical directive needed here +!!$OMP CRITICAL + DO L = 1, LLPAR + + ! Adjoint of unit conversion + !GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / + & !( AIRDEN(L,I,J) * XNUMOLAIR ) + GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * TCVV(IDTOX) / + & AD(I,J,L) + + ! mkeller: OMP critical directive needed here + + GC_ADJ_COUNT(I,J,L) = GC_ADJ_COUNT(I,J,L) + 1d0 + + GC_ADJ_TEMP(I,J,L) = GC_ADJ_TEMP(I,J,L)+GC_O3_NATIVE_ADJ(L) + + ENDDO +!!$OMP END CRITICAL + + + !GC_ADJ_TEMP_COST(I,J) = GC_ADJ_TEMP_COST(I,J) + NEW_COST(NT) + + ! dkh debug + ! mkeller: comment this out for now + !print*, 'GC_O3_NATIVE_ADJ conv ' + !WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) + 104 FORMAT(1X,d14.6) + + !WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) + !WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) + !WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) + !WRITE(105,110) ( 1d9 * DIFF_V(LL), LL=LTES,1,-1) + !WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) + !WRITE(107,111) NT, LTES + !WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) + !WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) + !WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) + !WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) + !WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) + !WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) + !WRITE(115,110) ( REAL(TES(NT)%LAT(1))) + 110 FORMAT(F18.6,1X) + 111 FORMAT(i4,1X,i4,1x) + 112 FORMAT(D14.6,1X) + + ENDDO ! NT +!!$OMP END PARALLEL DO + + DO L=1,LLPAR + DO J=1,JJPAR + DO I=1,IIPAR + + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + + JLOOP = JLOP(I,J,L) + + IF ( JLOOP > 0 ) THEN + + IF(GC_ADJ_COUNT(I,J,L)>0d0) THEN + + ! Pass adjoint back to adjoint tracer array + ! this formulation allows for aggregating the TES retrievals that fall into + ! a particular grid box into a super observation. This functionality has been + ! disabled for now. + + !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) = + & !CSPEC_AFTER_CHEM_ADJ(JLOOP,ID2C(IDO3)) + & !+ GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + STT_ADJ(I,J,L,IDTOX) = STT_ADJ(I,J,L,IDTOX) + + & GC_ADJ_TEMP(I,J,L)/GC_ADJ_COUNT(I,J,L) + + ENDIF + + ENDIF + + ENDIF + + ENDDO + + ! don't bin TES retrievals into a super observation for now. + + !IF( MAXVAL(GC_ADJ_COUNT(I,J,:) > 0d0) ) THEN + !COST_FUNC = COST_FUNC + + !& GC_ADJ_TEMP_COST(I,J)/MAXVAL(GC_ADJ_COUNT(I,J,:)) + !ENDIF + + ENDDO + ENDDO + + IF ( FIRST ) FIRST = .FALSE. + + ! Update cost function + COST_FUNC = COST_FUNC + SUM(NEW_COST(NTSTOP:NTSTART)) + + print*, ' Updated value of COST_FUNC = ', COST_FUNC + print*, ' TES contribution = ', COST_FUNC - OLD_COST + + ! Return to calling program + END SUBROUTINE CALC_TES_O3_FORCE + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CALC_TES_O3_FORCE_FD( COST_FUNC, PERT, ADJ ) +!! +!!****************************************************************************** +!! Subroutine CALC_TES_O3_FORCE_FD tests the adjoint of CALC_TES_O3_FORCE +!! (dkh, 05/05/10) +!! +!! Can be driven with: +!! PERT(:) = 1D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_0, PERT, ADJ ) +!! ADJ_SAVE(:) = ADJ(:) +!! print*, 'do3: COST_FUNC_0 = ', COST_FUNC_0 +!! DO L = 1, 30 +!! PERT(:) = 1D0 +!! PERT(L) = 1.1 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_1, PERT, ADJ ) +!! PERT(L) = 0.9 +!! COST_FUNC = 0D0 +!! CALL CALC_TES_O3_FORCE_FD( COST_FUNC_2, PERT, ADJ ) +!! FD(L) = ( COST_FUNC_1 - COST_FUNC_2 ) / 0.2d0 +!! print*, 'do3: FD = ', FD(L), L +!! print*, 'do3: ADJ = ', ADJ_SAVE(L), L +!! print*, 'do3: COST = ', COST_FUNC, L +!! print*, 'do3: FD / ADJ ', FD(L) / ADJ_SAVE(L) , L +!! ENDDO +!! +!! +!! +!! +!! Arguments as Input/Output: +!! ============================================================================ +!! (1 ) COST_FUNC (REAL*8) : Cost funciton [unitless] +!! +!! +!! NOTES: +!! (1 ) Updated to GCv8 (dkh, 10/07/09) +!! (1 ) Add more diagnostics. Now read and write doubled O3 (dkh, 11/08/09) +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : N_CALC +! USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +! USE ADJ_ARRAYS_MOD, ONLY : O3_PROF_SAV +! USE CHECKPT_MOD, ONLY : CHK_STT +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE +! USE DAO_MOD, ONLY : AD +! USE DAO_MOD, ONLY : AIRDEN +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE GRID_MOD, ONLY : GET_IJ +! USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE +! USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : XNUMOLAIR +! USE TRACERID_MOD, ONLY : IDO3 +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP +! +! +!# include "CMN_SIZE" ! Size params +! +! ! Arguments +! REAL*8, INTENT(INOUT) :: COST_FUNC +! +! REAL*8, INTENT(IN) :: PERT(LLPAR) +! REAL*8, INTENT(OUT) :: ADJ(LLPAR) +! +! ! Local variables +! INTEGER :: NTSTART, NTSTOP, NT +! INTEGER :: IIJJ(2), I, J +! INTEGER :: L, LL, LTES +! INTEGER :: JLOOP +! REAL*8 :: GC_PRES(LLPAR) +! REAL*8 :: GC_O3_NATIVE(LLPAR) +! REAL*8 :: GC_O3(MAXLEV) +! REAL*8 :: GC_PSURF +! REAL*8 :: MAP(LLPAR,MAXLEV) +! REAL*8 :: O3_HAT(MAXLEV) +! REAL*8 :: O3_PERT(MAXLEV) +! REAL*8 :: FORCE(MAXLEV) +! REAL*8 :: DIFF(MAXLEV) +! REAL*8 :: NEW_COST(MAXTES) +! REAL*8 :: OLD_COST +! REAL*8, SAVE :: TIME_FRAC(MAXTES) +! INTEGER,SAVE :: NTES +! +! REAL*8 :: GC_O3_NATIVE_ADJ(LLPAR) +! REAL*8 :: O3_HAT_ADJ(MAXLEV) +! REAL*8 :: O3_PERT_ADJ(MAXLEV) +! REAL*8 :: GC_O3_ADJ(MAXLEV) +! REAL*8 :: DIFF_ADJ(MAXLEV) +! +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: IOS +! CHARACTER(LEN=255) :: FILENAME +! +! +! +! !================================================================= +! ! CALC_TES_O3_FORCE_FD begins here! +! !================================================================= +! +! print*, ' - CALC_TES_O3_FORCE_FD ' +! +! NEW_COST = 0D0 +! +! ! Open files for output +! IF ( FIRST ) THEN +! FILENAME = 'pres.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 101, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 102, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'tes_o3.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 103, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'apriori.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 104, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'diff.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 105, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'force.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 106, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'nt_ll.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 107, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'o3_pert_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 108, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 109, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'exp_o3_hat.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 110, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_press.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 111, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 112, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_on_tes.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 113, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! FILENAME = 'gc_o3_native_adj.NN.m' +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) +! OPEN( 114, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', +! & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) +! +! +! ENDIF +! +! ! Save a value of the cost function first +! OLD_COST = COST_FUNC +! +! ! Check if it is the last hour of a day +!! IF ( GET_NHMS() == 236000 - GET_TS_CHEM() * 100 ) THEN +! IF ( FIRST ) THEN +! +! ! Read the TES O3 file for this day +! CALL READ_TES_O3_OBS( GET_NYMD(), NTES ) +! +! ! TIME is YYYYMMDD.frac-of-day. Subtract date and save just time fraction +! TIME_FRAC(1:NTES) = TES(1:NTES)%TIME(1) - GET_NYMD() +! +! FIRST = .FALSE. +! ENDIF +! +!! ! Get the range of TES retrievals for the current hour +!! CALL GET_NT_RANGE( NTES, GET_NHMS(), TIME_FRAC, NTSTART, NTSTOP ) +!! +!! IF ( NTSTART == 0 .and. NTSTOP == 0 ) THEN +!! +!! print*, ' No matching TES O3 obs for this hour' +!! RETURN +!! ENDIF +!! +!! print*, ' for hour range: ', GET_NHMS(), TIME_FRAC(NTSTART), +!! & TIME_FRAC(NTSTOP) +!! print*, ' found record range: ', NTSTART, NTSTOP +! +! NTSTART = 1590 +! NTSTOP = 1590 +! +!! need to update this in order to do i/o with this loop parallel +!!! ! Now do a parallel loop for analyzing data +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( NT, MAP, LTES, IIJJ, I, J, L, LL, JLOOP ) +!!!$OMP+PRIVATE( GC_PRES, GC_PSURF, GC_O3, DIFF ) +!!!$OMP+PRIVATE( GC_O3_NATIVE, O3_PERT, O3_HAT, FORCE ) +!!!$OMP+PRIVATE( GC_O3_NATIVE_ADJ, GC_O3_ADJ ) +!!!$OMP+PRIVATE( O3_PERT_ADJ, O3_HAT_ADJ ) +!!!$OMP+PRIVATE( DIFF_ADJ ) +! DO NT = NTSTART, NTSTOP, -1 +! +! print*, ' - CALC_TES_O3_FORCE: analyzing record ', NT +! +! ! For safety, initialize these up to LLTES +! GC_O3(:) = 0d0 +! MAP(:,:) = 0d0 +! O3_HAT_ADJ(:) = 0d0 +! FORCE(:) = 0d0 +! +! +! ! Copy LTES to make coding a bit cleaner +! LTES = TES(NT)%LTES(1) +! +! ! Get grid box of current record +! IIJJ = GET_IJ( REAL(TES(NT)%LON(1),4), REAL(TES(NT)%LAT(1),4)) +! I = IIJJ(1) +! J = IIJJ(2) +! +! print*, 'I,J = ', I, J +! +! ! Get GC pressure levels (mbar) +! DO L = 1, LLPAR +! GC_PRES(L) = GET_PCENTER(I,J,L) +! ENDDO +! +! ! Get GC surface pressure (mbar) +! GC_PSURF = GET_PEDGE(I,J,1) +! +! +! ! Calculate the interpolation weight matrix +! MAP(1:LLPAR,1:LTES) +! & = GET_INTMAP( LLPAR, GC_PRES(:), GC_PSURF, +! & LTES, TES(NT)%PRES(1:LTES), GC_PSURF ) +! +! +! ! Get O3 values at native model resolution +! DO L = 1, LLPAR +! +! +! ! check if in trop +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! ! get O3 from tropospheric array +! IF ( JLOOP > 0 ) THEN +! GC_O3_NATIVE(L) = CSPEC(JLOOP,IDO3) * PERT(L) +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! ENDIF +! +! ELSE +! +! ! get O3 from climatology [#/cm2] +! GC_O3_NATIVE(L) = O3_PROF_SAV(I,J,L) / +! & ( BXHEIGHT(I,J,L) * 100d0 ) +! !GC_O3_NATIVE(L) = 1d0 +! +! ENDIF +! +! ! Convert from #/cm3 to v/v +! GC_O3_NATIVE(L) = GC_O3_NATIVE(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! ENDDO +! +! +! ! Interpolate GC O3 column to TES grid +! DO LL = 1, LTES +! GC_O3(LL) = 0d0 +! DO L = 1, LLPAR +! GC_O3(LL) = GC_O3(LL) +! & + MAP(L,LL) * GC_O3_NATIVE(L) +! ENDDO +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' GC_PRES, GC_native_O3 [ppb] ' +! WRITE(6,100) (GC_PRES(L), GC_O3_NATIVE(L)*1d9, +! & L = LLPAR, 1, -1 ) +! print*, ' TES_PRES, GC_O3 ' +! WRITE(6,100) (TES(NT)%PRES(LL), +! & GC_O3(LL)*1d9, LL = LTES, 1, -1 ) +! 100 FORMAT(1X,F16.8,1X,F16.8) +! +! +! !-------------------------------------------------------------- +! ! Apply TES observation operator +! ! +! ! x_hat = x_a + A_k ( x_m - x_a ) +! ! +! ! where +! ! x_hat = GC modeled column as seen by TES [lnvmr] +! ! x_a = TES apriori column [lnvmr] +! ! x_m = GC modeled column [lnvmr] +! ! A_k = TES averaging kernel +! !-------------------------------------------------------------- +! +! ! x_m - x_a +! DO L = 1, LTES +! GC_O3(L) = MAX(GC_O3(L), 1d-10) +! O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! ! x_a + A_k * ( x_m - x_a ) +! DO L = 1, LTES +! O3_HAT(L) = 0d0 +! DO LL = 1, LTES +! O3_HAT(L) = O3_HAT(L) +! & + TES(NT)%AVG_KERNEL(L,LL) * O3_PERT(LL) +! ENDDO +! O3_HAT(L) = O3_HAT(L) + LOG(TES(NT)%PRIOR(L)) +! ENDDO +! +! +! !-------------------------------------------------------------- +! ! Calculate cost function, given S is error on ln(vmr) +! ! J = 1/2 [ model - obs ]^T S_{obs}^{-1} [ ln(model - obs ] +! !-------------------------------------------------------------- +! +! ! Calculate difference between modeled and observed profile +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! DIFF(L) = O3_HAT(L) - LOG( TES(NT)%O3(L) ) +! ELSE +! DIFF(L) = 0d0 +! ENDIF +! ENDDO +! +! ! Calculate 1/2 * DIFF^T * S_{obs}^{-1} * DIFF +! DO L = 1, LTES +! FORCE(L) = 0d0 +! DO LL = 1, LTES +! FORCE(L) = FORCE(L) + TES(NT)%S_OER_INV(L,LL) * DIFF(LL) +! ENDDO +! NEW_COST(NT) = NEW_COST(NT) + 0.5d0 * DIFF(L) * FORCE(L) +! ENDDO +! +! ! dkh debug: compare profiles: +! print*, ' TES_PRIOR, O3_HAT, O3_TES [ppb]' +! WRITE(6,090) ( 1d9 * TES(NT)%PRIOR(L), +! & 1d9 * EXP(O3_HAT(L)), +! & 1d9 * TES(NT)%O3(L), +! & L, L = LTES, 1, -1 ) +! +! print*, ' TES_PRIOR, O3_HAT, O3_TES [lnvmr], diag(S^-1)' +! WRITE(6,101) ( LOG(TES(NT)%PRIOR(L)), O3_HAT(L), +! & LOG(TES(NT)%O3(L)), TES(NT)%S_OER_INV(L,L), +! & L, L = LTES, 1, -1 ) +! 090 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,i3) +! 101 FORMAT(1X,F16.8,1X,F16.8,1X,F16.8,1X,d14.6,1x,i3) +! +! !-------------------------------------------------------------- +! ! Begin adjoint calculations +! !-------------------------------------------------------------- +! +! ! dkh debug +! print*, 'DIFF , FORCE ' +! WRITE(6,102) (DIFF(L), FORCE(L), +! & L = LTES, 1, -1 ) +! 102 FORMAT(1X,d14.6,1X,d14.6) +! +! ! The adjoint forcing is S_{obs}^{-1} * DIFF = FORCE +! DIFF_ADJ(:) = FORCE(:) +! +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !print*, ' FORCE with 1 for sensitivity ' +! !ADJ_DIFF(:) = 1d0 +! !NEW_COST(NT) = ?? SUM(ABS(LOG(O3_HAT(1:LTES)))) +! !print*, ' sumlog =', SUM(ABS(LOG(O3_HAT(:)))) +! !print*, ' sumlog =', ABS(LOG(O3_HAT(:))) +! +! ! Adjoint of difference +! DO L = 1, LTES +! IF ( TES(NT)%O3(L) > 0d0 ) THEN +! O3_HAT_ADJ(L) = DIFF_ADJ(L) +! ENDIF +! ENDDO +! +! ! adjoint of TES operator +! DO L = 1, LTES +! O3_PERT_ADJ(L) = 0d0 +! DO LL = 1, LTES +! O3_PERT_ADJ(L) = O3_PERT_ADJ(L) +! & + TES(NT)%AVG_KERNEL(LL,L) +! & * O3_HAT_ADJ(LL) +! ENDDO +! ENDDO +! +! ! Adjoint of x_m - x_a +! DO L = 1, LTES +! ! fwd code: +! !GC_O3(L) = MAX(GC_O3(L), 1d-10) +! !O3_PERT(L) = LOG(GC_O3(L)) - LOG(TES(NT)%PRIOR(L)) +! ! adj code: +! IF ( GC_O3(L) > 1d-10 ) THEN +! GC_O3_ADJ(L) = 1d0 / GC_O3(L) * O3_PERT_ADJ(L) +! ELSE +! GC_O3_ADJ(L) = 1d0 / 1d-10 * O3_PERT_ADJ(L) +! ENDIF +! ENDDO +! +! ! dkh debug +! print*, 'O3_HAT_ADJ, O3_PERT_ADJ, GC_O3_ADJ' +! WRITE(6,103) (O3_HAT_ADJ(L), O3_PERT_ADJ(L), GC_O3_ADJ(L), +! & L = LTES, 1, -1 ) +! 103 FORMAT(1X,d14.6,1X,d14.6,1X,d14.6) +! +! ! adjoint of interpolation +! DO L = 1, LLPAR +! GC_O3_NATIVE_ADJ(L) = 0d0 +! DO LL = 1, LTES +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) +! & + MAP(L,LL) * GC_O3_ADJ(LL) +! ENDDO +! ENDDO +! +! WRITE(114,112) ( GC_O3_NATIVE_ADJ(L), L=LLPAR,1,-1) +! +! DO L = 1, LLPAR +! +! ! Adjoint of unit conversion +! GC_O3_NATIVE_ADJ(L) = GC_O3_NATIVE_ADJ(L) * 1d6 / +! & ( AIRDEN(L,I,J) * XNUMOLAIR ) +! +! +! IF ( ITS_IN_THE_TROP(I,J,L) ) THEN +! +! JLOOP = JLOP(I,J,L) +! +! IF ( JLOOP > 0 ) THEN +! +! ! Pass adjoint back to adjoint tracer array +! CSPEC_ADJ_FORCE(JLOOP,IDO3) = +! & CSPEC_ADJ_FORCE(JLOOP,IDO3) + GC_O3_NATIVE_ADJ(L) +! +! ADJ(L) = GC_O3_NATIVE_ADJ(L) * CSPEC(JLOOP,IDO3) +! +! ENDIF +! +! ENDIF +! +! ENDDO +! +! ! dkh debug +! print*, 'GC_O3_NATIVE_ADJ conv ' +! WRITE(6,104) (GC_O3_NATIVE_ADJ(L), L = LLPAR, 1, -1 ) +! 104 FORMAT(1X,d14.6) +! +! +! WRITE(101,110) ( TES(NT)%PRES(LL), LL=LTES,1,-1) +! WRITE(102,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! WRITE(103,110) ( 1d9 * TES(NT)%O3(LL), LL=LTES,1,-1) +! WRITE(104,110) ( 1d9 * TES(NT)%PRIOR(LL), LL=LTES,1,-1) +! WRITE(105,110) ( DIFF(LL), LL=LTES,1,-1) +! WRITE(106,112) ( FORCE(LL), LL=LTES,1,-1) +! WRITE(107,111) NT, LTES +! WRITE(108,112) ( O3_PERT_ADJ(LL), LL=LTES,1,-1) +! WRITE(109,112) ( GC_O3_ADJ(LL), LL=LTES,1,-1) +! WRITE(110,110) ( 1d9 * EXP(O3_HAT(LL)), LL=LTES,1,-1) +! WRITE(111,110) ( GC_PRES(L), L=LLPAR,1,-1) +! WRITE(112,110) ( 1d9 * GC_O3_NATIVE(L), L=LLPAR,1,-1) +! WRITE(113,110) ( 1d9 * GC_O3(LL), LL=LTES,1,-1) +! 110 FORMAT(F18.6,1X) +! 111 FORMAT(i4,1X,i4,1x) +! 112 FORMAT(D14.6,1X) +! +! +! ENDDO ! NT +!!!$OMP END PARALLEL DO +! +! ! Update cost function +! COST_FUNC = SUM(NEW_COST(NTSTOP:NTSTART)) +! +! print*, ' Updated value of COST_FUNC = ', COST_FUNC +! print*, ' TES contribution = ', COST_FUNC - OLD_COST +! +! ! Return to calling program +! END SUBROUTINE CALC_TES_O3_FORCE_FD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE GET_NT_RANGE( NTES, HHMMSS, TIME_FRAC, NTSTART, NTSTOP) +! +!****************************************************************************** +! Subroutine GET_NT_RANGE retuns the range of retrieval records for the +! current model hour +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTES (INTEGER) : Number of TES retrievals in this day +! (2 ) HHMMSS (INTEGER) : Current model time +! (3 ) TIME_FRAC (REAL) : Vector of times (frac-of-day) for the TES retrievals +! +! Arguments as Output: +! ============================================================================ +! (1 ) NTSTART (INTEGER) : TES record number at which to start +! (1 ) NTSTOP (INTEGER) : TES record number at which to stop +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : YMD_EXTRACT + + ! Arguments + INTEGER, INTENT(IN) :: NTES + INTEGER, INTENT(IN) :: HHMMSS + REAL*8, INTENT(IN) :: TIME_FRAC(NTES) + INTEGER, INTENT(OUT) :: NTSTART + INTEGER, INTENT(OUT) :: NTSTOP + + ! Local variables + INTEGER, SAVE :: NTSAVE + LOGICAL :: FOUND_ALL_RECORDS + INTEGER :: NTEST + INTEGER :: HH, MM, SS + REAL*8 :: GC_HH_FRAC + REAL*8 :: H1_FRAC + + !================================================================= + ! GET_NT_RANGE begins here! + !================================================================= + + + ! Initialize + FOUND_ALL_RECORDS = .FALSE. + NTSTART = 0 + NTSTOP = 0 + + ! set NTSAVE to NTES every time we start with a new file + IF ( HHMMSS == 230000 ) NTSAVE = NTES + + + !print*, ' GET_NT_RANGE for ', HHMMSS + !print*, ' NTSAVE ', NTSAVE + !print*, ' NTES ', NTES + + CALL YMD_EXTRACT( HHMMSS, HH, MM, SS ) + + + ! Convert HH from hour to fraction of day + GC_HH_FRAC = REAL(HH,8) / 24d0 + + ! one hour as a fraction of day + H1_FRAC = 1d0 / 24d0 + + + ! All records have been read already + IF ( NTSAVE == 0 ) THEN + + print*, 'All records have been read already ' + RETURN + + ! No records reached yet + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC < GC_HH_FRAC ) THEN + + + print*, 'No records reached yet' + RETURN + + ! + ELSEIF ( TIME_FRAC(NTSAVE) + H1_FRAC >= GC_HH_FRAC ) THEN + + ! Starting record found + NTSTART = NTSAVE + + !print*, ' Starting : TIME_FRAC(NTSTART) ', + & !TIME_FRAC(NTSTART), NTSTART + + ! Now search forward to find stopping record + NTEST = NTSTART + + DO WHILE ( FOUND_ALL_RECORDS == .FALSE. ) + + ! Advance to the next record + NTEST = NTEST - 1 + + ! Stop if we reach the earliest available record + IF ( NTEST == 0 ) THEN + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ! When the combined test date rounded up to the nearest + ! half hour is smaller than the current model date, the + ! stopping record has been passed. + ELSEIF ( TIME_FRAC(NTEST) + H1_FRAC < GC_HH_FRAC ) THEN + + !print*, ' Testing : TIME_FRAC ', + & !TIME_FRAC(NTEST), NTEST + + NTSTOP = NTEST + 1 + FOUND_ALL_RECORDS = .TRUE. + + print*, ' Records found ' + print*, ' NTSTART, NTSTOP = ', NTSTART, NTSTOP + + ! Reset NTSAVE + NTSAVE = NTEST + + ELSE + !print*, ' still looking ', NTEST + + ENDIF + + ENDDO + + ELSE + + CALL ERROR_STOP('problem', 'GET_NT_RANGE' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_NT_RANGE + +!------------------------------------------------------------------------------ + + FUNCTION GET_INTMAP( LGC_TOP, GC_PRESC, GC_SURFP, + & LTM_TOP, TM_PRESC, TM_SURFP ) + * RESULT ( HINTERPZ ) +! +!****************************************************************************** +! Function GET_INTMAP linearly interpolates column quatities +! based upon the centered (average) pressue levels. +! +! Arguments as Input: +! ============================================================================ +! (1 ) LGC_TOP (TYPE) : Description [unit] +! (2 ) GC_PRES (TYPE) : Description [unit] +! (3 ) GC_SURFP(TYPE) : Description [unit] +! (4 ) LTM_TOP (TYPE) : Description [unit] +! (5 ) TM_PRES (TYPE) : Description [unit] +! (6 ) TM_SURFP(TYPE) : Description [unit] +! +! Arguments as Output: +! ============================================================================ +! (1 ) HINTERPZ (TYPE) : Description [unit] +! +! NOTES: +! (1 ) Based on the GET_HINTERPZ_2 routine I wrote for read_sciano2_mod. +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_BP + + ! Arguments + INTEGER :: LGC_TOP, LTM_TOP + REAL*8 :: GC_PRESC(LGC_TOP) + REAL*8 :: TM_PRESC(LTM_TOP) + REAL*8 :: GC_SURFP + REAL*8 :: TM_SURFP + + ! Return value + REAL*8 :: HINTERPZ(LGC_TOP, LTM_TOP) + + ! Local variables + INTEGER :: LGC, LTM + REAL*8 :: DIFF, DELTA_SURFP + REAL*8 :: LOW, HI + + !================================================================= + ! GET_HINTERPZ_2 begins here! + !================================================================= + + HINTERPZ(:,:) = 0D0 + +! ! Rescale GC grid according to TM surface pressure +!! p1_A = (a1 + b1 (ps_A - PTOP)) +!! p2_A = (a2 + b2 (ps_A - PTOP)) +!! p1_B = (a + b (ps_B - PTOP)) +!! p2_B = *(a + b (ps_B - PTOP)) +!! pc_A = 0.5(a1+a2 +(b1+b2)*(ps_A - PTOP)) +!! pc_B = 0.5(a1+a2 +(b1+b2)*(ps_B - PTOP)) +!! pc_B - pc_A = 0.5(b1_b2)(ps_B-ps_A) +!! pc_B = 0.5(b1_b2)(ps_B-ps_A) + pc_A +! DELTA_SURFP = 0.5d0 * ( TM_SURFP -GC_SURFP ) +! +! DO LGC = 1, LGC_TOP +! GC_PRESC(LGC) = ( GET_BP(LGC) + GET_BP(LGC+1)) +! & * DELTA_SURFP + GC_PRESC(LGC) +! IF (GC_PRESC(LGC) < 0) THEN +! CALL ERROR_STOP( 'highly unlikey', +! & 'read_sciano2_mod.f') +! ENDIF +! +! ENDDO + + + ! Loop over each pressure level of TM grid + DO LTM = 1, LTM_TOP + + ! Find the levels from GC that bracket level LTM + DO LGC = 1, LGC_TOP - 1 + + LOW = GC_PRESC(LGC+1) + HI = GC_PRESC(LGC) + IF (LGC == 0) HI = TM_SURFP + + ! Linearly interpolate value on the LTM grid + IF ( TM_PRESC(LTM) <= HI .and. + & TM_PRESC(LTM) > LOW) THEN + + DIFF = HI - LOW + HINTERPZ(LGC+1,LTM) = ( HI - TM_PRESC(LTM) ) / DIFF + HINTERPZ(LGC ,LTM) = ( TM_PRESC(LTM) - LOW ) / DIFF + + + ENDIF + + ! dkh debug + !print*, 'LGC,LTM,HINT', LGC, LTM, HINTERPZ(LGC,LTM) + + ENDDO + ENDDO + + ! Correct for case where TES pressure is higher than the + ! highest GC pressure. In this case, just 1:1 map. + DO LTM = 1, LTM_TOP + IF ( TM_PRESC(LTM) > GC_PRESC(1) ) THEN + HINTERPZ(:,LTM) = 0D0 + HINTERPZ(LTM,LTM) = 1D0 + ENDIF + ENDDO + + ! Return to calling program + END FUNCTION GET_INTMAP + +!!------------------------------------------------------------------------------ +! SUBROUTINE MAKE_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_O3_FILE saves O3 profiles that correspond to time and +!! place of TES O3 obs. (dkh, 03/01/09) +!! +!! Module variables as Input: +!! ============================================================================ +!! (1 ) O3_SAVE (REAL*8) : O3 profiles [ppmv] +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE +! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J, I0, J0, L, NT +! CHARACTER(LEN=120) :: FILENAME +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! INTEGER, PARAMETER :: IUN = 88 +! +! ! For binary punch file, version 2.0 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! !================================================================= +! ! MAKE_O3_FILE begins here! +! !================================================================= +! +! FILENAME = TRIM( 'nh3.bpch' ) +! +! ! Append data directory prefix +! FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'O3 profile ' +! CATEGORY = 'IJ-AVE-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! UNIT = 'ppmv' +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the checkpoint file for output -- binary punch format +! !================================================================= +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_O3_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IUN, FILENAME, TITLE ) +! +! ! Temporarily store data in DAT as REAL4 +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( NT ) +! DO NT = 1, MAXTES +! +! DAT(1,:,NT) = REAL(O3_SAVE(:,NT)) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IUN, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, 1d0, 1d0, RESERVED, +! & 1, LLPAR, MAXTES, I0+1, +! & J0+1, 1, DAT ) +! +! ! Close file +! CLOSE( IUN ) +! +! print*, ' O3_SAVE sum write = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE MAKE_O3_FILE +! +!!------------------------------------------------------------------------------ +! SUBROUTINE READ_O3_FILE( ) +!! +!!****************************************************************************** +!! Subroutine READ_O3_FILE reads the GC modeled O3 profiles that correspond +!! to the TES O3 times and locations. (dkh, 03/01/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! REAL*4 :: DAT(1,LLPAR,MAXTES) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( ADJTMP_DIR ) // +! & 'nh3.bpch' +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_O3_FILE: Reading ', a ) +! +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'IJ-AVE-$', 1, +! & 1d0, 1, LLPAR, +! & MAXTES, DAT, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! O3_SAVE(:,:) = DAT(1,:,:) +! +! print*, ' O3_SAVE sum read = ', SUM(O3_SAVE(:,:)) +! +! ! Return to calling program +! END SUBROUTINE READ_O3_FILE +! +!!----------------------------------------------------------------------------- +! FUNCTION GET_DOUBLED_O3( NYMD, NHMS, LON, LAT ) RESULT( O3_DBL ) +!! +!!****************************************************************************** +!! Subroutine GET_DOUBLED_O3 reads and returns the nh3 profiles from +!! model run with doubled emissions. (dkh, 11/08/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TIME_MOD, ONLY : GET_TAU +! +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER :: NYMD, NHMS +! REAL*4 :: LON, LAT +! +! ! Function arg +! REAL*8 :: O3_DBL(LLPAR) +! +! ! Local variables +! REAL*4 :: DAT(144,91,20) +! CHARACTER(LEN=255) :: FILENAME +! INTEGER :: IIJJ(2) +! +! !================================================================= +! ! GET_DOUBLED_O3 begins here! +! !================================================================= +! +! ! filename +! FILENAME = 'nh3.YYYYMMDD.hhmm' +! +! ! Expand filename +! CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) +! +! ! Full path to file +! FILENAME = TRIM( DATA_DIR ) // +! & 'doubled_nh3/' // +! & TRIM( FILENAME ) // +! & TRIM( '00' ) +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - GET_DOUBLED_O3: Reading ', a ) +! +! ! dkh debug +! print*, ' GET_TAU() = ', GET_TAU() +! +! ! Get data +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 29, +! & GET_TAU(), 144, 91, +! & 20, DAT, QUIET=.FALSE. ) +! +! IIJJ = GET_IJ_2x25( LON, LAT ) +! +! print*, ' found doubled in I/J = ', IIJJ +! +! ! just the column for the present location, and convert ppb to ppm +! O3_DBL(1:20) = REAL(DAT(IIJJ(1),IIJJ(2),:),8) / 1000d0 +! O3_DBL(21:LLPAR) = 0d0 +! +! print*, ' O3_DBL = ', O3_DBL +! +! ! Return to calling program +! END FUNCTION GET_DOUBLED_O3 +! +!!------------------------------------------------------------------------------ + FUNCTION GET_IJ_2x25( LON, LAT ) RESULT ( IIJJ ) + +! +!****************************************************************************** +! Subroutine GET_IJ_2x25 returns I and J index from the 2 x 2.5 grid for a +! LON, LAT coord. (dkh, 11/08/09) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) LON (REAL*8) : Longitude [degrees] +! (2 ) LAT (REAL*8) : Latitude [degrees] +! +! Function result +! ============================================================================ +! (1 ) IIJJ(1) (INTEGER) : Long index [none] +! (2 ) IIJJ(2) (INTEGER) : Lati index [none] +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + REAL*4 :: LAT, LON + + ! Return + INTEGER :: I, J, IIJJ(2) + + ! Local variables + REAL*8 :: TLON, TLAT, DLON, DLAT + REAL*8, PARAMETER :: DISIZE = 2.5d0 + REAL*8, PARAMETER :: DJSIZE = 2.0d0 + INTEGER, PARAMETER :: IIMAX = 144 + INTEGER, PARAMETER :: JJMAX = 91 + + + !================================================================= + ! GET_IJ_2x25 begins here! + !================================================================= + + TLON = 180d0 + LON + DISIZE + TLAT = 90d0 + LAT + DJSIZE + + I = TLON / DISIZE + J = TLAT / DJSIZE + + + IF ( TLON / DISIZE - REAL(I) >= 0.5d0 ) THEN + I = I + 1 + ENDIF + + IF ( TLAT / DJSIZE - REAL(J) >= 0.5d0 ) THEN + J = J + 1 + ENDIF + + + ! Longitude wraps around + !IF ( I == 73 ) I = 1 + IF ( I == ( IIMAX + 1 ) ) I = 1 + + ! Check for impossible values + IF ( I > IIMAX .or. J > JJMAX .or. + & I < 1 .or. J < 1 ) THEN + CALL ERROR_STOP('Error finding grid box', 'GET_IJ_2x25') + ENDIF + + IIJJ(1) = I + IIJJ(2) = J + + ! Return to calling program + END FUNCTION GET_IJ_2x25 + +!!----------------------------------------------------------------------------- +! SUBROUTINE INIT_TES_O3 +!! +!!***************************************************************************** +!! Subroutine INIT_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! IIPAR, JJPAR +! +! ! Local variables +! INTEGER :: AS +! +! !================================================================= +! ! INIT_TES_O3 begins here +! !================================================================= +! +! ! dkh debug +! print*, ' INIT_TES_O3' +! +! ALLOCATE( O3_SAVE( LLPAR, MAXTES ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_SAVE' ) +! O3_SAVE = 0d0 +! +! +! TES( 1 )%NYMD = 20050704 +! TES( 2 )%NYMD = 20050704 +! TES( 3 )%NYMD = 20050704 +! TES( 4 )%NYMD = 20050704 +! TES( 5 )%NYMD = 20050704 +! TES( 6 )%NYMD = 20050704 +! TES( 7 )%NYMD = 20050704 +! TES( 8 )%NYMD = 20050704 +! TES( 9 )%NYMD = 20050705 +! TES( 10 )%NYMD = 20050705 +! TES( 11 )%NYMD = 20050705 +! TES( 12 )%NYMD = 20050705 +! TES( 13 )%NYMD = 20050705 +! TES( 14 )%NYMD = 20050705 +! TES( 15 )%NYMD = 20050705 +! TES( 16 )%NYMD = 20050705 +! TES( 17 )%NYMD = 20050705 +! TES( 18 )%NYMD = 20050710 +! TES( 19 )%NYMD = 20050710 +! TES( 20 )%NYMD = 20050710 +! TES( 21 )%NYMD = 20050710 +! TES( 22 )%NYMD = 20050710 +! TES( 23 )%NYMD = 20050710 +! TES( 24 )%NYMD = 20050710 +! TES( 25 )%NYMD = 20050710 +! TES( 26 )%NYMD = 20050710 +! TES( 27 )%NYMD = 20050711 +! TES( 28 )%NYMD = 20050711 +! TES( 29 )%NYMD = 20050711 +! TES( 30 )%NYMD = 20050711 +! TES( 31 )%NYMD = 20050712 +! TES( 32 )%NYMD = 20050712 +! TES( 33 )%NYMD = 20050712 +! TES( 34 )%NYMD = 20050712 +! TES( 35 )%NYMD = 20050712 +! TES( 36 )%NYMD = 20050712 +! TES( 37 )%NYMD = 20050712 +! TES( 38 )%NYMD = 20050712 +! TES( 39 )%NYMD = 20050713 +! TES( 40 )%NYMD = 20050713 +! TES( 41 )%NYMD = 20050713 +! TES( 42 )%NYMD = 20050713 +! TES( 43 )%NYMD = 20050713 +! TES( 44 )%NYMD = 20050713 +! TES( 45 )%NYMD = 20050713 +! TES( 46 )%NYMD = 20050713 +! TES( 47 )%NYMD = 20050713 +! TES( 48 )%NYMD = 20050714 +! TES( 49 )%NYMD = 20050714 +! TES( 50 )%NYMD = 20050714 +! TES( 51 )%NYMD = 20050714 +! TES( 52 )%NYMD = 20050714 +! TES( 53 )%NYMD = 20050714 +! TES( 54 )%NYMD = 20050714 +! TES( 55 )%NYMD = 20050714 +! TES( 56 )%NYMD = 20050715 +! TES( 57 )%NYMD = 20050715 +! TES( 58 )%NYMD = 20050715 +! TES( 59 )%NYMD = 20050715 +! TES( 60 )%NYMD = 20050715 +! TES( 61 )%NYMD = 20050715 +! TES( 62 )%NYMD = 20050715 +! TES( 63 )%NYMD = 20050715 +! TES( 64 )%NYMD = 20050715 +! TES( 65 )%NYMD = 20050716 +! TES( 66 )%NYMD = 20050717 +! TES( 67 )%NYMD = 20050717 +! TES( 68 )%NYMD = 20050717 +! TES( 69 )%NYMD = 20050717 +! TES( 70 )%NYMD = 20050717 +! TES( 71 )%NYMD = 20050717 +! TES( 72 )%NYMD = 20050717 +! TES( 73 )%NYMD = 20050717 +! TES( 74 )%NYMD = 20050717 +! TES( 75 )%NYMD = 20050718 +! TES( 76 )%NYMD = 20050718 +! TES( 77 )%NYMD = 20050718 +! TES( 78 )%NYMD = 20050718 +! TES( 79 )%NYMD = 20050719 +! TES( 80 )%NYMD = 20050719 +! TES( 81 )%NYMD = 20050719 +! TES( 82 )%NYMD = 20050719 +! TES( 83 )%NYMD = 20050719 +! TES( 84 )%NYMD = 20050719 +! TES( 85 )%NYMD = 20050719 +! TES( 86 )%NYMD = 20050719 +! TES( 87 )%NYMD = 20050719 +! +! TES( 1 )%NHMS = 202000 +! TES( 2 )%NHMS = 202100 +! TES( 3 )%NHMS = 202100 +! TES( 4 )%NHMS = 202100 +! TES( 5 )%NHMS = 202200 +! TES( 6 )%NHMS = 202300 +! TES( 7 )%NHMS = 202300 +! TES( 8 )%NHMS = 202400 +! TES( 9 )%NHMS = 082100 +! TES( 10 )%NHMS = 082100 +! TES( 11 )%NHMS = 082200 +! TES( 12 )%NHMS = 082200 +! TES( 13 )%NHMS = 082300 +! TES( 14 )%NHMS = 082300 +! TES( 15 )%NHMS = 082400 +! TES( 16 )%NHMS = 082400 +! TES( 17 )%NHMS = 082500 +! TES( 18 )%NHMS = 194300 +! TES( 19 )%NHMS = 194300 +! TES( 20 )%NHMS = 194400 +! TES( 21 )%NHMS = 194400 +! TES( 22 )%NHMS = 194500 +! TES( 23 )%NHMS = 194500 +! TES( 24 )%NHMS = 194600 +! TES( 25 )%NHMS = 194600 +! TES( 26 )%NHMS = 194700 +! TES( 27 )%NHMS = 092300 +! TES( 28 )%NHMS = 092300 +! TES( 29 )%NHMS = 092400 +! TES( 30 )%NHMS = 092400 +! TES( 31 )%NHMS = 193000 +! TES( 32 )%NHMS = 193100 +! TES( 33 )%NHMS = 193100 +! TES( 34 )%NHMS = 193200 +! TES( 35 )%NHMS = 193300 +! TES( 36 )%NHMS = 193300 +! TES( 37 )%NHMS = 193400 +! TES( 38 )%NHMS = 193400 +! TES( 39 )%NHMS = 091000 +! TES( 40 )%NHMS = 091100 +! TES( 41 )%NHMS = 091100 +! TES( 42 )%NHMS = 091200 +! TES( 43 )%NHMS = 091200 +! TES( 44 )%NHMS = 091200 +! TES( 45 )%NHMS = 091300 +! TES( 46 )%NHMS = 091300 +! TES( 47 )%NHMS = 091400 +! TES( 48 )%NHMS = 191900 +! TES( 49 )%NHMS = 191900 +! TES( 50 )%NHMS = 191900 +! TES( 51 )%NHMS = 192000 +! TES( 52 )%NHMS = 192000 +! TES( 53 )%NHMS = 192100 +! TES( 54 )%NHMS = 192100 +! TES( 55 )%NHMS = 192200 +! TES( 56 )%NHMS = 085800 +! TES( 57 )%NHMS = 085800 +! TES( 58 )%NHMS = 085900 +! TES( 59 )%NHMS = 085900 +! TES( 60 )%NHMS = 090000 +! TES( 61 )%NHMS = 090000 +! TES( 62 )%NHMS = 090100 +! TES( 63 )%NHMS = 090100 +! TES( 64 )%NHMS = 090100 +! TES( 65 )%NHMS = 190900 +! TES( 66 )%NHMS = 084500 +! TES( 67 )%NHMS = 084600 +! TES( 68 )%NHMS = 084600 +! TES( 69 )%NHMS = 084700 +! TES( 70 )%NHMS = 084700 +! TES( 71 )%NHMS = 084800 +! TES( 72 )%NHMS = 084800 +! TES( 73 )%NHMS = 084900 +! TES( 74 )%NHMS = 084900 +! TES( 75 )%NHMS = 203200 +! TES( 76 )%NHMS = 203300 +! TES( 77 )%NHMS = 203300 +! TES( 78 )%NHMS = 203400 +! TES( 79 )%NHMS = 083300 +! TES( 80 )%NHMS = 083400 +! TES( 81 )%NHMS = 083400 +! TES( 82 )%NHMS = 083500 +! TES( 83 )%NHMS = 083500 +! TES( 84 )%NHMS = 083500 +! TES( 85 )%NHMS = 083600 +! TES( 86 )%NHMS = 083600 +! TES( 87 )%NHMS = 083700 +! +! TES( 1 )%LAT = 31.29 +! TES( 2 )%LAT = 33 +! TES( 3 )%LAT = 34.64 +! TES( 4 )%LAT = 36.2 +! TES( 5 )%LAT = 37.91 +! TES( 6 )%LAT = 41.1 +! TES( 7 )%LAT = 42.8 +! TES( 8 )%LAT = 44.43 +! TES( 9 )%LAT = 43.54 +! TES( 10 )%LAT = 41.84 +! TES( 11 )%LAT = 40.2 +! TES( 12 )%LAT = 38.65 +! TES( 13 )%LAT = 36.94 +! TES( 14 )%LAT = 35.3 +! TES( 15 )%LAT = 33.74 +! TES( 16 )%LAT = 32.03 +! TES( 17 )%LAT = 30.39 +! TES( 18 )%LAT = 31.28 +! TES( 19 )%LAT = 32.99 +! TES( 20 )%LAT = 34.63 +! TES( 21 )%LAT = 36.19 +! TES( 22 )%LAT = 37.9 +! TES( 23 )%LAT = 39.53 +! TES( 24 )%LAT = 41.09 +! TES( 25 )%LAT = 42.8 +! TES( 26 )%LAT = 44.42 +! TES( 27 )%LAT = 43.55 +! TES( 28 )%LAT = 41.85 +! TES( 29 )%LAT = 40.22 +! TES( 30 )%LAT = 38.66 +! TES( 31 )%LAT = 31.28 +! TES( 32 )%LAT = 32.99 +! TES( 33 )%LAT = 34.63 +! TES( 34 )%LAT = 36.19 +! TES( 35 )%LAT = 39.53 +! TES( 36 )%LAT = 41.09 +! TES( 37 )%LAT = 42.79 +! TES( 38 )%LAT = 44.42 +! TES( 39 )%LAT = 43.55 +! TES( 40 )%LAT = 41.85 +! TES( 41 )%LAT = 40.22 +! TES( 42 )%LAT = 38.66 +! TES( 43 )%LAT = 36.96 +! TES( 44 )%LAT = 35.32 +! TES( 45 )%LAT = 33.76 +! TES( 46 )%LAT = 32.04 +! TES( 47 )%LAT = 30.4 +! TES( 48 )%LAT = 32.99 +! TES( 49 )%LAT = 34.63 +! TES( 50 )%LAT = 36.2 +! TES( 51 )%LAT = 37.9 +! TES( 52 )%LAT = 39.54 +! TES( 53 )%LAT = 41.1 +! TES( 54 )%LAT = 42.8 +! TES( 55 )%LAT = 44.42 +! TES( 56 )%LAT = 43.55 +! TES( 57 )%LAT = 41.85 +! TES( 58 )%LAT = 40.22 +! TES( 59 )%LAT = 38.66 +! TES( 60 )%LAT = 36.95 +! TES( 61 )%LAT = 35.31 +! TES( 62 )%LAT = 33.75 +! TES( 63 )%LAT = 32.04 +! TES( 64 )%LAT = 30.4 +! TES( 65 )%LAT = 44.4 +! TES( 66 )%LAT = 43.59 +! TES( 67 )%LAT = 41.89 +! TES( 68 )%LAT = 40.26 +! TES( 69 )%LAT = 38.7 +! TES( 70 )%LAT = 37 +! TES( 71 )%LAT = 35.36 +! TES( 72 )%LAT = 33.8 +! TES( 73 )%LAT = 32.09 +! TES( 74 )%LAT = 30.45 +! TES( 75 )%LAT = 31.27 +! TES( 76 )%LAT = 32.98 +! TES( 77 )%LAT = 34.62 +! TES( 78 )%LAT = 36.18 +! TES( 79 )%LAT = 43.58 +! TES( 80 )%LAT = 41.88 +! TES( 81 )%LAT = 40.25 +! TES( 82 )%LAT = 38.69 +! TES( 83 )%LAT = 36.98 +! TES( 84 )%LAT = 35.34 +! TES( 85 )%LAT = 33.78 +! TES( 86 )%LAT = 32.07 +! TES( 87 )%LAT = 30.43 +! +! TES( 1 )%LON = -105.13 +! TES( 2 )%LON = -105.6 +! TES( 3 )%LON = -106.05 +! TES( 4 )%LON = -106.5 +! TES( 5 )%LON = -107 +! TES( 6 )%LON = -108 +! TES( 7 )%LON = -108.57 +! TES( 8 )%LON = -109.13 +! TES( 9 )%LON = -92.52 +! TES( 10 )%LON = -93.09 +! TES( 11 )%LON = -93.62 +! TES( 12 )%LON = -94.11 +! TES( 13 )%LON = -94.62 +! TES( 14 )%LON = -95.09 +! TES( 15 )%LON = -95.53 +! TES( 16 )%LON = -96 +! TES( 17 )%LON = -96.44 +! TES( 18 )%LON = -95.84 +! TES( 19 )%LON = -96.3 +! TES( 20 )%LON = -96.76 +! TES( 21 )%LON = -97.2 +! TES( 22 )%LON = -97.71 +! TES( 23 )%LON = -98.21 +! TES( 24 )%LON = -98.71 +! TES( 25 )%LON = -99.27 +! TES( 26 )%LON = -99.83 +! TES( 27 )%LON = -107.94 +! TES( 28 )%LON = -108.51 +! TES( 29 )%LON = -109.04 +! TES( 30 )%LON = -109.53 +! TES( 31 )%LON = -92.74 +! TES( 32 )%LON = -93.2 +! TES( 33 )%LON = -93.66 +! TES( 34 )%LON = -94.11 +! TES( 35 )%LON = -95.11 +! TES( 36 )%LON = -95.61 +! TES( 37 )%LON = -96.17 +! TES( 38 )%LON = -96.73 +! TES( 39 )%LON = -104.84 +! TES( 40 )%LON = -105.41 +! TES( 41 )%LON = -105.94 +! TES( 42 )%LON = -106.43 +! TES( 43 )%LON = -106.94 +! TES( 44 )%LON = -107.42 +! TES( 45 )%LON = -107.86 +! TES( 46 )%LON = -108.33 +! TES( 47 )%LON = -108.76 +! TES( 48 )%LON = -90.1 +! TES( 49 )%LON = -90.56 +! TES( 50 )%LON = -91.01 +! TES( 51 )%LON = -91.51 +! TES( 52 )%LON = -92.01 +! TES( 53 )%LON = -92.51 +! TES( 54 )%LON = -93.07 +! TES( 55 )%LON = -93.64 +! TES( 56 )%LON = -101.74 +! TES( 57 )%LON = -102.32 +! TES( 58 )%LON = -102.84 +! TES( 59 )%LON = -103.33 +! TES( 60 )%LON = -103.84 +! TES( 61 )%LON = -104.32 +! TES( 62 )%LON = -104.76 +! TES( 63 )%LON = -105.23 +! TES( 64 )%LON = -105.67 +! TES( 65 )%LON = -90.54 +! TES( 66 )%LON = -98.64 +! TES( 67 )%LON = -99.22 +! TES( 68 )%LON = -99.75 +! TES( 69 )%LON = -100.23 +! TES( 70 )%LON = -100.75 +! TES( 71 )%LON = -101.22 +! TES( 72 )%LON = -101.67 +! TES( 73 )%LON = -102.13 +! TES( 74 )%LON = -102.57 +! TES( 75 )%LON = -108.19 +! TES( 76 )%LON = -108.65 +! TES( 77 )%LON = -109.11 +! TES( 78 )%LON = -109.55 +! TES( 79 )%LON = -95.57 +! TES( 80 )%LON = -96.14 +! TES( 81 )%LON = -96.67 +! TES( 82 )%LON = -97.16 +! TES( 83 )%LON = -97.67 +! TES( 84 )%LON = -98.15 +! TES( 85 )%LON = -98.59 +! TES( 86 )%LON = -99.06 +! TES( 87 )%LON = -99.49 +! +! TES( 1 )%FILENAME = TRIM('retv_vars.02945_0457_002.cdf') +! TES( 2 )%FILENAME = TRIM('retv_vars.02945_0457_003.cdf') +! TES( 3 )%FILENAME = TRIM('retv_vars.02945_0457_004.cdf') +! TES( 4 )%FILENAME = TRIM('retv_vars.02945_0458_002.cdf') +! TES( 5 )%FILENAME = TRIM('retv_vars.02945_0458_003.cdf') +! TES( 6 )%FILENAME = TRIM('retv_vars.02945_0459_002.cdf') +! TES( 7 )%FILENAME = TRIM('retv_vars.02945_0459_003.cdf') +! TES( 8 )%FILENAME = TRIM('retv_vars.02945_0459_004.cdf') +! TES( 9 )%FILENAME = TRIM('retv_vars.02945_0982_002.cdf') +! TES( 10 )%FILENAME = TRIM('retv_vars.02945_0982_003.cdf') +! TES( 11 )%FILENAME = TRIM('retv_vars.02945_0982_004.cdf') +! TES( 12 )%FILENAME = TRIM('retv_vars.02945_0983_002.cdf') +! TES( 13 )%FILENAME = TRIM('retv_vars.02945_0983_003.cdf') +! TES( 14 )%FILENAME = TRIM('retv_vars.02945_0983_004.cdf') +! TES( 15 )%FILENAME = TRIM('retv_vars.02945_0984_002.cdf') +! TES( 16 )%FILENAME = TRIM('retv_vars.02945_0984_003.cdf') +! TES( 17 )%FILENAME = TRIM('retv_vars.02945_0984_004.cdf') +! TES( 18 )%FILENAME = TRIM('retv_vars.02956_0457_002.cdf') +! TES( 19 )%FILENAME = TRIM('retv_vars.02956_0457_003.cdf') +! TES( 20 )%FILENAME = TRIM('retv_vars.02956_0457_004.cdf') +! TES( 21 )%FILENAME = TRIM('retv_vars.02956_0458_002.cdf') +! TES( 22 )%FILENAME = TRIM('retv_vars.02956_0458_003.cdf') +! TES( 23 )%FILENAME = TRIM('retv_vars.02956_0458_004.cdf') +! TES( 24 )%FILENAME = TRIM('retv_vars.02956_0459_002.cdf') +! TES( 25 )%FILENAME = TRIM('retv_vars.02956_0459_003.cdf') +! TES( 26 )%FILENAME = TRIM('retv_vars.02956_0459_004.cdf') +! TES( 27 )%FILENAME = TRIM('retv_vars.02956_1054_002.cdf') +! TES( 28 )%FILENAME = TRIM('retv_vars.02956_1054_003.cdf') +! TES( 29 )%FILENAME = TRIM('retv_vars.02956_1054_004.cdf') +! TES( 30 )%FILENAME = TRIM('retv_vars.02956_1055_002.cdf') +! TES( 31 )%FILENAME = TRIM('retv_vars.02960_0457_002.cdf') +! TES( 32 )%FILENAME = TRIM('retv_vars.02960_0457_003.cdf') +! TES( 33 )%FILENAME = TRIM('retv_vars.02960_0457_004.cdf') +! TES( 34 )%FILENAME = TRIM('retv_vars.02960_0458_002.cdf') +! TES( 35 )%FILENAME = TRIM('retv_vars.02960_0458_004.cdf') +! TES( 36 )%FILENAME = TRIM('retv_vars.02960_0459_002.cdf') +! TES( 37 )%FILENAME = TRIM('retv_vars.02960_0459_003.cdf') +! TES( 38 )%FILENAME = TRIM('retv_vars.02960_0459_004.cdf') +! TES( 39 )%FILENAME = TRIM('retv_vars.02960_1054_002.cdf') +! TES( 40 )%FILENAME = TRIM('retv_vars.02960_1054_003.cdf') +! TES( 41 )%FILENAME = TRIM('retv_vars.02960_1054_004.cdf') +! TES( 42 )%FILENAME = TRIM('retv_vars.02960_1055_002.cdf') +! TES( 43 )%FILENAME = TRIM('retv_vars.02960_1055_003.cdf') +! TES( 44 )%FILENAME = TRIM('retv_vars.02960_1055_004.cdf') +! TES( 45 )%FILENAME = TRIM('retv_vars.02960_1056_002.cdf') +! TES( 46 )%FILENAME = TRIM('retv_vars.02960_1056_003.cdf') +! TES( 47 )%FILENAME = TRIM('retv_vars.02960_1056_004.cdf') +! TES( 48 )%FILENAME = TRIM('retv_vars.02963_0457_003.cdf') +! TES( 49 )%FILENAME = TRIM('retv_vars.02963_0457_004.cdf') +! TES( 50 )%FILENAME = TRIM('retv_vars.02963_0458_002.cdf') +! TES( 51 )%FILENAME = TRIM('retv_vars.02963_0458_003.cdf') +! TES( 52 )%FILENAME = TRIM('retv_vars.02963_0458_004.cdf') +! TES( 53 )%FILENAME = TRIM('retv_vars.02963_0459_002.cdf') +! TES( 54 )%FILENAME = TRIM('retv_vars.02963_0459_003.cdf') +! TES( 55 )%FILENAME = TRIM('retv_vars.02963_0459_004.cdf') +! TES( 56 )%FILENAME = TRIM('retv_vars.02963_1054_002.cdf') +! TES( 57 )%FILENAME = TRIM('retv_vars.02963_1054_003.cdf') +! TES( 58 )%FILENAME = TRIM('retv_vars.02963_1054_004.cdf') +! TES( 59 )%FILENAME = TRIM('retv_vars.02963_1055_002.cdf') +! TES( 60 )%FILENAME = TRIM('retv_vars.02963_1055_003.cdf') +! TES( 61 )%FILENAME = TRIM('retv_vars.02963_1055_004.cdf') +! TES( 62 )%FILENAME = TRIM('retv_vars.02963_1056_002.cdf') +! TES( 63 )%FILENAME = TRIM('retv_vars.02963_1056_003.cdf') +! TES( 64 )%FILENAME = TRIM('retv_vars.02963_1056_004.cdf') +! TES( 65 )%FILENAME = TRIM('retv_vars.02967_0459_004.cdf') +! TES( 66 )%FILENAME = TRIM('retv_vars.02967_1054_002.cdf') +! TES( 67 )%FILENAME = TRIM('retv_vars.02967_1054_003.cdf') +! TES( 68 )%FILENAME = TRIM('retv_vars.02967_1054_004.cdf') +! TES( 69 )%FILENAME = TRIM('retv_vars.02967_1055_002.cdf') +! TES( 70 )%FILENAME = TRIM('retv_vars.02967_1055_003.cdf') +! TES( 71 )%FILENAME = TRIM('retv_vars.02967_1055_004.cdf') +! TES( 72 )%FILENAME = TRIM('retv_vars.02967_1056_002.cdf') +! TES( 73 )%FILENAME = TRIM('retv_vars.02967_1056_003.cdf') +! TES( 74 )%FILENAME = TRIM('retv_vars.02967_1056_004.cdf') +! TES( 75 )%FILENAME = TRIM('retv_vars.02971_0457_002.cdf') +! TES( 76 )%FILENAME = TRIM('retv_vars.02971_0457_003.cdf') +! TES( 77 )%FILENAME = TRIM('retv_vars.02971_0457_004.cdf') +! TES( 78 )%FILENAME = TRIM('retv_vars.02971_0458_002.cdf') +! TES( 79 )%FILENAME = TRIM('retv_vars.02971_0982_002.cdf') +! TES( 80 )%FILENAME = TRIM('retv_vars.02971_0982_003.cdf') +! TES( 81 )%FILENAME = TRIM('retv_vars.02971_0982_004.cdf') +! TES( 82 )%FILENAME = TRIM('retv_vars.02971_0983_002.cdf') +! TES( 83 )%FILENAME = TRIM('retv_vars.02971_0983_003.cdf') +! TES( 84 )%FILENAME = TRIM('retv_vars.02971_0983_004.cdf') +! TES( 85 )%FILENAME = TRIM('retv_vars.02971_0984_002.cdf') +! TES( 86 )%FILENAME = TRIM('retv_vars.02971_0984_003.cdf') +! TES( 87 )%FILENAME = TRIM('retv_vars.02971_0984_004.cdf') +! +! ! Return to calling program +! END SUBROUTINE INIT_TES_O3 +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CLEANUP_TES_O3 +!! +!!***************************************************************************** +!! Subroutine CLEANUP_TES_O3 deallocates all module arrays. (dkh, 02/15/09) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! +! IF ( ALLOCATED( O3_SAVE ) ) DEALLOCATE( O3_SAVE ) +! +! +! ! Return to calling program +! END SUBROUTINE CLEANUP_TES_O3 +!!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ + + SUBROUTINE SVD(A,N,U,S,VT) +! +!****************************************************************************** +! Subroutine SVD is a driver for the LAPACK SVD routine DGESVD. (dkh, 05/04/10) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) A (REAL*8) : N x N matrix to decompose +! (2 ) N (INTEGER) : N is dimension of A +! +! Arguments as Output: +! ============================================================================ +! (1 ) U (REAL*8) : Array of left singular vectors +! (2 ) S (REAL*8) : Vector of singular values +! (3 ) VT (REAL*8) : Array of right singular vectors, TRANSPOSED +! +! +! NOTES: +! +* Copyright (C) 2009-2010 Intel Corporation. All Rights Reserved. +* The information and material ("Material") provided below is owned by Intel +* Corporation or its suppliers or licensors, and title to such Material remains +* with Intel Corporation or its suppliers or licensors. The Material contains +* proprietary information of Intel or its suppliers and licensors. The Material +* is protected by worldwide copyright laws and treaty provisions. No part of +* the Material may be copied, reproduced, published, uploaded, posted, +* transmitted, or distributed in any way without Intel's prior express written +* permission. No license under any patent, copyright or other intellectual +* property rights in the Material is granted to or conferred upon you, either +* expressly, by implication, inducement, estoppel or otherwise. Any license +* under such intellectual property rights must be express and approved by Intel +* in writing. +* ============================================================================= +* +* DGESVD Example. +* ============== +* +* Program computes the singular value decomposition of a general +* rectangular matrix A: +* +* 8.79 9.93 9.83 5.45 3.16 +* 6.11 6.91 5.04 -0.27 7.98 +* -9.15 -7.93 4.86 4.85 3.01 +* 9.57 1.64 8.83 0.74 5.80 +* -3.49 4.02 9.80 10.00 4.27 +* 9.84 0.15 -8.99 -6.02 -5.31 +* +* Description. +* ============ +* +* The routine computes the singular value decomposition (SVD) of a real +* m-by-n matrix A, optionally computing the left and/or right singular +* vectors. The SVD is written as +* +* A = U*SIGMA*VT +* +* where SIGMA is an m-by-n matrix which is zero except for its min(m,n) +* diagonal elements, U is an m-by-m orthogonal matrix and VT (V transposed) +* is an n-by-n orthogonal matrix. The diagonal elements of SIGMA +* are the singular values of A; they are real and non-negative, and are +* returned in descending order. The first min(m, n) columns of U and V are +* the left and right singular vectors of A. +* +* Note that the routine returns VT, not V. +* +* Example Program Results. +* ======================== +* +* DGESVD Example Program Results +* +* Singular values +* 27.47 22.64 8.56 5.99 2.01 +* +* Left singular vectors (stored columnwise) +* -0.59 0.26 0.36 0.31 0.23 +* -0.40 0.24 -0.22 -0.75 -0.36 +* -0.03 -0.60 -0.45 0.23 -0.31 +* -0.43 0.24 -0.69 0.33 0.16 +* -0.47 -0.35 0.39 0.16 -0.52 +* 0.29 0.58 -0.02 0.38 -0.65 +* +* Right singular vectors (stored rowwise) +* -0.25 -0.40 -0.69 -0.37 -0.41 +* 0.81 0.36 -0.25 -0.37 -0.10 +* -0.26 0.70 -0.22 0.39 -0.49 +* 0.40 -0.45 0.25 0.43 -0.62 +* -0.22 0.14 0.59 -0.63 -0.44 +* ============================================================================= +!****************************************************************************** +! + ! Arguements + INTEGER,INTENT(IN) :: N + REAL*8, INTENT(IN) :: A(N,N) + REAL*8, INTENT(OUT) :: U(N,N) + REAL*8, INTENT(OUT) :: S(N) + REAL*8, INTENT(OUT) :: VT(N,N) + + ! Local variables + INTEGER, PARAMETER :: LWMAX = MAXLEV * 35 + INTEGER :: INFO, LWORK + DOUBLE PRECISION :: WORK( LWMAX ) + +* .. External Subroutines .. + EXTERNAL :: DGESVD + +* .. Intrinsic Functions .. + INTRINSIC :: INT, MIN + + !================================================================= + ! SVD begins here! + !================================================================= + +* .. Executable Statements .. + !WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', N, N, A, N, S, U, N, VT, N, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF + +! Uncomment the following to print out singlular values, vectors (dkh, 05/04/10) +!! +!! Print singular values. +!! +! CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +!! +!! Print left singular vectors. +!! +! CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', +! $ N, N, U, N ) +!! +!! Print right singular vectors. +!! +! CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', +! $ N, N, VT, N ) + + ! Return to calling program + END SUBROUTINE SVD +!------------------------------------------------------------------------------ + SUBROUTINE DGESVD_EXAMPLE + +* .. Parameters .. + INTEGER M, N + PARAMETER ( M = 6, N = 5 ) + INTEGER LDA, LDU, LDVT + PARAMETER ( LDA = M, LDU = M, LDVT = N ) + INTEGER LWMAX + PARAMETER ( LWMAX = 1000 ) +* +* .. Local Scalars .. + INTEGER INFO, LWORK +* +* .. Local Arrays .. + DOUBLE PRECISION A( LDA, N ), U( LDU, M ), VT( LDVT, N ), S( N ), + $ WORK( LWMAX ) + DATA A/ + $ 8.79, 6.11,-9.15, 9.57,-3.49, 9.84, + $ 9.93, 6.91,-7.93, 1.64, 4.02, 0.15, + $ 9.83, 5.04, 4.86, 8.83, 9.80,-8.99, + $ 5.45,-0.27, 4.85, 0.74,10.00,-6.02, + $ 3.16, 7.98, 3.01, 5.80, 4.27,-5.31 + $ / +* +* .. External Subroutines .. + EXTERNAL DGESVD + !EXTERNAL PRINT_MATRIX +* +* .. Intrinsic Functions .. + INTRINSIC INT, MIN +* +* .. Executable Statements .. + WRITE(*,*)'DGESVD Example Program Results' +* +* Query the optimal workspace. +* + LWORK = -1 + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) + LWORK = MIN( LWMAX, INT( WORK( 1 ) ) ) +* +* Compute SVD. +* + CALL DGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, INFO ) +* +* Check for convergence. +* + IF( INFO.GT.0 ) THEN + WRITE(*,*)'The algorithm computing SVD failed to converge.' + STOP + END IF +* +* Print singular values. +* + CALL PRINT_MATRIX( 'Singular values', 1, N, S, 1 ) +* +* Print left singular vectors. +* + CALL PRINT_MATRIX( 'Left singular vectors (stored columnwise)', + $ M, N, U, LDU ) +* +* Print right singular vectors. +* + CALL PRINT_MATRIX( 'Right singular vectors (stored rowwise)', + $ N, N, VT, LDVT ) + +* +* End of DGESVD Example. + END SUBROUTINE DGESVD_EXAMPLE +!------------------------------------------------------------------------------ +* +* Auxiliary routine: printing a matrix. +* + SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA ) + CHARACTER*(*) DESC + INTEGER M, N, LDA + DOUBLE PRECISION A( LDA, * ) +* + INTEGER I, J +* + WRITE(*,*) + WRITE(*,*) DESC + DO I = 1, M + WRITE(*,9998) ( A( I, J ), J = 1, N ) + END DO +* +! Change format of output (dkh, 05/04/10) +! 9998 FORMAT( 11(:,1X,F6.2) ) + 9998 FORMAT( 11(:,1X,E14.8) ) + RETURN + + END SUBROUTINE PRINT_MATRIX +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_TES_BIAS_FILE_HDF5(FILE_ID) + + USE HDF5 + + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + + INTEGER(HID_T) :: FILE_ID + + CHARACTER(LEN=255) :: LON_NAME, LAT_NAME, LEV_NAME + CHARACTER(LEN=255) :: TES_O3_NAME + CHARACTER(LEN=255) :: TES_GC_O3_NAME + CHARACTER(LEN=255) :: TES_BIAS_NAME + CHARACTER(LEN=255) :: TES_COUNT_NAME + CHARACTER(LEN=255) :: LON_RAW_NAME, LAT_RAW_NAME, TIME_RAW_NAME + CHARACTER(LEN=255) :: TES_O3_RAW_NAME, TES_GC_O3_RAW_NAME + + CHARACTER(LEN=255) :: TES_O3_LONGNAME + CHARACTER(LEN=255) :: TES_GC_O3_LONGNAME + CHARACTER(LEN=255) :: TES_BIAS_LONGNAME + CHARACTER(LEN=255) :: TES_COUNT_LONGNAME + CHARACTER(LEN=255) :: TES_O3_RAW_LONGNAME, TES_GC_O3_RAW_LONGNAME + + CHARACTER(LEN=255) :: TES_O3_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_UNIT + CHARACTER(LEN=255) :: TES_BIAS_UNIT + CHARACTER(LEN=255) :: TES_COUNT_UNIT + CHARACTER(LEN=255) :: TES_O3_RAW_UNIT + CHARACTER(LEN=255) :: TES_GC_O3_RAW_UNIT + + CHARACTER(LEN=255) :: LON_LONGNAME, LAT_LONGNAME, LEV_LONGNAME + CHARACTER(LEN=255) :: LON_UNIT, LAT_UNIT, LEV_UNIT + CHARACTER(LEN=255) :: LON_RAW_LONGNAME, LAT_RAW_LONGNAME + CHARACTER(LEN=255) :: TIME_RAW_LONGNAME + CHARACTER(LEN=255) :: LON_RAW_UNIT, LAT_RAW_UNIT + CHARACTER(LEN=255) :: TIME_RAW_UNIT + + INTEGER(HID_T) :: SPACE_LON, SPACE_LAT, SPACE_LEV + INTEGER(HID_T) :: SPACE_RAW_1D, SPACE_RAW_2D + INTEGER(HID_T) :: LON_ID, LAT_ID, LEV_ID + INTEGER(HID_T) :: LON_RAW_ID, LAT_RAW_ID, TIME_RAW_ID + INTEGER(HID_T) :: SPACE_TES, DSET_TES_O3_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_ID + INTEGER(HID_T) :: DSET_TES_BIAS_ID + INTEGER(HID_T) :: DSET_TES_COUNT_ID + INTEGER(HID_T) :: DSET_TES_O3_RAW_ID + INTEGER(HID_T) :: DSET_TES_GC_O3_RAW_ID + + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER(HID_T) :: TES_GROUP_ID, GRID_GROUP_ID + INTEGER(HID_T) :: GRID_DATA_GROUP_ID, RAW_DATA_GROUP_ID + INTEGER(HID_T) :: LEVEL3_GROUP_ID + + INTEGER(HSIZE_T) :: DIMS(3), DIM_LON(1), DIM_LAT(1), DIM_LEV(1) + INTEGER(HSIZE_T) :: DIM_RAW_1D(1), DIM_RAW_2D(2) + + INTEGER :: HDF_ERR + INTEGER :: RANK = 3 + + INTEGER :: I,J,L + REAL*4 :: MISS_VAL = -999.9 + REAL*4 :: LON_VALS(IIPAR), LAT_VALS(JJPAR), LEV_VALS(MAXLEV) + + ! populate lon & lat arrays + + DO I=1,IIPAR + LON_VALS(I)=GET_XMID(I) + ENDDO + + DO J=1,JJPAR + LAT_VALS(J)=GET_YMID(J) + ENDDO + + DO I=1,MAXLEV + LEV_VALS(I)=TES_PRESSURE(I) ! assume that TES retrieval grid doesn't change + ENDDO + + DO L=1,MAXLEV + DO J=1,JJPAR + DO I=1,IIPAR + + IF(TES_BIAS_COUNT(I,J,L)>0d0) THEN + TES_O3_MEAN(I,J,L) = + & REAL(TES_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_GC_O3_MEAN(I,J,L) = + & REAL(TES_GC_O3_MEAN(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + TES_BIAS(I,J,L) = + & REAL(TES_BIAS(I,J,L)/TES_BIAS_COUNT(I,J,L))*1E9 + ELSE + TES_O3_MEAN(I,J,L) = MISS_VAL + TES_GC_O3_MEAN(I,J,L) = MISS_VAL + TES_BIAS(I,J,L) = MISS_VAL + !TES_CHI_SQUARED(I,J,L) = MISS_VAL + ENDIF + + ENDDO + ENDDO + ENDDO + + DIMS(1) = IIPAR + DIMS(2) = JJPAR + DIMS(3) = MAXLEV + + ADIMS(1) = 1 + + DIM_LON = IIPAR + DIM_LAT = JJPAR + DIM_LEV = MAXLEV + + DIM_RAW_1D = FLEX_LON%CURRENT_N + + DIM_RAW_2D(1) = MAXLEV + DIM_RAW_2D(2) = FLEX_LON%CURRENT_N + + ! open HDF5 interface + + CALL H5OPEN_F(HDF_ERR) + + ! create group structure in file + + CALL H5GCREATE_F(FILE_ID,"TES",TES_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level3",LEVEL3_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Data", + & GRID_DATA_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(LEVEL3_GROUP_ID,"Grid",GRID_GROUP_ID,HDF_ERR) + CALL H5GCREATE_F(TES_GROUP_ID,"Level2",RAW_DATA_GROUP_ID,HDF_ERR) + + ! write Level3 grid information + + CALL H5SCREATE_SIMPLE_F(1,DIM_LON,SPACE_LON,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LAT,SPACE_LAT,HDF_ERR) + CALL H5SCREATE_SIMPLE_F(1,DIM_LEV,SPACE_LEV,HDF_ERR) + + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Longitude", + & H5T_IEEE_F32LE, SPACE_LON, LON_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Latitude", + & H5T_IEEE_F32LE, SPACE_LAT, LAT_ID, HDF_ERR) + CALL H5DCREATE_F(GRID_GROUP_ID, "/TES/Level3/Grid/Level", + & H5T_IEEE_F32LE, SPACE_LEV, LEV_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_ID, H5T_NATIVE_REAL, LON_VALS, + & DIM_LON, HDF_ERR) + CALL H5DWRITE_F(LAT_ID, H5T_NATIVE_REAL, LAT_VALS, + & DIM_LAT, HDF_ERR) + CALL H5DWRITE_F(LEV_ID, H5T_NATIVE_REAL, LEV_VALS, + & DIM_LEV, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_ID,"Longitude","degrees") + CALL WRITE_ATTRIBUTES(LAT_ID,"Latitude","degrees") + CALL WRITE_ATTRIBUTES(LEV_ID,"Vertical level","hPa") + + CALL H5DCLOSE_F(LON_ID, HDF_ERR) + CALL H5DCLOSE_F(LAT_ID, HDF_ERR) + CALL H5DCLOSE_F(LEV_ID, HDF_ERR) + + CALL H5SCLOSE_F(SPACE_LON, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LAT, HDF_ERR) + CALL H5SCLOSE_F(SPACE_LEV, HDF_ERR) + + ! create dataspace for TES diagnostics + + CALL H5SCREATE_SIMPLE_F(RANK,DIMS,SPACE_TES,HDF_ERR) + + ! write gridded (Level3) data + ! create all datasets as little-endian 32 bit IEEE float + + ! write TES O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_ID, H5T_NATIVE_REAL, + & TES_O3_MEAN, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_ID,"Mean TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_ID,HDF_ERR) + + ! write TES_GC O3 concentrations + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_GC_O3_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_ID, H5T_NATIVE_REAL, + & TES_GC_O3_MEAN, ADIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_ID, + & "Mean GC O3 profiles in TES observation space", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_ID,HDF_ERR) + + ! write TES_GC O3 bias + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_BIAS", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_BIAS_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_BIAS_ID, H5T_NATIVE_REAL, + & TES_BIAS, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_BIAS_ID,"Mean TES O3 bias profile", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_BIAS_ID,HDF_ERR) + + ! write TES_GC O3 count + + CALL H5DCREATE_F(GRID_DATA_GROUP_ID,"/TES/Level3/Data/TES_COUNT", + & H5T_IEEE_F32LE, SPACE_TES, DSET_TES_COUNT_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_COUNT_ID, H5T_NATIVE_REAL, + & TES_BIAS_COUNT, DIMS, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_COUNT_ID,"TES data count", + & "1") + + CALL H5DCLOSE_F(DSET_TES_COUNT_ID,HDF_ERR) + + !----------------------------------------------------------------------------------------------------- + + ! create dataspace for raw 1D (Level2) diagnostics + + CALL H5SCREATE_SIMPLE_F(1,DIM_RAW_1D,SPACE_RAW_1D,HDF_ERR) + + ! write raw longitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Longitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LON_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LON_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LON%DATA(1:FLEX_LON%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LON_RAW_ID,"Longitude", "degrees") + + CALL H5DCLOSE_F(LON_RAW_ID,HDF_ERR) + + ! write raw latitudes + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Latitude", + & H5T_IEEE_F32LE, SPACE_RAW_1D, LAT_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(LAT_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_LAT%DATA(1:FLEX_LAT%CURRENT_N),4), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(LAT_RAW_ID,"Latitude", "degrees") + + CALL H5DCLOSE_F(LAT_RAW_ID,HDF_ERR) + + ! write raw times + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/Time", + & H5T_IEEE_F64LE, SPACE_RAW_1D, TIME_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(TIME_RAW_ID, H5T_NATIVE_DOUBLE, + & FLEX_TIME%DATA(1:FLEX_TIME%CURRENT_N), + & DIM_RAW_1D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(TIME_RAW_ID,"Time","YYYYMMDD.frac-of-day") + + CALL H5DCLOSE_F(TIME_RAW_ID,HDF_ERR) + + ! create dataspace for raw 2D diagnostics + + CALL H5SCREATE_SIMPLE_F(2,DIM_RAW_2D,SPACE_RAW_2D,HDF_ERR) + + ! write raw TES O3 profiles + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_TES_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_O3_RAW_ID,"TES O3 profiles", + & "ppbv") + + CALL H5DCLOSE_F(DSET_TES_O3_RAW_ID,HDF_ERR) + + ! write raw GC O3 profiles as observed by GEOS-Chem + + CALL H5DCREATE_F(RAW_DATA_GROUP_ID,"/TES/Level2/TES_GC_O3", + & H5T_IEEE_F32LE, SPACE_RAW_2D, DSET_TES_GC_O3_RAW_ID, HDF_ERR) + + CALL H5DWRITE_F(DSET_TES_GC_O3_RAW_ID, H5T_NATIVE_REAL, + & REAL(FLEX_GC_O3%DATA(:,1:FLEX_TIME%CURRENT_N)*1e9,4), + & DIM_RAW_2D, HDF_ERR) + + CALL WRITE_ATTRIBUTES(DSET_TES_GC_O3_RAW_ID, + & "GEOS-Chem O3 profiles in TES observation space","ppbv") + + CALL H5DCLOSE_F(DSET_TES_GC_O3_RAW_ID,HDF_ERR) + + !close data spaces and groups + + CALL H5SCLOSE_F(SPACE_TES,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_1D,HDF_ERR) + CALL H5SCLOSE_F(SPACE_RAW_2D,HDF_ERR) + + CALL H5GCLOSE_F(RAW_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_DATA_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(GRID_GROUP_ID, HDF_ERR) + CALL H5GCLOSE_F(TES_GROUP_ID, HDF_ERR) + + ! close HDF5 interface + + CALL H5CLOSE_F(HDF_ERR) + + CALL H5EPRINT_F(HDF_ERR,"hdf_error") + + ! clear flexible arrays + + CALL CLEAR_FLEX_REAL_1D(FLEX_LON) + CALL CLEAR_FLEX_REAL_1D(FLEX_LAT) + CALL CLEAR_FLEX_REAL_1D(FLEX_TIME) + + CALL CLEAR_FLEX_REAL_2D(FLEX_TES_O3) + CALL CLEAR_FLEX_REAL_2D(FLEX_GC_O3) + + END SUBROUTINE MAKE_TES_BIAS_FILE_HDF5 + + SUBROUTINE WRITE_ATTRIBUTES(DSET_ID,LONGNAME,UNIT) + + USE HDF5 + + INTEGER(HID_T) :: DSET_ID + CHARACTER(LEN=*) :: LONGNAME + CHARACTER(LEN=*) :: UNIT + + INTEGER(HID_T) :: ASPACE_ID, ATYPE_ID, ATT_ID + INTEGER(HSIZE_T) :: ADIMS(1) + + INTEGER :: HDF_ERR + + ADIMS(1) = 1 + + ! create attribute "Long name" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(LONGNAME),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Long name", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,LONGNAME, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + ! create attribute "Unit" + + CALL H5SCREATE_SIMPLE_F(1,ADIMS,ASPACE_ID,HDF_ERR) + + CALL H5TCOPY_F(H5T_NATIVE_CHARACTER,ATYPE_ID,HDF_ERR) + CALL H5TSET_SIZE_F(ATYPE_ID,LEN(UNIT),HDF_ERR) + + CALL H5ACREATE_F(DSET_ID,"Unit", + & ATYPE_ID,ASPACE_ID,ATT_ID,HDF_ERR) + CALL H5AWRITE_F(ATT_ID,ATYPE_ID,UNIT, + & ADIMS,HDF_ERR) + + CALL H5ACLOSE_F(ATT_ID,HDF_ERR) + CALL H5SCLOSE_F(ASPACE_ID,HDF_ERR) + + END SUBROUTINE WRITE_ATTRIBUTES + + !-------------------------------------------------------------------------------- + + !mkeller: helper routines for managing flexible arrays + ! reinventing the wheel here, but hey... + + SUBROUTINE INIT_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_1D + + SUBROUTINE GROW_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:) + ALLOCATE(TEMP_ARRAY(INPUT%MAX_N * 2)) + TEMP_ARRAY(1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_1D + + SUBROUTINE PUSH_FLEX_REAL_1D(INPUT, NEW_VAL) + + TYPE(FLEX_REAL_1D) :: INPUT + REAL*8 :: NEW_VAL + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_1D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(INPUT%CURRENT_N) = NEW_VAL + + END SUBROUTINE PUSH_FLEX_REAL_1D + + SUBROUTINE CLEAR_FLEX_REAL_1D(INPUT) + + TYPE(FLEX_REAL_1D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_1D + + !-------------------------------------------------------------------------------- + + SUBROUTINE INIT_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D):: INPUT + INPUT%CURRENT_N = 0 + INPUT%MAX_N = 1000 + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) ! safety first + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N)) + + END SUBROUTINE INIT_FLEX_REAL_2D + + SUBROUTINE GROW_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8, ALLOCATABLE :: TEMP_ARRAY(:,:) + ALLOCATE(TEMP_ARRAY(MAXLEV,INPUT%MAX_N * 2)) + TEMP_ARRAY(:,1:INPUT%MAX_N) = INPUT%DATA + DEALLOCATE(INPUT%DATA) + ALLOCATE(INPUT%DATA(MAXLEV,INPUT%MAX_N * 2)) + INPUT%DATA = TEMP_ARRAY + DEALLOCATE(TEMP_ARRAY) + INPUT%MAX_N = INPUT%MAX_N * 2 + + END SUBROUTINE GROW_FLEX_REAL_2D + + SUBROUTINE PUSH_FLEX_REAL_2D(INPUT, NEW_VAL, NLEV) + + TYPE(FLEX_REAL_2D) :: INPUT + REAL*8 :: NEW_VAL(MAXLEV) + INTEGER :: NLEV + IF(INPUT%CURRENT_N == INPUT%MAX_N) THEN + CALL GROW_FLEX_REAL_2D(INPUT) + ENDIF + INPUT%CURRENT_N = INPUT%CURRENT_N + 1 + INPUT%DATA(MAXLEV-NLEV+1:MAXLEV,INPUT%CURRENT_N) = NEW_VAL(1:NLEV) + + END SUBROUTINE PUSH_FLEX_REAL_2D + + SUBROUTINE CLEAR_FLEX_REAL_2D(INPUT) + + TYPE(FLEX_REAL_2D) :: INPUT + IF(ALLOCATED(INPUT%DATA)) DEALLOCATE(INPUT%DATA) + + END SUBROUTINE CLEAR_FLEX_REAL_2D + + END MODULE TES_O3_MOD