SUBROUTINE CH_BRPACMA(CDTYPE,LDAPPEND,KFILE,KNRECS) 1,4
#if defined (DOC)
*
***s/r CH_BRPACMA -CONVERT DATA IN CMC BURP FILES (BURPV2.0 species format)
* TO CMA FOR 'TR' OBS FAMILY.
*
*Author . Y.J. Rochon, ARQX/EC Feb 2006
* Based on BRPACMA of P. KOCLAS(CMC TEL. 4665) and on earlier
* adaptations by Y. YANG for initial 'TR' BURP files.
*
*Revision:
* . See revisions for BRAPCMA
* Y.J. Rochon, Aug 2010
* - Added reading of info block to check for the need to read
* averaging kernels or correlation matrix.
* - Added *AVGKER* and *CORREL*
* Note: Identification of correlation/covariance matrices may need
* to be revisited (i.e. use of 25145).
*
*Important differences with BRPACMA (other than reading species BURP data)
*
* - Additions:
* 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.
*
* PURPOSE: TO READ DATA BLOCK IN BURP FILE (AND OTHER RELATED BLOCKS)
* AND TRANSFER ALL GOOD 'TR' FAMILY DATA TO CMA.
*
*
* ARGUMENTS:
* INPUT:
* -CDTYPE : DATA TYPE (I.E: UA=UPPER AIR ...)
* -LDAPPEND: .TRUE. -> APPEND DATA TO CMA FILE
* .FALSE.-> START NEW CMC FILE
* -KFILE : LOGICAL UNIT NUMBER OF BURP FILE
* -KNRECS : NUMBER OF RECORDS IN BURP FILE
*
* OUTPUT: NONE
*
#endif
*
IMPLICIT NONE
#include "comlun.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"
*
INTEGER KFILE,KNRECS
INTEGER INUM,ICOUNT
INTEGER ITOTDAT,IMXL
INTEGER ITECH,IMASK,ISAT,ISATCNT,ISATZEN,ITERRAIN
INTEGER ISENSOR,INSTRUM
*
CHARACTER *(*) CDTYPE
LOGICAL LDAPPEND
*
INTEGER IER
INTEGER IBTYP,IBKNAT,IBKTYP,IBKSTP,IBKNATMA
INTEGER IHANDL,IBKNO,I3D
INTEGER INELE,INVAL,INSELE,INSVAL
INTEGER ITIME,IFLGS,IDBURP,ILAT,ILON,IDX,IDY,
+ IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,IXAUX
INTEGER ISTNID14,ISTNID58,ISTNID99
CHARACTER *4 CSID14,CSID58
CHARACTER *2 CSID2
CHARACTER *1 CSID99
REAL*8 ZLONG,ZLAT
*
INTEGER MRFPUT,MRFVOI,MRBTYP,VMRFOPR,MRFOPN,MRFLOC,MRFGET
+ ,MRFMXL
INTEGER MRBINI,MRBADD,VMRBCVT,MRBXTR,MRBPRM,MRBDCL,MRBHDR
+ ,MRBPRML,MRBLOCX,MRBTBL
*
EXTERNAL MRFPUT,MRFVOI,MRBTYP,VMRFOPR,MRFOPN,MRFLOC,MRFGET
+ ,MRFMXL
EXTERNAL MRBINI,MRBADD,VMRBCVT,MRBXTR,MRBPRM,MRBDCL,MRBHDR
+ ,MRBPRML,MRBLOCX,MRBTBL
*
CHARACTER*9 CLSTNID
*
INTEGER ITBL(10,JPMXBK)
INTEGER ILSTM(JPMXNEL)
INTEGER ILISTIN(JPMXNEL)
INTEGER ILIST(JPMXNEL), ISLIST(JPMXNEL)
INTEGER ILCOD(JPMXNEL)
INTEGER ILCODS(JPMXNEL)
INTEGER ILCODMA(JPMXNEL)
*
INTEGER ITBLINF(1)
INTEGER IMARK(1)
INTEGER IBUF(1)
REAL*8 ZVAL(1),ZSVAL(1)
POINTER(PXVAL ,ZVAL)
POINTER(PXSVAL ,ZSVAL)
POINTER(PXmark ,Imark)
POINTER(PXTBL ,ITBLINF)
POINTER(PXBUF ,Ibuf)
*
INTEGER ISZA
REAL*8 ZTORAD, XLAT, XLON, ZSZA(JPMXNLV)
*
INTEGER JI,JJ,JK
INTEGER ICHECK,INELM,INVM,INTM,IBKNMA,IBFAM,ISPECN
INTEGER ILONG,INBLKS,IKOUNT,IND,INBON
LOGICAL LLERR,LLMA
LOGICAL LCHECNAT,LCHECTYP,LCHECSTP
C
INTEGER IAVGKERN,IAVGKERP,ICORREL,ICORRELP
C
*
************************************************************************
* SET BURP RELATED PARAMETERS VIA CALL TO RESUME SUBROUTINE
************************************************************************
*
WRITE(NULOUT,*)' ------------------------------------------------'
WRITE(NULOUT,*)' --------- BEGIN CH_BRPACMA ---------------'
WRITE(NULOUT,*)' ------------------------------------------------'
*
ZTORAD=RPI/180.
*
************************************************************************
* ALLOCATE SPACE FOR DATA BUFFFER AND SET "ATTRIBUTES"
* OF DATA TO BE READ VIA CALL TO RESUME ROUTINE
************************************************************************
*
ILONG=MRFMXL(KFILE)+20
CALL HPALLOC(PXBUF,ILONG,IER,1)
IBUF(1)=ILONG
IHANDL=MRFLOC(KFILE,0,'>>*******',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDL .LT. 0 ) THEN
IHANDL=MRFLOC(KFILE,0,'*********',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDL .LT. 0 ) THEN
WRITE(NULOUT,*)' BRPACMA: IMPOSSIBLE TO FIND VALID HANDLE'
RETURN
ENDIF
ENDIF
CALL RESUME(IHANDL,CDTYPE,IBUF)
IER=VMRFOPR('MISSING',PPMIS)
*
************************************************************************
* 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_BRPACMA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
RETURN
ENDIF
ENDIF
*
IKOUNT=0
IND =0
*
************************************************************************
* ALLOCATE SPACE TO READ DATA
************************************************************************
*
IHANDL=0
IMXL=1000
CALL HPALLOC(PXTBL,IMXL,IER,1)
CALL HPALLOC(PXVAL, IMXL,IER,8)
CALL HPALLOC(PXSVAL, IMXL,IER,8)
CALL HPALLOC(PXmark,IMXL,IER,1)
*-----------------------------------------------------------------------
DO 1 JI=1,KNRECS
LLERR=.FALSE.
*
************************************************************************
* LOCATE AND READ THE OBSERVATION
************************************************************************
*
IHANDL=MRFLOC(KFILE,IHANDL,'*********',-1,-1,-1,-1,-1,-1,0)
IF ( IHANDL .LT. 0 )LLERR=.TRUE.
*
IER=MRFGET(IHANDL,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)
ZLONG = (REAL(ILON)*0.01)
ZLAT = (REAL(ILAT)*0.01-90.)
*
IF (IER.LT.0) LLERR=.TRUE.
if (CLSTNID(1:2).eq.'>>') LLERR=.TRUE.
if (CLSTNID(1:1).eq.'^') THEN
WRITE(NULOUT,*) 'CH_BRPACMA: WARNING. Cannot handle grouped data.'
LLERR=.TRUE.
end if
IF ( .NOT. LLERR ) THEN
INBLKS=MRBPRML(IBUF,0,ITBL,10,JPMXBK)
*
************************************************************************
* Read and check uni info block
************************************************************************
*
IAVGKERN=0
IAVGKERP=0
ICORREL=0
ICORRELP=0
IBKNO=MRBLOCX(IBUF,-1,-1,1,-1,-1,0)
IF ( IBKNO .GT. 0 ) THEN
INELE =ITBL(2,IBKNO)
IF (INELE.GT.IMXL) THEN
IMXL=INELE
CALL HPDEALLC(PXTBL,IER,1)
CALL HPALLOC(PXTBL,INELE,IER,1)
ENDIF
IER=MRBXTR(IBUF,IBKNO,ILCOD,ITBLINF)
IER=MRBDCL(ILCOD,ILISTIN,INELE)
DO JK=1,INELE
IF (ILISTIN(JK).eq.15043) IAVGKERN=ITBLINF(JK)
IF (ILISTIN(JK).eq.25145) ICORREL=ITBLINF(JK)
END DO
ENDIF
*
************************************************************************
* Read and store obs data, stats, and flag blocks
************************************************************************
**
*
* 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(PXTBL,IER,1)
CALL HPDEALLC(PXVAL,IER,1)
CALL HPDEALLC(PXSVAL,IER,1)
CALL HPDEALLC(PXmark,IER,1)
CALL HPALLOC(PXTBL,ITOTDAT,IER,1)
CALL HPALLOC(PXVAL,ITOTDAT,IER,8)
CALL HPALLOC(PXSVAL,ITOTDAT,IER,8)
CALL HPALLOC(PXmark,ITOTDAT,IER,1)
ENDIF
C
INBON=0
ICOUNT=0
DO JK=1,INBLKS
IBTYP=ITBL(7,JK)
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IBKNMA=-1
IF( LCHECNAT(IBKNAT) .AND. LCHECTYP(IBKTYP)
+ .AND. LCHECSTP(IBKSTP) ) THEN
*
IBKNO =ITBL(1,JK) ! Should be the same as JK
INELE =ITBL(2,JK)
INVAL =ITBL(3,JK)
I3D =ITBL(4,JK)
IBFAM =ITBL(5,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 (unless specified as first
* two digits in STNID)
*
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,ITBLINF,ILIST,INELE,INVAL,I3D)
*
* Search for MARKER block.
*
IBFAM=ISPECN
IBKNATMA=IBKNAT+3
IBKNMA=MRBLOCX(IBUF,IBFAM,-1,IBKNATMA,IBKTYP,IBKSTP,0)
c
c IBKNMA=MRBLOCX(IBUF,IBFAM,-1,NBKNAUN,IBKTYP,IBKSTP,0)
c IF ( IBKNMA .LE. 0 ) THEN
c IBKNMA=MRBLOCX(IBUF,IBFAM,-1,NBKNAMU,IBKTYP,IBKSTP,0)
c ENDIF
*
IF ( IBKNMA.GT.0) THEN
*
* Marker block found. Extract relevant info.
*
LLMA=.TRUE.
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_BRPACMA: Size inconsistency.')
END IF
ENDIF
*
* Search for obs. STD. DEV. block.
*
IBFAM=ISPECN+10
IBKNMA=MRBLOCX(IBUF,IBFAM,-1,-1,-1,14,0)
*
IF (IBKNMA.GT.0) THEN
*
* Found block with std. dev.. Extract relevant info.
*
CALL CH_RDBRPBLK(IBKNMA,ILONG,IBUF,ILCODS,10,JPMXBK,
& ITBL,ZSVAL,ITBLINF,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
INSVAL=0
INSELE=0
END IF
*
* INSERT OBS DATA INTO CMA
*
CALL CH_BRP2BDY(IBKNO,ILIST,ISLIST,IMXL
& ,IMARK,ZVAL,ZSVAL,IALT,IDBURP,CLSTNID
& ,LLMA,INELE,INVAL,INSELE
& ,ZSZA,ISZA,ZLONG,ZLAT
& ,IAVGKERN,IAVGKERP,ICORREL,ICORRELP
& ,10,JPMXBK,ITBL,INUM,INBON)
ICOUNT=ICOUNT+INUM
*
ENDIF
END DO
1000 CONTINUE
*
************************************************************************
* INSERT MISCELLANEOUS OBS INFO INTO CMA HEADER ARRAYS
************************************************************************
*
IF (ICOUNT.GT.0) THEN
IF (ISZA.GT.0) THEN
*
* Change SZA into integer to be stored in MOBHDR(NCMBOX,..)
*
ISATZEN = INT(ZSZA(1) *100.0)
IMASK=0
INSTRUM=0
ISAT =0
ITECH=0
ELSE
ITECH=0
IMASK=0
INSTRUM=0
ISAT=0
ISATZEN=0
ENDIF
*
************************************************************************
* IF VALID DATA WAS FOUND GENERATE THE CMA HEADER
* AND INCREMENT NOBTOT
************************************************************************
*
IF ( NOBTOT .LT. NMXOBS) THEN
NOBTOT=NOBTOT + 1
csid14=CLSTNID(1:4)
csid58=CLSTNID(5:8)
csid99=CLSTNID(9:9)
READ(csid14,'(a4)')ISTNID14
READ(csid58,'(a4)')ISTNID58
READ(csid99,'(a1)')ISTNID99
CSTNID(NOBTOT)=CLSTNID
ROBHDR(NCMLON,NOBTOT) = (REAL(ILON)*0.01)*ZTORAD
ROBHDR(NCMLAT,NOBTOT) = (REAL(ILAT)*0.01-90.)*ZTORAD
ROBHDR(NCMALT,NOBTOT) = (REAL(IALT)-400)
ROBHDR(NCMTLO,NOBTOT) = (REAL(ILON)*0.01)*ZTORAD
ROBHDR(NCMTLA,NOBTOT) = (REAL(ILAT)*0.01-90.)*ZTORAD
MOBHDR(NCMNLV,NOBTOT) = INBON
*
IF ( NOBTOT .EQ. 1) THEN
MOBHDR(NCMRLN,1)=1
ELSE
MOBHDR(NCMRLN,NOBTOT) = MOBHDR(NCMRLN,NOBTOT-1)
+ + MOBHDR(NCMNLV,NOBTOT-1)
ENDIF
*
************************************************************************
* REMAINDER OF HEADER
************************************************************************
*
MOBHDR(NCMONM,NOBTOT) = NOBTOT
MOBHDR(NCMBOX,NOBTOT) = INSTRUM + ISATZEN*10000
MOBHDR(NCMOTP,NOBTOT) = NVTYP
MOBHDR(NCMITY,NOBTOT) = IDBURP+ 1000*ISAT+ 1000000*ITECH
MOBHDR(NCMDAT,NOBTOT) = IDATE
MOBHDR(NCMETM,NOBTOT) = ITIME
MOBHDR(NCMSID,NOBTOT) = ISTNID14
MOBHDR(NCMSI2,NOBTOT) = ISTNID58
MOBHDR(NCMSI3,NOBTOT) = ISTNID99
MOBHDR(NCMOEC,NOBTOT) = 999
MOBHDR(NCMOFL,NOBTOT) = IMASK
MOBHDR(NCMST1,NOBTOT) = IFLGS
*
MOBHDR(NCMNUM,NOBTOT) = ICOUNT
*
MOBHDR(NCMKER,NOBTOT) = IAVGKERP
MOBHDR(NCMCOR,NOBTOT) = ICORRELP
ENDIF
c ELSE
c WRITE(NULOUT,*)' WARNING: CH_BRPACMA: NO VALID DATA'
c & ,' OBS ',CLSTNID,' TYPE ',IDBURP,' LAT ', ILAT,
c & ' LON ', ILON
ENDIF
IF ( NDATA .GE. NDATAMX .OR. NOBTOT .GE. NMXOBS ) THEN
CALL HPDEALLC(PXTBL ,IER,1)
CALL HPDEALLC(PXVAL ,IER,1)
CALL HPDEALLC(PXmark ,IER,1)
CALL HPDEALLC(PXBUF ,IER,1)
*
*-----------------------------------------------------------------------
WRITE(NULOUT,*)' ******************************************'
WRITE(NULOUT,*)' * ATTN ATTN ATTN ATTN ATTN ATTN *'
WRITE(NULOUT,*)' * ATTN ATTN ATTN ATTN ATTN ATTN *'
WRITE(NULOUT,*)' * *'
WRITE(NULOUT,*)' * CMA FILE FULL: NO MORE DATA READ *'
WRITE(NULOUT,*)' * ABORT WHEN LABORTFULL = .TRUE. *'
WRITE(NULOUT,*)' * *'
WRITE(NULOUT,*)' * CHECK NMXOBS, NDATAMX IN NAMELIST *'
WRITE(NULOUT,*)' * *'
WRITE(NULOUT,*)' * LABORTFULL = .TRUE. ==> CALL ABORT *'
WRITE(NULOUT,*)' * LABORTFULL = .FALSE. ===> CONTINUE *'
WRITE(NULOUT,*)' * *'
WRITE(NULOUT,*)' ******************************************'
*
WRITE(NULOUT,*)'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
WRITE(NULOUT,*)' WARNING: CH_BPRACMA: CMA FILE FULL'
WRITE(NULOUT,*)'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
*
WRITE(NULOUT,'(1x,"NDATA = ",I10," NDATAMX",I10)')
& NDATA, NDATAMX
WRITE(NULOUT,'(1x,"NOBTOT= ",I10," NMXOBS = ",I10)')
& NOBTOT, NMXOBS
WRITE(NULOUT,*)' LABORTFULL = ', LABORTFULL
*
CALL PRNTBRP(NOBTOT,IKOUNT,NDATA)
*
IF (LABORTFULL) THEN
WRITE(NULOUT,*)' CH_BRPACMA: CMA FILE FULL - CALL ABORT3D '
call abort3d(nulout,'CH_BRPACMA')
ELSE
WRITE(NULOUT,*)' CH_BRPACMA: CMA FILE FULL - CONTINUE '
ENDIF
*
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END CH_BRPACMA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
RETURN
ENDIF
ENDIF
1 CONTINUE
CALL HPDEALLC(PXTBL ,IER,1)
CALL HPDEALLC(PXVAL ,IER,1)
CALL HPDEALLC(PXSVAL ,IER,1)
CALL HPDEALLC(PXmark ,IER,1)
CALL HPDEALLC(PXBUF ,IER,1)
*
*-----------------------------------------------------------------------
CALL PRNTBRP(NOBTOT,IKOUNT,NDATA)
*
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END CH_BRPACMA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
*
RETURN
END