seqsdx.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION
C>   FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A
C>   USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY BUFR
C>   ARCHIVE LIBRARY SUBROUTINE RDUSDX.  THESE ARE THEN ADDED TO THE
C>   ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) WITHIN
C>   THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN MODULE TABABD.
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"
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C>                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
C> 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C>
C> USAGE:    CALL SEQSDX (CARD, LUN)
C>   INPUT ARGUMENT LIST:
C>     CARD     - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ
C>                FROM A USER-SUPPLIED BUFR DICTIONARY TABLE
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ADN30    BORT2    NEMOCK   NEMTAB
C>                               NUMTAB   PARSTR   PKTDD    RSVFVM
C>                               STRNUM
C>    THIS ROUTINE IS CALLED BY: RDUSDX
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE seqsdx(CARD,LUN)
 
 
 
      COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)
 
      CHARACTER*128 BORT_STR1,BORT_STR2
      CHARACTER*80  CARD,SEQS
      CHARACTER*12  ATAG,TAGS(250)
      CHARACTER*8   NEMO,NEMA,NEMB
      CHARACTER*6   ADN30,CLEMON
      CHARACTER*3   TYPS
      CHARACTER*1   REPS,TAB
 
      DATA maxtgs /250/
      DATA maxtag /12/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING
C  --------------------------------------------------------------
 
      nemo = card( 3:10)
      seqs = card(14:78)
 
C     Note that an entry for this mnemonic should already exist within
C     the internal BUFR Table D array TABD(*,LUN); this entry should
C     have been created by subroutine RDUSDX when the mnemonic and its
C     associated FXY value and description were initially defined
C     within a card read from the "Descriptor Definition" section at
C     the top of the user-supplied BUFR dictionary table in character
C     format.  Now, we need to retrieve the positional index for that
C     entry within TABD(*,LUN) so that we can access the entry and then
C     add the decoded sequence information to it.
 
      CALL nemtab(lun,nemo,idn,tab,iseq)
      IF(tab.NE.'D') GOTO 900
      CALL parstr(seqs,tags,maxtgs,ntag,' ',.true.)
      IF(ntag.EQ.0 ) GOTO 901
 
      DO n=1,ntag
      atag = tags(n)
      irep = 0
 
C  CHECK FOR REPLICATOR
C  --------------------
 
      DO i=1,5
      IF(atag(1:1).EQ.reps(i,1)) THEN
 
C        Note that REPS(*,*), which contains all of the symbols used to
C        denote all of the various replication schemes that are
C        possible within a user-supplied BUFR dictionary table in
C        character format, was previously defined within subroutine
C        BFRINI.
 
         DO j=2,maxtag
         IF(atag(j:j).EQ.reps(i,2)) THEN
            IF(j.EQ.maxtag) GOTO 902
 
C           Note that subroutine STRNUM will return NUMR = 0 if the
C           string passed to it contains all blanks (as *should* be the
C           case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or
C           5 '<' '>').
 
C           However, when I = 1 '"' '"', then subroutine STRNUM will
C           return NUMR = (the number of replications for the mnemonic
C           using F=1 "regular" (i.e. non-delayed) replication).
 
            CALL strnum(atag(j+1:maxtag),numr)
            IF(i.EQ.1 .AND. numr.LE.0  ) GOTO 903
            IF(i.EQ.1 .AND. numr.GT.255) GOTO 904
            IF(i.NE.1 .AND. numr.NE.0  ) GOTO 905
            atag = atag(2:j-1)
            irep = i
            GOTO 1
         ENDIF
         ENDDO
         GOTO 902
      ENDIF
      ENDDO
 
C  CHECK FOR VALID TAG
C  -------------------
 
1     iret=nemock(atag)
      IF(iret.EQ.-1) GOTO 906
      IF(iret.EQ.-2) GOTO 907
      CALL nemtab(lun,atag,idn,tab,iret)
      IF(iret.GT.0) THEN
 
C        Note that the next code line checks that we are not trying to
C        replicate a Table B mnemonic (which is currently not allowed).
C        The logic works because, for replicated mnemonics, IREP = I =
C        (the index within REPS(*,*) of the symbol associated with the
C        type of replication in question (e.g. "{, "<", etc.))
 
         IF(tab.EQ.'B' .AND. irep.NE.0) GOTO 908
         IF(atag(1:1).EQ.'.') THEN
 
C           This mnemonic is a "following value" mnemonic
C           (i.e. it relates to the mnemonic that immediately
C           follows it within the user-supplied character-format BUFR
C           dictionary table sequence), so confirm that it contains, as
C           a substring, this mnemonic that immediately follows it.
 
            nemb = tags(n+1)
c  .... get NEMA from IDN
            CALL numtab(lun,idn,nema,tab,itab)
            CALL nemtab(lun,nemb,jdn,tab,iret)
            CALL rsvfvm(nema,nemb)
            IF(nema.NE.atag) GOTO 909
c  .... DK: I don't think the next test can ever be satisfied
c  ....     should probably be IF(N.EQ.NTAG ) GOTO 910
            IF(n.GT.ntag ) GOTO 910
            IF(tab.NE.'B') GOTO 911
         ENDIF
      ELSE
         GOTO 912
      ENDIF
 
C  WRITE THE DESCRIPTOR STRING INTO TABD ARRAY
C  -------------------------------------------
c  .... first look for a replication descriptor
      IF(irep.GT.0) CALL pktdd(iseq,lun,idnr(irep,1)+numr,iret)
      IF(iret.LT.0) GOTO 913
      CALL pktdd(iseq,lun,idn,iret)
      IF(iret.LT.0) GOTO 914
 
      ENDDO
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '//
     . '(UNDEFINED, TAB=",A,")")') nemo,tab
      CALL bort2(bort_str1,bort_str2)
901   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') nemo
      CALL bort2(bort_str1,bort_str2)
902   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
903   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
     . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'//
     . ' 2ND QUOTE")') nemo,tags(n),numr
      CALL bort2(bort_str1,bort_str2)
904   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
     . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '//
     . '255")') nemo,tags(n),numr
      CALL bort2(bort_str1,bort_str2)
905   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'//
     . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'//
     . 'NO")') nemo,tags(n),numr
      CALL bort2(bort_str1,bort_str2)
906   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")')
     . nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
907   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
908   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")')
     . nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
909   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '//
     . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")')
     . nemo,tags(n),nema
      CALL bort2(bort_str1,bort_str2)
910   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '//
     . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '//
     . 'STRING")') nemo,nema
      CALL bort2(bort_str1,bort_str2)
911   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'//
     . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '//
     . 'ENTRY")') nemo,nemb
      CALL bort2(bort_str1,bort_str2)
912   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")')
     .  nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
913   clemon = adn30(idnr(irep,1)+numr,6)
      WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
     . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '//
     . 'WARNING MSG")') nemo,clemon
      CALL bort2(bort_str1,bort_str2)
914   WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
     . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '//
     . 'WARNING MSG")') nemo,tags(n)
      CALL bort2(bort_str1,bort_str2)
      END