!$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