SUBROUTINE CH_CMAABRP(CDTYPE,LDAPPEND,KFILE,KNRECS,KLIST,KNVALS) 1,4
#if defined (DOC)
*-------------------------------------------------------------------
*
***s/r CH_CMAABRP - CONVERT DATA IN CMA FORMAT TO CMC BURP FILES
* FOR 'TR' OBS FAMILY.
*
*Author . Y.J. Rochon, ARQX/EC Feb. 2006
* Based on CMAABRP by P. KOCLAS/CMC and earlier updates
* by Y. YANG (ARQI) for initial 'TR' BURP files.
*
*Revisions 001-015: see CMAABRP
*
*Revision 017: Y.J. Rochon ARQX/MSC May 2005
* -Complete indentation re-alignment.
*Revision 018: Y.Yang May 2005
* - Consideration of second vertical coordinate.
*Revision 019: Y.J. Rochon ARQX July 2010
* Imposer ITOPOST=0 quand LSIMOB=.true.
*
*Important differences with CMAABRP (other than reading species BURP data)
*
* - Addtitions:
* 1) Checking for, and reading of, std. dev.
* 2) Can have multiple DATA blocks per report
* - Restrictions:
* 1) Does not handle 3D blocks at this time.
* 2) There must be only one DATA block per distinct BFAM value.
* - Others:
* 1) No reading or check for existence of INFO block.
*
* PURPOSE: TO READ ALL 'TR' FAMILY DATA IN CMA AND TRANSFER
* TO POSTFILE OF 3D_VAR IN BURP FORMAT.
*
* ARGUMENTS:
* INPUT:
*
* -CDTYPE : DATA TYPE (I.E: UA=UPPER AIR ...)
* Must be 'TR' for this routine to be
* called.
* -LDAPPEND: .TRUE. -> APPEND DATA TO CMA FILE
* .FALSE.-> START NEW CMC FILE
* -KFILE : LOGICAL UNIT NUMBER OF BURP DATA FILE
* -KNRECS : NUMBERY OF RECORDS IN BURP FILE
* -KLIST : LIST OF INDICES POINTING
* TO VALUES TO BE EXTRACED FROM
* CMA ( 1 ---> OBS ERROR , 2 ---> O-A )
* -KNVALS : NUMBER OF VALUES IN KLIST
*
* OUTPUT: NONE
*
*---------------------------------------------------------------
#endif
*
IMPLICIT NONE
#include "comlun.cdk"
#include "comct0.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comcst.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "cbtypes.cdk"
#include "cparbrp.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "partov.cdk"
#include "comtov.cdk"
#include "commvo.cdk"
#include "comchem.cdk"
*
INTEGER KNVALS
INTEGER KFILE,KNRECS,KLIST(KNVALS)
INTEGER ITOTDAT,IMXL
INTEGER IDATYP
*
CHARACTER *(*) CDTYPE
LOGICAL LDAPPEND,LLTOPOST
*
INTEGER IER
INTEGER IBTYP,IBKNAT,IBKTYP,IBKSTP,IBFAM,ISPECN
INTEGER IBKNATMA
INTEGER IHANDL,IHANDLP,IBKNO,I3D
INTEGER INELE,INVAL,INSELE,INSVAL,IBKNS
INTEGER IZMODEL
INTEGER ITIME,IDLT,IFLGS,IDBURP,ILAT,ILON,IDX,IDY,
+ IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,IXAUX
*
INTEGER MRFPUT,MRFVOI,MRBTYP,VMRFOPR,MRFOPN,MRFLOC,MRFGET
+ ,MRFMXL,MRFGOC,MRFDEL
INTEGER MRBINI,MRBADD,VMRBCVT,MRBXTR,MRBPRM,MRBDCL,MRBHDR
+ ,MRBPRML,MRBLOCX,MRBTBL,MRBCOL,MRBDEL,MRBREP,MRBUPD
*
EXTERNAL MRFPUT,MRFVOI,MRBTYP,VMRFOPR,MRFOPN,MRFLOC,MRFGET
+ ,MRFMXL,MRFDEL
EXTERNAL MRBINI,MRBADD,VMRBCVT,MRBXTR,MRBPRM,MRBDCL,MRBHDR
+ ,MRBPRML,MRBLOCX,MRBTBL,MRBCOL,MRBDEL,MRBREP,MRBUPD,MRFGOC
*
CHARACTER*9 CLSTNID,CLSTNID2
*
INTEGER ITBL(10,JPMXBK)
INTEGER ILSTM(JPMXNEL)
INTEGER ILIST(JPMXNEL),ISLIST(JPMXNEL)
INTEGER ILCOD(JPMXNEL)
INTEGER ILCODS(JPMXNEL)
INTEGER ILCODMA(JPMXNEL)
*
INTEGER ITBLVAL(1),ITBLVALS(1)
INTEGER IMARK(1)
INTEGER IBUF(1),IBUFW(1)
REAL*8 ZVAL(1),ZSVAL(1)
POINTER(PXVAL ,ZVAL)
POINTER(PXSVAL ,ZSVAL)
POINTER(PXTABL ,ITBLVAL)
POINTER(PXTABLS ,ITBLVALS)
POINTER(PXmark ,Imark)
POINTER(PXBUF ,IBUF)
POINTER(PXBUFW ,IBUFW)
*
INTEGER JI,JJ,JK
INTEGER ICHECK,INELM,INVM,INTM,IBKNMA,ITOPOST
INTEGER ILONG,INBLKS,IKOUNT,IND,INBON,IEXTRAEL,ICOUNT
LOGICAL LLERR
LOGICAL LCHECNAT,LCHECTYP,LCHECSTP,LLRESUM
*
************************************************************************
* SET BURP RELATED PARAMETERS VIA CALL TO RESUME SUBROUTINE
************************************************************************
*
WRITE(NULOUT,*)' ------------------------------------------------'
WRITE(NULOUT,*)' --------- BEGIN CH_CMAABRP ---------------'
WRITE(NULOUT,*)' ------------------------------------------------'
*
IF (CDTYPE.NE.'TR') RETURN
LLTOPOST = .FALSE.
*
************************************************************************
* ALLOCATE SPACE FOR DATA BUFFER AND SET "ATTRIBUTES"
* OF DATA TO BE READ VIA CALL TO RESUME ROUTINE
************************************************************************
*
ILONG=6*MRFMXL(KFILE)+20
CALL HPALLOC(PXBUF,ILONG,IER,1)
IBUF(1) =ILONG
CALL HPALLOC(PXBUFW,ILONG,IER,1)
IBUFW(1) =ILONG
*
LLRESUM=.TRUE.
IHANDL=MRFLOC(KFILE,0,'>>*******',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDL .LT. 0 ) THEN
LLRESUM=.FALSE.
IHANDL=MRFLOC(KFILE,0,'*********',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDL .LT. 0 ) THEN
WRITE(NULOUT,*)' CH_CMAABRP: IMPOSSIBLE TO FIND VALID HANDLE'
RETURN
ENDIF
ENDIF
*
************************************************************************
* CHANGE THE RESUME RECORD TO POSTALT TYPE
************************************************************************
*
CALL RESUME(IHANDL,CDTYPE,IBUF)
IER=VMRFOPR('MISSING',PPMIS)
IER=MRFGOC('ERRTOLR','INFORMATIF')
*
IER=MRFGET(IHANDL,IBUF)
IER=MRBHDR(IBUF,ITIME,IFLGS,CLSTNID,IDBURP,ILAT,ILON,IDX,IDY,
& IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,0,IXAUX,0)
*
* FOR BACKGROUND CHECK THE LAST 6 BITS OF BTYP NEED TO BE CHANGED.
*
IF ( CDTYPE .EQ. 'TO' .AND. NCONF .EQ. 121 ) THEN
ITOPOST=0
*
ELSE
IF ( (NCONF .EQ. 101 .AND. CLSTNID .NE. '>>POSTALT') .OR.
& (NCONF .EQ. 101 .AND. CLSTNID .NE. '>>BGCKALT') ) THEN
ITOPOST=4
IF (LSIMOB.AND.
& (CLSTNID.EQ.'>>POSTALT'.or.CLSTNID.EQ.'>>BGCKALT')) ITOPOST=0
ELSE
ITOPOST=0
ENDIF
*
IF ( nconf.eq.141 .OR. NCONF .EQ. 101
& .OR. NINT(NCONF/100.0) .EQ.6) THEN
CLSTNID='>>POSTALT'
IF ( NCONF .EQ. 101 ) CLSTNID='>>BGCKALT'
IF ( LLRESUM) THEN
LLTOPOST = .TRUE.
IHANDLP=IHANDL
IER=MRBUPD(KFILE,IBUF,-1,-1,CLSTNID,-1,-1,-1,-1,-1,
& -1,-1,-1,-1,-1,-1,0,-1,0)
IER=MRFPUT(KFILE,IHANDL,IBUF)
write(nulout,*) 'Modified IHANDL: ',IHANDL,CLSTNID
C
C Remove previously existing resume record(s)
C
1234 IHANDL=MRFLOC(KFILE,IHANDL,'>>*******',-1,-1,-1,-1,-1,-1,0)
write(nulout,*) 'Identified IHANDL ',IHANDL
IF (IHANDL.GT.0) THEN
IER=MRFGET(IHANDL,IBUF)
IER=MRBHDR(IBUF,ITIME,IFLGS,CLSTNID2,IDBURP,ILAT,ILON,IDX,IDY,
& IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,0,IXAUX,0)
IF (CLSTNID2.NE.CLSTNID) THEN
write(nulout,*) 'Removed ',CLSTNID2
IER=MRFDEL(IHANDL)
ELSE
write(nulout,*) 'Kept'
END IF
GO TO 1234
END IF
ELSE
WRITE(NULOUT,*)' NO RESUME RECORD FOR CDTYPE :',CDTYPE
ENDIF
ENDIF
*
ENDIF
*
************************************************************************
* INITIALIZE DATA COUNTERS THEN BEGIN LOOP TO READ DATA
************************************************************************
*
IF ( .NOT. LDAPPEND ) THEN
NOBTOT =0
NDATA =0
ELSE
*
WRITE(NULOUT,*)' '
WRITE(NULOUT,*)'=============================================='
WRITE(NULOUT,*)'NUMBER OF REPORTS CURRENTLY IN CMA FILE',NOBTOT
WRITE(NULOUT,*)'DATA CURRENTLY IN CMA FILE ',NDATA
WRITE(NULOUT,*)'=============================================='
WRITE(NULOUT,*) ' '
IF ( NOBTOT .GE. NMXOBS) THEN
WRITE(NULOUT,*) ' CMA FILE FULL: NO DATA READ'
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END CH_CMAABRP -------------'
WRITE(NULOUT,*)' ------------------------------------------'
RETURN
ENDIF
ENDIF
*
IKOUNT=0
IND =0
*
************************************************************************
* ALLOCATE SPACE TO READ DATA
************************************************************************
*
IHANDL=0
IHANDLP=0
IMXL=1000
CALL HPALLOC(PXVAL, IMXL,IER,8)
CALL HPALLOC(PXSVAL, IMXL,IER,8)
CALL HPALLOC(PXTABL,IMXL,IER,1)
CALL HPALLOC(PXTABLS,IMXL,IER,1)
CALL HPALLOC(PXmark,IMXL,IER,1)
*-----------------------------------------------------------------------
DO 1 JI=1,KNRECS
LLERR=.FALSE.
*
************************************************************************
* LOCATE AND READ RECORD ON DATA FILE
************************************************************************
*
IHANDLP=MRFLOC(KFILE,IHANDLP,'*********',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDLP .LT. 0 )LLERR=.TRUE.
*
IER=MRFGET(IHANDLP,IBUF)
IF (IER.LT.0) LLERR=.TRUE.
*
************************************************************************
* EXTRACT THE HEADER
************************************************************************
*
IER=MRBHDR(IBUF,ITIME,IFLGS,CLSTNID,IDBURP,ILAT,ILON,IDX,IDY,
& IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,0,IXAUX,0)
*
IF (IER.LT.0) LLERR=.TRUE.
IF ( CLSTNID(1:2) .eq. '>>')LLERR=.TRUE.
if (CLSTNID(1:1).eq.'^') THEN
WRITE(NULOUT,*) 'CH_CMAABRP: WARNING. Cannot handle grouped data.'
LLERR=.TRUE.
end if
*
IF (.NOT.LLERR) THEN
*
* Determine number of blocks in original report.
*
INBLKS=MRBPRML(IBUF,0,ITBL,10,JPMXBK)
*
* Get work copy of original report array.
*
* IBUF is kept unchanged.
* IBUFW will become the modified report.
*
IER=MRFGET(IHANDLP,IBUFW)
*
* Make certain work arrays large enough
*
ITOTDAT=IMXL
DO JK=1,INBLKS
INELE =ITBL(2,JK)
INVAL =ITBL(3,JK)
I3D =ITBL(4,JK)
IF (INELE*INVAL*I3D.GT.ITOTDAT)
& ITOTDAT=INELE*INVAL*I3D
END DO
IF (ITOTDAT.GT.IMXL) THEN
IMXL=ITOTDAT
CALL HPDEALLC(PXVAL,IER,1)
CALL HPDEALLC(PXSVAL,IER,1)
CALL HPDEALLC(PXTABL,IER,1)
CALL HPDEALLC(PXTABLS,IER,1)
CALL HPDEALLC(PXmark,IER,1)
CALL HPALLOC(PXVAL,ITOTDAT,IER,8)
CALL HPALLOC(PXSVAL,ITOTDAT,IER,8)
CALL HPALLOC(PXTABL,ITOTDAT,IER,1)
CALL HPALLOC(PXTABLS,ITOTDAT,IER,1)
CALL HPALLOC(PXmark,ITOTDAT,IER,1)
ENDIF
*
* Loop over blocks
*
INBON=0
ICOUNT=INBLKS
DO JK=1,INBLKS
IBTYP=ITBL(7,JK)
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IF( LCHECNAT(IBKNAT) .AND. LCHECTYP(IBKTYP)
+ .AND. LCHECSTP(IBKSTP) ) THEN
*
* Extract required data, std. dev. and marker blocks.
* Required to identify observations for which to extract
* info from the CMA and to set format of additional
* blocks to be added to the report.
*
IBKNO =ITBL(1,JK) ! Should be equal JK
INELE =ITBL(2,JK)
INVAL =ITBL(3,JK)
I3D =ITBL(4,JK)
IBFAM =ITBL(5,JK)
IDATYP=ITBL(10,JK)
*
* Identify species (or dynamics variable)
* Species identifier number is stored using the 7 left-most
* bits of the 12 bit IBFAM. When ISPECN=0, data are not
* species obs. but dynamics obs.
*
ISPECN=(IBFAM/32)*32
*
* Set number of values in block
*
ITOTDAT=INELE*INVAL*I3D
IKOUNT=IKOUNT+ITOTDAT
*
* Read DATA block content
*
CALL CH_RDBRPBLK(IBKNO,ILONG,IBUF,ILCOD,10,JPMXBK,
& ITBL,ZVAL,ITBLVAL,ILIST,INELE,INVAL,I3D)
*
* Search for MARKER block.
*
IBFAM=ISPECN
IBKNATMA=IBKNAT+3
IBKNMA=MRBLOCX(IBUF,IBFAM,-1,IBKNATMA,IBKTYP,IBKSTP,0)
*
IF (IBKNMA.GT.0) THEN
*
* Marker block found. Extract relevant info.
*
IER =MRBXTR(IBUF,IBKNMA,ILCODMA,IMARK)
*
INELM=ITBL(2,IBKNMA)
INVM=ITBL(3,IBKNMA)
INTM=ITBL(4,IBKNMA)
*
IER =MRBDCL(ILCODMA,ILSTM,INELM)
*
* Check for size consistency of marker and data block sizes
*
ICHECK=
+ IABS(INELE-INELM)+IABS(INVAL-INVM)+IABS(I3D-INTM)
DO JJ=1,INELE
ICHECK=ICHECK+IABS((ILSTM(JJ)-200000-ILIST(JJ)))
END DO
IF (ICHECK.NE.0) THEN
WRITE(NULOUT,*)
WRITE(NULOUT,*) 'INELE,INELM,INVAL,INVM,I3D,INTM: ',
& INELE,INELM,INVAL,INVM,I3D,INTM
CALL ABORT3D(NULOUT,'CH_CMAAPRB: Size inconsistency.')
END IF
ENDIF
*
* Search for obs. STD. DEV. block.
*
IBFAM=ISPECN+10
IBKNS=MRBLOCX(IBUF,IBFAM,-1,-1,-1,14,0)
*
IF (IBKNS.GT.0) THEN
*
* Found block with std. dev.. Extract relevant info.
*
CALL CH_RDBRPBLK(IBKNS,ILONG,IBUF,ILCODS,10,JPMXBK,
& ITBL,ZSVAL,ITBLVALS,ISLIST,INSELE,INSVAL,I3D)
*
* Only require consistency of INVAL and INSVAL.
*
IF (INSVAL.NE.INVAL) THEN
WRITE(NULOUT,*)
WRITE(NULOUT,*) 'INSVAL, INVAL: ',INSVAL,INVAL
CALL ABORT3D(NULOUT,'CH_BRPACMA: Size inconsistency.')
END IF
*
ELSE
IBKNS=0
INSELE=1
END IF
*
* Acquire and insert CMC data into
* BURP report storage array IBUFW
*
CALL CH_BDY2BRP(KLIST,KNVALS,IBKNO,IBKNMA,IBKNS
& ,ILIST,ISLIST,ITOPOST
& ,IBUFW,ILONG,IMARK,ZVAL,ZSVAL,IDBURP
& ,CLSTNID,INELE,INVAL,I3D,INSELE
& ,10,JPMXBK,ITBL,ILCOD,ILCODMA
& ,ILCODS,ITBLVAL,ITBLVALS,INBON,ICOUNT)
*
END IF
END DO
*
IF (INBON.GT.0) THEN
*
* Update BURP file with modified report.
*
NOBTOT=NOBTOT + 1
IFLGS=MOBHDR(NCMST1,NOBTOT)
IZMODEL= NINT(RMTMOBS(NOBTOT)/RG) + 400
IF(LLTOPOST) IFLGS = ibset(IFLGS , 12 )
ier=mrbupd(KFILE,IBUFW,-1,IFLGS,CLSTNID,
+ -1,-1,-1,-1,-1,-1,-1,-1,IZMODEL,
+ ICOUNT,-1,-1,-1,-1)
IER=MRFPUT(KFILE,IHANDLP,IBUFW)
ELSE
C
C Keep report but re-write (and do not increment NOBTOT)
C
ier=mrbupd(KFILE,IBUFW,-1,-1,CLSTNID,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,
+ ICOUNT,-1,-1,-1,-1)
IER=MRFPUT(KFILE,IHANDLP,IBUFW)
ENDIF
ENDIF
1 CONTINUE
*
CALL HPDEALLC(PXVAL ,IER,1)
CALL HPDEALLC(PXSVAL ,IER,1)
CALL HPDEALLC(PXTABL ,IER,1)
CALL HPDEALLC(PXTABLS ,IER,1)
CALL HPDEALLC(PXmark ,IER,1)
CALL HPDEALLC(PXBUFW ,IER,1)
CALL HPDEALLC(PXBUF ,IER,1)
*
CALL PRNTBRP(NOBTOT,IKOUNT,NDATA)
*
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END CH_CMAABRP -------------'
WRITE(NULOUT,*)' ------------------------------------------'
*
RETURN
END