igetrfel.f

Go to the documentation of this file.

C> @file
C> @author J @date 2016-05-27
    
C> THIS FUNCTION CHECKS WHETHER THE INPUT ELEMENT REFERS TO
C>   A PREVIOUS ELEMENT WITHIN THE SAME SUBSET VIA AN INTERNAL BITMAP.
C>   IF SO, THEN THE REFERENCED ELEMENT IS RETURNED.  IN ADDITION, IF
C>   THE INPUT ELEMENT IS A 2-XX-255 MARKER OPERATOR, ITS SCALE FACTOR,
C>   BIT WIDTH AND REFERENCE VALUE ARE SET INTERNALLY TO MATCH THOSE
C>   OF THE REFERENCED ELEMENT.
C>
C> PROGRAM HISTORY LOG:
C> 2016-05-27  J. ATOR    -- ORIGINAL AUTHOR
C> 2017-04-03  J. ATOR    -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT
C>                           EACH SUBSET DEFINITION IN THE JUMP/LINK
C>                           TABLE HAS ITS OWN SET OF TABLE C OPERATORS
C>
C> USAGE:    CALL IGETRFEL ( N, LUN )
C>   INPUT ARGUMENT LIST:
C>     N        - INTEGER: SUBSET ELEMENT
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   OUTPUT ARGUMENT LIST:
C>     IGETRFEL - INTEGER: SUBSET ELEMENT REFERENCED BY ELEMENT N
C>                WITHIN THE SAME SUBSET
C>                  0 = INPUT ELEMENT DOES NOT REFER TO A PREVIOUS
C>                      ELEMENT, OR REFERENCED ELEMENT NOT FOUND
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ADN30    BORT     IBFMS    IMRKOPR
C>                               LSTJPB   NEMTAB
C>    THIS ROUTINE IS CALLED BY: RCSTPL   RDCMPS
C>                               Normally not called by any application
C>                               programs.
C>
    INTEGER FUNCTION igetrfel ( N, LUN )
 
    USE moda_msgcwd
    USE moda_usrint
    USE moda_tables
    USE moda_bitmaps
    USE moda_nrv203
 
    character*128   bort_str
    character*6 cflwopr,adn30,fxy
    character*1 tab
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
    igetrfel = 0
 
    node = inv( n, lun )
 
    IF ( itp(node) .GT. 1 ) THEN
        IF ( node .EQ. lstnod ) THEN
        lstnodct = lstnodct + 1
        ELSE
        lstnod = node
        lstnodct = 1
        END IF
C
C       Does this subset definition contain any Table C operators
C       with an X value of 21 or greater?
C
        idxta = 0
        IF ( ntamc .GT. 0 ) THEN
        nodtam = lstjpb( node, lun, 'SUB' )
        DO ii = 1, ntamc
          IF ( nodtam .EQ. inodtamc(ii) ) THEN
            idxta = ii
            ntc = ntco(ii)
          END IF
        END DO
        END IF
        IF ( ( idxta .GT. 0 ) .AND. ( nbtm .GT. 0 ) ) THEN
 
C       Check whether this element references a previous element
C       in the same subset via an internal bitmap.  To do this,
C       we first need to determine the appropriate "follow"
C       operator (if any) corresponding to this element.
 
        cflwopr = 'XXXXXX'
        IF ( imrkopr(tag(node)) .EQ. 1 ) THEN
          cflwopr = tag(node)(1:3) // '000'
        ELSE
          CALL nemtab( lun, tag(node), idn, tab, nn )
          IF ( tab .EQ. 'B' ) THEN
            fxy = adn30(idn,6)
            IF ( fxy(2:3) .EQ. '33' ) cflwopr = '222000'
          END IF
        END IF
        IF ( cflwopr .EQ. 'XXXXXX' ) THEN
          IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 900
          RETURN
        END IF
 
C       Now, check whether the appropriate "follow" operator was
C       actually present in the subset.  If there are multiple
C       occurrences, we want the one that most recently precedes
C       the element in question.
 
        nodflw = 0
        DO jj = 1, ntc
          IF ( ( ctco(idxta,jj) .EQ. cflwopr ) .AND.
     .            ( inodtco(idxta,jj) .GE. inode(lun) ) .AND.
     .            ( inodtco(idxta,jj) .LE. isc(inode(lun)) ) .AND.
     .            ( inodtco(idxta,jj) .LT. node ) )
     .          nodflw = inodtco(idxta,jj)
        ENDDO
        IF ( nodflw .EQ. 0 ) THEN
          IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 901
          RETURN
        END IF
 
C       We found an appropriate corresponding "follow" operator,
C       so now we need to look for a bitmap corresponding to
C       this operator.  First, look for a bitmap indicator.
 
        nodl236 = 0
        nodbmap = 0
        jj = 1
        DO WHILE ( ( jj .LE. ntc ) .AND.
     .            ( inodtco(idxta,jj) .GE. inode(lun) ) .AND.
     .            ( inodtco(idxta,jj) .LE. isc(inode(lun)) ) .AND.
     .          ( nodbmap .EQ. 0 ) )
          IF ( ctco(idxta,jj) .EQ. '236000' ) THEN
            nodl236 = inodtco(idxta,jj)
            IF ( inodtco(idxta,jj) .EQ. nodflw ) THEN
              nodbmap = nodflw
            END IF
          ELSE IF ( ( ctco(idxta,jj) .EQ. '235000' ) .OR.
     .              ( ctco(idxta,jj) .EQ. '237255' ) ) THEN
            nodl236 = 0
          ELSE IF ( ( ctco(idxta,jj) .EQ. '237000' ) .AND.
     .             ( inodtco(idxta,jj) .EQ. nodflw ) .AND.
     .              ( nodl236 .NE. 0 ) ) THEN
            nodbmap = nodl236
          END IF
          jj = jj + 1
        END DO
        IF ( nodbmap .EQ. 0 ) THEN
 
C         There was no valid bitmap indicator, so we'll just
C         look for a bitmap after the "follow" indicator.
 
          nodbmap = nodflw
        END IF
 
C       Find the corresponding bitmap.
 
        nn = 1
        idxbtm = 0
        DO WHILE ( ( idxbtm .EQ. 0 ) .AND.
     .            ( nn .LE. nval(lun) ) )
          IF ( inv( nn, lun ) .GT. nodbmap ) THEN
            ii = 1
            DO WHILE ( ( idxbtm .EQ. 0 ) .AND.
     .                ( ii .LE. nbtm ) )
              IF ( nn .EQ. istbtm(ii) ) THEN
            idxbtm = ii
              ELSE
            ii = ii + 1
              END IF
            END DO
          END IF
          nn = nn + 1
        END DO
        IF ( idxbtm .EQ. 0 ) THEN
          IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 902
          RETURN
        END IF
 
C       Use the bitmap to find the previous element in the
C       subset that is referenced by the current element.
C       Search backwards from the start of the bitmap, but
C       make sure not to cross a 2-35-000 operator.
 
        IF ( lstnodct .GT. nbtmse(idxbtm) ) THEN
          IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 903
          RETURN
        END IF
        iemrk = iszbtm(idxbtm) - ibtmse(idxbtm,lstnodct) + 1
        iect = 0
        DO WHILE ( ( nn .GE. 1 ) .AND. ( igetrfel .EQ. 0 ) )
          nodnn = inv( nn, lun )
          IF ( nodnn .LE. nodbmap ) THEN
            DO jj = 1, ntc
              IF ( ( nodnn .EQ. inodtco(idxta,jj) ) .AND.
     .            ( ctco(idxta,jj) .EQ. '235000' ) ) THEN
            IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 903
            RETURN
              END IF
            END DO
            IF ( itp(nodnn) .GT. 1 ) THEN
              iect = iect + 1
              IF ( iect .EQ. iemrk ) igetrfel = nn
            END IF
          END IF
          nn = nn - 1
        END DO
        IF ( igetrfel .EQ. 0 ) THEN
          IF ( imrkopr(tag(node)) .EQ. 1 ) GOTO 903
          RETURN
        END IF
 
        IF ( imrkopr(tag(node)) .EQ. 1 ) THEN
 
C         This element is a marker operator, so set the scale,
C         reference value and bit width accordingly based on
C         those of the previous referenced element.
    
          nodrfe = inv( igetrfel, lun )
          isc(node) = isc(nodrfe)
          IF ( tag(node)(1:3) .EQ. '225' ) THEN
            ibt(node) = ibt(nodrfe) + 1
            irf(node) = -1 * (2 ** ibt(nodrfe))
          ELSE  
            ibt(node) = ibt(nodrfe)
            irf(node) = irf(nodrfe)
            IF ( nnrv .GT. 0 ) THEN
              DO ii = 1, nnrv
            IF ( ( nodrfe .NE. inodnrv(ii) ) .AND.
     .              ( tag(nodrfe)(1:8) .EQ. tagnrv(ii) ) .AND.
     .              ( nodrfe .GE. isnrv(ii) ) .AND.
     .              ( nodrfe .LE. ienrv(ii) ) ) THEN
              irf(node) = nrv(ii)
              RETURN
            END IF
              END DO
            END IF
          END IF
        END IF
 
        END IF
    END IF
 
    RETURN
900 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO DETERMINE '//
     .      'FOLLOW OPERATOR FOR MARKER OPERATOR ",A)') tag(node)
    CALL bort(bort_str)
901 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND FOLLOW '//
     .      'OPERATOR ",A," IN SUBSET")') cflwopr
    CALL bort(bort_str)
902 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND BITMAP '//
     .      'FOR MARKER OPERATOR ",A)') tag(node)
    CALL bort(bort_str)
903 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND PREVIOUS '//
     .      'ELEMENT REFERENCED BY MARKER OPERATOR ",A)') tag(node)
    CALL bort(bort_str)
    END