NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
strbtm.f
Go to the documentation of this file.
1 C> @file
2 C> @author J @date 2016-05-27
3 
4 C> THIS SUBROUTINE STORES INTERNAL INFORMATION IN
5 C> MODULE BITMAPS IF THE INPUT ELEMENT IS PART OF A BITMAP.
6 C>
7 C> PROGRAM HISTORY LOG:
8 C> 2016-05-27 J. ATOR -- ORIGINAL AUTHOR
9 C> 2019-05-22 J. ATOR -- ADD CONFIRMATION CHECK
10 C>
11 C> USAGE: CALL STRBTM ( N, LUN )
12 C> INPUT ARGUMENT LIST:
13 C> N - INTEGER: SUBSET ELEMENT
14 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
15 C>
16 C> THIS ROUTINE CALLS: BORT IBFMS LSTJPB
17 C> THIS ROUTINE IS CALLED BY: RCSTPL RDCMPS
18 C> Normally not called by any application
19 C> programs.
20 C>
21  SUBROUTINE strbtm ( N, LUN )
22 
23  USE moda_msgcwd
24  USE moda_usrint
25  USE moda_tables
26  USE moda_bitmaps
27 
28  LOGICAL isbtme
29 
30 C-----------------------------------------------------------------------
31 C-----------------------------------------------------------------------
32 
33  node = inv( n, lun )
34 
35  IF ( tag(node)(1:5) .EQ. 'DPRI ' ) THEN
36 
37 C Confirm that this is really an entry within a bitmap.
38 C Although it is rare, it is possible for a DPRI element
39 C to appear in a subset definition outside of a bitmap.
40 
41  isbtme = .false.
42  IF ( ntamc .GT. 0 ) THEN
43  nodtam = lstjpb( node, lun, 'SUB' )
44  DO ii = 1, ntamc
45  IF ( nodtam .EQ. inodtamc(ii) ) THEN
46  DO jj = 1, ntco(ii)
47  IF ( ( inodtco(ii,jj) .GE. inode(lun) ) .AND.
48  . ( inodtco(ii,jj) .LE. isc(inode(lun)) ) .AND.
49  . ( inodtco(ii,jj) .LT. node ) ) THEN
50  IF ( ctco(ii,jj) .EQ. '236000' ) THEN
51  isbtme = .true.
52  ELSE IF ( ( ctco(ii,jj) .EQ. '235000' ) .OR.
53  . ( ctco(ii,jj) .EQ. '237255' ) ) THEN
54  isbtme = .false.
55  END IF
56  END IF
57  END DO
58  END IF
59  END DO
60  END IF
61  IF ( .NOT. isbtme ) THEN
62  linbtm = .false.
63  RETURN
64  ELSE IF ( .NOT. linbtm ) THEN
65 
66 C This is the start of a new bitmap.
67 
68  IF ( nbtm .GE. mxbtm ) goto 900
69  nbtm = nbtm + 1
70  istbtm(nbtm) = n
71  iszbtm(nbtm) = 0
72  nbtmse(nbtm) = 0
73  linbtm = .true.
74  END IF
75  iszbtm(nbtm) = iszbtm(nbtm) + 1
76  IF ( ibfms(val(n,lun)) .EQ. 0 ) THEN
77 
78 C This is a "set" (value=0) entry in the bitmap.
79 
80  IF ( nbtmse(nbtm) .GE. mxbtmse ) goto 901
81  nbtmse(nbtm) = nbtmse(nbtm) + 1
82  ibtmse(nbtm,nbtmse(nbtm)) = iszbtm(nbtm)
83  END IF
84  ELSE IF ( itp(node) .GT. 1 ) THEN
85  linbtm = .false.
86  END IF
87 
88  RETURN
89 900 CALL bort('BUFRLIB: STRBTM - MXBTM OVERFLOW')
90 901 CALL bort('BUFRLIB: STRBTM - MXBTMSE OVERFLOW')
91  END
function lstjpb(NODE, LUN, JBTYP)
THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN NODE WITHIN THE JUMP/LINK TABLE...
Definition: lstjpb.f:57
subroutine strbtm(N, LUN)
THIS SUBROUTINE STORES INTERNAL INFORMATION IN MODULE BITMAPS IF THE INPUT ELEMENT IS PART OF A BITMA...
Definition: strbtm.f:21
This module contains array and variable declarations used to store bitmaps internally within a data s...
Definition: moda_bitmaps.F:13
INTEGER function ibfms(R8VAL)
This function provides a handy way to check whether a real*8 data value returned from a previous call...
Definition: ibfms.f:39
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23