NCEPLIBS-bufr  12.1.0
openclosebf.F90
Go to the documentation of this file.
1 
5 
15 recursive subroutine fortran_open(filename, lunit, format, position, iret)
16 
17  use modv_vars, only: im8b
18 
19  implicit none
20  character*(*), intent(in) :: filename, format, position
21  integer, intent(in) :: lunit
22  integer, intent(out) :: iret
23  integer my_lunit
24 
25  ! check for i8 integers
26 
27  if(im8b) then
28  im8b=.false.
29 
30  call x84(lunit,my_lunit,1)
31  call fortran_open(filename,my_lunit,format,position,iret)
32  call x48(iret,iret,1)
33 
34  im8b=.true.
35  return
36  endif
37 
38  open(lunit, file=trim(filename), form=trim(format), position=trim(position), iostat=iret)
39  return
40 end subroutine fortran_open
41 
48 recursive subroutine fortran_close(lunit, iret)
49 
50  use modv_vars, only: im8b
51 
52  implicit none
53  integer, intent(in) :: lunit
54  integer, intent(out) :: iret
55  integer my_lunit
56 
57  ! check for i8 integers
58 
59  if(im8b) then
60  im8b=.false.
61 
62  call x84(lunit,my_lunit,1)
63  call fortran_close(my_lunit,iret)
64  call x48(iret,iret,1)
65 
66  im8b=.true.
67  return
68  endif
69 
70  close(lunit, iostat=iret)
71  return
72 end subroutine fortran_close
73 
168 recursive subroutine openbf(lunit,io,lundx)
169 
170  use bufrlib
171 
172  use modv_vars, only: im8b, ifopbf, nfiles
173 
174  use moda_msgcwd
175  use moda_stbfr
176  use moda_sc3bfr
177  use moda_lushr
178  use moda_nulbfr
179  use moda_stcode
180 
181  implicit none
182 
183  integer, intent(in) :: lunit, lundx
184  integer my_lunit, my_lundx, iprt, iprtprv, lun, il, im
185 
186  character*(*), intent(in) :: io
187  character*255 filename, fileacc
188  character*128 bort_str, errstr
189  character*28 cprint(0:4)
190 
191  common /quiet/ iprt
192 
193  data cprint/ &
194  ' (only ABORTs) ', &
195  ' (limited -default) ', &
196  ' (all warnings) ', &
197  ' (all warnings+infos) ', &
198  ' (all warnings+infos+debugs)'/
199 
200  ! Check for i8 integers
201 
202  if(im8b) then
203  im8b=.false.
204 
205  call x84(lunit,my_lunit,1)
206  call x84(lundx,my_lundx,1)
207  call openbf(my_lunit,io,my_lundx)
208 
209  im8b=.true.
210  return
211  endif
212 
213  ! If this is the first call to this subroutine, initialize iprt in /quiet/ as 0
214 
215  if(ifopbf==0) iprt = 0
216 
217  if(io=='QUIET') then
218  ! override previous iprt value (printout indicator)
219  iprtprv = iprt
220  iprt = lundx
221  if(iprt<-1) iprt = -1
222  if(iprt>3) iprt = 3
223  if(iprt>=0) then
224  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
225  write ( unit=errstr, fmt='(A,I3,A,A,I3,A)' ) 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR CHNGED FROM', &
226  iprtprv,cprint(iprtprv+1),' TO',iprt,cprint(iprt+1)
227  call errwrt(errstr)
228  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
229  call errwrt(' ')
230  endif
231  endif
232 
233  if(ifopbf==0) then
234  ! This is the first call to this subroutine, so take care of some initial housekeeping tasks.
235  ! Note that arallocf and arallocc_c must be called before calling bfrini.
236 
237  ! Allocate internal arrays.
238  call arallocf
239  call arallocc_c
240 
241  ! Initialize some global variables.
242  call bfrini
243 
244  ifopbf = 1
245  endif
246  if( (io=='FIRST') .or. (io=='QUIET') ) return
247 
248  ! See if a file can be opened
249 
250  call status(lunit,lun,il,im)
251  if(lun==0) then
252  write(bort_str,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3," BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') &
253  nfiles,lunit
254  call bort(bort_str)
255  endif
256  if(il/=0) then
257  write(bort_str,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT",I5," IS ALREADY OPEN")') lunit
258  call bort(bort_str)
259  endif
260  null(lun) = 0
261  isc3(lun) = 0
262  iscodes(lun) = 0
263  lus(lun) = 0
264 
265  ! Use inquire to obtain the filename associated with unit lunit
266 
267  if (io/='NUL' .and. io/='INUL') then
268  inquire(lunit,access=fileacc)
269  if(fileacc=='UNDEFINED') open(lunit)
270  inquire(lunit,name=filename)
271  filename=trim(filename)//char(0)
272  endif
273 
274  nmsg(lun) = 0
275  nsub(lun) = 0
276  msub(lun) = 0
277  inode(lun) = 0
278  idate(lun) = 0
279 
280  ! Decide how to open the file and setup the dictionary
281 
282  if(io=='IN') then
283  call openrb_c(lun,filename)
284  call wtstat(lunit,lun,-1,0)
285  call readdx(lunit,lun,lundx)
286  else if(io=='INUL') then
287  call wtstat(lunit,lun,-1,0)
288  if(lunit/=lundx) call readdx(lunit,lun,lundx)
289  null(lun) = 1
290  else if(io=='NUL') then
291  call wtstat(lunit,lun,1,0)
292  if(lunit/=lundx) call readdx(lunit,lun,lundx)
293  null(lun) = 1
294  else if(io=='INX') then
295  call openrb_c(lun,filename)
296  call wtstat(lunit,lun,-1,0)
297  null(lun) = 1
298  else if(io=='OUX') then
299  call openwb_c(lun,filename)
300  call wtstat(lunit,lun,1,0)
301  else if(io=='SEC3') then
302  call openrb_c(lun,filename)
303  call wtstat(lunit,lun,-1,0)
304  isc3(lun) = 1
305  else if(io=='OUT') then
306  call openwb_c(lun,filename)
307  call wtstat(lunit,lun,1,0)
308  call writdx(lunit,lun,lundx)
309  else if(io=='NODX') then
310  call openwb_c(lun,filename)
311  call wtstat(lunit,lun,1,0)
312  call readdx(lunit,lun,lundx)
313  else if(io=='APN' .or. io=='APX') then
314  call openab_c(lun,filename)
315  call wtstat(lunit,lun,1,0)
316  if(lunit/=lundx) call readdx(lunit,lun,lundx)
317  call posapx(lunit)
318  else
319  call bort('BUFRLIB: OPENBF - ILLEGAL SECOND (INPUT) ARGUMENT')
320  endif
321 
322  return
323 end subroutine openbf
324 
337 recursive subroutine closbf(lunit)
338 
339  use bufrlib
340 
341  use modv_vars, only: im8b
342 
343  use moda_nulbfr
344 
345  implicit none
346 
347  character*128 errstr
348 
349  integer, intent(in) :: lunit
350  integer my_lunit, lun, il, im
351 
352  ! Check for i8 integers
353 
354  if(im8b) then
355  im8b=.false.
356 
357  call x84(lunit,my_lunit,1)
358  call closbf(my_lunit)
359 
360  im8b=.true.
361  return
362  endif
363 
364  if ( .not. allocated(null) ) then
365  call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
366  errstr = 'BUFRLIB: CLOSBF WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
367  call errwrt(errstr)
368  call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
369  return
370  endif
371 
372  call status(lunit,lun,il,im)
373  if(il>0 .and. im/=0) call closmg(lunit)
374  if(il/=0 .and. null(lun)==0) call closfb_c(lun)
375  call wtstat(lunit,lun,0,0)
376 
377  ! Close Fortran unit if null(lun) = 0
378 
379  if(null(lun)==0) close(lunit)
380 
381  return
382 end subroutine closbf
383 
405 recursive subroutine status(lunit,lun,il,im)
406 
407  use modv_vars, only: im8b, nfiles
408 
409  use moda_stbfr
410 
411  implicit none
412 
413  integer, intent(in) :: lunit
414  integer, intent(out) :: lun, il, im
415  integer my_lunit, i
416 
417  character*128 bort_str, errstr
418 
419  ! Check for I8 integers
420 
421  if(im8b) then
422  im8b=.false.
423 
424  call x84(lunit,my_lunit,1)
425  call status(my_lunit,lun,il,im)
426  call x48(lun,lun,1)
427  call x48(il,il,1)
428  call x48(im,im,1)
429 
430  im8b=.true.
431  return
432  endif
433 
434  if(lunit<=0 .or. lunit>99) then
435  write(bort_str,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") OUTSIDE LEGAL RANGE OF 1-99")') lunit
436  call bort(bort_str)
437  endif
438 
439  ! Clear the status indicators
440 
441  lun = 0
442  il = 0
443  im = 0
444 
445  ! See if the unit is already connected to the library
446 
447  if ( .not. allocated(iolun) ) then
448  call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
449  errstr = 'BUFRLIB: STATUS WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
450  call errwrt(errstr)
451  call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
452  return
453  endif
454 
455  do i=1,nfiles
456  if(abs(iolun(i))==lunit) lun = i
457  enddo
458 
459  ! If not, try to define it so as to connect it to the library
460 
461  if(lun==0) then
462  do i=1,nfiles
463  if(iolun(i)==0) then
464  ! File space is available, return with lun > 0, il and im remain 0
465  lun = i
466  return
467  endif
468  enddo
469  ! File space is NOT available, return with lun, il and im all 0
470  return
471  endif
472 
473  ! If the unit was already connected to the library prior to this call, then return statuses
474 
475  il = sign(1,iolun(lun))
476  im = iomsg(lun)
477 
478  return
479 end subroutine status
480 
508 subroutine wtstat(lunit,lun,il,im)
509 
510  use moda_stbfr
511 
512  implicit none
513 
514  integer, intent(in) :: lunit, lun, il, im
515 
516  character*128 bort_str
517 
518  ! Check on the arguments
519 
520  if(lunit<=0) then
521  write(bort_str,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED INTO FIRST ARGUMENT (INPUT) (=",I3,")")') lunit
522  call bort(bort_str)
523  endif
524  if(lun<=0) then
525  write(bort_str,'("BUFRLIB: WTSTAT - INVALID FILE ID PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') lun
526  call bort(bort_str)
527  endif
528  if(il<-1 .or. il>1) then
529  write(bort_str,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS INDICATOR PASSED INTO THIRD ARGUMENT '// &
530  '(INPUT) (=",I4,")")') il
531  call bort(bort_str)
532  endif
533  if(im< 0 .or. im>1) then
534  write(bort_str,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS INDICATOR PASSED INTO FOURTH ARGUMENT '// &
535  '(INPUT) (=",I4,")")') im
536  call bort(bort_str)
537  endif
538 
539  ! Check on lunit-lun combination
540 
541  if(abs(iolun(lun))/=lunit .and. (iolun(lun)/=0)) then
542  write(bort_str,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE EXISTING FILE UNIT (LOGICAL UNIT '// &
543  'NUMBER ",I3,")")') iolun(lun)
544  call bort(bort_str)
545  endif
546 
547  ! Reset the file statuses
548 
549  if(il/=0) then
550  iolun(lun) = sign(lunit,il)
551  iomsg(lun) = im
552  else
553  iolun(lun) = 0
554  iomsg(lun) = 0
555  endif
556 
557  return
558 end subroutine wtstat
559 
585 recursive subroutine ufbcnt(lunit,kmsg,ksub)
586 
587  use modv_vars, only: im8b
588 
589  use moda_msgcwd
590 
591  implicit none
592 
593  integer, intent(in) :: lunit
594  integer, intent(out) :: kmsg, ksub
595  integer my_lunit, lun, il, im
596 
597  ! Check for I8 integers
598 
599  if(im8b) then
600  im8b=.false.
601  call x84(lunit,my_lunit,1)
602  call ufbcnt(my_lunit,kmsg,ksub)
603  call x48(kmsg,kmsg,1)
604  call x48(ksub,ksub,1)
605  im8b=.true.
606  return
607  endif
608 
609  ! Check the file status - return the message and subset counters
610 
611  call status(lunit,lun,il,im)
612  if(il==0) call bort('BUFRLIB: UFBCNT - BUFR FILE IS CLOSED, IT MUST BE OPEN FOR EITHER INPUT OR OUTPUT')
613  kmsg = nmsg(lun)
614  ksub = nsub(lun)
615 
616  return
617 end subroutine ufbcnt
618 
630 subroutine posapx(lunxx)
631 
632  use bufrlib
633 
634  use moda_mgwa
635 
636  implicit none
637 
638  integer, intent(in) :: lunxx
639  integer lunit, lun, il, im, ier, idxmsg
640 
641  lunit = abs(lunxx)
642 
643  call status(lunit,lun,il,im)
644  if(il==0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
645  if(il<0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
646 
647  ! Try to read to the end of the file
648 
649  do while (.true.)
650  call rdmsgw(lunit,mgwa,ier)
651  if(ier<0) return
652  if(idxmsg(mgwa)==1) then
653  ! This is an internal dictionary message that was generated by the NCEPLIBS-bufr software. Backspace the file pointer
654  ! and then read and store all such dictionary messages (they should be stored consecutively!) and reset the internal tables.
655  call backbufr_c(lun)
656  call rdbfdx(lunit,lun)
657  endif
658  enddo
659 
660 end subroutine posapx
661 
693 subroutine rewnbf(lunit,isr)
694 
695  use bufrlib
696 
697  use moda_msgcwd
698  use moda_bitbuf
699  use moda_bufrsr
700 
701  implicit none
702 
703  integer, intent(in) :: lunit, isr
704  integer lun, il, im, i, kdate, ier
705 
706  character*128 bort_str
707  character*8 subset
708 
709  ! Try to trap bad call problems
710  if(isr==0) then
711  call status(lunit,lun,il,im)
712  if(jsr(lun)/=0) then
713  write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
714  'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED (AND NOT YET RESTORED) (UNIT",I3,")")') lunit
715  call bort(bort_str)
716  endif
717  if(il==0) then
718  write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
719  'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT OR OUTPUT) (UNIT",I3,")")') lunit
720  call bort(bort_str)
721  endif
722  elseif(isr==1) then
723  if(junn==0 .or. jsr(junn)/=1) then
724  write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// &
725  'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') lunit
726  call bort(bort_str)
727  endif
728  lun = junn
729  else
730  write(bort_str,'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// &
731  'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') isr, lunit
732  call bort(bort_str)
733  endif
734 
735  if(isr==0) then
736  ! Store the existing file parameters
737  jmsg = nmsg(lun)
738  jsub = nsub(lun)
739  if ( il > 0 ) then
740  ! The file is open for writing
741  jbit = ibit
742  jbyt = mbyt(lun)
743  do i=1,jbyt
744  jbay(i) = mbay(i,lun)
745  enddo
746  endif
747  junn = lun
748  jill = il
749  jimm = im
750  ! Reset the file for reading
751  call wtstat(lunit,lun,-1,0)
752  endif
753 
754  ! Rewind the file
755  call cewind_c(lun)
756 
757  if(isr==1) then
758  ! Restore the previous file parameters. Note that we already restored the previous value of lun earlier in this routine.
759 
760  ! Reset nmsg(lun) to 0, so that the below calls to readmg() will internally restore nmsg(lun) to the correct value.
761  nmsg(lun) = 0
762 
763  ! Note that the below calls to readmg() are valid even if the file was previously open for writing, because we haven't yet
764  ! called wtstat() to restore the file to its previous I/O status. So until then we can still read from it as though it
765  ! was an input file.
766  do i=1,jmsg
767  call readmg(lunit,subset,kdate,ier)
768  if(ier<0) then
769  write(bort_str,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// &
770  'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE NO.",I5)') lunit, jmsg
771  call bort(bort_str)
772  endif
773  enddo
774 
775  if ( jill < 0 ) then
776  ! The file was previously open for reading
777  do i=1,jsub
778  call readsb(lunit,ier)
779  enddo
780  else
781  ! The file was previously open for writing
782  do i=1,jbyt
783  mbay(i,lun) = jbay(i)
784  enddo
785  nsub(lun) = jsub
786  mbyt(lun) = jbyt
787  ibit = jbit
788  endif
789 
790  ! Now restore the file to its previous I/O status
791  il = jill
792  im = jimm
793  call wtstat(lunit,lun,il,im)
794  endif
795 
796  ! Toggle the stack status indicator
797  jsr(lun) = mod(jsr(lun)+1,2)
798 
799  return
800 end subroutine rewnbf
801 
856 recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str)
857 
858  use modv_vars, only: im8b, bmiss, iac
859 
860  use moda_usrint
861  use moda_msgcwd
862  use moda_unptyp
863  use moda_bitbuf
864  use moda_tables
865 
866  implicit none
867 
868  integer*8 ival, lref, ninc, mps, lps
869  integer, intent(in) :: lunin, i1, i2
870  integer, intent(out) :: iret
871  integer, parameter :: maxtg = 100
872  integer nnod, ncon, nods, nodc, ivls, kons, iprt, my_lunin, my_i1, my_i2, lunit, lun, il, im, irec, isub, i, j, n, ntg, &
873  jdate, jbit, kbit, lbit, mbit, nbit, nibit, nbyt, nsb, node, nbmp, nrep, lret, linc, iac_prev, ityp, &
875 
876  character*(*), intent(in) :: str
877  character*128 errstr
878  character*40 cref
879  character*10 tgs(maxtg)
880  character*8 subset, cval
881 
882  logical openit, overflow, just_count, need_node
883 
884  real*8, intent(out) :: tab(i1,i2)
885  real*8 rval, ups
886 
887  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
888  common /quiet/ iprt
889 
890  equivalence(cval,rval)
891 
892  ! Statement functions
893  mps(node) = 2_8**(ibt(node))-1
894  lps(lbit) = max(2_8**(lbit)-1,1)
895 
896  ! Check for I8 integers
897  if(im8b) then
898  im8b=.false.
899  call x84(lunin,my_lunin,1)
900  call x84(i1,my_i1,1)
901  call x84(i2,my_i2,1)
902  call ufbtab(my_lunin,tab,my_i1,my_i2,iret,str)
903  call x48(iret,iret,1)
904  im8b=.true.
905  return
906  endif
907 
908  ! Make sure subroutine openbf() has been called at least once before trying to call subroutine status(); otherwise,
909  ! status() might try to access array space that hasn't yet been dynamically allocated.
910  call openbf(0,'FIRST',0)
911 
912  lunit = abs(lunin)
913  call status(lunit,lun,il,im)
914  openit = il==0
915 
916  if(openit) then
917  ! Open BUFR file connected to unit lunit if it isn't already open
918  call openbf(lunit,'INX',lunit)
919  else
920  ! If BUFR file already opened, save position and rewind to first data message
921  call rewnbf(lunit,0)
922  endif
923 
924  ! Initialize all of the output array values to the current value for "missing"
925  do j=1,i2
926  do i=1,i1
927  tab(i,j) = bmiss
928  enddo
929  enddo
930 
931  ! Set counters to zero
932  iret = 0
933  irec = 0
934  isub = 0
935 
936  iac_prev = iac
937  iac = 1
938 
939  overflow = .false.
940 
941  ! Check for count subset only option
942  just_count = lunin<lunit
943  if(just_count) then
944  do while(ireadmg(-lunit,subset,jdate)>=0)
945  iret = iret+nmsub(lunit)
946  enddo
947  else
948  ! Check for special tags in string
949  call parstr(str,tgs,maxtg,ntg,' ',.true.)
950  do i=1,ntg
951  if(tgs(i)=='IREC') irec = i
952  if(tgs(i)=='ISUB') isub = i
953  enddo
954  endif
955 
956  outer: do while (.not. just_count)
957  ! Read the next message from the file
958  if(ireadmg(-lunit,subset,jdate)<0) exit
959  call string(str,lun,i1,0)
960  if(irec>0) nods(irec) = 0
961  if(isub>0) nods(isub) = 0
962 
963  if(msgunp(lun)/=2) then
964  ! The message is uncompressed
965 
966  inner1: do while (.true.)
967  ! Get the next subset from the message
968  if(nsub(lun)==msub(lun)) cycle outer
969  if(iret+1>i2) then
970  overflow = .true.
971  exit outer
972  endif
973  iret = iret+1
974  do i=1,nnod
975  nods(i) = abs(nods(i))
976  enddo
977  if(msgunp(lun)==0) then
978  mbit = mbyt(lun)*8 + 16
979  else
980  mbit = mbyt(lun)
981  endif
982  nbit = 0
983  n = 1
984  call usrtpl(lun,n,n)
985  inner2: do while (.true.)
986  ! Cycle through each node of the subset to look for the requested values
987  if(n+1<=nval(lun)) then
988  n = n+1
989  node = inv(n,lun)
990  mbit = mbit+nbit
991  nbit = ibt(node)
992  if(itp(node)==1) then
993  call upb8(ival,nbit,mbit,mbay(1,lun))
994  nbmp=int(ival)
995  call usrtpl(lun,n,nbmp)
996  endif
997  do i=1,nnod
998  if(nods(i)==node) then
999  if(itp(node)==1) then
1000  call upb8(ival,nbit,mbit,mbay(1,lun))
1001  tab(i,iret) = ival
1002  elseif(itp(node)==2) then
1003  call upb8(ival,nbit,mbit,mbay(1,lun))
1004  if(ival<mps(node)) tab(i,iret) = ups(ival,node)
1005  elseif(itp(node)==3) then
1006  cval = ' '
1007  kbit = mbit
1008  call upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
1009  tab(i,iret) = rval
1010  endif
1011  nods(i) = -nods(i)
1012  cycle inner2
1013  endif
1014  enddo
1015  do i=1,nnod
1016  if(nods(i)>0) cycle inner2
1017  enddo
1018  endif
1019  exit
1020  enddo inner2
1021  ! Update the subset pointers
1022  if(msgunp(lun)==0) then
1023  ibit = mbyt(lun)*8
1024  call upb(nbyt,16,mbay(1,lun),ibit)
1025  mbyt(lun) = mbyt(lun) + nbyt
1026  else
1027  mbyt(lun) = mbit
1028  endif
1029  nsub(lun) = nsub(lun) + 1
1030  if(irec>0) tab(irec,iret) = nmsg(lun)
1031  if(isub>0) tab(isub,iret) = nsub(lun)
1032  enddo inner1
1033 
1034  else
1035  ! The message is compressed
1036 
1037  if(iret+msub(lun)>i2) then
1038  overflow = .true.
1039  exit outer
1040  endif
1041  if(irec>0.or.isub>0) then
1042  do nsb=1,msub(lun)
1043  if(irec>0) tab(irec,iret+nsb) = nmsg(lun)
1044  if(isub>0) tab(isub,iret+nsb) = nsb
1045  enddo
1046  endif
1047  call usrtpl(lun,1,1)
1048  ibit = mbyt(lun)
1049  n = 0
1050  inner3: do n = n+1,nval(lun)
1051  ! Cycle through each node of each subset to look for the requested values
1052  node = inv(n,lun)
1053  nbit = ibt(node)
1054  ityp = itp(node)
1055  if(n==1) then
1056  ! Reset the node indices
1057  do i=1,nnod
1058  nods(i) = abs(nods(i))
1059  enddo
1060  else
1061  ! Are we still looking for more values?
1062  need_node = .false.
1063  do i=1,nnod
1064  if(nods(i)>0) then
1065  need_node = .true.
1066  exit
1067  endif
1068  enddo
1069  if(.not. need_node) exit inner3
1070  endif
1071  if(ityp==1 .or. ityp==2) then
1072  call up8(lref,nbit,mbay(1,lun),ibit)
1073  call upb(linc,6,mbay(1,lun),ibit)
1074  nibit = ibit + linc*msub(lun)
1075  elseif(ityp==3) then
1076  cref=' '
1077  call upc(cref,nbit/8,mbay(1,lun),ibit,.true.)
1078  call upb(linc,6,mbay(1,lun),ibit)
1079  nibit = ibit + 8*linc*msub(lun)
1080  else
1081  cycle
1082  endif
1083  if(ityp==1) then
1084  ! This is a delayed replication node
1085  jbit = ibit + linc
1086  call up8(ninc,linc,mbay(1,lun),jbit)
1087  ival = lref+ninc
1088  call usrtpl(lun,n,int(ival))
1089  cycle
1090  endif
1091  do i=1,nnod
1092  if(node==nods(i)) then
1093  ! This is one of the requested values, so store the corresponding value from each subset in the message
1094  nods(i) = -nods(i)
1095  lret = iret
1096  if(ityp==1 .or. ityp==2) then
1097  do nsb=1,msub(lun)
1098  jbit = ibit + linc*(nsb-1)
1099  call up8(ninc,linc,mbay(1,lun),jbit)
1100  ival = lref+ninc
1101  lret = lret+1
1102  if(ninc<lps(linc)) tab(i,lret) = ups(ival,node)
1103  enddo
1104  elseif(ityp==3) then
1105  do nsb=1,msub(lun)
1106  if(linc==0) then
1107  cval = cref(1:8)
1108  else
1109  jbit = ibit + linc*(nsb-1)*8
1110  cval = ' '
1111  call upc(cval,linc,mbay(1,lun),jbit,.true.)
1112  endif
1113  lret = lret+1
1114  tab(i,lret) = rval
1115  enddo
1116  else
1117  call bort('UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
1118  endif
1119  endif
1120  enddo
1121  ibit = nibit
1122  enddo inner3
1123  iret = iret+msub(lun)
1124 
1125  endif
1126 
1127  enddo outer
1128 
1129  if(overflow) then
1130  nrep = iret
1131  do while(ireadsb(lunit)==0)
1132  nrep = nrep+1
1133  enddo
1134  do while(ireadmg(-lunit,subset,jdate)>=0)
1135  nrep = nrep+nmsub(lunit)
1136  enddo
1137  if(iprt>=0) then
1138  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1139  write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', &
1140  .GT.'IS LIMIT OF ', i2, ' IN THE 4TH ARG. (INPUT) - INCOMPLETE READ'
1141  call errwrt(errstr)
1142  write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBTAB STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
1143  call errwrt(errstr)
1144  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1145  call errwrt(' ')
1146  endif
1147  endif
1148 
1149  if(openit) then
1150  ! Close BUFR file if it was opened here
1151  call closbf(lunit)
1152  else
1153  ! Restore BUFR file to its previous status and position
1154  call rewnbf(lunit,1)
1155  endif
1156 
1157  iac = iac_prev
1158 
1159  return
1160 end subroutine ufbtab
subroutine arallocf
Dynamically allocate Fortran language arrays.
Definition: arallocf.F90:19
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
subroutine up8(nval, nbits, ibay, ibit)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:128
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 writdx(lunit, lun, lundx)
Write DX BUFR table (dictionary) messages to the beginning of an output BUFR file in lunit.
Definition: dxtable.F90:812
subroutine readdx(lunit, lun, lundx)
Initialize modules moda_tababd and moda_msgcwd with DX BUFR (dictionary) tables.
Definition: dxtable.F90:29
subroutine rdbfdx(lunit, lun)
Beginning at the current file pointer location within lunit, read a complete DX BUFR table into inter...
Definition: dxtable.F90:121
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
subroutine bfrini
Initialize numerous global variables and arrays within internal modules and COMMON blocks throughout ...
Definition: misc.F90:16
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 arrays and variables needed to store the current position within a BUFR file.
integer jill
File status indicator of BUFR file.
integer jimm
Message status indicator of BUFR file.
integer, dimension(:), allocatable jsr
Indicator of stack status when entering subroutine rewnbf().
integer jmsg
Sequential number of BUFR message, counting from the beginning of the file.
integer jbit
Bit pointer within BUFR message.
integer jsub
Sequential number of BUFR data subset, counting from the beginning of the current BUFR message.
integer junn
File ID of BUFR file.
integer jbyt
Length (in bytes) of BUFR message.
integer, dimension(:), allocatable jbay
BUFR message.
Declare an array used by subroutine makestab() to keep track of which logical units share DX BUFR tab...
integer, dimension(:), allocatable lus
Tracking index 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 inode
Table A mnemonic for type of BUFR message.
integer, dimension(:), allocatable idate
Section 1 date-time of message.
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 an array used to store a switch for each file ID, indicating whether any BUFR messages should...
integer, dimension(:), allocatable null
Output switch for each file ID:
Declare an array used to store a switch for each file ID, indicating whether BUFR messages read from ...
integer, dimension(:), allocatable isc3
Section 3 switch for each file ID:
Declare arrays used to store file and message status indicators for all logical units that have been ...
integer, dimension(:), allocatable iolun
File status indicators.
integer, dimension(:), allocatable iomsg
Message status indicator corresponding to iolun, denoting whether a BUFR message is currently open wi...
Declare an array used to store a status code for each file ID if an error or other abnormal result oc...
integer, dimension(:), allocatable iscodes
Abnormal status codes.
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.
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
recursive subroutine fortran_open(filename, lunit, format, position, iret)
Open a Fortran file on the local system.
Definition: openclosebf.F90:16
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 fortran_close(lunit, iret)
Close a Fortran file on the local system.
Definition: openclosebf.F90:49
recursive subroutine ufbcnt(lunit, kmsg, ksub)
Get the current location of the file pointer within a BUFR file, in terms of a message number countin...
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 subroutine ufbtab(lunin, tab, i1, i2, iret, str)
Read through every data subset in a BUFR file and return one or more specified data values from each ...
subroutine posapx(lunxx)
Position an output BUFR file for appending.
recursive subroutine closmg(lunin)
Close the BUFR message that is currently open for writing within internal arrays associated with logi...
recursive integer function nmsub(lunit)
Get the total number of data subsets available within the BUFR message that was most recently opened ...
recursive subroutine readmg(lunxx, subset, jdate, iret)
Read the next BUFR message from logical unit abs(lunxx) into internal arrays.
Definition: readwritemg.F90:44
subroutine rdmsgw(lunit, mesg, iret)
Read the next BUFR message from logical unit lunit as an array of integer words.
recursive integer function ireadmg(lunit, subset, idate)
Call subroutine readmg() and pass back its return code as the function value.
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
recursive integer function ireadsb(lunit)
Call subroutine readsb() and pass back its return code as the function value.
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
Definition: readwritesb.F90:32
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