NCEPLIBS-bufr  12.1.0
memmsgs.F90
Go to the documentation of this file.
1 
5 
38 recursive subroutine ufbmem(lunit,inew,iret,iunit)
39 
40  use bufrlib
41 
42  use modv_vars, only: im8b, maxmem, maxmsg
43 
44  use moda_mgwa
45  use moda_msgmem
46 
47  implicit none
48 
49  integer, intent(in) :: lunit, inew
50  integer, intent(out) :: iret, iunit
51  integer iprt, my_lunit, my_inew, iflg, itim, lun, il, im, itemp, ier, nmsg, lmem, i, mlast0, idxmsg, nmwrd
52 
53  character*128 bort_str, errstr
54 
55  common /quiet/ iprt
56 
57  ! Check for I8 integers
58 
59  if(im8b) then
60  im8b=.false.
61 
62  call x84(lunit,my_lunit,1)
63  call x84(inew,my_inew,1)
64  call ufbmem(my_lunit,my_inew,iret,iunit)
65  call x48(iret,iret,1)
66  call x48(iunit,iunit,1)
67 
68  im8b=.true.
69  return
70  endif
71 
72  ! Try to open BUFR file and set to initialize or concatenate
73 
74  call openbf(lunit,'IN',lunit)
75 
76  if(inew==0) then
77  msgp(0) = 0
78  munit = 0
79  mlast = 0
80  ndxts = 0
81  ldxts = 0
82  ndxm = 0
83  ldxm = 0
84  endif
85 
86  nmsg = msgp(0)
87  iret = 0
88  iflg = 0
89  itim = 0
90 
91  ! Copy any BUFR dictionary table messages from the beginning of lunit into @ref moda_msgmem for possible later use.
92  ! Note that such a table (if one exists) is already now in scope due to the prior call to subroutine openbf(), which
93  ! in turn would have automatically called subroutines readdx(), rdbfdx() and makestab() for this table.
94 
95  itemp = ndxts
96  call status(lunit,lun,il,im)
97  call cewind_c(lun)
98  call cpdxmm(lunit)
99 
100  ! If a table was indeed present at the beginning of the file, then set the flag to indicate that this table is now in scope.
101 
102  if ((itemp+1)==ndxts) ldxts = ndxts
103 
104  ! Transfer messages from file to memory and set message pointers
105 
106  do while (.true.)
107  call rdmsgw(lunit,mgwa,ier)
108  if(ier==-1) exit
109  if(ier==-2) then
110  write(bort_str,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit
111  call bort(bort_str)
112  endif
113 
114  if(idxmsg(mgwa)==1) then
115  ! New "embedded" BUFR dictionary table messages have been found in this file. Copy them into @ref moda_msgmem
116  ! for later use.
117  call backbufr_c(lun) ! Backspace lunit
118  call cpdxmm(lunit)
119  cycle
120  endif
121 
122  nmsg = nmsg+1
123  if(nmsg>maxmsg) iflg = 1
124  lmem = nmwrd(mgwa)
125  if(lmem+mlast>maxmem) iflg = 2
126 
127  if(iflg==0) then
128  iret = iret+1
129  do i=1,lmem
130  msgs(mlast+i) = mgwa(i)
131  enddo
132  msgp(0) = nmsg
133  msgp(nmsg) = mlast+1
134  else
135  if(itim==0) then
136  mlast0 = mlast
137  itim=1
138  endif
139  endif
140  mlast = mlast+lmem
141  enddo
142 
143  if(iflg==1) then
144  ! Emergency room treatment for maxmsg array overflow
145  if(iprt>=0) then
146  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
147  write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', &
148  'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ'
149  call errwrt(errstr)
150  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
151  call errwrt(errstr)
152  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
153  call errwrt(errstr)
154  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
155  call errwrt(' ')
156  endif
157  mlast=mlast0
158  endif
159 
160  if(iflg==2) then
161  ! Emergency room treatment for maxmem array overflow
162  if(iprt>=0) then
163  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
164  write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', &
165  'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ'
166  call errwrt(errstr)
167  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
168  call errwrt(errstr)
169  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
170  call errwrt(errstr)
171  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
172  call errwrt(' ')
173  endif
174  mlast=mlast0
175  endif
176 
177  if(iret==0) then
178  call closbf(lunit)
179  else
180  if(munit/=0) call closbf(lunit)
181  if(munit==0) munit = lunit
182  endif
183  iunit = munit
184 
185  return
186 end subroutine ufbmem
187 
216 recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg)
217 
218  use modv_vars, only: im8b, maxmem, maxmsg
219 
220  use moda_mgwa
221  use moda_msgmem
222 
223  implicit none
224 
225  character*128 bort_str, errstr
226 
227  integer, intent(in) :: lunit(*), lundx(*), inew(*)
228  integer, intent(out) :: mesg(*), iret(*)
229  integer iprt, my_lunit(1), my_lundx(1), my_inew(1), nmesg, iflg, itim, ier, nmsg, lmem, i, mlast0, iupbs01, nmwrd
230 
231  common /quiet/ iprt
232 
233  ! Check for I8 integers
234 
235  if(im8b) then
236  im8b=.false.
237 
238  call x84(lunit(1),my_lunit(1),1)
239  call x84(lundx(1),my_lundx(1),1)
240  call x84(inew(1),my_inew(1),1)
241  if (my_inew(1)==0) then
242  nmesg = 0
243  else
244  nmesg = msgp(0)
245  call x84(mesg(1),mesg(1),nmesg)
246  endif
247  call ufbmex(my_lunit(1),my_lundx(1),my_inew(1),iret(1),mesg(1))
248  call x48(mesg(1),mesg(1),nmesg+iret(1))
249  call x48(iret(1),iret(1),1)
250 
251  im8b=.true.
252  return
253  endif
254 
255  ! Try to open BUFR file and set to initialize or concatenate
256 
257  call openbf(lunit(1),'IN',lundx(1))
258 
259  if(inew(1)==0) then
260  msgp(0) = 0
261  munit = 0
262  mlast = 0
263  ndxts = 0
264  ldxts = 0
265  ndxm = 0
266  ldxm = 0
267  endif
268 
269  nmsg = msgp(0)
270  iret(1) = 0
271  iflg = 0
272  itim = 0
273 
274  ! Set some flags so that subsequent calls to the message reading routines will know there is a BUFR table in scope.
275 
276  ndxts = 1
277  ldxts = 1
278  ipmsgs(1) = 1
279 
280  ! Transfer messages from file to memory and set message pointers.
281 
282  do while (.true.)
283  call rdmsgw(lunit(1),mgwa,ier)
284  if(ier==-1) exit
285  if(ier==-2) then
286  write(bort_str,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit(1)
287  call bort(bort_str)
288  endif
289 
290  nmsg = nmsg+1
291  mesg(nmsg) = iupbs01(mgwa,'MTYP')
292  if(nmsg>maxmsg) iflg = 1
293  lmem = nmwrd(mgwa)
294  if(lmem+mlast>maxmem) iflg = 2
295 
296  if(iflg==0) then
297  iret(1) = iret(1)+1
298  do i=1,lmem
299  msgs(mlast+i) = mgwa(i)
300  enddo
301  msgp(0) = nmsg
302  msgp(nmsg) = mlast+1
303  else
304  if(itim==0) then
305  mlast0 = mlast
306  itim=1
307  endif
308  endif
309  mlast = mlast+lmem
310  enddo
311 
312  if(iflg==1) then
313  ! Emergency room treatment for maxmsg array overflow
314  if(iprt>=0) then
315  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
316  write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', &
317  'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ'
318  call errwrt(errstr)
319  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
320  call errwrt(errstr)
321  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
322  call errwrt(errstr)
323  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
324  call errwrt(' ')
325  endif
326  mlast=mlast0
327  endif
328 
329  if(iflg==2) then
330  ! Emergency room treatment for maxmem array overflow
331  if(iprt>=0) then
332  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
333  write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', &
334  'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ'
335  call errwrt(errstr)
336  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
337  call errwrt(errstr)
338  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
339  call errwrt(errstr)
340  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
341  call errwrt(' ')
342  endif
343  mlast=mlast0
344  endif
345 
346  if(iret(1)==0) then
347  call closbf(lunit(1))
348  else
349  if(munit/=0) call closbf(lunit(1))
350  if(munit==0) munit = lunit(1)
351  endif
352 
353  return
354 end subroutine ufbmex
355 
381 recursive subroutine readmm(imsg,subset,jdate,iret)
382 
383  use modv_vars, only: im8b
384 
385  implicit none
386 
387  integer, intent(inout) :: imsg
388  integer, intent(out) :: jdate, iret
389 
390  character*8, intent(out) :: subset
391 
392  ! Check for I8 integers.
393 
394  if(im8b) then
395  im8b=.false.
396 
397  call x84(imsg,imsg,1)
398  call readmm(imsg,subset,jdate,iret)
399  call x48(imsg,imsg,1)
400  call x48(jdate,jdate,1)
401  call x48(iret,iret,1)
402 
403  im8b=.true.
404  return
405  endif
406 
407  call rdmemm(imsg,subset,jdate,iret)
408 
409  imsg = imsg+1
410 
411  return
412 end subroutine readmm
413 
433 recursive integer function ireadmm(imsg,subset,idate) result(iret)
434 
435  use modv_vars, only: im8b
436 
437  implicit none
438 
439  integer, intent(inout) :: imsg
440  integer, intent(out) :: idate
441 
442  character*8, intent(out) :: subset
443 
444  ! Check for I8 integers.
445 
446  if(im8b) then
447  im8b=.false.
448 
449  call x84(imsg,imsg,1)
450  iret=ireadmm(imsg,subset,idate)
451  call x48(imsg,imsg,1)
452  call x48(idate,idate,1)
453 
454  im8b=.true.
455  return
456  endif
457 
458  call readmm(imsg,subset,idate,iret)
459 
460  return
461 end function ireadmm
462 
486 recursive subroutine rdmemm(imsg,subset,jdate,iret)
487 
488  use modv_vars, only: im8b
489 
490  use moda_msgcwd
491  use moda_bitbuf
492  use moda_mgwa
493  use moda_msgmem
494 
495  implicit none
496 
497  integer, intent(in) :: imsg
498  integer, intent(out) :: jdate, iret
499  integer iprt, my_imsg, lun, il, im, ii, jj, kk, nwrd, iptr, lptr, ier
500 
501  character*128 bort_str, errstr
502  character*8, intent(out) :: subset
503 
504  logical known
505 
506  common /quiet/ iprt
507 
508  ! Check for I8 integers
509 
510  if(im8b) then
511  im8b=.false.
512 
513  call x84(imsg,my_imsg,1)
514  call rdmemm(my_imsg,subset,jdate,iret)
515  call x48(jdate,jdate,1)
516  call x48(iret,iret,1)
517 
518  im8b=.true.
519  return
520  endif
521 
522  ! Check the message request and file status
523 
524  call status(munit,lun,il,im)
525  call wtstat(munit,lun,il,1)
526  iret = 0
527 
528  if(imsg==0 .or.imsg>msgp(0)) then
529  call wtstat(munit,lun,il,0)
530  if(iprt>=1) then
531  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
532  if(imsg==0) then
533  errstr = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH IRET = -1'
534  else
535  write ( unit=errstr, fmt='(A,I6,A,I6,A)' ) 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', imsg, &
536  ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (', msgp(0), '), RETURN WITH IRET = -1'
537  endif
538  call errwrt(errstr)
539  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
540  call errwrt(' ')
541  endif
542  iret = -1
543  return
544  endif
545 
546  ! Determine which table applies to this message.
547 
548  known = .false.
549  jj = ndxts
550  do while ((.not.known).and.(jj>=1))
551  if (ipmsgs(jj)<=imsg) then
552  known = .true.
553  else
554  jj = jj - 1
555  endif
556  enddo
557  if (.not.known) then
558  write(bort_str,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR REQUESTED MESSAGE #",I5)') imsg
559  call bort(bort_str)
560  endif
561 
562  ! Is this table the one that is currently in scope?
563 
564  if (jj/=ldxts) then
565 
566  ! No, so reset the software to use the proper table.
567 
568  if(iprt>=2) then
569  call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
570  write ( unit=errstr, fmt='(A,I3,A,I3,A,I6)' ) 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', jj, &
571  ' INSTEAD OF DX TABLE #', ldxts, ' FOR REQUESTED MESSAGE #', imsg
572  call errwrt(errstr)
573  call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
574  call errwrt(' ')
575  endif
576  call dxinit(lun,0)
577 
578  ! Store each of the DX dictionary messages which constitute this table.
579 
580  do ii = ifdxts(jj), (ifdxts(jj)+icdxts(jj)-1)
581  if (ii==ndxm) then
582  nwrd = ldxm - ipdxm(ii) + 1
583  else
584  nwrd = ipdxm(ii+1) - ipdxm(ii)
585  endif
586  do kk = 1, nwrd
587  mgwa(kk) = mdx(ipdxm(ii)+kk-1)
588  enddo
589  call stbfdx(lun,mgwa)
590  enddo
591 
592  ! Rebuild the internal jump/link table.
593 
594  call makestab
595  ldxts = jj
596  endif
597 
598  ! Read memory message number imsg into a message buffer.
599 
600  iptr = msgp(imsg)
601  if(imsg<msgp(0)) lptr = msgp(imsg+1)-iptr
602  if(imsg==msgp(0)) lptr = mlast-iptr+1
603  iptr = iptr-1
604 
605  do ii=1,lptr
606  mbay(ii,lun) = msgs(iptr+ii)
607  enddo
608 
609  ! Parse the message section contents.
610 
611  call cktaba(lun,subset,jdate,ier)
612  nmsg(lun) = imsg
613 
614  return
615 end subroutine rdmemm
616 
634 recursive subroutine rdmems(isub,iret)
635 
636  use modv_vars, only: im8b
637 
638  use moda_msgcwd
639  use moda_unptyp
640  use moda_bitbuf
641  use moda_msgmem
642 
643  implicit none
644 
645  integer, intent(in) :: isub
646  integer, intent(out) :: iret
647  integer my_isub, iprt, lun, il, im, mbym, nbyt, i, iupb
648 
649  character*128 bort_str, errstr
650 
651  common /quiet/ iprt
652 
653  ! Check for I8 integers
654 
655  if(im8b) then
656  im8b=.false.
657 
658  call x84(isub,my_isub,1)
659  call rdmems(my_isub,iret)
660  call x48(iret,iret,1)
661 
662  im8b=.true.
663  return
664  endif
665 
666  ! Check the message request and file status
667 
668  call status(munit,lun,il,im)
669  if(im==0) call bort('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
670  if(nsub(lun)/=0) then
671  write(bort_str,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," '// &
672  'SUBSETS HAVE BEEN READ, SHOULD BE 0)")') nsub(lun)
673  call bort(bort_str)
674  endif
675 
676  if(isub>msub(lun)) then
677  if(iprt>=0) then
678  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
679  write ( unit=errstr, fmt='(A,I5,A,A,I5,A)' ) 'BUFRLIB: RDMEMS - REQ. SUBSET #', isub, ' (= 1st INPUT ', &
680  'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', msub(lun), ')'
681  call errwrt(errstr)
682  call errwrt('RETURN WITH IRET = -1')
683  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
684  call errwrt(' ')
685  endif
686  iret = -1
687  return
688  endif
689 
690  mbym = mbyt(lun)
691  nbyt = 0
692 
693  ! Position to subset number isub in memory message
694 
695  if(msgunp(lun)==0) then
696  nsub(lun) = isub-1
697  do i=1,isub-1
698  mbyt(lun) = mbyt(lun) + iupb(mbay(1,lun),mbyt(lun)+1,16)
699  enddo
700  elseif(msgunp(lun)==1) then
701  ! message with "standard" Section 3
702  do i=1,isub-1
703  call readsb(munit,iret)
704  enddo
705  else
706  ! compressed message
707  nsub(lun) = isub-1
708  endif
709 
710  ! Now read subset number isub from memory message
711 
712  call readsb(munit,iret)
713  if(iret/=0) call bort('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED WITH IRET = -1 (EITHER MEMORY MESSAGE '// &
714  'NOT OPEN OR ALL SUBSETS IN MESSAGE READ')
715 
716  ! Reset subset pointer back to zero (beginning of message) and return
717 
718  mbyt(lun) = mbym
719  nsub(lun) = 0
720 
721  return
722 end subroutine rdmems
723 
729 subroutine cpdxmm( lunit )
730 
731  use bufrlib
732 
733  use modv_vars, only: mxdxts
734 
735  use moda_mgwa
736  use moda_msgmem
737 
738  implicit none
739 
740  integer, intent(in) :: lunit
741  integer iprt, ict, lun, il, im, ier, j, lmem, idxmsg, iupbs3, nmwrd
742 
743  character*128 errstr
744 
745  logical done
746 
747  common /quiet/ iprt
748 
749  if ( ndxts >= mxdxts ) call bort('BUFRLIB: CPDXMM - MXDXTS OVERFLOW')
750 
751  ict = 0
752  done = .false.
753  call status(lunit,lun,il,im)
754 
755  ! Read a complete dictionary table from lunit, as a set of one or more DX dictionary messages.
756 
757  do while ( .not. done )
758  call rdmsgw ( lunit, mgwa, ier )
759  if ( ier == -2 ) call bort('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR')
760  if ( ier == -1 ) then
761 
762  ! Don't abort for an end-of-file condition, since it may be possible for a file to end with dictionary messages.
763  ! Instead, backspace the file pointer and let the calling routine diagnose the end-of-file condition and deal with
764  ! it as it sees fit.
765 
766  call backbufr_c(lun)
767  done = .true.
768  else if ( idxmsg(mgwa) /= 1 ) then
769 
770  ! This is a non-DX dictionary message. Assume we've reached the end of the dictionary table, and backspace lunit so
771  ! that the next read (e.g. in the calling routine) will get this same message.
772 
773  call backbufr_c(lun)
774  done = .true.
775  else if ( iupbs3(mgwa,'nsub') == 0 ) then
776 
777  ! This is a DX dictionary message, but it doesn't contain any actual dictionary information. Assume we've reached the
778  ! end of the dictionary table.
779 
780  done = .true.
781  else
782 
783  ! Store this message into @ref moda_msgmem.
784 
785  ict = ict + 1
786  if ( ( ndxm + ict ) > mxdxm ) call bort('BUFRLIB: CPDXMM - MXDXM OVERFLOW')
787  ipdxm(ndxm+ict) = ldxm + 1
788  lmem = nmwrd(mgwa)
789  if ( ( ldxm + lmem ) > mxdxw ) call bort('BUFRLIB: CPDXMM - MXDXW OVERFLOW')
790  do j = 1, lmem
791  mdx(ldxm+j) = mgwa(j)
792  enddo
793  ldxm = ldxm + lmem
794  endif
795  enddo
796 
797  ! Update the table information within @ref moda_msgmem.
798 
799  if ( ict > 0 ) then
800  ifdxts(ndxts+1) = ndxm + 1
801  icdxts(ndxts+1) = ict
802  ipmsgs(ndxts+1) = msgp(0) + 1
803  ndxm = ndxm + ict
804  ndxts = ndxts + 1
805  if ( iprt >= 2 ) then
806  call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
807  write ( unit=errstr, fmt='(A,I3,A,I3,A)') 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', ndxts, &
808  ' CONSISTING OF ', ict, ' MESSAGES'
809  call errwrt(errstr)
810  call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
811  call errwrt(' ')
812  endif
813  endif
814 
815  return
816 end subroutine cpdxmm
817 
839 recursive subroutine ufbmms(imsg,isub,subset,jdate)
840 
841  use modv_vars, only: im8b
842 
843  use moda_msgcwd
844  use moda_msgmem
845 
846  implicit none
847 
848  integer, intent(in) :: imsg, isub
849  integer, intent(out) :: jdate
850  integer my_imsg, my_isub, lun, il, im, iret
851 
852  character*8, intent(out) :: subset
853 
854  character*128 bort_str
855 
856  ! Check for I8 integers
857 
858  if(im8b) then
859  im8b=.false.
860 
861  call x84(imsg,my_imsg,1)
862  call x84(isub,my_isub,1)
863  call ufbmms(my_imsg,my_isub,subset,jdate)
864  call x48(jdate,jdate,1)
865 
866  im8b=.true.
867  return
868  endif
869 
870  ! Read subset #isub from memory message #imsg
871 
872  call rdmemm(imsg,subset,jdate,iret)
873  if(iret<0) then
874  if(imsg>0) then
875  write(bort_str,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// &
876  'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0)
877  else
878  write(bort_str,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")')
879  endif
880  call bort(bort_str)
881  endif
882  call rdmems(isub,iret)
883  if(iret/=0) then
884  call status(munit,lun,il,im)
885  write(bort_str,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// &
886  'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg
887  call bort(bort_str)
888  endif
889 
890  return
891 end subroutine ufbmms
892 
910 recursive subroutine ufbmns(irep,subset,idate)
911 
912  use modv_vars, only: im8b
913 
914  use moda_msgmem
915 
916  implicit none
917 
918  integer, intent(in) :: irep
919  integer, intent(out) :: idate
920  integer my_irep, imsg, jrep, iret, ireadmm, nmsub
921 
922  character*8, intent(out) :: subset
923 
924  character*128 bort_str
925 
926  ! Check for I8 integers
927 
928  if(im8b) then
929  im8b=.false.
930 
931  call x84(irep,my_irep,1)
932  call ufbmns(my_irep,subset,idate)
933  call x48(idate,idate,1)
934 
935  im8b=.true.
936  return
937  endif
938 
939  jrep = 0
940  imsg = 1
941 
942  ! Read subset #irep
943 
944  do while(ireadmm(imsg,subset,idate)==0)
945  if(jrep+nmsub(munit)>=irep) then
946  call rdmems(irep-jrep,iret)
947  return
948  endif
949  jrep = jrep+nmsub(munit)
950  enddo
951 
952  write(bort_str,'("BUFRLIB: UFBMNS - REQ. SUBSET NO. TO READ IN (",I5,") EXCEEDS TOTAL NO. OF SUBSETS IN THE COLLECTION '// &
953  'OF MEMORY MESSAGES (",I5,")")') irep,jrep
954  call bort(bort_str)
955 end subroutine ufbmns
956 
976 recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str)
977 
978  use modv_vars, only: im8b
979 
980  use moda_msgcwd
981  use moda_msgmem
982 
983  implicit none
984 
985  integer, intent(in) :: imsg, isub, i1, i2
986  integer, intent(out) :: iret
987  integer iprt, my_imsg, my_isub, my_i1, my_i2, jdate, lun, il, im
988 
989  real*8, intent(out) :: usr(i1,i2)
990 
991  character*(*), intent(in) :: str
992  character*128 bort_str, errstr
993  character*8 subset
994 
995  common /quiet/ iprt
996 
997  ! Check for I8 integers
998 
999  if(im8b) then
1000  im8b=.false.
1001 
1002  call x84(imsg,my_imsg,1)
1003  call x84(isub,my_isub,1)
1004  call x84(i1,my_i1,1)
1005  call x84(i2,my_i2,1)
1006  call ufbrms(my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
1007  call x48(iret,iret,1)
1008 
1009  im8b=.true.
1010  return
1011  endif
1012 
1013  iret = 0
1014  if(i1<=0) then
1015  if(iprt>=0) then
1016  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1017  errstr = .LE.'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
1018  call errwrt(errstr)
1019  call errwrt(str)
1020  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1021  call errwrt(' ')
1022  endif
1023  return
1024  elseif(i2<=0) then
1025  if(iprt>=0) then
1026  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1027  errstr = .LE.'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
1028  call errwrt(errstr)
1029  call errwrt(str)
1030  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1031  call errwrt(' ')
1032  endif
1033  return
1034  endif
1035 
1036  ! Read requested values from subset #isub within memory message #imsg
1037 
1038  call rdmemm(imsg,subset,jdate,iret)
1039  if(iret<0) then
1040  if(imsg>0) then
1041  write(bort_str,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// &
1042  'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0)
1043  else
1044  write(bort_str,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")')
1045  endif
1046  call bort(bort_str)
1047  endif
1048  call rdmems(isub,iret)
1049  if(iret/=0) then
1050  call status(munit,lun,il,im)
1051  write(bort_str,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// &
1052  'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg
1053  call bort(bort_str)
1054  endif
1055 
1056  call ufbint(munit,usr,i1,i2,iret,str)
1057 
1058  return
1059 end subroutine ufbrms
1060 
1102 recursive subroutine ufbtam(tab,i1,i2,iret,str)
1103 
1104  use modv_vars, only: im8b, bmiss
1105 
1106  use moda_usrint
1107  use moda_msgcwd
1108  use moda_bitbuf
1109  use moda_msgmem
1110  use moda_tables
1111 
1112  implicit none
1113 
1114  character*(*), intent(in) :: str
1115  character*128 bort_str, errstr
1116  character*10 tgs(100)
1117  character*8 subset, cval
1118 
1119  integer*8 mps, ival
1120  integer, intent(in) :: i1, i2
1121  integer, intent(out) :: iret
1122  integer iprt, maxtg, nnod, ncon, nods, nodc, ivls, kons, my_i1, my_i2, i, j, irec, isub, itbl, lun, il, im, jdate, mret, &
1123  kbit, mbit, nbit, n, node, imsg, kmsg, nrep, ntg, nbyt, nbmp, nmsub
1124 
1125  real*8, intent(out) :: tab(i1,i2)
1126  real*8 rval, ups
1127 
1128  common /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
1129  common /quiet/ iprt
1130 
1131  equivalence(cval,rval)
1132 
1133  data maxtg /100/
1134 
1135  ! Statement function
1136  mps(node) = 2_8**(ibt(node))-1
1137 
1138  ! Check for I8 integers
1139 
1140  if(im8b) then
1141  im8b=.false.
1142 
1143  call x84(i1,my_i1,1)
1144  call x84(i2,my_i2,1)
1145  call ufbtam(tab,my_i1,my_i2,iret,str)
1146  call x48(iret,iret,1)
1147 
1148  im8b=.true.
1149  return
1150  endif
1151 
1152  iret = 0
1153 
1154  if(msgp(0)==0) return
1155 
1156  do j=1,i2
1157  do i=1,i1
1158  tab(i,j) = bmiss
1159  enddo
1160  enddo
1161 
1162  ! Check for special tags in string
1163 
1164  call parstr(str,tgs,maxtg,ntg,' ',.true.)
1165  irec = 0
1166  isub = 0
1167  itbl = 0
1168  do i=1,ntg
1169  if(tgs(i)=='IREC') irec = i
1170  if(tgs(i)=='ISUB') isub = i
1171  if(tgs(i)=='ITBL') itbl = i
1172  enddo
1173 
1174  call status(munit,lun,il,im)
1175 
1176  ! Cycle through all of the memory messages in the internal arrays
1177 
1178  outer: do imsg=1,msgp(0)
1179  call rdmemm(imsg,subset,jdate,mret)
1180  if(mret<0) then
1181  write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') imsg
1182  call bort(bort_str)
1183  endif
1184 
1185  call string(str,lun,i1,0)
1186  if(irec>0) nods(irec) = 0
1187  if(isub>0) nods(isub) = 0
1188  if(itbl>0) nods(itbl) = 0
1189 
1190  ! Process all the subsets in the memory message
1191 
1192  do while (nsub(lun)<msub(lun))
1193  if(iret+1>i2) then
1194  ! Emergency room treatment for array overflow
1195  call rdmemm(0,subset,jdate,mret)
1196  nrep = 0
1197  do kmsg=1,msgp(0)
1198  call rdmemm(kmsg,subset,jdate,mret)
1199  if(mret<0) then
1200  write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') kmsg
1201  call bort(bort_str)
1202  endif
1203  nrep = nrep+nmsub(munit)
1204  enddo
1205  if(iprt>=0) then
1206  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1207  write ( unit=errstr, fmt='(A,A,I8,A,A)' ) 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', &
1208  .GT.'IS LIMIT OF ', i2, ' IN THE 3RD ARG. (INPUT) - INCOMPLETE READ'
1209  call errwrt(errstr)
1210  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBTAM STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
1211  call errwrt(errstr)
1212  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1213  call errwrt(' ')
1214  endif
1215  exit outer
1216  endif
1217 
1218  iret = iret+1
1219 
1220  do i=1,nnod
1221  nods(i) = abs(nods(i))
1222  enddo
1223 
1224  call usrtpl(lun,1,1)
1225  mbit = mbyt(lun)*8+16
1226  nbit = 0
1227  n = 1
1228 
1229  inner: do while(n+1<=nval(lun))
1230  n = n+1
1231  node = inv(n,lun)
1232  mbit = mbit+nbit
1233  nbit = ibt(node)
1234  if(itp(node)==1) then
1235  call upb8(ival,nbit,mbit,mbay(1,lun))
1236  nbmp=int(ival)
1237  call usrtpl(lun,n,nbmp)
1238  endif
1239  do i=1,nnod
1240  if(nods(i)==node) then
1241  if(itp(node)==1) then
1242  call upb8(ival,nbit,mbit,mbay(1,lun))
1243  tab(i,iret) = ival
1244  elseif(itp(node)==2) then
1245  call upb8(ival,nbit,mbit,mbay(1,lun))
1246  if(ival<mps(node)) tab(i,iret) = ups(ival,node)
1247  elseif(itp(node)==3) then
1248  cval = ' '
1249  kbit = mbit
1250  call upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
1251  tab(i,iret) = rval
1252  endif
1253  nods(i) = -nods(i)
1254  cycle inner
1255  endif
1256  enddo
1257  do i=1,nnod
1258  if(nods(i)>0) cycle inner
1259  enddo
1260  enddo inner
1261 
1262  ! Update the subset pointers before next read
1263 
1264  ibit = mbyt(lun)*8
1265  call upb(nbyt,16,mbay(1,lun),ibit)
1266  mbyt(lun) = mbyt(lun) + nbyt
1267  nsub(lun) = nsub(lun) + 1
1268  if(irec>0) tab(irec,iret) = nmsg(lun)
1269  if(isub>0) tab(isub,iret) = nsub(lun)
1270  if(itbl>0) tab(itbl,iret) = ldxts
1271  enddo
1272 
1273  enddo outer
1274 
1275  ! Reset the memory file
1276  call rdmemm(0,subset,jdate,mret)
1277 
1278  return
1279 end subroutine ufbtam
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:202
subroutine upb8(nval, nbits, ibit, ibay)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:80
real *8 function ups(ival, node)
Unpack a real*8 value from an integer by applying the proper scale and reference values.
Definition: cidecode.F90:319
recursive integer function iupb(mbay, nbyt, nbit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:226
subroutine upc(chr, nchr, ibay, ibit, cnvnull)
Decode a character string from within a specified number of bytes of an integer array,...
Definition: cidecode.F90:26
subroutine stbfdx(lun, mesg)
Copy a DX BUFR tables message into the internal memory arrays in module moda_tababd.
Definition: dxtable.F90:990
subroutine dxinit(lun, ioi)
Clear out the internal arrays (in module moda_tababd) holding the DX BUFR table, then optionally init...
Definition: dxtable.F90:606
integer function idxmsg(mesg)
Check whether a BUFR message contains DX BUFR tables information that was generated by the NCEPLIBS-b...
Definition: dxtable.F90:1123
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
recursive subroutine rdmems(isub, iret)
Read a specified data subset from the BUFR message that was most recently read via a call to subrouti...
Definition: memmsgs.F90:635
subroutine cpdxmm(lunit)
Read an entire DX BUFR table from a specified file into internal memory arrays.
Definition: memmsgs.F90:730
recursive subroutine rdmemm(imsg, subset, jdate, iret)
Read a specified BUFR message from internal arrays in memory, so that it is now in scope for processi...
Definition: memmsgs.F90:487
recursive subroutine ufbmem(lunit, inew, iret, iunit)
Connect a new file to the NCEPLIBS-bufr software for input operations, then read the entire file cont...
Definition: memmsgs.F90:39
recursive subroutine readmm(imsg, subset, jdate, iret)
Read a specified BUFR message from internal arrays in memory, so that it is now in scope for processi...
Definition: memmsgs.F90:382
recursive subroutine ufbmex(lunit, lundx, inew, iret, mesg)
Connect a new file to the NCEPLIBS-bufr software for input operations, then read the entire file cont...
Definition: memmsgs.F90:217
recursive subroutine ufbmns(irep, subset, idate)
Read a specified data subset from internal arrays in memory, so that it is now in scope for processin...
Definition: memmsgs.F90:911
recursive subroutine ufbrms(imsg, isub, usr, i1, i2, iret, str)
Read one or more data values from a data subset in internal arrays.
Definition: memmsgs.F90:977
recursive subroutine ufbtam(tab, i1, i2, iret, str)
Read through every data subset in internal arrays and return one or more specified data values from e...
Definition: memmsgs.F90:1103
recursive subroutine ufbmms(imsg, isub, subset, jdate)
Read a specified data subset from internal arrays.
Definition: memmsgs.F90:840
recursive integer function ireadmm(imsg, subset, idate)
Call subroutine readmm() and pass back its return code as the function value.
Definition: memmsgs.F90:434
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Definition: bufrlib.F90:11
Declare arrays and variables used to store BUFR messages internally for multiple file IDs.
integer ibit
Bit pointer within ibay.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each file ID.
integer, dimension(:), allocatable mbyt
Length (in bytes) of current BUFR message for each file ID.
Declare an array used by various subroutines and functions to hold a temporary working copy of a BUFR...
integer, dimension(:), allocatable mgwa
Temporary working copy of BUFR message.
Declare arrays used to store information about the current BUFR message that is in the process of bei...
integer, dimension(:), allocatable nmsg
Current message pointer within logical unit.
integer, dimension(:), allocatable msub
Total number of data subsets in message.
integer, dimension(:), allocatable nsub
Current subset pointer within message.
Declare arrays and variables used to store the contents of one or more BUFR files within internal mem...
integer, dimension(:), allocatable msgp
Pointers to the beginning of each message within msgs (up to a maximum of maxmsg, and where array ele...
integer, dimension(:), allocatable ipmsgs
Pointers to first message within msgs for which each DX BUFR table applies.
integer, dimension(:), allocatable msgs
BUFR messages read from one or more BUFR files.
integer, dimension(:), allocatable icdxts
Number of consecutive messages within mdx which constitute each DX BUFR table, beginning with the cor...
integer mxdxm
Maximum number of DX BUFR table messages that can be stored within mdx.
integer, dimension(:), allocatable ifdxts
Pointers to the beginning of each DX BUFR table within mdx.
integer munit
Fortran logical unit number for use in accessing contents of BUFR files within internal memory.
integer ndxm
Number of DX BUFR table messages stored within mdx (up to a maximum of mxdxm).
integer ldxm
Number of array elements filled within mdx (up to a maximum of mxdxw).
integer mlast
Number of array elements filled within msgs (up to a maximum of maxmem).
integer ldxts
Number of DX BUFR table that is currently in scope, depending on which BUFR message within msgs is cu...
integer ndxts
Number of DX BUFR tables represented by the messages within mdx (up to a maximum of mxdxts).
integer, dimension(:), allocatable mdx
DX BUFR table messages read from one or more BUFR files, for use in decoding the messages in msgs.
integer mxdxw
Maximum number of entries that can be stored within mdx.
integer, dimension(:), allocatable ipdxm
Pointers to the beginning of each message within mdx.
Declare arrays and variables used to store the internal jump/link table.
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Declare an array used to store, for each file ID from which a BUFR message is currently being read as...
integer, dimension(:), allocatable msgunp
Flag indicating how to unpack data subsets from BUFR message:
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
recursive subroutine closbf(lunit)
Close the connection between logical unit lunit and the NCEPLIBS-bufr software.
recursive subroutine openbf(lunit, io, lundx)
Connect a new file to the NCEPLIBS-bufr software for input or output operations, or initialize the li...
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
subroutine wtstat(lunit, lun, il, im)
Update file status in library internals.
recursive integer function nmsub(lunit)
Get the total number of data subsets available within the BUFR message that was most recently opened ...
integer function nmwrd(mbay)
Given an integer array containing Section 0 from a BUFR message, determine the array size (in integer...
subroutine rdmsgw(lunit, mesg, iret)
Read the next BUFR message from logical unit lunit as an array of integer words.
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
Definition: readwritesb.F90:32
recursive subroutine ufbint(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.
subroutine cktaba(lun, subset, jdate, iret)
Get the Table A mnemonic from Sections 1 and 3 of a BUFR message.
Definition: s013vals.F90:1272
recursive integer function iupbs01(mbay, s01mnem)
Read a specified value from within Section 0 or Section 1 of a BUFR message.
Definition: s013vals.F90:247
subroutine parstr(str, tags, mtag, ntag, sep, limit80)
Parse a string containing one or more substrings into an array of substrings.
Definition: strings.F90:473
subroutine string(str, lun, i1, io)
Check whether a string is in the internal mnemonic string cache.
Definition: strings.F90:25
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x4884.F90:18
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65