rcstpl.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
C>   SUBSET ARRAYS IN MODULES USRINT AND USRBIT.  THIS IS IN
C>   PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE
C>   LIBRARY SUBROUTINE RDTREE.
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> 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C>                           LINING CODE WITH FPP DIRECTIVES
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> 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           10,000 TO 20,000 BYTES
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
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); MAXRCR (MAXIMUM
C>                           NUMBER OF RECURSION LEVELS) INCREASED FROM
C>                           50 TO 100  (WAS IN VERIFICATION VERSION);
C>                           UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY; COMMENTED OUT
C>                           HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT
C>                           IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN
C>                           MACHINES)
C> 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2016-11-09  J. ATOR    -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY
C>                           CORRUPT SUBSETS
C>
C> USAGE:    CALL RCSTPL (LUN,IRET)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   OUTPUT ARGUMENT LIST:
C>     IRET     - INTEGER: RETURN CODE:
C>                       0 = NORMAL RETURN
C>                      -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A
C>                           CORRUPT SUBSET IN THE INPUT MESSAGE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     IGETRFEL STRBTM   UPBB
C>    THIS ROUTINE IS CALLED BY: RDTREE
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE rcstpl(LUN,IRET)

      USE modv_bmiss
      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