SUBROUTINE CH_BDY2BRP(KKLIST,KNVALS,KNO,KNMA,KNS 1,4
& ,KLIST,KSLIST,KTOPOST
& ,KBUF,KNBUF,KMARK,PVAL,PSVAL,KDBURP
& ,CDSTNID,KNELE,KNVAL,KNT,KNSELE
& ,K1TBL,K2TBL,KTBL,KLCOD,KLCODMA
& ,KLCODS,KTBLVAL,KTBLVALS,KNBON,KNBLKS)
*
IMPLICIT NONE
*
CHARACTER*(*) CDSTNID
INTEGER KNO,KNELE,KNVAL,KNSELE,KNVALS,KNBUF,KNBLKS
INTEGER KALT,KDBURP,K1TBL,K2TBL,KNMA,KNS
INTEGER KKLIST(KNVALS),KBUF(KNBUF),KTOPOST,KNT
INTEGER KTBL(K1TBL,K2TBL),KMARK(KNELE,KNVAL,KNT)
INTEGER KLIST(KNELE),KSLIST(KNSELE)
REAL*8 PVAL(KNELE,KNVAL,KNT),PSVAL(KNSELE,KNVAL,KNT)
INTEGER KNBON
INTEGER KTBLVAL(KNELE,KNVAL,KNT),KTBLVALS(KNSELE,KNVAL,KNT)
INTEGER KLCODMA(KNELE),KLCOD(KNELE),KLCODS(KNSELE)
*
#if defined (DOC)
*-----------------------------------------------------------------------
*
***s/r CH_BDY2BRP - EXTRACT AND STORE CMA DATA TO CORRESPONDING BURP
* REPORT STORAGE ARRAY.
*
*Author . Y.J. Rochon *AQRX/EC Feb 2006
* (starting from sections extracted from CMAABRP routine)
*
*Revisions:
* Y.J. Rochon *ARQX/EC Feb 2006
* - 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/EC Apr 2006
* - Modified re-writing of unused blocks. Now, unused blocks
* removed but not replaced by commenting out IER=MRBADD(...)
* Y.J. Rochon *ARQX/EC Feb 2007
* - Added use of WORK array. Otherwise, PVAL values lost
* after first call to CH_GETCMA.
* Y.J. Rochon *ARQC/EC Aug 2010
* - Added consideration of avg. kernel matrices and covar matrices.
* These must not reset to dummy values but retained when present.
* - Added pressure profile in the buffer (see module ch_diagn)
* when the obs vertical coordinate is not in pressure.
*
*
* PURPOSE: EXTRACT AND STORE CMA DATA TO CORRESPONDING BURP
* REPORT STORAGE ARRAY.
*
* COMMENT: TBD. Routine should be made shorter by placing some of
* its content in other routines to be called.
*
* ARGUMENTS:
*
* INPUT:
*
* -KKLIST : List of data types required from CMA
* -KNVALS : Length of KKLIST
* -KNO : Block index for obs data block
* -KNMA : Block index for marker block
* -KNS : Block index for std. dev. block
* -KTOPOST : Offset for BKTYP
* -KBUF : Report storage array
* -KNBUF : Size of KBUF
* -KMARK : Marker/flag array from marker block
* -KNELE : Dimension of KLIST
* -KNSELE : Dimension of KSLIST
* -KNVAL : Length of profiles
* -KNT : Third dimension (should currently be 1)
* -K1TBL : First dimension of KTBL
* -K2TBL : Second dimension of KTBL
* -KTBL : Block header info
* -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)
* -KLCOD : Coded BUFR elements for DATA
* -KLCODS : Coded BUFR elements for STD. DEV.
* -KLCODMA : Coded BUFR elements for markers
* -KTBLVAL : Table of block coded data values
* -KTBLVALS: Table of block coded std. dev. values
* -KNBLKS : Counter for number of blocks
*
* OUTPUT:
*
* -KNBON : Number of obs elements
* -KBUF : Augmented report array
* -KNBLKS : Counter for number of blocks
*
* COMMENTS:
*
* 1) CURRENT RESTRICTIONS:
*
* - Third dimension assumed to be of size 1 (KNT=I3D=1)
* - Not currently set to handle grouped data.
*
* 2) IMPORTANT: Obs counting in CH_BDY2BRP (and CH_GETCMA)
* 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 "comlun.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comchem.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "commvo.cdk"
#include "comcst.cdk"
#include "comfilt.cdk"
#include "cparbrp.cdk"
#include "cbtypes.cdk"
#include "comct0.cdk"
*
INTEGER IER
INTEGER II3D,IDATA,IVAL,IOBTOT,IC,ITYPDATA
INTEGER JJ,IND,JL,INDSTD,JJEL,J2,J
INTEGER INELE,INVAL,I3D,IBFAM,IBDESC,IBTYP,INBIT,IDATYP
INTEGER INO,INBITMA,IBTYPMA,IDATYPMA
INTEGER IBKNAT,IBKTYP,IBKSTP,IBIT0,IBIT1,IBKN1,IBKN2
INTEGER ISPECN,IBKNATMA,IBKNO,IBKNMA,IKTBL(10,JPMXBK),INBLKS
REAL*8 WORK(KNELE,KNVAL,KNT)
REAL*4 Z4VAL
C
INTEGER ITBLVAL2(KNELE+1,KNVAL,KNT),IMARK2(KNELE+1,KNVAL,KNT)
INTEGER ILCOD2(KNELE+1),ILCODA2(KNELE+1),IPRESS
REAL*8 ZPRESS(KNVAL)
C
LOGICAL LLTEST
INTEGER IDESC(jpmxnel),ILDESC(jpmxnel),INDESC,IVCORD
INTEGER ILDESCS(jpmxnel)
C
INTEGER VMRBCVT,MRBTYP,MRBDEL,MRBADD,MRBLOCX,MRBPRML,MRBCOV
EXTERNAL VMRBCVT,MRBTYP,MRBDEL,MRBADD,MRBLOCX,MRBPRML,MRBCOV
C
C Initialization
C
IND=0
II3D=1
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 unless species ID stored as first two
C digits in STNID when IBFAM/32=0.
C
IBFAM =KTBL(5,KNO)
ISPECN=IBFAM/32
C ISPECN=ISPECN-1
C
if (ISPECN.eq.0) then
C
C Check STNID for species id
C
ISPECN=0
READ(CDSTNID(7:8),'(i2)',err=2000) ISPECN
ISPECN=ISPECN+1 ! Species list in tablespecies starts with 01 until further notice.
2000 end if
C
IF (KNT.GT.1) THEN
write(nulout,*)
write(nulout, *) 'CH_BDY2BRP: 3D block - cannot be processed'
call abort3d(nulout,'CH_BDY2BRP')
END IF
II3D=1
C
C Initialize/reset non-coordinate profiles in block table to -1
C (or 1.E30 if IDATYP=6)
C
IDATYP=KTBL(10,KNO)
IC=0
C
DO J=1,KNELE
IF (KLIST(J).LT.11000) GO TO 901 ! May be changed
DO JJ = 1, NALLVCORD
IVCORD = NDESCVCORD(JJ)
IF (IVCORD .LE. 0) go to 900
IF (KLIST(J).EQ.IVCORD) GO TO 901
END DO
C
900 KTBLVAL(J,1:KNVAL,1:KNT)=-1
IF (IDATYP.EQ.6) KTBLVAL(J,1:KNVAL,1:KNT)=TRANSFER(1.0E30,IC)
IC=1
C
901 CONTINUE
END DO
C
IF (KNS.GT.0) THEN
IDATYP=KTBL(10,KNS)
C
DO J=1,KNSELE
IF (KSLIST(J).LT.11000.OR.KSLIST(J).EQ.15044.OR.
& KSLIST(J).EQ.59239) GO TO 951 ! May be changed
C
C Note: 15044 for avg kernels, 59239 for covar matrices.
C
DO JJ = 1, NALLVCORD
IVCORD = NDESCVCORD(JJ)
IF (IVCORD .LE. 0) go to 950
IF (KSLIST(J).EQ.IVCORD) GO TO 951
END DO
C
950 KTBLVALS(J,1:KNVAL,1:KNT)=-1
IF (IDATYP.EQ.6) KTBLVALS(J,1:KNVAL,1:KNT)=TRANSFER(1.0E30,IC)
C
951 CONTINUE
END DO
END IF
C
C Get 'TR' family obs. descriptors
C
CALL CH_KGETTRDESC(KLIST,ISPECN,KNELE,CDSTNID,IDESC,ILDESC,INDESC)
IF (INDESC.EQ.0) THEN
IF (IC.EQ.1) THEN
C
C Re-write data block before exiting
C
INO=KNO
INELE=KTBL(2,INO)
INVAL=KTBL(3,INO)
I3D=KTBL(4,INO)
IBFAM=KTBL(5,INO)
IBDESC=KTBL(6,INO)
IBTYP=KTBL(7,INO)
INBIT=KTBL(8,INO)
IDATYP=KTBL(10,INO)
C
C Remove block
C
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IBKNO=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
IER=MRBDEL(KBUF,IBKNO)
C
C Add replacement block
C
c IER=MRBADD(KBUF,IBKN2,INELE,INVAL,I3D,IBFAM,
c + IBDESC,IBTYP,INBIT,IBIT0,IDATYP,KLCOD,
c + KTBLVAL)
C
C Re-writing marker block only moves same block in tandem
C with data block (to current end of report).
C
INO=KNMA
INELE=KTBL(2,INO)
INVAL=KTBL(3,INO)
I3D=KTBL(4,INO)
IBFAM=KTBL(5,INO)
IBDESC=KTBL(6,INO)
IBTYP=KTBL(7,INO)
INBIT=KTBL(8,INO)
IDATYP=KTBL(10,INO)
C
C Remove block
C
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IBKNMA=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
IER=MRBDEL(KBUF,IBKNMA)
C
C Add replacement block
C
c IER=MRBADD(KBUF,IBKN1,INELE,INVAL,I3D,IBFAM,
c + IBDESC,IBTYP,INBIT,IBIT1,IDATYP,KLCODMA,
c + KMARK)
C
IF (KNS.GT.0) THEN
C
C Do same with std. dev. block
C
INO=KNS
INELE=KTBL(2,INO)
INVAL=KTBL(3,INO)
I3D=KTBL(4,INO)
IBFAM=KTBL(5,INO)
IBDESC=KTBL(6,INO)
IBTYP=KTBL(7,INO)
INBIT=KTBL(8,INO)
IDATYP=KTBL(10,INO)
C
C Remove block
C
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IBKNO=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
IER=MRBDEL(KBUF,IBKNO)
C
C Add replacement block
C
c IER=MRBADD(KBUF,IBKN2,INELE,INVAL,I3D,IBFAM,
c + IBDESC,IBTYP,INBIT,IBIT0,IDATYP,KLCODS,
c + KTBLVALS)
END IF
C
END IF
RETURN
END IF
IF (KNS.GT.0)
& CALL CH_KGETTRDESC(KSLIST,ISPECN,KNSELE,CDSTNID,IDESC,ILDESCS,INDESC)
C
C Loop over requested additions/changes to report.
C
IDATA=NDATA
DO JJEL=1,KNVALS
NDATA=IDATA
IVAL=KKLIST(JJEL)
C
INO=KNO
IF (IVAL.EQ.NCMOER.AND.KNS.GT.0) INO=KNS
INELE=KTBL(2,INO)
INVAL=KTBL(3,INO)
I3D=KTBL(4,INO)
IBFAM=KTBL(5,INO)
IBDESC=KTBL(6,INO)
IBTYP=KTBL(7,INO)
INBIT=KTBL(8,INO)
IDATYP=KTBL(10,INO)
C
INBITMA=KTBL(8,KNMA)
IDATYPMA=KTBL(10,KNMA)
C
ISPECN=(IBFAM/32)*32
C
C Loop over data profiles in block
C
IF (INO.EQ.KNO) THEN
DO J=1,INDESC
C
C Extract relevant data from CMA and substitute to buffer array
C
WORK=PVAL
CALL CH_GETCMA(WORK,KMARK,ILDESC(J),
+ INELE,INVAL,I3D,IND,II3D,IVAL,
+ IPRESS,ZPRESS)
IF (LSIMOB) IPRESS=0
C
C Transfer changes in buffer array to report table array
C
IF (IDATYP.EQ.2.OR.IDATYP.EQ.4) THEN
C
C Block to contain integer
C
JJ=ILDESC(J)
DO J2=1,INVAL
IF (WORK(JJ,J2,II3D).EQ.PPMIS) THEN
KTBLVAL(JJ,J2,II3D)=-1
ELSE
KTBLVAL(JJ,J2,II3D)=ANINT(WORK(JJ,J2,II3D))
END IF
END DO
IER=VMRBCVT(KLCOD,KTBLVAL,
& WORK,INELE,INVAL,1,1)
C
ELSE IF (IDATYP.EQ.6) THEN
C
C Block to contain real*4
C
IC=0
JJ=ILDESC(J)
DO J2=1,INVAL
IF (WORK(JJ,J2,II3D).EQ.PPMIS) THEN
KTBLVAL(JJ,J2,II3D)= TRANSFER(1.0E30,IC)
ELSE
Z4VAL=WORK(JJ,J2,II3D)
KTBLVAL(JJ,J2,II3D)=TRANSFER(Z4VAL,IC)
c KTBLVAL(JJ,J2,II3D)=
c & TRANSFER(SNGL(WORK(JJ,J2,II3D)),IC)
END IF
END DO
END IF
C
KNBON=KNBON+IND
END DO
C
IF (IPRESS.GT.0) THEN
C
C Add a pressure column in the block if not present.
C
DO JJ=1,KNELE
IF (KLIST(JJ).EQ.10004) IPRESS=0
END DO
C
IF (IPRESS.GT.0) THEN
ILCOD2(1:ILDESC(1)-1)=KLCOD(1:ILDESC(1)-1)
ILCOD2(ILDESC(1)+1:INELE+1)=KLCOD(ILDESC(1):INELE)
ILCODA2(1:ILDESC(1)-1)=KLCODMA(1:ILDESC(1)-1)
ILCODA2(ILDESC(1)+1:INELE+1)=KLCODMA(ILDESC(1):INELE)
ILCOD2(ILDESC(1))=MRBCOV(10004)
ILCODA2(ILDESC(1))=MRBCOV(210004)
C
ITBLVAL2(1:ILDESC(1)-1,:,:)=KTBLVAL(1:ILDESC(1)-1,:,:)
ITBLVAL2(ILDESC(1)+1:INELE+1,:,:)=KTBLVAL(ILDESC(1):INELE,:,:)
ITBLVAL2(ILDESC(1),:,:)=0
IMARK2(1:ILDESC(1)-1,:,:)=KMARK(1:ILDESC(1)-1,:,:)
IMARK2(ILDESC(1)+1:INELE+1,:,:)=KMARK(ILDESC(1):INELE,:,:)
IMARK2(ILDESC(1),:,:)=0
IF (IDATYP.EQ.2.OR.IDATYP.EQ.4) THEN
DO J2=1,INVAL
ITBLVAL2(ILDESC(1),J2,II3D)=ANINT(ZPRESS(J2))
END DO
IER=VMRBCVT(ILCOD2(ILDESC(1)),ITBLVAL2(ILDESC(1),:,II3D),
& ZPRESS,1,INVAL,1,1)
ELSE IF (IDATYP.EQ.6) THEN
IC=0
DO J2=1,INVAL
Z4VAL=ZPRESS(J2)
ITBLVAL2(ILDESC(1),J2,II3D)=TRANSFER(Z4VAL,IC)
END DO
END IF
END IF
END IF
C
ELSE
DO J=1,INDESC
C
C Extract relevant data from CMA and substitute to buffer array
C
CALL CH_GETCMA(PSVAL,KMARK,ILDESCS(J),
+ INELE,INVAL,I3D,IND,II3D,IVAL,
+ IPRESS,ZPRESS)
C
C Transfer changes in buffer array to report table array
C
IF (IDATYP.EQ.2.OR.IDATYP.EQ.4) THEN
C
C Block to contain integer
C
JJ=ILDESCS(J)
DO J2=1,INVAL
IF (PSVAL(JJ,J2,II3D).EQ.PPMIS) THEN
KTBLVAL(JJ,J2,II3D)=-1
ELSE
KTBLVALS(JJ,J2,II3D)=ANINT(PSVAL(JJ,J2,II3D))
END IF
END DO
IER=VMRBCVT(KLCODS,KTBLVALS,
& PSVAL,INELE,INVAL,1,1)
C
ELSE IF (IDATYP.EQ.6) THEN
C
C Block to contain real*4
C
IC=0
JJ=ILDESCS(J)
DO J2=1,INVAL
IF (PSVAL(JJ,J2,II3D).EQ.PPMIS) THEN
KTBLVAL(JJ,J2,II3D)= TRANSFER(1.0E30,IC)
ELSE
Z4VAL=PSVAL(JJ,J2,II3D)
KTBLVALS(JJ,J2,II3D)=TRANSFER(Z4VAL,IC)
c KTBLVALS(JJ,J2,II3D)=
c & TRANSFER(PSVAL(JJ,J2,II3D),IC)
END IF
END DO
END IF
C
KNBON=KNBON+IND
END DO
END IF
C
IF ( IND .EQ. 0) THEN
WRITE(NULOUT,*)'OBS ',CDSTNID,
+ ' TYPE ',KDBURP,': NO VALID DATA'
ENDIF
C
C Identify block number(s) of relevant existing block(s)
C in report work array.
C
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
C
IF (IVAL.EQ.NCMVAR) THEN
IBKNO=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
IBKNATMA=IBKNAT+3
IBKNMA=MRBLOCX(KBUF,IBFAM,-1,IBKNATMA,IBKTYP,IBKSTP,0)
ELSE IF (IVAL.EQ.NCMOER.AND.KNS.GT.0) THEN
IBKNO=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
END IF
C
C Set BTYP/BTYPMA and BFAM of new/modified block(s)
C
C GET LAST 6 BITS OF BTYP
C
LLTEST=BTEST(IBKTYP,6)
IF ( LLTEST) THEN
ITYPDATA=IBKTYP-64 + KTOPOST
ELSE
ITYPDATA=IBKTYP + KTOPOST
ENDIF
IF (IBKTYP .EQ. NBKTYPS) THEN
C SURFACE BLOCK
C ---------------
IBKTYP=ITYPDATA + 0
ELSE IF (IBKTYP .EQ. NBKTYPA) THEN
C ALTITUDE BLOCK
C ---------------
IBKTYP=ITYPDATA + 64
ENDIF
C
IF ( IVAL .EQ. NCMOER) THEN
C OBSERVATION ERROR STD. DEV. BLOCK
C ------------------------
IBKSTP=14
IBFAM=10+ISPECN
ELSE IF ( IVAL .EQ. NCMFGE) THEN
C FORECAST ERROR STD. DEV. BLOCK
C ------------------------
IBKSTP=15
IBFAM=10+ISPECN
ELSE IF ( IVAL .EQ. NCMOMF) THEN
C RESIDUALS BLOCK
C ------------------------
IBKSTP=10
IBFAM=14+ISPECN
ELSE IF ( IVAL .EQ. NCMVAR) THEN
C DATA BLOCK SEEN BY 3D-VAR
C ------------------------
IBFAM=0+ISPECN
ELSE IF ( IVAL .EQ. NCMOMA) THEN
C ANALYSIS INCREMENT BLOCK
C ------------------------
IBKSTP=10
IBFAM=12+ISPECN
ENDIF
C
IBTYP=MRBTYP(IBKNAT,IBKTYP,IBKSTP,-1)
C
C Add block(s) to report array (and delete previous block(s) with same
C IBTYP and IBFAM)
C
IF (IND .GT. 0) THEN
IF (IVAL .EQ. NCMVAR) THEN
IBKNATMA=IBKNAT+3
IBTYPMA=MRBTYP(IBKNATMA,IBKTYP,IBKSTP,-1)
IER=MRBDEL(KBUF,IBKNMA)
IER=MRBDEL(KBUF,IBKNO)
IF (IPRESS.EQ.0) THEN
IER=MRBADD(KBUF,IBKN2,INELE,INVAL,I3D,IBFAM,
+ IBDESC,IBTYP,INBIT,IBIT0,IDATYP,KLCOD,
+ KTBLVAL)
IER=MRBADD(KBUF,IBKN1,INELE,INVAL,I3D,IBFAM,
+ IBDESC,IBTYPMA,INBITMA,IBIT1,IDATYPMA,KLCODMA,
+ KMARK)
ELSE
IER=MRBADD(KBUF,IBKN2,INELE+1,INVAL,I3D,IBFAM,
+ IBDESC,IBTYP,INBIT,IBIT0,IDATYP,ILCOD2,
+ ITBLVAL2)
IER=MRBADD(KBUF,IBKN1,INELE+1,INVAL,I3D,IBFAM,
+ IBDESC,IBTYPMA,INBITMA,IBIT1,IDATYPMA,ILCODA2,
+ IMARK2)
END IF
ELSE IF (IVAL.EQ.NCMOER.AND.KNS.GT.0) THEN
IER=MRBDEL(KBUF,IBKNO)
IER=MRBADD(KBUF,IBKN1,INELE,INVAL,I3D,IBFAM,
+ IBDESC,IBTYP,INBIT,IBIT0,IDATYP,KLCODS,
+ KTBLVALS)
ELSE
IBKN1=MRBLOCX(KBUF,IBFAM,-1,IBKNAT,IBKTYP,IBKSTP,0)
IF (IBKN1.GT.0) THEN
INBLKS=MRBPRML(KBUF,0,IKTBL,10,JPMXBK)
IF (INBLKS.GT.0.AND.IKTBL(10,IBKN1).EQ.IDATYP) THEN
IER=MRBDEL(KBUF,IBKN1)
ELSE
KNBLKS=KNBLKS+1
END IF
END IF
IER=MRBADD(KBUF,IBKN1,INELE,INVAL,I3D,IBFAM,
+ IBDESC,IBTYP,INBIT,IBIT0,IDATYP,KLCOD,
+ KTBLVAL)
ENDIF
ELSE
IND =0
ENDIF
C
END DO
C
RETURN
END