!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE BRPACMA_LA(CDTYPE,indxfile,LDAPPEND,KFILE,KNRECS) 1,49
#if defined (DOC)
*
***s/r BRPACMA_LA - version of brpacma when in grd_typ = 'LU' mode and lsw.
*
*Author . Luc Fillion - 19 Mar 2008.
*
*Revision:
* . S. Macpherson *MRD/ARMA August 2008
* - Add code for GB-GPS (GP) data
* Bin He *ARMA/MRB Jan. 2010
* - MPI Implemented to 3DVAR
*
* PURPOSE: TO READ ALL DATA BLOCKS IN BURP FILE AND TRANSFER
* ALL GOOD DATA TO CMA.
*
*
* ARGUMENTS:
* INPUT:
*
* -CDTYPE : DATA TYPE (I.E: UA=UPPER AIR ...)
* -indxfile: the index of the array CFAMTYP(j)
* -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 "cvcord.cdk"
#include "comnumbr.cdk"
#include "comct0.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comgdpar.cdk"
#include "namcva.cdk"
#include "comcva.cdk"
*
INTEGER KFILE,KNRECS,jji,jn,jpnbrelem
INTEGER iind2,IIND,IPOS,ILPOS,INELEFD,ISCRAP
INTEGER ITOTDAT,IMXL,IMXL3D,IMXLINF
INTEGER ITECH,IMASK,ISAT,ISATCNT,ISATZEN,ITERRAIN
INTEGER ISENSOR,INSTRUM,ISATAZIM,ISUNZA,ICLFR
*
CHARACTER *(*) CDTYPE
INTEGER indxfile
LOGICAL LDAPPEND,LLSURF
*
INTEGER IER
INTEGER IBTYP,IBKNAT,IBKTYP,IBKSTP,ibknatma
INTEGER IHANDL,IBKNO,I3D
INTEGER INELE,INVAL
INTEGER INELEIN
INTEGER INELE3D
INTEGER IDLT,ITIME,IFLGS,IDBURP,ILAT,ILON,IDX,IDY,
+ IALT,IDELAY,IDATE,IRS,IRUNN,INBLK,ISUP,IXAUX
INTEGER ISTNID14,ISTNID58,ISTNID99
CHARACTER *4 CSID14,CSID58
CHARACTER *1 CSID99
integer gdxyfll
real xpti(1), ypti(1), xlati(1), xloni(1)
*
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
*
REAL*8 ZPROF(jpmxnlv),ZEXTRA(jpmxnlv)
INTEGER ITBL(10,JPMXBK)
INTEGER ILSTM(JPMXNEL)
INTEGER ILIST3D(JPMXNEL)
INTEGER ILISTIN(JPMXNEL)
INTEGER ILIST(JPMXNEL)
INTEGER ILCOD3D(JPMXNEL)
INTEGER ILCOD(JPMXNEL)
INTEGER ILCODMA(JPMXNEL)
INTEGER ILISTNELE(JPMXNEL)
*
INTEGER ITBLVAL(1)
INTEGER ITBL3D(1)
INTEGER ITBLINF(1)
INTEGER IMARK(1)
INTEGER IBUF(1)
REAL*8 ZVAL(1)
REAL*8 ZVAL3D(1)
POINTER(PXVAL ,ZVAL)
POINTER(PXVAL3D ,ZVAL3D)
POINTER(PXTABL ,ITBLVAL)
POINTER(PXTABL3D ,ITBL3D)
POINTER(PXTABLINF,ITBLINF)
POINTER(PXmark ,Imark)
POINTER(PXBUF ,Ibuf)
*
REAL*8 ZTORAD, XLAT, XLON
*
INTEGER JI,JJ,JK,J3D
INTEGER ICHECK,INELM,INVM,INTM,IBKNMA
INTEGER ILONG,INBLKS,IKOUNT,IND,INBON,IEXTRAEL
LOGICAL LLERR,LLMA,LLGROUP,LLERROR,LLSAT,LLUNI,LLRESET,LLGO,LLAIRS
LOGICAL LCHECNAT,LCHECTYP,LCHECSTP
logical lldocma
C
C GENERATE TABLES TO ADJUST VERTICAL COORDINATE OF SURFACE DATA
C
do jj=1,254
do jn=1,jpnbrelem
vcordsf(jn,jj)=0.
end do
end do
*
************************************************************************
* SET BURP RELATED PARAMETERS VIA CALL TO RESUME SUBROUTINE
************************************************************************
*
WRITE(NULOUT,*)' ------------------------------------------------'
WRITE(NULOUT,*)' --------- BEGIN BRPACMA_LA ---------------'
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)
CALL HPALLOC(PXBUF, ILONG + 20,IER,1)
IBUF(1)=ILONG + 20
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_LA: 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 BRPACMA_LA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
RETURN
ENDIF
ENDIF
*
IKOUNT=0
IND =0
*
************************************************************************
* ALLOCATE SPACE TO READ DATA
************************************************************************
*
IHANDL=0
IMXL=1000
IMXL3D=400
IMXLINF=400
CALL HPALLOC(PXVAL, IMXL,IER,8)
CALL HPALLOC(PXVAL3D,IMXL3D,IER,8)
CALL HPALLOC(PXTABL,IMXL,IER,1)
CALL HPALLOC(PXmark,IMXL,IER,1)
CALL HPALLOC(PXTABL3D,IMXL3D,IER,1)
CALL HPALLOC(PXTABLINF,IMXLINF,IER,1)
*-----------------------------------------------------------------------
DO 1 JI=1,KNRECS
LLERR=.FALSE.
itbl=0
*
************************************************************************
* 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)
*
** Temporarily re-define NVCORD for GOES radiances (IDBURP=180).
** This is done until a more general BURP structure is defined
** and valid for all radiances from any platform.
** Also special case for EXPERIMENTAL AIRS data.
** ------------
*
IF ( IDBURP .EQ. 180 ) THEN
NVCORD = 5042
ELSEIF ( IDBURP .EQ. 164 .AND. CLSTNID .EQ. 'UNKNOWN' ) THEN
NVCORD = 5042
ELSEIF ( IDBURP .EQ. 168 .AND. CLSTNID(1:5) .EQ. '^DMSP' ) THEN
NVCORD = 5042
ELSEIF ( IDBURP .EQ. 183 .AND. CLSTNID(1:5) .EQ. '^AQUA' ) THEN
NVCORD = 5042
ELSEIF ( IDBURP .EQ. 164 .AND. CLSTNID(1:5) .EQ. '^NOAA' ) THEN
NVCORD = 2150
ELSEIF ( IDBURP .EQ. 164 .AND. CLSTNID(1:5) .EQ. '^AQUA' ) THEN
NVCORD = 2150
ENDIF
IF (IER.LT.0) LLERR=.TRUE.
*
************************************************************************
* EXTRACT THE DATA AND FLAG BLOCKS
************************************************************************
*
if ( CLSTNID(1:2) .eq. '>>') LLERR=.TRUE.
IF ( .NOT. LLERR ) THEN
INBLKS=MRBPRML(IBUF,0,ITBL,10,JPMXBK)
*
IF ( CLSTNID(1:1) .EQ. '^' ) THEN
IBKNO=MRBLOCX(IBUF,-1,-1,2,-1,-1,0)
IF (IBKNO .LT. 0) IBKNO=MRBLOCX(IBUF,-1,-1,6,-1,-1,0)
LLGROUP=.TRUE.
IF ( IBKNO .GT. 0 ) THEN
I3D =ITBL(4,IBKNO)
INELE3D =ITBL(2,IBKNO)
ITOTDAT=I3D*INELE3D
IF ( ITOTDAT .GT. IMXL3D) THEN
IMXL3D=ITOTDAT
CALL HPDEALLC(PXTABL3D,IER,1)
CALL HPDEALLC(PXVAL3D,IER,1)
CALL HPALLOC(PXTABL3D,IMXL3D,IER,1)
CALL HPALLOC(PXVAL3D,IMXL3D,IER,8)
ENDIF
IER=MRBXTR(IBUF,IBKNO,ILCOD3D,ITBL3D)
IER=VMRBCVT(ILCOD3D,ITBL3D,ZVAL3D,INELE3D,1,I3D,0)
IER=MRBDCL(ILCOD3D,ILIST3D,INELE3D)
ENDIF
ELSE
LLGROUP=.FALSE.
I3D=1
ENDIF
*
*----------------------->
* uni info block
*----------------------->
*
IBKNO =MRBLOCX(IBUF,-1,-1,1,-1,-1,0)
IF ( IBKNO .GT. 0 ) THEN
INELEIN =ITBL(2,IBKNO)
ITOTDAT=I3D*INELEIN
IF ( ITOTDAT .GT. IMXLINF) THEN
IMXLINF=ITOTDAT
CALL HPDEALLC(PXTABLINF,IER,1)
CALL HPALLOC(PXTABLINF,IMXLINF,IER,1)
ENDIF
IER=MRBXTR(IBUF,IBKNO,ILCOD3D,ITBLINF)
IER=MRBDCL(ILCOD3D,ILISTIN,INELEIN)
LLUNI=.TRUE.
ELSE
LLUNI=.FALSE.
ENDIF
*
*----------------------->
* data blocks
*----------------------->
*
IPOS=1
ILPOS=1
ITOTDAT=0
DO JK=1,INBLKS
LLSURF=.FALSE.
IBTYP=ITBL(7,JK)
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IBKNMA=-1
IF( LCHECNAT(IBKNAT) .AND. LCHECTYP(IBKTYP)
+ .AND. LCHECSTP(IBKSTP) ) THEN
IBKNO =MRBLOCX(IBUF,-1,-1,IBKNAT,IBKTYP,IBKSTP,0)
INELE =ITBL(2,JK)
INVAL =ITBL(3,JK)
* ALLOW 2 EXTRA ELEMENTS IN CASE WE NEED TO ADDP FF DD WIND ARRAYS TO CMA
* ALLOW 1 EXTRA ELEMENT FOR LQ
IEXTRAEL=3
ibknatma=(IBKNAT + 3)
ITOTDAT=ITOTDAT + (INELE+IEXTRAEL)*INVAL*I3D
IF ( ITOTDAT .GT. IMXL) THEN
IMXL=ITOTDAT
CALL HPDEALLC(PXVAL,IER,1)
CALL HPDEALLC(PXTABL,IER,1)
CALL HPDEALLC(PXmark,IER,1)
CALL HPALLOC(PXVAL,ITOTDAT,IER,8)
CALL HPALLOC(PXTABL,ITOTDAT,IER,1)
CALL HPALLOC(PXmark,ITOTDAT,IER,1)
ENDIF
IER=MRBXTR(IBUF,IBKNO,ILCOD(ILPOS),ITBLVAL(IPOS))
do jji =1,INELE*INVAL*I3D
ZVAL(ipos + jji-1)=ITBLVAL(IPOS + jji -1)
end do
*
IER=VMRBCVT(ILCOD(ILPOS),ITBLVAL(IPOS),ZVAL(ipos),
& INELE,INVAL,I3D,0)
IER=MRBDCL(ILCOD(ILPOS),ILIST(ilpos),INELE)
*
IBKNMA=MRBLOCX(IBUF,-1,-1,NBKNAUN,IBKTYP,IBKSTP,0)
IF ( IBKNMA .LE. 0 ) THEN
IBKNMA=MRBLOCX(IBUF,-1,-1,NBKNAMU,IBKTYP,IBKSTP,0)
ENDIF
C
IF ( IBKNMA .GT. 0 ) THEN
IER =MRBXTR(IBUF,IBKNMA,ILCODMA(ILPOS),IMARK(IPOS))
*
INELM =ITBL(2,IBKNMA)
INVM =ITBL(3,IBKNMA)
INTM =ITBL(4,IBKNMA)
IER =MRBDCL(ILCODMA(ILPOS),ILSTM(ILPOS),INELM)
ICHECK=
+ IABS(INELE-INELM)+IABS(INVAL-INVM)+IABS(I3D-INTM)
DO JJ=ILPOS,ILPOS+INELE-1
ICHECK=ICHECK+IABS((ILSTM(JJ)-200000-ILIST(JJ)))
END DO
LLMA= (ICHECK .EQ. 0 )
llma=.true.
*-----------------------------------------------------------------------
* TRANSFER REJECT FLAGS BETWEEN WIND DIRECTION AND SPEED
*-----------------------------------------------------------------------
CALL FLAGWND(IMARK(IPOS)
+ ,ILSTM(ILPOS),INELM,INVM,INTM
+ ,CLSTNID,IDBURP,ILAT,ILON)
*-----------------------------------------------------------------------
ENDIF
*-----------------------------------------------------------------------
* CONVERT F-D WIND TO U-V COMPONENTS
*-------------------------------------------------------------------
if ( ibknat .eq. 0 .and. cdtype .eq. 'UA') then
nvcordtyp=1
LLSURF = .TRUE.
endif
if ( ibknat .eq. 4 .and. cdtype .eq. 'UA')nvcordtyp=2
if ( cdtype == 'SF' .OR. cdtype == 'SC'
& .OR. LLSURF ) then
CALL VCORDADJ(IDBURP,ZVAL(IPOS),IMARK(IPOS)
+ ,ILIST(ILPOS),INELE,INVAL,I3D,ISCRAP)
endif
CALL FDTOUV(ZVAL(IPOS),IMARK(IPOS),ILIST(ILPOS),INELE,
+ INVAL,I3D,INELEFD)
ILISTNELE(JK)=INELEfd
INELE=ILISTNELE(JK)
CALL FLAGFDTOUV(IMARK(IPOS)
+ ,ILIST(ILPOS),INELE,INVAL,I3D
+ ,CLSTNID,IDBURP,ILAT,ILON)
*-----------------------------------------------------------------------
* CONVERT ES TO HU
*-------------------------------------------------------------------
CALL ESTOHU(ZVAL(IPOS),IMARK(IPOS),ILIST(ILPOS),INELE,
+ INVAL,I3D,INELEFD)
ILISTNELE(JK)=INELEfd
INELE=ILISTNELE(JK)
*-------------------------------------------------------------------
ILPOS=INELE + ILPOS
IPOS =INELE*INVAL*I3D + IPOS
IKOUNT=IKOUNT + INELE*INVAL*I3D
ENDIF
END DO
*
************************************************************************
* INSERT DATA INTO CMA FILE
************************************************************************
*
DO J3D=1,I3D
IPOS=1
ILPOS=1
INBON=0
IND=0
DO 3 JK=1,inblks
LLSURF=.FALSE.
IBTYP=ITBL(7,JK)
IER=MRBTYP(IBKNAT,IBKTYP,IBKSTP,IBTYP)
IF( LCHECNAT(IBKNAT) .AND. LCHECTYP(IBKTYP)
+ .AND. LCHECSTP(IBKSTP) ) THEN
if ( ibknat .eq. 0 .and. cdtype .eq. 'UA') then
nvcordtyp=1
LLSURF = .TRUE.
endif
if ( ibknat .eq. 4 .and. cdtype .eq. 'UA')
+ nvcordtyp=2
INELE =ITBL(2,JK)
INELE =ilistnele(jk)
INVAL =ITBL(3,JK)
CALL GETELE(NVCORD,J3D,ILIST(ILPOS),ZVAL(IPOS),
+ ZPROF,INELE,INVAL,I3D,IIND)
if ( cdtype == 'SF' .OR. cdtype == 'SC'
& .OR. LLSURF ) then
iind=1
zprof(1)=REAL(IALT-400)
endif
*
* FOR GB-GPS DATA, USE STATION HEIGHT FOR ZPROF
*----------------------------------------------------------------------
*
if ( cdtype .eq. 'GP' ) then
iind=1
zprof(1)=REAL(IALT-400)
endif
*
* FOR PROFILER DATA, ADD STATION HEIGHT TO ZPROF
* FOR USE IN NCMPPP
*----------------------------------------------------------------------
*
if ( cdtype .eq. 'PR' ) then
DO jj=1,INVAL
zprof(JJ)=REAL(IALT-400) + zprof(JJ)
END DO
endif
*
* FOR HUMSAT DATA GET THE OBSERVATION ERROR IS
* CONTAINED IN THE REPORT DATA BLOCK
*----------------------------------------------------------------------
*
IF ( CDTYPE .EQ. 'HU' ) THEN
CALL GETELE(12230,J3D,ILIST(ILPOS),ZVAL(IPOS),
+ ZEXTRA,INELE,INVAL,I3D,IIND)
LLERROR=.TRUE.
ELSE
LLERROR=.FALSE.
ENDIF
*
* FOR GOES OR AIRS DATA GET THE SURFACE EMISSIVITY WHICH IS
* CONTAINED IN THE REPORT DATA BLOCK
*----------------------------------------------------------------------
*
IF ( CDTYPE .EQ. 'GO' ) THEN
CALL GETELE(55043,J3D,ILIST(ILPOS),ZVAL(IPOS),
+ ZEXTRA,INELE,INVAL,I3D,IIND)
LLGO=.TRUE.
ELSE
LLGO=.FALSE.
ENDIF
IF ( CLSTNID(1:5) .EQ. '^AQUA' .AND. IDBURP .EQ. 183 ) THEN
IF ( NCONF .NE. 101 ) THEN
CALL GETELE(55043,J3D,ILIST(ILPOS),ZVAL(IPOS),
+ ZEXTRA,INELE,INVAL,I3D,IIND)
LLAIRS=.TRUE.
ELSE
LLAIRS=.FALSE.
END IF
ELSE
LLAIRS=.FALSE.
ENDIF
*
*----------------------------------------------------------------------
*
* FOR SATEMS REFERENCE PRESSSURE IS CONTAINED IN THE REPORT DATA BLOCK
*----------------------------------------------------------------------
*
IF ( CDTYPE .EQ. 'ST' ) THEN
CALL GETELE(07193,J3D,ILIST(ILPOS),ZVAL(IPOS),
+ ZEXTRA,INELE,INVAL,I3D,IIND)
LLSAT=.TRUE.
ELSE
LLSAT=.FALSE.
ENDIF
*----------------------------------------------------------------------
*
lldocma = .true.
!
IF ( IIND .GT. 0 ) THEN
!
if (grd_typ.eq.'LU'.or.multi_grd.gt.0) then
!
! Get latitude and longitude and select obs within analysis domain
!
IF (LLGROUP ) THEN
CALL GETELE(5002,J3D,ILIST3D,ZVAL3D,
& XLAT,INELE3D,1,I3D,IIND)
CALL GETELE(6002,J3D,ILIST3D,ZVAL3D,
& XLON,INELE3D,1,I3D,IIND)
!
ILAT = 9000 + NINT(XLAT*100.)
ILON = NINT(XLON*100.)
IF ( ILON .LT. 0 ) ILON = 36000 + ILON
ELSE
xlat = (float(ilat) - 9000.0) / 100.0
xlon = float(ilon) / 100.0
ENDIF
if (xlon.lt.0.0) then
xlon = 360.0 + xlon
endif
xlati(1) = xlat
xloni(1) = xlon
! write(nulout,*) 'BRPACMA_LA: xlati, xloni=',xlati, xloni
ier = gdxyfll(ngid_an, xpti, ypti,
& xlati, xloni, 1)
! write(nulout,*) 'BRPACMA_LA: ngid_an = ',ngid_an
! write(nulout,*) 'BRPACMA_LA: xpti(1),ypti(1)=',xpti(1),ypti(1)
! write(nulout,*) 'BRPACMA_LA: mni_in,mnj_in=',mni_in,mnj_in
! write(nulout,*) 'BRPACMA_LA: miobsbufn=', miobsbufn
! write(nulout,*) 'BRPACMA_LA: miobsbufs=', miobsbufs
! write(nulout,*) 'BRPACMA_LA: miobsbufe=', miobsbufe
! write(nulout,*) 'BRPACMA_LA: miobsbufw=', miobsbufw
!
if (xpti(1).le.(1+miobsbufw).or.
& xpti(1).ge.(mni_in-miobsbufe)) then
lldocma = .false.
else if (ypti(1).le.(1+mjobsbufs).or.
& ypti(1).ge.(mnj_in-mjobsbufn)) then
lldocma = .false.
else
lldocma = .true.
endif
endif
!
IF (CDTYPE .EQ. 'MI' ) THEN
if (lldocma) then
CALL CMABDY(ZVAL(IPOS),ILIST(ILPOS),IMARK(ipos),
+ LLMA,ZEXTRA,LLERROR,LLSAT,LLGO,LLAIRS,INELE,INVAL,I3D,IND,
+ -1 ,ZPROF,J3D,IDBURP)
endif
ELSE
if (lldocma) then
CALL CMABDY(ZVAL(IPOS),ILIST(ILPOS),IMARK(ipos),
+ LLMA,ZEXTRA,LLERROR,LLSAT,LLGO,LLAIRS,INELE,INVAL,I3D,IND,
+ NVCORD,ZPROF,J3D,IDBURP)
endif
ENDIF
ELSE
IF (CDTYPE .NE. 'TO') THEN
write(nulout,*)'for station:',clstnid
+ ,' vertical coordinate not found:',NVCORD
ENDIF
IND =0
ENDIF
ILPOS=INELE + ILPOS
IPOS =INELE*INVAL*I3D + IPOS
INBON =INBON + IND
ENDIF
3 CONTINUE
IF ( INBON .GT. 0 ) THEN
*
************************************************************************
* for grouped data: get date time latitude and longitude
* from 3d description block
************************************************************************
*
IF (LLGROUP ) THEN
CALL IGETELE
+ (55200,J3D,ILIST3D,ITBL3D,IFLGS,INELE3D,1,I3D,IIND)
CALL IGETELE
+ (4196,J3D,ILIST3D,ITBL3D,IDATE,INELE3D,1,I3D,IIND)
IF ( IIND .EQ. -1)
+ CALL IGETELE
+ (4208,J3D,ILIST3D,ITBL3D,IDATE,INELE3D,1,I3D,IIND)
CALL IGETELE
+ (4197,J3D,ILIST3D,ITBL3D,ITIME,INELE3D,1,I3D,IIND)
*
CALL GETELE(5002,J3D,ILIST3D,ZVAL3D,
+ XLAT,INELE3D,1,I3D,IIND)
CALL GETELE(6002,J3D,ILIST3D,ZVAL3D,
+ XLON,INELE3D,1,I3D,IIND)
*
** convert from burp units:
** latitude : [-90.00, +90.00], longitude : [-180.00,+180.00],
** to cma units:
** latitude : [ 0, 18000], longitude : [ 0, 36000].
*
ILAT = 9000 + NINT(XLAT*100.)
ILON = NINT(XLON*100.)
IF ( ILON .LT. 0 ) ILON = 36000 + ILON
*
CALL IGETELE
+ (4016,J3D,ILIST3D,ITBL3D,IDLT,INELE3D,1,I3D,IIND)
ENDIF
*
*
************************************************************************
* for tovs data: get retrieval technique satellite, satellite number,
* land/sea mask, scan position, satellite zenith angle,
* terrain type and satellite sensor indicator/instrument
* from info block
************************************************************************
*
IF ( CDTYPE .EQ. 'TO' ) THEN
*
CALL IGETELE
+ (2022,J3D,ILISTIN,ITBLINF,ITECH,INELEIN,1,I3D,IIND)
***************use bit #'s 3,4 and 5; set other bits to zero.
***************correct for NESDIS BUFR coding error of cloudy path. Correction is:
***************if clear path bit off or if element not found, then it is assumed cloudy.
IF ( IIND .NE. -1 ) THEN
ITECH = AND(ITECH,56)
IF (ITECH .EQ. 0 ) THEN
ITECH = 8
ENDIF
ELSE
ITECH = 8
ENDIF
*
CALL IGETELE
+ (1007,J3D,ILISTIN,ITBLINF,ISAT,INELEIN,1,I3D,IIND)
*
CALL IGETELE
+ (8012,J3D,ILISTIN,ITBLINF,IMASK,INELEIN,1,I3D,IIND)
*
** terrain type
CALL IGETELE
+ (13039,J3D,ILISTIN,ITBLINF,ITERRAIN,INELEIN,1,I3D,IIND)
*
* Is terrain type sea ice (iterrain=0)?, If so, sert imask=2.
IF ( IIND .NE. -1 .AND.
+ ITERRAIN .EQ. 0 ) THEN
IMASK = 2
ENDIF
*
** satellite sensor indicator (element #2048) or
** satellite instrument (element #2019).
** If element #2048 is present, map into element #2019.
CALL IGETELE
+ (2048,J3D,ILISTIN,ITBLINF,ISENSOR,INELEIN,1,I3D,IIND)
IF ( IIND .EQ. -1 ) THEN
CALL IGETELE
+ (2019,J3D,ILISTIN,ITBLINF,INSTRUM,INELEIN,1,I3D,IIND)
IF ( IIND .EQ. -1 ) THEN
INSTRUM = 0
ENDIF
ELSE
CALL CVT_BURP_INSTRUM(ISENSOR,INSTRUM)
ENDIF
*
* Define ISAT for AIRS which has no element #1007
IF ( INSTRUM == 420 ) ISAT = 784
*
ISATZEN = 9000
IF ( ISAT .GE. 206 ) THEN
* satellite zenith angle
CALL IGETELE
+ (7024,J3D,ILISTIN,ITBLINF,ISATZEN,INELEIN,1,I3D,IIND)
* satellite azimuth angle
CALL IGETELE
+ (5021,J3D,ILISTIN,ITBLINF,ISATAZIM,INELEIN,1,I3D,IIND)
* sun zenith angle
CALL IGETELE
+ (7025,J3D,ILISTIN,ITBLINF,ISUNZA,INELEIN,1,I3D,IIND)
* cloud fraction
CALL IGETELE
+ (20010,J3D,ILISTIN,ITBLINF,ICLFR,INELEIN,1,I3D,IIND)
ENDIF
ELSE IF ( CDTYPE .EQ. 'ST' ) THEN
IF ( LLUNI) THEN
CALL IGETELE
+ (2022,J3D,ILISTIN,ITBLINF,ITECH,INELEIN,1,I3D,IIND)
ELSE
ITECH=0
ENDIF
IMASK=0
INSTRUM=0
ISAT =0
ISATZEN =0
*
************************************************************************
* for goes data: get retrieval technique satellite, satellite number,
* land/sea mask, satellite zenith angle from info block
************************************************************************
*
ELSE IF ( CDTYPE .EQ. 'GO' ) THEN
*
* satellite processing technique n/a for goes data atm
ITECH = 8
*
** satellite instrument (element #2019).
c CALL IGETELE
c + (2019,J3D,ILISTIN,ITBLINF,INSTRUM,INELEIN,1,I3D,IIND)
c IF ( IIND .EQ. -1 ) THEN
INSTRUM = 0
c ENDIF
*
* satellite identifier number
CALL IGETELE
+ (1007,J3D,ILISTIN,ITBLINF,ISAT,INELEIN,1,I3D,IIND)
*
* land/sea mask
CALL IGETELE
+ (8012,J3D,ILISTIN,ITBLINF,IMASK,INELEIN,1,I3D,IIND)
*
* satellite zenith angle
CALL IGETELE
+ (7024,J3D,ILISTIN,ITBLINF,ISATZEN,INELEIN,1,I3D,IIND)
*
ELSE
ITECH=0
IMASK=0
INSTRUM=0
ISAT =0
ISATZEN =0
ISATAZIM =0
ISUNZA = 0
ICLFR = 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) = indxfile
MOBHDR(NCMOFL,NOBTOT) = IMASK
MOBHDR(NCMST1,NOBTOT) = IFLGS
MOBHDR(NCMAZA,NOBTOT) = ISATAZIM
MOBHDR(NCMSUN,NOBTOT) = ISUNZA
MOBHDR(NCMCLF,NOBTOT) = ICLFR
ENDIF
ELSE
if (lldocma) then
WRITE(NULOUT,*)' Warning 3DV:BRPACMA_LA: NO VALID DATA'
& ,' OBS ',CLSTNID,' TYPE ',IDBURP,' LAT ', ILAT,
& ' LON ', ILON
endif
ENDIF
IF ( NDATA .GE. NDATAMX .OR. NOBTOT .GE. NMXOBS ) THEN
CALL HPDEALLC(PXVAL ,IER,1)
CALL HPDEALLC(PXVAL3D ,IER,1)
CALL HPDEALLC(PXTABL ,IER,1)
CALL HPDEALLC(PXTABL3D ,IER,1)
CALL HPDEALLC(PXTABLINF,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,*)'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
WRITE(NULOUT,*)' Warning 3DV:BRPACMA_LA: CMA FILE FULL'
WRITE(NULOUT,*)'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
*
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,*)' BRPACMA_LA: CMA FILE FULL - CALL ABORT3D '
call abort3d(nulout,'BRPACMA_LA')
ELSE
WRITE(NULOUT,*)' BRPACMA_LA: CMA FILE FULL - CONTINUE '
ENDIF
*
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END BRPACMA_LA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
RETURN
ENDIF
5 END DO
ENDIF
1 CONTINUE
CALL HPDEALLC(PXVAL ,IER,1)
CALL HPDEALLC(PXVAL3D ,IER,1)
CALL HPDEALLC(PXTABL ,IER,1)
CALL HPDEALLC(PXTABL3D ,IER,1)
CALL HPDEALLC(PXTABLINF,IER,1)
CALL HPDEALLC(PXmark ,IER,1)
CALL HPDEALLC(PXBUF ,IER,1)
*
*-----------------------------------------------------------------------
CALL PRNTBRP(NOBTOT,IKOUNT,NDATA)
*
WRITE(NULOUT,*)' ------------------------------------------'
WRITE(NULOUT,*)' ------ END BRPACMA_LA -------------'
WRITE(NULOUT,*)' ------------------------------------------'
*
RETURN
END