ufbevn.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT
C>   BUFR DATA SUBSET WITHIN INTERNAL ARRAYS.  THE DATA VALUES
C>   CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION
C>   SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE.  THE INNER
C>   SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER
C>   SEQUENCE WITH DATA "EVENTS".  THE BUFR FILE IN LOGICAL UNIT LUNIT
C>   MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE
C>   LIBRARY SUBROUTINE OPENBF.   IN ADDITION, THE DATA SUBSET MUST HAVE
C>   SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY
C>   ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR
C>   READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE
C>   READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY
C>   SUBROUTINE READNS).  OTHER THAN THE ADDITION OF A THIRD
C>   DIMENSION AND THE READ ONLY RESTRICTION, THE CONTEXT AND USAGE OF
C>   UFBEVN IS EXACTLY THE SAME AS FOR BUFR ARCHIVE LIBRARY SUBROUTINES
C>   UFBINT, UFBREP AND UFBSEQ.  THIS SUBROUTINE IS DESIGNED TO READ
C>   EVENT INFORMATION FROM "PREPBUFR" TYPE BUFR FILES.  PREPBUFR FILES
C>   HAVE THE FOLLOWING BUFR TABLE EVENT STRUCTURE (NOTE SIXTEEN
C>   CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN TO ALLOW THE
C>   TABLE TO FIT IN THIS DOCBLOCK):
C>
C>   | ADPUPA   | HEADR  {PLEVL}
C>   |----------|---------------      
C>   | HEADR    | SID  XOB  YOB  DHR  ELV  TYP  T29  TSB  ITP  SQN  
C>   | PLEVL    | CAT <PINFO> <QINFO> <TINFO> <ZINFO> <WINFO>      
C>   | PINFO    | [PEVN]             <PBACKG>  <PPOSTP>             
C>   | QINFO    | [QEVN]    TDO      <QBACKG>  <QPOSTP>             
C>   | TINFO    | [TEVN]    TVO      <TBACKG>  <TPOSTP>             
C>   | ZINFO    | [ZEVN]             <ZBACKG>  <ZPOSTP>             
C>   | WINFO    | [WEVN]             <WBACKG>  <WPOSTP>             
C>   | PEVN     | POB  PQM  PPC  PRC                                
C>   | QEVN     | QOB  QQM  QPC  QRC                                
C>   | TEVN     | TOB  TQM  TPC  TRC                                
C>   | ZEVN     | ZOB  ZQM  ZPC  ZRC                                
C>   | WEVN     | UOB  WQM  WPC  WRC  VOB                           
C>   | PBACKG   | POE  PFC                                          
C>   | QBACKG   | QOE  QFC                                          
C>   | TBACKG   | TOE  TFC                                          
C>   | ZBACKG   | ZOE  ZFC                                          
C>   | WBACKG   | WOE  UFC  VFC                                     
C>   | PPOSTP   | PAN                                               
C>   | QPOSTP   | QAN                                               
C>   | TPOSTP   | TAN                                               
C>   | ZPOSTP   | ZAN                                               
C>   | WPOSTP   | UAN  VAN                                          
C>
C>   NOTE THAT THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES "[xxxx]"
C>   ARE NESTED INSIDE ONE-BIT DELAYED REPLICATED SEQUENCES "<yyyy>".
C>   THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBIN3 DOES NOT WORK
C>   PROPERLY ON THIS TYPE OF EVENT STRUCTURE.  IT WORKS ONLY ON THE
C>   EVENT STRUCTURE FOUND IN "PREPFITS" TYPE BUFR FILES (SEE UFBIN3 FOR
C>   MORE DETAILS).  IN TURN, UFBEVN DOES NOT WORK PROPERLY ON THE EVENT
C>   STRUCTURE FOUND IN PREPFITS FILES (ALWAYS USE UFBIN3 IN THIS CASE).
C>   ONE OTHER DIFFERENCE BETWEEN UFBEVN AND UFBIN3 IS THAT UFBEVN
C>   STORES THE MAXIMUM NUMBER OF EVENTS FOUND FOR ALL DATA VALUES
C>   SPECIFIED AMONGST ALL LEVELS RETURNED INTERNALLY IN COMMON BLOCK
C>   /UFBN3C/.  UFBIN3 RETURNS THIS VALUE AS AN ADDITIONAL OUTPUT
C>   ARGUMENT.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; IMPROVED MACHINE
C>                           PORTABILITY
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2003-11-04  J. WOOLLEN -- SAVES THE MAXIMUM NUMBER OF EVENTS FOUND
C>                           FOR ALL DATA VALUES SPECIFIED AMONGST ALL
C>                           LEVELS RETURNED AS VARIABLE MAXEVN IN NEW
C>                           COMMON BLOCK /UFBN3C/
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); ADDED CALL TO BORT
C>                           IF BUFR FILE IS OPEN FOR OUTPUT; UNIFIED/
C>                           PORTABLE FOR WRF; ADDED DOCUMENTATION
C>                           (INCLUDING HISTORY); OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
C> 2009-04-21  J. ATOR    -- USE ERRWRT
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL UFBEVN (LUNIT, USR, I1, I2, I3, IRET, STR)
C>   INPUT ARGUMENT LIST:
C>     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C>     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT
C>                LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED
C>                MNEMONICS IN STR)
C>     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
C>     I3       - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM
C>                VALUE IS 255)
C>     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
C>                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
C>                DIMENSION OF USR
C>                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
C>                     TO TABLE B, THESE RETURN THE FOLLOWING
C>                     INFORMATION IN CORRESPONDING USR LOCATION:
C>                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
C>                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
C>                            MESSAGE (RECORD) NUMBER IN WHICH THIS
C>                            SUBSET RESIDES
C>                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
C>                            NUMBER OF THIS SUBSET WITHIN THE BUFR
C>                            MESSAGE (RECORD) NUMBER 'IREC'
C>
C>   OUTPUT ARGUMENT LIST:
C>     USR      - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES
C>                READ FROM DATA SUBSET
C>     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM
C>                DATA SUBSET (MUST BE NO LARGER THAN I2)
C>
C> REMARKS:
C>    APPLICATION PROGRAMS READING PREPFITS FILES SHOULD NOT CALL THIS
C>    ROUTINE.
C>
C>    THIS ROUTINE CALLS:        BORT     CONWIN   ERRWRT   GETWIN
C>                               NVNWIN   NXTWIN   STATUS   STRING
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE ufbevn(LUNIT,USR,I1,I2,I3,IRET,STR)

      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd

      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /ufbn3c/ maxevn
      COMMON /quiet / iprt

      CHARACTER*(*) str
      CHARACTER*128 errstr
      dimension     invn(255)
      REAL*8        usr(i1,i2,i3)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      maxevn = 0
      iret   = 0

C  CHECK THE FILE STATUS AND I-NODE
C  --------------------------------

      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) goto 900
      IF(il.GT.0) goto 901
      IF(im.EQ.0) goto 902
      IF(inode(lun).NE.inv(1,lun)) goto 903

      IF(i1.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' 
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         goto 100
      ELSEIF(i2.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' 
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         goto 100
      ELSEIF(i3.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' 
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         goto 100
      ENDIF

C  PARSE OR RECALL THE INPUT STRING
C  --------------------------------

      CALL string(str,lun,i1,0)

C  INITIALIZE USR ARRAY
C  --------------------

      DO k=1,i3
      DO j=1,i2
      DO i=1,i1
      usr(i,j,k) = bmiss
      ENDDO
      ENDDO
      ENDDO

C  LOOP OVER COND WINDOWS
C  ----------------------

      inc1 = 1
      inc2 = 1

1     CALL conwin(lun,inc1,inc2)
      IF(nnod.EQ.0) THEN
         iret = i2
         goto 100
      ELSEIF(inc1.EQ.0) THEN
         goto 100
      ELSE
         DO i=1,nnod
         IF(nods(i).GT.0) THEN
            ins2 = inc1
            CALL getwin(nods(i),lun,ins1,ins2)
            IF(ins1.EQ.0) goto 100
            goto 2
         ENDIF
         ENDDO
         ins1 = inc1
         ins2 = inc2
      ENDIF

C  READ PUSH DOWN STACK DATA INTO 3D ARRAYS
C  ----------------------------------------

2     iret = iret+1
      IF(iret.LE.i2) THEN
         DO i=1,nnod
         IF(nods(i).GT.0) THEN
            nnvn = nvnwin(nods(i),lun,ins1,ins2,invn,i3)
            maxevn = max(nnvn,maxevn)
            DO n=1,nnvn
            usr(i,iret,n) = val(invn(n),lun)
            ENDDO
         ENDIF
         ENDDO
      ENDIF

C  DECIDE WHAT TO DO NEXT
C  ----------------------

      CALL nxtwin(lun,ins1,ins2)
      IF(ins1.GT.0 .AND. ins1.LT.inc2) goto 2
      IF(ncon.GT.0) goto 1

      IF(iret.EQ.0)  THEN
         IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' 
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
      ENDIF

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '//
     . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
     . 'INTERNAL SUBSET ARRAY')
      END