rcstpl.f

Go to the documentation of this file.

C> @file
C> @brief Store the subset template into internal arrays.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine initializes space in internal subset array space (inv
C> and val) in modules @ref moda_usrint and @ref moda_usrbit, according
C> to the subset definition from subroutine maksetab(). This is in
C> preparation for the actual unpacking of the subset in rdtree().
C>
C> @param[in] LUN - integer: I/O stream index into internal memory arrays.
C> @param[out] IRET - integer: return code:.
C> - 0 Normal return.
C> - -1 An error occurred, possibly due to a corrupt subset in the input message.
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE rcstpl(LUN,IRET)
 
      USE modv_bmiss
      USE modv_maxjl
      USE modv_maxss
 
      USE moda_usrint
      USE moda_usrbit
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables
      USE moda_usrtmp
 
      COMMON /quiet / iprt
 
      CHARACTER*128 BORT_STR
      dimension     nbmp(2,maxrcr),newn(2,maxrcr)
      dimension     knx(maxrcr)
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      iret = 0
 
C  SET THE INITIAL VALUES FOR THE TEMPLATE
C  ---------------------------------------
 
c  .... Positional index of Table A mnem.
      inv(1,lun) = inode(lun)
      val(1,lun) = 0
      nbmp(1,1) = 1
      nbmp(2,1) = 1
      nodi = inode(lun)
      node = inode(lun)
      mbmp = 1
      knvn = 1
      nr   = 0
 
      DO i=1,maxrcr
      knx(i) = 0
      ENDDO
 
C  SET UP THE PARAMETERS FOR A LEVEL OF RECURSION
C  ----------------------------------------------
 
10    CONTINUE
 
      nr = nr+1
      IF(nr.GT.maxrcr) GOTO 900
      nbmp(1,nr) = 1
      nbmp(2,nr) = mbmp
 
      n1 = iseq(node,1)
      n2 = iseq(node,2)
      IF(n1.EQ.0         ) GOTO 901
      IF(n2-n1+1.GT.maxjl) THEN
        IF(iprt.GE.0) THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt('BUFRLIB: RCSTPL - MAXJL OVERFLOW; SUBSET SKIPPED')
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
        ENDIF
        iret = -1
        RETURN
      ENDIF
      newn(1,nr) = 1
      newn(2,nr) = n2-n1+1
 
      DO n=1,newn(2,nr)
      nn = jseq(n+n1-1)
      iutmp(n,nr) = nn
      vutmp(n,nr) = vali(nn)
      ENDDO
 
C  STORE NODES AT SOME RECURSION LEVEL
C  -----------------------------------
 
20    DO i=nbmp(1,nr),nbmp(2,nr)
      IF(knx(nr).EQ.0000) knx(nr) = knvn
      IF(i.GT.nbmp(1,nr)) newn(1,nr) = 1
      DO j=newn(1,nr),newn(2,nr)
      IF(knvn+1.GT.maxss) THEN
        IF(iprt.GE.0) THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt('BUFRLIB: RCSTPL - MAXSS OVERFLOW; SUBSET SKIPPED')
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
        ENDIF
        iret = -1
        RETURN
      ENDIF
      knvn = knvn+1
      node = iutmp(j,nr)
c  .... INV is positional index in internal jump/link table for packed
c       subset element KNVN in MBAY
      inv(knvn,lun) = node
c  .... MBIT is the bit in MBAY pointing to where the packed subset
c       element KNVN begins
      mbit(knvn) = mbit(knvn-1)+nbit(knvn-1)
c  .... NBIT is the number of bits in MBAY occupied by packed subset
c       element KNVN
      nrfelm(knvn,lun) = igetrfel(knvn,lun)
      nbit(knvn) = ibt(node)
      IF(tag(node)(1:5).EQ.'DPRI ') THEN
c  .... This is a bitmap entry, so get and store the corresponding value
        CALL upbb(idpri,nbit(knvn),mbit(knvn),mbay(1,lun))
        IF(idpri.EQ.0) THEN
          val(knvn,lun) = 0.0
        ELSE
          val(knvn,lun) = bmiss
        ENDIF
        CALL strbtm(knvn,lun)
      ENDIF
c  .... Actual unpacked subset values (VAL) are initialized here
c       (numbers as BMISS)
      val(knvn,lun) = vutmp(j,nr)
      IF(itp(node).EQ.1) THEN
         CALL upbb(mbmp,nbit(knvn),mbit(knvn),mbay(1,lun))
         newn(1,nr) = j+1
         nbmp(1,nr) = i
         GOTO 10
      ENDIF
      ENDDO
      new = knvn-knx(nr)
      val(knx(nr)+1,lun) = val(knx(nr)+1,lun) + new
      knx(nr) = 0
      ENDDO
 
C  CONTINUE AT ONE RECURSION LEVEL BACK
C  ------------------------------------
 
      IF(nr-1.NE.0) THEN
         nr = nr-1
         GOTO 20
      ENDIF
 
C  FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE
C  -------------------------------------------------------------------
 
      nval(lun) = knvn
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '//
     . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') maxrcr
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)')
     . tag(nodi)
      CALL bort(bort_str)
      END