stbfdx.f

Go to the documentation of this file.

C> @file
C> @author J @date 2009-03-23
      
C> THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE
C>   FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN
C>   MODULE TABABD.
C>
C> PROGRAM HISTORY LOG:
C> 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC COPIED
C>                           FROM PREVIOUS VERSION OF RDBFDX
C> 2014-11-14  J. ATOR    -- REPLACE CHRTRNA CALLS WITH UPC CALLS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL STBFDX (LUN,MESG)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
C>                BUFR TABLE (DICTIONARY) MESSAGE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     CAPIT    GETLENS  IGETNTBI
C>                               IDN30    IFXY     IUPB     IUPBS01
C>                               NENUBD   PKTDD    STNTBIA  UPC
C>    THIS ROUTINE IS CALLED BY: RDBFDX   RDMEMM   READERME
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE stbfdx(LUN,MESG)

      USE modv_maxcd
      USE moda_tababd

      COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
     .                ld30(10),dxstr(10)

      CHARACTER*128 bort_str
      CHARACTER*128 tabb1,tabb2
      CHARACTER*56  dxstr
      CHARACTER*55  cseq
      CHARACTER*50  dxcmp
      CHARACTER*24  unit
      CHARACTER*8   nemo
      CHARACTER*6   numb,cidn
      dimension     ldxbd(10),ldxbe(10)

      dimension     mesg(*)

      DATA ldxbd /38,70,8*0/
      DATA ldxbe /42,42,8*0/

C-----------------------------------------------------------------------
      ja(i) = ia+1+lda*(i-1)
      jb(i) = ib+1+ldb*(i-1)
C-----------------------------------------------------------------------

C  GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
C  -------------------------------------------------

      idxs = iupbs01(mesg,'MSBT')+1
      IF(idxs.GT.idxv+1) idxs = iupbs01(mesg,'MTVL')+1
      IF(ldxa(idxs).EQ.0) goto 901
      IF(ldxb(idxs).EQ.0) goto 901
      IF(ldxd(idxs).EQ.0) goto 901

      CALL getlens(mesg,3,len0,len1,len2,len3,l4,l5)
      i3 = len0+len1+len2
      dxcmp = ' '
      jbit = 8*(i3+7)
      CALL upc(dxcmp,nxstr(idxs),mesg,jbit,.false.)
      IF(dxcmp.NE.dxstr(idxs)) goto 902

C  SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D
C  --------------------------------------------------

      lda  = ldxa(idxs)
      ldb  = ldxb(idxs)
      ldd  = ldxd(idxs)
      ldbd = ldxbd(idxs)
      ldbe = ldxbe(idxs)
      l30  = ld30(idxs)

      ia = i3+len3+5
      la = iupb(mesg,ia,8)
      ib = ja(la+1)
      lb = iupb(mesg,ib,8)
      id = jb(lb+1)
      ld = iupb(mesg,id,8)

C  TABLE A
C  -------

      DO i=1,la
        n = igetntbi(lun,'A')
        jbit = 8*(ja(i)-1)
        CALL upc(taba(n,lun),lda,mesg,jbit,.true.)
        numb = '   '//taba(n,lun)(1:3)
        nemo = taba(n,lun)(4:11)
        cseq = taba(n,lun)(13:67)
        CALL stntbia(n,lun,numb,nemo,cseq)
      ENDDO

C  TABLE B
C  -------

      DO i=1,lb
        n = igetntbi(lun,'B')
        jbit = 8*(jb(i)-1)
        CALL upc(tabb1,ldbd,mesg,jbit,.true.)
        jbit = 8*(jb(i)+ldbd-1)
        CALL upc(tabb2,ldbe,mesg,jbit,.true.)
        tabb(n,lun) = tabb1(1:ldxbd(idxv+1))//tabb2(1:ldxbe(idxv+1))
        numb = tabb(n,lun)(1:6)
        nemo = tabb(n,lun)(7:14)
        CALL nenubd(nemo,numb,lun)
        idnb(n,lun) = ifxy(numb)
        unit = tabb(n,lun)(71:94)
        CALL capit(unit)
        tabb(n,lun)(71:94) = unit
        ntbb(lun) = n
      ENDDO

C  TABLE D
C  -------

      DO i=1,ld
        n = igetntbi(lun,'D')
        jbit = 8*id
        CALL upc(tabd(n,lun),ldd,mesg,jbit,.true.)
        numb = tabd(n,lun)(1:6)
        nemo = tabd(n,lun)(7:14)
        CALL nenubd(nemo,numb,lun)
        idnd(n,lun) = ifxy(numb)
        nd = iupb(mesg,id+ldd+1,8)
        IF(nd.GT.maxcd) goto 903
        DO j=1,nd
          ndd = id+ldd+2 + (j-1)*l30
          jbit = 8*(ndd-1)
          CALL upc(cidn,l30,mesg,jbit,.true.)
          idn = idn30(cidn,l30)
          CALL pktdd(n,lun,idn,iret)
          IF(iret.LT.0) goto 904
        ENDDO
        id = id+ldd+1 + nd*l30
        IF(iupb(mesg,id+1,8).EQ.0) id = id+1
        ntbd(lun) = n
      ENDDO

C  EXITS
C  -----

      RETURN
901   CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
     . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '//
     . 'KNOWN)')
902   CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
     . 'CONTENTS')
903   WRITE(bort_str,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '//
     . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '//
     . ' (",I4,")")') nemo,nd,maxcd
      CALL bort(bort_str)
904   CALL bort('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '//
     . 'PKTDD, SEE PREVIOUS WARNING MESSAGE')
      END