SUBROUTINE CH_BRP2BDY(KNO,KLIST,KSLIST,KMXL 1,9
& ,KMARK,PVAL,PSVAL,KALT,KDBURP,CDSTNID
& ,LDMA,KNELE,KNVAL,KNSELE
& ,PSZA,KSZA,PLONG,PLAT
& ,KAVGKERN,KAVGKERP,KCORREL,KCORRELP
& ,K1TBL,K2TBL,KTBL,KNUM,KNBON)
*
IMPLICIT NONE
*
CHARACTER*(*) CDSTNID
LOGICAL LDMA
INTEGER KNO,KNUM,KNELE,KNVAL,KNSELE,KNSVAL,KSZA,KDSZA
INTEGER KMXL,KALT,KDBURP,K1TBL,K2TBL
INTEGER KTBL(K1TBL,K2TBL),KMARK(KMXL),KLIST(KNELE),KSLIST(KNELE)
REAL*8 PVAL(KMXL),PSVAL(KMXL),PSZA(KNVAL),PLONG,PLAT
INTEGER KNBON
INTEGER KAVGKERN,KAVGKERP,KCORREL,KCORRELP
*
#if defined (DOC)
*-----------------------------------------------------------------------
*
***s/r CH_BRP2BDY - EXTRACT AND STORE TO CMA BODY REQUIRED 'TR' FAMILY OBS
* DATA PROVIDED IN THE 2-D OBS BLOCK ARRAYS READ FROM
* A BURP FILE.
*
*Author . Y. Yang and Y.J. Rochon *AQRB/MSC May/June 2005
* (starting with IGETELE and BRPACMA routines as reference)
*
*Revision:
* Y.J. Rochon *ARQX/MSC May 2005 - April 2006
* - Code re-packaged as a subroutine.
* - Changed some aspects related to std. dev.
* - Allowance for multiple obs per block
* - Non-species scalar obs allowed (e.g. temperature but
* not winds). However, no checking for winds.
* - Re-configured for version BURPV2.0 of 'TR' family burp files.
* BURPV2.0 refers to the convention agreed upon by
* for P. Koclas, Y. Pelletier, M. Neish, and Y.J. Rochon
* regarding format.
* Y.J. Rochon ARQX August 2010
* - Added CDSTNID argument to call of CH_GETOBSERR
* - Added *AVGKER* and *CORREL* and reading/saving of
* averaging kernel matrixes. Reading/saving of correlation/covar
* matrixes not validated!
*
* PURPOSE: EXTRACT AND STORE TO CMA BODY REQUIRED 'TR' FAMILY OBS
* DATA PROVIDED IN THE 2-D OBS BLOCK ARRAYS READ FROM
* A BURP FILE.
*
* ARGUMENTS:
*
* INPUT:
*
* -KNO : Block index for obs data block
* -LDMA : Logical for presence of markers
* -KMARK : Marker/flag array from marker block
* -KNELE : Dimension of KLIST
* -KNSELE : Dimension of KSLIST (0 for no std. dev.)
* -KNVAL : Length of profiles
* -K1TBL : First dimension of KTBL
* -K2TBL : Second dimension of KTBL
* -KTBL : Block header info
* -KMXL : Max dimension of array
* -KLIST : Decoded BUFR element names for DATA
* (in 6 digit decimal BUFR format)
* -KSLIST : Decoded BUFR element names for STD. DEV.
* -PVAL : Data profiles
* -PSVAL : Std. dev. profiles
* -KDBURP : Data type number (from report header)
* -CDSTNID : Stn id (from report header)
* -PLONG : Longitude (degrees)
* -PLAT : Latitude (degrees)
* -KAVGKERN: >0 if avg kernels to be read
* -KCORREL : >0 if correlation/covariance matrix to be read
*
* OUTPUT:
*
* -KSZA : Number of SZA values (-1 for no values)
* -PSZA : SZA profile
* -KNUM : Number of obs profiles
* -KNBON : Number of obs elements
*
* -Additions to CMA body
*
*
* COMMENTS:
*
* IMPORTANT: Obs counting in CH_BDY2BRP
* must be consistent with that in CH_BRP2BDY
* (and CH_CMABDY). Otherwise, there will be a position
* mismatch between the required CMA data and the BURP
* report content.
*
*-----------------------------------------------------------------------
#endif
*
#include "pardim.cdk"
#include "comlun.cdk"
#include "comdim.cdk"
#include "comchem.cdk"
#include "cparbrp.cdk"
#include "commatrix.cdk"
*
LOGICAL LLERROR
INTEGER IER,IVCORD,IBTYP,IVCORDTYP,IDATYP,J
INTEGER II3D,I3D,INELE,INVAL
INTEGER IIND,IIND2,JJ,IND,JL,INDSTD,JJ1
INTEGER IBFAM,ISPECN,NOBSTYP,IMAT
REAL*8 ZPROF(jpmxnlv),ZEXTRA(jpmxnlv)
REAL*8 ZPROF2(jpmxnlv), ZPROF3(jpmxnlv)
C
INTEGER IDESC(jpmxnel),ILDESC(jpmxnel),INDESC
C
C Initialization
C
LLERROR=.FALSE.
C
IND=0
KNUM=0
IIND = -1
IIND2 = -1
C
C Extract dimensions and flags of data block.
C
INELE=KTBL(2,KNO)
INVAL=KTBL(3,KNO)
IF (INELE.NE.KNELE.OR.INVAL.NE.KNVAL) THEN
write(nulout,*)
write(nulout, *) 'CH_BRP2BDY: Unexpected block size'
call abort3d(nulout,'CH_BRP2BDY')
END IF
IBTYP=KTBL(7,KNO)
IDATYP=KTBL(10,KNO)
I3D=KTBL(4,KNO)
IBFAM =KTBL(5,KNO)
C
C Identify species (when ISPECN=0, data are not species obs)
C Species identifier number is stored using the 7 left-most
C bits of the 12 bit IBFAM.
C
ISPECN=IBFAM/32
C
IF (I3D.GT.1) THEN
write(nulout,*)
write(nulout, *) 'CH_BRP2BDY: 3D block - cannot be processed'
call abort3d(nulout,'CH_BRP2BDY')
END IF
II3D=1
C
C Get 'TR' family obs. descriptors
C
CALL CH_KGETTRDESC(KLIST,ISPECN,KNELE,CDSTNID,IDESC,ILDESC,INDESC)
IF (INDESC.EQ.0) RETURN
C
C Get vertical coordinate arrays from BURP report and set related
C flags.
C
C Loop over possible descriptors for vertical coordinates.
C Find and select first vertical coordinate element in KLIST.
C
ZPROF(:)=-1.
ZPROF2(:)=-1.
IIND=0
DO JL=1,KNELE
DO JJ = 1, NALLVCORD
IVCORD = NDESCVCORD(JJ)
IF (IVCORD .LE. 0) go to 900
IF (KLIST(JL).EQ.IVCORD) THEN
IIND=JL-1
CALL CH_GETELEX(IVCORD,II3D,KLIST,PVAL,
+ ZPROF,KNELE,KNVAL,I3D,IIND)
GO TO 950
END IF
END DO
900 CONTINUE
END DO
950 CONTINUE
C
IF (IIND .GT. 0) THEN
IVCORDTYP = NDESVTYP(JJ)
C
C Check for second column denoting same vertical coordinate.
C The presence of a second column implies obs
C of column integrals or column averages.
C The two values denote the layer top and bottom.
C
C Second column must be beside (and to the right of) the first.
C
IIND2=-1
JJ1=JJ
DO JJ = JJ1, NALLVCORD
IF (NDESCVCORD(JJ).LE.0) go to 960
IF (IVCORDTYP.EQ.NDESVTYP(JJ)) THEN
IIND2=IIND
CALL CH_GETELEX(NDESCVCORD(JJ),II3D,KLIST,PVAL,
+ ZPROF2,KNELE,KNVAL,I3D,IIND2)
IF (IIND2.EQ.IIND+1) go to 960
END IF
END DO
960 IF (IIND2.NE.IIND+1) IIND2=0
END IF
C
C Finalize vertical coordinate arrays and related flags.
C Step 1: Test for availability of required coordinate info.
C Step 2: Add station altitude to heights when appropriate
C Step 3: For IIND2>0, ensure that the layer top is stored in zprof
C and the layer bottom is in zprof2
C
CALL CH_VCOORD(IIND,IIND2,KNVAL,INDESC,KALT,
& IVCORDTYP,IVCORD,IDESC,ZPROF,ZPROF2)
C
C Set observation handling flag IOBSTYP. This flag identifies which
C forward model, and related adjoint model and TLM, are to be used
C for the observation (see CH_JOCALC, CH_ODA_H*TR, and CH_ONEOBS)
C
CALL CH_OBSTYP(IIND,IIND2,INDESC,CDSTNID,NOBSTYP,IDESC)
C
C Get the solar zenith angle associated to each observation
C (if present).
C
CALL GETELE(007025,II3D,KLIST,PVAL,
+ PSZA,KNELE,KNVAL,I3D,KSZA)
C
C Loop over data profiles (assumes 1 profile for species block and
C possible multi-profiles for non-species blocks.
C
DO J=1,INDESC
C
C Select and set final obs error std. dev.
C
LLERROR=.TRUE.
CALL CH_GETOBSERR(0,ILDESC(J),ISPECN,II3D,KLIST,
+ PVAL,ZEXTRA,KNELE,KNVAL,I3D,INDSTD,
+ LLERROR,KNSELE,KSLIST,PSVAL,KMXL,CDSTNID)
IF (LLERROR) THEN
write(nulout,*) 'CH_BRP2BDY: No set obs error std. dev. ',
+ 'for stnid ',cdstnid,ISPECN,KLIST(ILDESC(J))
call abort3d(nulout,'CH_BRP2BDY')
ELSE
C
C Store valid obs data in CMA
C
C Note: Loop over obs is done outside CH_CMABDY.
C (For CMABDY, loop is done inside routine)
C
CALL CH_CMABDY(PVAL,KLIST,KMARK,
+ ZEXTRA,LLERROR,INDESC,ISPECN,ILDESC(J),
+ KNELE,KNVAL,I3D,IND,
+ IIND2,IVCORDTYP,ZPROF,ZPROF2,II3D,NOBSTYP,
+ PLONG,PLAT,CDSTNID)
KNBON=KNBON+IND
C
C Read/save averaging kernel matrix
C
IF (INDESC.eq.1) THEN ! requires one obs variable only per block
IF (KAVGKERN.GT.0) THEN
IF (NUMAVGK.GT.-1) THEN
NUMAVGK=NUMAVGK+1
IF (NUMAVGK.GT.NMATMAX) THEN
write(nulout,*) 'NMATMAX =',NMATMAX
call ABORT3D(NULOUT,'CH_BRP2BDY: Max number of matrices reached')
END IF
ELSE
NUMAVGK=1
END IF
KAVGKERP=NUMAVGK
NAVGKERN(NUMAVGK,1)=KNVAL ! Assuming KNSVAL=KNVAL when KNSELE.ne.0
NAVGKERN(NUMAVGK,2)=KAVGKERN
IF (KNSELE.EQ.0) THEN
RAVGKERN(:,:,NUMAVGK)=0.0
DO JJ=1,KNVAL
RAVGKERN(JJ,JJ,NUMAVGK)=1.0
END DO
write(NULOUT,*) 'WARNING - CH_BRP2BDY: Avg. kernel matrix not set here.'
ELSE
IMAT=0
CALL CH_GETMATX(15044,II3D,KSLIST,PSVAL,
+ RAVGKERN(1,1,NUMAVGK),KNSELE,KNVAL,
+ JPNFLEV,KAVGKERN,I3D,IMAT)
IF (IMAT.LE.0) call ABORT3D(NULOUT,'CH_BRP2BDY: Matrix not found')
END IF
END IF
C
C Read/save correlation/covariance matrix
C
IF (KCORREL.GT.0) THEN ! TBD
call ABORT3D(nulout,'CH_BRP2BDY: Correlation/covar matrix requested.')
IF (NUMCORL.GT.-1) THEN
NUMCORL=NUMCORL+1
IF (NUMCORL.GT.NMATMAX) THEN
write(nulout,*) 'NMATMAX =',NMATMAX
call ABORT3D(NULOUT,'CH_BRP2BDY: Max number of matrices reached')
END IF
ELSE
NUMCORL=1
END IF
KCORRELP=NUMCORL
NCORREL(NUMCORL,1)=KNVAL ! Assuming KNSVAL=KNVAL when KNSELE.ne.0
NCORREL(NUMCORL,2)=KCORREL
IF (KNSELE.EQ.0) THEN
RCORREL(:,:,NUMCORL)=0.0
DO JJ=1,KNVAL
RCORREL(JJ,JJ,NUMCORL)=1.0
END DO
write(NULOUT,*) 'WARNING - CH_BRP2BDY: Covar matrix not set here'
ELSE
IMAT=0
CALL CH_GETMATX(59239,II3D,KSLIST,PSVAL,
+ RCORREL(1,1,NUMCORL),KNSELE,KNSVAL,
+ JPNFLEV,KCORREL,I3D,IMAT)
IF (IMAT.LE.0) call ABORT3D(NULOUT,'CH_BRP2BDY: Covar matrix not found')
END IF
END IF
END IF
END IF
IF (KNBON.GT.0) KNUM=INDESC
END DO
C
RETURN
END