strbtm.f

Go to the documentation of this file.

C> @file
C> @author J @date 2016-05-27
    
C> THIS SUBROUTINE STORES INTERNAL INFORMATION IN
C>   MODULE BITMAPS IF THE INPUT ELEMENT IS PART OF A BITMAP.
C>
C> PROGRAM HISTORY LOG:
C> 2016-05-27  J. ATOR    -- ORIGINAL AUTHOR
C> 2019-05-22  J. ATOR    -- ADD CONFIRMATION CHECK
C>
C> USAGE:    CALL STRBTM ( N, LUN )
C>   INPUT ARGUMENT LIST:
C>     N        - INTEGER: SUBSET ELEMENT
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>    THIS ROUTINE CALLS:        BORT     IBFMS    LSTJPB
C>    THIS ROUTINE IS CALLED BY: RCSTPL   RDCMPS
C>                               Normally not called by any application
C>                               programs.
C>
    SUBROUTINE strbtm ( N, LUN )

    USE moda_msgcwd
    USE moda_usrint
    USE moda_tables
    USE moda_bitmaps

        LOGICAL isbtme

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

    node = inv( n, lun )

    IF ( tag(node)(1:5) .EQ. 'DPRI ' ) THEN

C           Confirm that this is really an entry within a bitmap.
C           Although it is rare, it is possible for a DPRI element
C           to appear in a subset definition outside of a bitmap.

            isbtme = .false.
            IF ( ntamc .GT. 0 ) THEN
                nodtam = lstjpb( node, lun, 'SUB' )
                DO ii = 1, ntamc
                  IF ( nodtam .EQ. inodtamc(ii) ) THEN
                    DO jj = 1, ntco(ii)
                      IF ( ( inodtco(ii,jj) .GE. inode(lun) ) .AND.
     .                     ( inodtco(ii,jj) .LE. isc(inode(lun)) ) .AND.
     .                     ( inodtco(ii,jj) .LT. node ) ) THEN
                        IF ( ctco(ii,jj) .EQ. '236000' ) THEN
                          isbtme = .true.
                        ELSE IF ( ( ctco(ii,jj) .EQ. '235000' ) .OR.
     .                            ( ctco(ii,jj) .EQ. '237255' ) ) THEN
                          isbtme = .false.
                        END IF
                      END IF
                    END DO
                  END IF
                END DO
            END IF
            IF ( .NOT. isbtme ) THEN
              linbtm = .false.
              RETURN
        ELSE IF ( .NOT. linbtm ) THEN

C       This is the start of a new bitmap.

        IF ( nbtm .GE. mxbtm ) goto 900
        nbtm = nbtm + 1
        istbtm(nbtm) = n
        iszbtm(nbtm) = 0
        nbtmse(nbtm) = 0
        linbtm = .true.
        END IF
        iszbtm(nbtm) = iszbtm(nbtm) + 1
        IF ( ibfms(val(n,lun)) .EQ. 0 ) THEN

C       This is a "set" (value=0) entry in the bitmap.

        IF ( nbtmse(nbtm) .GE. mxbtmse ) goto 901
        nbtmse(nbtm) = nbtmse(nbtm) + 1
        ibtmse(nbtm,nbtmse(nbtm)) = iszbtm(nbtm)
        END IF
    ELSE IF ( itp(node) .GT. 1 ) THEN
        linbtm = .false.
    END IF

    RETURN
900 CALL bort('BUFRLIB: STRBTM - MXBTM OVERFLOW')
901 CALL bort('BUFRLIB: STRBTM - MXBTMSE OVERFLOW')
    END