NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
rdmemm.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Read a specified BUFR message from internal arrays.
3 
4 C> This subroutine reads a specified BUFR message from internal
5 C> arrays in memory, so that it is now in scope for processing
6 C> via a subsequent call to subroutine rdmems().
7 C>
8 C> <p>BUFR messages should already be stored within internal
9 C> arrays in memory via one or more previous calls to
10 C> subroutine ufbmem().
11 C>
12 C> @author J. Woollen
13 C> @date 1994-01-06
14 C>
15 C> @param[in] IMSG -- integer: Number of BUFR message to be
16 C> read into scope for further processing,
17 C> counting from the beginning of the
18 C> internal arrays in memory
19 C> @param[out] SUBSET -- character*8: Table A mnemonic for type of BUFR
20 C> message that was read into scope
21 C> (see [DX BUFR Tables](@ref dfbftab) for
22 C> further information about Table A mnemonics)
23 C> @param[out] JDATE -- integer: Date-time stored within Section 1 of
24 C> BUFR message that was read into scope,
25 C> in format of either YYMMDDHH or YYYYMMDDHH,
26 C> depending on the most
27 C> recent call to subroutine datelen()
28 C> @param[out] IRET -- integer: return code
29 C> - 0 = requested message was
30 C> successfully read into scope
31 C> - -1 = requested message number could not
32 C> be found in internal arrays
33 C>
34 C> <b>Program history log:</b>
35 C> | Date | Programmer | Comments |
36 C> | -----|------------|----------|
37 C> | 1994-01-06 | J. Woollen | Original author |
38 C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort(); modified to make Y2K compliant |
39 C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32; increased MAXMEM from 4 Mb to 8 Mb |
40 C> | 2000-09-19 | J. Woollen | Removed logic that had been replicated in this and other read routines and consolidated it into a new routine cktaba(); maximum message length increased from 10,000 to 20,000 bytes |
41 C> | 2001-08-15 | D. Keyser | Increased MAXMEM from 8 Mb to 16 Mb |
42 C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies |
43 C> | 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation |
44 C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
45 C> | 2004-11-15 | D. Keyser | Increased MAXMEM from 16 Mb to 50 Mb |
46 C> | 2009-03-23 | J. Ator | Modified to handle embedded BUFR table (dictionary) messages; use errwrt() |
47 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
48 C>
49  SUBROUTINE rdmemm(IMSG,SUBSET,JDATE,IRET)
50 
51  USE moda_msgcwd
52  USE moda_bitbuf
53  USE moda_mgwa
54  USE moda_msgmem
55 
56  COMMON /quiet / iprt
57 
58  CHARACTER*128 bort_str,errstr
59  CHARACTER*8 subset
60 
61  LOGICAL known
62 
63 C-----------------------------------------------------------------------
64 C-----------------------------------------------------------------------
65 
66 C CHECK THE MESSAGE REQUEST AND FILE STATUS
67 C -----------------------------------------
68 
69  CALL status(munit,lun,il,im)
70  CALL wtstat(munit,lun,il, 1)
71  IF(il.EQ.0) goto 900
72  IF(il.GT.0) goto 901
73  iret = 0
74 
75  IF(imsg.EQ.0 .OR.imsg.GT.msgp(0)) THEN
76  CALL wtstat(munit,lun,il,0)
77  IF(iprt.GE.1) THEN
78  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
79  IF(imsg.EQ.0) THEN
80  errstr = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '//
81  . 'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '//
82  . 'IRET = -1'
83  ELSE
84  WRITE ( unit=errstr, fmt='(A,I6,A,I6,A)' )
85  . 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', imsg,
86  . ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (',
87  . msgp(0), '), RETURN WITH IRET = -1'
88  ENDIF
89  CALL errwrt(errstr)
90  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
91  CALL errwrt(' ')
92  ENDIF
93  iret = -1
94  goto 100
95  ENDIF
96 
97 C ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE
98 C ---------------------------------------------------
99 
100 C Determine which table applies to this message.
101 
102  known = .false.
103  jj = ndxts
104  DO WHILE ((.NOT.known).AND.(jj.GE.1))
105  IF (ipmsgs(jj).LE.imsg) THEN
106  known = .true.
107  ELSE
108  jj = jj - 1
109  ENDIF
110  ENDDO
111  IF (.NOT.known) goto 902
112 
113 C Is this table the one that is currently in scope?
114 
115  IF (jj.NE.ldxts) THEN
116 
117 C No, so reset the software to use the proper table.
118 
119  IF(iprt.GE.2) THEN
120  CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
121  WRITE ( unit=errstr, fmt='(A,I3,A,I3,A,I6)' )
122  . 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', jj,
123  . ' INSTEAD OF DX TABLE #', ldxts,
124  . ' FOR REQUESTED MESSAGE #', imsg
125  CALL errwrt(errstr)
126  CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
127  CALL errwrt(' ')
128  ENDIF
129  CALL dxinit(lun,0)
130 
131 C Store each of the DX dictionary messages which constitute
132 C this table.
133 
134  DO ii = ifdxts(jj), (ifdxts(jj)+icdxts(jj)-1)
135  IF (ii.EQ.ndxm) THEN
136  nwrd = ldxm - ipdxm(ii) + 1
137  ELSE
138  nwrd = ipdxm(ii+1) - ipdxm(ii)
139  ENDIF
140  DO kk = 1, nwrd
141  mgwa(kk) = mdx(ipdxm(ii)+kk-1)
142  ENDDO
143  CALL stbfdx(lun,mgwa)
144  ENDDO
145 
146 C Rebuild the internal jump/link table.
147 
148  CALL makestab
149  ldxts = jj
150  ENDIF
151 
152 C READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER
153 C -----------------------------------------------------
154 
155  iptr = msgp(imsg)
156  IF(imsg.LT.msgp(0)) lptr = msgp(imsg+1)-iptr
157  IF(imsg.EQ.msgp(0)) lptr = mlast-iptr+1
158  iptr = iptr-1
159 
160  DO i=1,lptr
161  mbay(i,lun) = msgs(iptr+i)
162  ENDDO
163 
164 C PARSE THE MESSAGE SECTION CONTENTS
165 C ----------------------------------
166 
167  CALL cktaba(lun,subset,jdate,jret)
168  nmsg(lun) = imsg
169 
170 C EXITS
171 C -----
172 
173 100 RETURN
174 900 CALL bort('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '//
175  . 'MUST BE OPEN FOR INPUT')
176 901 CALL bort('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '//
177  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
178 902 WRITE(bort_str,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '//
179  . 'REQUESTED MESSAGE #",I5)') imsg
180  CALL bort(bort_str)
181  END
subroutine cktaba(LUN, SUBSET, JDATE, IRET)
THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSL...
Definition: cktaba.f:75
subroutine dxinit(LUN, IOI)
THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS (IN MODULE TABABD) HOLDING THE DICTIONARY TABLE...
Definition: dxinit.f:40
This module contains array and variable declarations used to store the contents of one or more BUFR f...
Definition: moda_msgmem.F:14
subroutine rdmemm(IMSG, SUBSET, JDATE, IRET)
This subroutine reads a specified BUFR message from internal arrays in memory, so that it is now in s...
Definition: rdmemm.f:49
subroutine wtstat(LUNIT, LUN, IL, IM)
This subroutine can be used to connect or disconnect a specified Fortran logical unit number to/from ...
Definition: wtstat.f:52
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:55
subroutine makestab
THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE WITHIN MODULE TABLES, USING THE INFORMATION WI...
Definition: makestab.f:74
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41
subroutine stbfdx(LUN, MESG)
THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE FROM THE INPUT ARRAY MESG INTO THE INTERNAL ...
Definition: stbfdx.f:28
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10