NCEPLIBS-bufr  12.2.0
•All Data Structures Namespaces Files Functions Variables Macros Pages
readwriteval.F90
Go to the documentation of this file.
1 
5 
37 recursive subroutine setvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb, r8val, iret )
38 
39  use modv_vars, only: im8b
40 
41  use moda_usrint
42  use moda_msgcwd
43  use moda_tables
44 
45  implicit none
46 
47  integer, intent(in) :: lunit, ntagpv, ntagnb
48  integer, intent(out) :: iret
49  integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft
50 
51  character*(*), intent(in) :: tagpv, tagnb
52 
53  real*8, intent(in) :: r8val
54 
55  ! Check for I8 integers.
56  if(im8b) then
57  im8b=.false.
58  call x84 ( lunit, my_lunit, 1 )
59  call x84 ( ntagpv, my_ntagpv, 1 )
60  call x84 ( ntagnb, my_ntagnb, 1 )
61  call setvalnb ( my_lunit, tagpv, my_ntagpv, tagnb, my_ntagnb, r8val, iret )
62  call x48 ( iret, iret, 1 )
63  im8b=.true.
64  return
65  endif
66 
67  iret = -1
68 
69  ! Get lun from lunit.
70  call status (lunit, lun, il, im )
71  if ( il <= 0 ) return
72  if ( inode(lun) /= inv(1,lun) ) return
73 
74  ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv.
75  call fstag( lun, tagpv, ntagpv, 1, npv, ierft )
76  if ( ierft /= 0 ) return
77 
78  ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb.
79  call fstag( lun, tagnb, ntagnb, npv, nnb, ierft )
80  if ( ierft /= 0 ) return
81 
82  iret = 0
83  val(nnb,lun) = r8val
84 
85  return
86 end subroutine setvalnb
87 
121 recursive real*8 function getvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb ) result ( r8val )
122 
123  use modv_vars, only: im8b, bmiss
124 
125  use moda_usrint
126  use moda_msgcwd
127  use moda_tables
128 
129  implicit none
130 
131  integer, intent(in) :: lunit, ntagpv, ntagnb
132  integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft
133 
134  character*(*), intent(in) :: tagpv, tagnb
135 
136  ! Check for I8 integers.
137  if(im8b) then
138  im8b=.false.
139  call x84(lunit,my_lunit,1)
140  call x84(ntagpv,my_ntagpv,1)
141  call x84(ntagnb,my_ntagnb,1)
142  r8val=getvalnb(my_lunit,tagpv,my_ntagpv,tagnb,my_ntagnb)
143  im8b=.true.
144  return
145  endif
146 
147  r8val = bmiss
148 
149  ! Get lun from lunit.
150  call status (lunit, lun, il, im )
151  if ( il >= 0 ) return
152  if ( inode(lun) /= inv(1,lun) ) return
153 
154  ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv.
155  call fstag( lun, tagpv, ntagpv, 1, npv, ierft )
156  if ( ierft /= 0 ) return
157 
158  ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb.
159  call fstag( lun, tagnb, ntagnb, npv, nnb, ierft )
160  if ( ierft /= 0 ) return
161 
162  r8val = val(nnb,lun)
163 
164  return
165 end function getvalnb
166 
199 recursive subroutine writlc(lunit,chr,str)
200 
201  use modv_vars, only: im8b, mxlcc, iprt
202 
203  use moda_usrint
204  use moda_msgcwd
205  use moda_bitbuf
206  use moda_tables
207  use moda_comprs
208 
209  implicit none
210 
211  integer, intent(in) :: lunit
212  integer my_lunit, maxtg, lun, il, im, ntg, nnod, kon, ii, n, node, ioid, ival, mbit, nbit, nbmp, nchr, nbyt, nsubs, &
213  itagct, len0, len1, len2, len3, l4, l5, mbyte, iupbs3
214 
215  character*(*), intent(in) :: chr, str
216  character*128 bort_str, errstr
217  character*10 ctag
218  character*14 tgs(10)
219 
220  real roid
221 
222  data maxtg /10/
223 
224  ! Check for I8 integers
225  if(im8b) then
226  im8b=.false.
227  call x84(lunit,my_lunit,1)
228  call writlc(my_lunit,chr,str)
229  im8b=.true.
230  return
231  endiF
232 
233  ! Check the file status.
234  call status(lunit,lun,il,im)
235  if(il==0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
236  if(il<0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
237  if(im==0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
238 
239  ! Check for tags (mnemonics) in input string (there can only be one)
240  call parstr(str,tgs,maxtg,ntg,' ',.true.)
241  if(ntg>1) then
242  write(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// &
243  ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4,")")') str,ntg
244  call bort(bort_str)
245  endif
246 
247  ! Check if a specific occurrence of the input string was requested; if not, then the default is to write the first occurrence
248  call parutg(lun,1,tgs(1),nnod,kon,roid)
249  if(kon==6) then
250  ioid=nint(roid)
251  if(ioid<=0) ioid = 1
252  ctag = ' '
253  ii = 1
254  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
255  ctag(ii:ii)=tgs(1)(ii:ii)
256  ii = ii + 1
257  enddo
258  else
259  ioid = 1
260  ctag = tgs(1)(1:10)
261  endif
262 
263  if(iupbs3(mbay(1,lun),'ICMP')>0) then
264  ! The message is compressed
265  n = 1
266  itagct = 0
267  call usrtpl(lun,n,n)
268  do while (n+1<=nval(lun))
269  n = n+1
270  node = inv(n,lun)
271  if(itp(node)==1) then
272  nbmp=int(matx(n,ncol))
273  call usrtpl(lun,n,nbmp)
274  elseif(ctag==tag(node)) then
275  itagct = itagct + 1
276  if(itagct==ioid) then
277  if(itp(node)/=3) then
278  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
279  ctag,typ(node)
280  call bort(bort_str)
281  endif
282  catx(n,ncol)=' '
283  ! The following statement enforces a limit of mxlcc characters per long character string when writing
284  ! compressed messages. This limit keeps the array catx to a reasonable dimensioned size.
285  nchr=min(mxlcc,ibt(node)/8)
286  catx(n,ncol)=chr(1:nchr)
287  call usrtpl(lun,1,1)
288  return
289  endif
290  endif
291  enddo
292  else
293  ! The message is not compressed. Locate the beginning of the data (Section 4) in the message.
294  call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
295  mbyte = len0 + len1 + len2 + len3 + 4
296  nsubs = 1
297  ! Find the most recently written subset in the message.
298  do while(nsubs<nsub(lun))
299  ibit = mbyte*8
300  call upb(nbyt,16,mbay(1,lun),ibit)
301  mbyte = mbyte + nbyt
302  nsubs = nsubs + 1
303  enddo
304  if(nsubs/=nsub(lun)) then
305  if(iprt>=0) then
306  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
307  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // &
308  ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
309  call errwrt(errstr)
310  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
311  call errwrt(' ')
312  endif
313  return
314  endif
315  ! Locate and write the long character string within this subset.
316  itagct = 0
317  mbit = mbyte*8 + 16
318  nbit = 0
319  n = 1
320  call usrtpl(lun,n,n)
321  do while (n+1<=nval(lun))
322  n = n+1
323  node = inv(n,lun)
324  mbit = mbit+nbit
325  nbit = ibt(node)
326  if(itp(node)==1) then
327  call upbb(ival,nbit,mbit,mbay(1,lun))
328  call usrtpl(lun,n,ival)
329  elseif(ctag==tag(node)) then
330  itagct = itagct + 1
331  if(itagct==ioid) then
332  if(itp(node)/=3) then
333  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
334  ctag,typ(node)
335  call bort(bort_str)
336  endif
337  nchr = nbit/8
338  ibit = mbit
339  do ii=1,nchr
340  call pkc(' ',1,mbay(1,lun),ibit)
341  enddo
342  call pkc(chr,nchr,mbay(1,lun),mbit)
343  call usrtpl(lun,1,1)
344  return
345  endif
346  endif
347  enddo
348  endif
349 
350  ! If we made it here, then we couldn't find the requested string.
351  if(iprt>=0) then
352  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
353  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE ' // &
354  'SUBSET DEFINITION'
355  call errwrt(errstr)
356  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
357  call errwrt(errstr)
358  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
359  call errwrt(' ')
360  endif
361 
362  return
363 end subroutine writlc
364 
404 recursive subroutine readlc(lunit,chr,str)
405 
406  use modv_vars, only: im8b, iprt
407 
408  use moda_usrint
409  use moda_usrbit
410  use moda_unptyp
411  use moda_bitbuf
412  use moda_tables
413  use moda_rlccmn
414 
415  implicit none
416 
417  integer, intent(in) :: lunit
418  integer my_lunit, maxtg, lchr, lun, il, im, ntg, nnod, kon, ii, n, nod, ioid, itagct, nchr, kbit
419 
420  character*(*), intent(in) :: str
421  character*(*), intent(out) :: chr
422 
423  character*128 bort_str, errstr
424  character*10 ctag
425  character*14 tgs(10)
426 
427  real roid
428 
429  data maxtg /10/
430 
431  ! Check for I8 integers
432  if(im8b) then
433  im8b=.false.
434  call x84(lunit,my_lunit,1)
435  call readlc(my_lunit,chr,str)
436  im8b=.true.
437  return
438  endif
439 
440  chr = ' '
441  lchr=len(chr)
442 
443  ! Check the file status
444  call status(lunit,lun,il,im)
445  if(il==0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
446  if(il>0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
447  if(im==0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
448 
449  ! Check for tags (mnemonics) in input string (there can only be one)
450  call parstr(str,tgs,maxtg,ntg,' ',.true.)
451  if(ntg>1) then
452  write(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// &
453  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntg
454  call bort(bort_str)
455  endif
456 
457  ! Check if a specific occurrence of the input string was requested; if not, then the default is to return the
458  ! first occurrence.
459  call parutg(lun,0,tgs(1),nnod,kon,roid)
460  if(kon==6) then
461  ioid=nint(roid)
462  if(ioid<=0) ioid = 1
463  ctag = ' '
464  ii = 1
465  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
466  ctag(ii:ii)=tgs(1)(ii:ii)
467  ii = ii + 1
468  enddo
469  else
470  ioid = 1
471  ctag = tgs(1)(1:10)
472  endif
473 
474  ! Locate and decode the long character string
475  if(msgunp(lun)==0.or.msgunp(lun)==1) then
476  ! The message is not compressed
477  itagct = 0
478  do n=1,nval(lun)
479  nod = inv(n,lun)
480  if(ctag==tag(nod)) then
481  itagct = itagct + 1
482  if(itagct==ioid) then
483  if(itp(nod)/=3) then
484  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// &
485  'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
486  call bort(bort_str)
487  endif
488  nchr = nbit(n)/8
489  if(nchr>lchr) then
490  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
491  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
492  call bort(bort_str)
493  endif
494  kbit = mbit(n)
495  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
496  return
497  endif
498  endif
499  enddo
500  else
501  ! The message is compressed
502  if(nrst>0) then
503  itagct = 0
504  do ii=1,nrst
505  if(ctag==crtag(ii)) then
506  itagct = itagct + 1
507  if(itagct==ioid) then
508  nchr = irnch(ii)
509  if(nchr>lchr) then
510  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
511  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
512  call bort(bort_str)
513  endif
514  kbit = irbit(ii)
515  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
516  return
517  endif
518  endif
519  enddo
520  endif
521  endif
522 
523  ! If we made it here, then we couldn't find the requested string.
524  if(iprt>=0) then
525  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
526  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // &
527  ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT'
528  call errwrt(errstr)
529  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
530  call errwrt(' ')
531  endif
532  do ii=1,lchr
533  call ipkm(chr(ii:ii),1,255)
534  enddo
535 
536  return
537 end subroutine readlc
538 
641 recursive subroutine ufbint(lunin,usr,i1,i2,iret,str)
642 
643  use modv_vars, only: im8b, bmiss, iprt
644 
645  use moda_usrint
646  use moda_msgcwd
647 
648  implicit none
649 
650  character*(*), intent(in) :: str
651  character*128 bort_str1, bort_str2, errstr
652 
653  integer, intent(in) :: lunin, i1, i2
654  integer, intent(out) :: iret
655  integer nnod, ncon, nods, nodc, ivls, kons, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io
656 
657  real*8, intent(inout) :: usr(i1,i2)
658 
659  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
660 
661  data ifirst1 /0/, ifirst2 /0/
662 
663  save ifirst1, ifirst2
664 
665  ! Check for I8 integers
666  if(im8b) then
667  im8b=.false.
668  call x84(lunin,my_lunin,1)
669  call x84(i1,my_i1,1)
670  call x84(i2,my_i2,1)
671  call ufbint(my_lunin,usr,my_i1,my_i2,iret,str)
672  call x48(iret,iret,1)
673  im8b=.true.
674  return
675  endif
676 
677  iret = 0
678 
679  ! Check the file status and inode
680  lunit = abs(lunin)
681  call status(lunit,lun,il,im)
682  if(il==0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN')
683  if(im==0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
684  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
685  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
686 
687  io = min(max(0,il),1)
688  if(lunit/=lunin) io = 0
689 
690  if(i1<=0) then
691  if(iprt>=0) then
692  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
693  errstr = .LE.'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
694  call errwrt(errstr)
695  call errwrt(str)
696  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
697  call errwrt(' ')
698  endif
699  return
700  elseif(i2<=0) then
701  if(iprt==-1) ifirst1 = 1
702  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
703  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
704  errstr = .LE.'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
705  call errwrt(errstr)
706  call errwrt(str)
707  if(iprt==0 .and. io==1) then
708  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
709  'all such messages,'
710  call errwrt(errstr)
711  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
712  'BUFRLIB routine.'
713  call errwrt(errstr)
714  endif
715  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
716  call errwrt(' ')
717  ifirst1 = 1
718  endif
719  return
720  endif
721 
722  ! Parse or recall the input string
723  call string(str,lun,i1,io)
724 
725  ! Initialize usr array preceeding an input operation
726  if(io==0) usr(1:i1,1:i2) = bmiss
727 
728  ! Call the mnemonic reader/writer
729  call ufbrw(lun,usr,i1,i2,io,iret)
730 
731  ! If incomplete write try to initialize replication sequence or return
732  if(io==1 .and. iret/=i2 .and. iret>=0) then
733  call trybump(lun,usr,i1,i2,io,iret)
734  if(iret/=i2) then
735  write(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ",A)') str
736  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
737  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
738  call bort2(bort_str1,bort_str2)
739  endif
740  elseif(iret==-1) then
741  iret = 0
742  endif
743 
744  if(iret==0) then
745  if(io==0) then
746  if(iprt>=1) then
747  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
748  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
749  call errwrt(errstr)
750  call errwrt(str)
751  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
752  call errwrt(' ')
753  endif
754  else
755  if(iprt==-1) ifirst2 = 1
756  if(ifirst2==0 .or. iprt>=1) then
757  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
758  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
759  call errwrt(errstr)
760  call errwrt(str)
761  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
762  if(iprt==0) then
763  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
764  'all such messages,'
765  call errwrt(errstr)
766  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // &
767  'to a BUFRLIB routine.'
768  call errwrt(errstr)
769  endif
770  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
771  call errwrt(' ')
772  ifirst2 = 1
773  endif
774  endif
775  endif
776 
777  return
778 end subroutine ufbint
779 
874 recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str)
875 
876  use modv_vars, only: im8b, bmiss, iac, iprt
877 
878  use moda_usrint
879  use moda_msgcwd
880 
881  implicit none
882 
883  character*(*), intent(in) :: str
884  character*128 bort_str1, bort_str2, errstr
885 
886  integer, intent(in) :: lunin, i1, i2
887  integer, intent(out) :: iret
888  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, iac_prev
889 
890  real*8, intent(inout) :: usr(i1,i2)
891 
892  data ifirst1 /0/
893 
894  save ifirst1
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 ufbrep(my_lunin,usr,my_i1,my_i2,iret,str)
903  call x48(iret,iret,1)
904  im8b=.true.
905  return
906  endif
907 
908  iret = 0
909 
910  ! Check the file status and inode
911  lunit = abs(lunin)
912  call status(lunit,lun,il,im)
913  if(il==0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
914  if(im==0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
915  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
916  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
917 
918  io = min(max(0,il),1)
919  if(lunit/=lunin) io = 0
920 
921  if(i1<=0) then
922  if(iprt>=0) then
923  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
924  errstr = .LE.'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
925  call errwrt(errstr)
926  call errwrt(str)
927  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
928  call errwrt(' ')
929  endif
930  return
931  elseif(i2<=0) then
932  if(iprt==-1) ifirst1 = 1
933  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
934  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
935  errstr = .LE.'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
936  call errwrt(errstr)
937  call errwrt(str)
938  if(iprt==0 .and. io==1) then
939  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
940  'all such messages,'
941  call errwrt(errstr)
942  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
943  'BUFRLIB routine.'
944  call errwrt(errstr)
945  endif
946  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
947  call errwrt(' ')
948  ifirst1 = 1
949  endif
950  return
951  endif
952 
953  ! Initialize usr array preceeding an input operation
954  if(io==0) usr(1:i1,1:i2) = bmiss
955 
956  ! Parse or recall the input string
957  iac_prev = iac
958  iac = 1
959  call string(str,lun,i1,io)
960  iac = iac_prev
961 
962  ! Call the mnemonic reader/writer
963  call ufbrp(lun,usr,i1,i2,io,iret)
964 
965  if(io==1 .and. iret<i2) then
966  write(bort_str1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ",A)') str
967  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
968  'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
969  call bort2(bort_str1,bort_str2)
970  endif
971 
972  if(iret==0 .and. io==0 .and. iprt>=1) then
973  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
974  errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
975  call errwrt(errstr)
976  call errwrt(str)
977  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
978  call errwrt(' ')
979  endif
980 
981  return
982 end subroutine ufbrep
983 
1079 recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str)
1080 
1081  use modv_vars, only: im8b, bmiss, iprt
1082 
1083  use moda_usrint
1084  use moda_msgcwd
1085 
1086  implicit none
1087 
1088  character*(*), intent(in) :: str
1089  character*128 bort_str1, bort_str2, errstr
1090 
1091  integer, intent(in) :: lunin, i1, i2
1092  integer, intent(out) :: iret
1093  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io
1094 
1095  real*8, intent(inout) :: usr(i1,i2)
1096 
1097  data ifirst1 /0/
1098 
1099  save ifirst1
1100 
1101  ! Check for I8 integers
1102  if(im8b) then
1103  im8b=.false.
1104  call x84(lunin,my_lunin,1)
1105  call x84(i1,my_i1,1)
1106  call x84(i2,my_i2,1)
1107  call ufbstp(my_lunin,usr,my_i1,my_i2,iret,str)
1108  call x48(iret,iret,1)
1109  im8b=.true.
1110  return
1111  endif
1112 
1113  iret = 0
1114 
1115  ! Check the file status and inode
1116  lunit = abs(lunin)
1117  call status(lunit,lun,il,im)
1118  if(il==0) call bort('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1119  if(im==0) call bort('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1120  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
1121  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1122 
1123  io = min(max(0,il),1)
1124  if(lunit/=lunin) io = 0
1125 
1126  if(i1<=0) then
1127  if(iprt>=0) then
1128  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1129  errstr = .LE.'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1130  call errwrt(errstr)
1131  call errwrt(str)
1132  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1133  call errwrt(' ')
1134  endif
1135  return
1136  elseif(i2<=0) then
1137  if(iprt==-1) ifirst1 = 1
1138  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1139  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1140  errstr = .LE.'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1141  call errwrt(errstr)
1142  call errwrt(str)
1143  if(iprt==0 .and. io==1) then
1144  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1145  'all such messages,'
1146  call errwrt(errstr)
1147  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1148  'BUFRLIB routine.'
1149  call errwrt(errstr)
1150  endif
1151  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1152  call errwrt(' ')
1153  ifirst1 = 1
1154  endif
1155  return
1156  endif
1157 
1158  ! Initialize usr array preceeding an input operation
1159  if(io==0) usr(1:i1,1:i2) = bmiss
1160 
1161  ! Parse or recall the input string
1162  call string(str,lun,i1,io)
1163 
1164  ! Call the mnemonic reader/writer
1165  call ufbsp(lun,usr,i1,i2,io,iret)
1166 
1167  if(io==1 .and. iret/=i2) then
1168  write(bort_str1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ",A)') str
1169  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
1170  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
1171  call bort2(bort_str1,bort_str2)
1172  endif
1173 
1174  if(iret==0 .and. io==0 .and. iprt>=1) then
1175  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1176  errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1177  call errwrt(errstr)
1178  call errwrt(str)
1179  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1180  call errwrt(' ')
1181  endif
1182 
1183  return
1184 end subroutine ufbstp
1185 
1292 recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str)
1293 
1294  use modv_vars, only: im8b, bmiss, iprt
1295 
1296  use moda_usrint
1297  use moda_msgcwd
1298  use moda_tables
1299 
1300  implicit none
1301 
1302  integer, intent(in) :: lunin, i1, i2
1303  integer, intent(out) :: iret
1304  integer, parameter :: mtag = 10
1305  integer ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j, ntag, node, nods, ins1, ins2, insx, &
1306  nseq, isq, ityp, invwin, invtag
1307 
1308  real*8, intent(inout) :: usr(i1,i2)
1309 
1310  character*(*), intent(in) :: str
1311  character*156 bort_str
1312  character*128 errstr
1313  character*10 tags(mtag)
1314 
1315  data ifirst1 /0/, ifirst2 /0/
1316 
1317  save ifirst1, ifirst2
1318 
1319  ! Check for I8 integers
1320  if(im8b) then
1321  im8b=.false.
1322  call x84(lunin,my_lunin,1)
1323  call x84(i1,my_i1,1)
1324  call x84(i2,my_i2,1)
1325  call ufbseq(my_lunin,usr,my_i1,my_i2,iret,str)
1326  call x48(iret,iret,1)
1327  im8b=.true.
1328  return
1329  endif
1330 
1331  iret = 0
1332 
1333  ! Check the file status and inode
1334  lunit = abs(lunin)
1335  call status(lunit,lun,il,im)
1336  if(il==0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1337  if(im==0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1338 
1339  io = min(max(0,il),1)
1340  if(lunit/=lunin) io = 0
1341 
1342  if(i1<=0) then
1343  if(iprt>=0) then
1344  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1345  errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1346  call errwrt(errstr)
1347  call errwrt(str)
1348  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1349  call errwrt(' ')
1350  endif
1351  return
1352  elseif(i2<=0) then
1353  if(iprt==-1) ifirst1 = 1
1354  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1355  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1356  errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1357  call errwrt(errstr)
1358  call errwrt(str)
1359  if(iprt==0 .and. io==1) then
1360  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1361  'all such messages,'
1362  call errwrt(errstr)
1363  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1364  'BUFRLIB routine.'
1365  call errwrt(errstr)
1366  endif
1367  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1368  call errwrt(' ')
1369  ifirst1 = 1
1370  endif
1371  return
1372  endif
1373 
1374  ! Check for valid sequence and sequence length arguments
1375  call parstr(str,tags,mtag,ntag,' ',.true.)
1376  if(ntag<1) then
1377  write(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") DOES NOT CONTAIN ANY MNEMONICS!!")') str
1378  call bort(bort_str)
1379  endif
1380  if(ntag>1) then
1381  write(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// &
1382  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntag
1383  call bort(bort_str)
1384  endif
1385  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// &
1386  'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1387 
1388  ! Initialize usr array preceeding an input operation
1389  if(io==0) usr(1:i1,1:i2) = bmiss
1390 
1391  ! Find the parameters of the specified sequence
1392  outer: do node=inode(lun),isc(inode(lun))
1393  if(str==tag(node)) then
1394  if(typ(node)=='SEQ' .or. typ(node)=='RPC') then
1395  ins1 = 1
1396  do while (.true.)
1397  ins1 = invtag(node,lun,ins1,nval(lun))
1398  if(ins1==0) exit outer
1399  if(typ(node)/='RPC' .or. val(ins1,lun)/=0.) exit
1400  ins1 = ins1+1
1401  enddo
1402  ins2 = invtag(node,lun,ins1+1,nval(lun))
1403  if(ins2==0) ins2 = 10e5
1404  nods = node
1405  do while(link(nods)==0 .and. jmpb(nods)>0)
1406  nods = jmpb(nods)
1407  enddo
1408  if(link(nods)==0) then
1409  insx = nval(lun)
1410  elseif(link(nods)>0) then
1411  insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
1412  endif
1413  ins2 = min(ins2,insx)
1414  elseif(typ(node)=='SUB') then
1415  ins1 = 1
1416  ins2 = nval(lun)
1417  else
1418  write(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// &
1419  'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
1420  call bort(bort_str)
1421  endif
1422  nseq = 0
1423  do isq=ins1,ins2
1424  ityp = itp(inv(isq,lun))
1425  if(ityp>1) nseq = nseq+1
1426  enddo
1427  if(nseq>i1) then
1428  write(bort_str,.GT.'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A," CONSISTS OF",I4," TABLE B MNEM., THE MAX. '// &
1429  'SPECIFIED IN (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
1430  call bort(bort_str)
1431  endif
1432  ! Frame a section of the buffer - return when no frame
1433  inner: do while (.true.)
1434  ins1 = invtag(node,lun,ins1,nval(lun))
1435  if(ins1>nval(lun)) exit outer
1436  if(ins1>0) then
1437  if(typ(node)=='RPC' .and. val(ins1,lun)==0.) then
1438  ins1 = ins1+1
1439  cycle
1440  elseif(io==0 .and. iret+1>i2) then
1441  if(iprt>=0) then
1442  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1443  write ( unit=errstr, fmt='(A,I5,A,A,A)' ) 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2, &
1444  ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1), ' WERE READ'
1445  call errwrt(errstr)
1446  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1447  call errwrt(' ')
1448  endif
1449  exit outer
1450  endif
1451  elseif(ins1==0) then
1452  if(io==1 .and. iret<i2) then
1453  write(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'.LT.' WRITTEN (",I5,") NO. REQUESTED (",I5,") - '// &
1454  'INCOMPLETE WRITE (INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
1455  call bort(bort_str)
1456  endif
1457  else
1458  write(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE ZERO, HERE IT IS",I4," - INPUT MNEMONIC '// &
1459  'IS ",A)') ins1,tags(1)
1460  call bort(bort_str)
1461  endif
1462  if(ins1==0 .or. iret==i2) exit outer
1463  iret = iret+1
1464  ins1 = ins1+1
1465  ! Read/write user values
1466  j = ins1
1467  do i=1,nseq
1468  do while(itp(inv(j,lun))<2)
1469  j = j+1
1470  enddo
1471  if(io==0) usr(i,iret) = val(j,lun)
1472  if(io==1) val(j,lun) = usr(i,iret)
1473  j = j+1
1474  enddo
1475  enddo inner
1476  endif
1477  enddo outer
1478 
1479  if(iret==0) then
1480  if(io==0) then
1481  if(iprt>=1) then
1482  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1483  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1484  call errwrt(errstr)
1485  call errwrt(str)
1486  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1487  call errwrt(' ')
1488  endif
1489  else
1490  if(iprt==-1) ifirst2 = 1
1491  if(ifirst2==0 .or. iprt>=1) then
1492  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1493  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1494  call errwrt(errstr)
1495  call errwrt(str)
1496  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
1497  if(iprt==0) then
1498  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1499  'all such messages,'
1500  call errwrt(errstr)
1501  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1502  'BUFRLIB routine.'
1503  call errwrt(errstr)
1504  endif
1505  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1506  call errwrt(' ')
1507  ifirst2 = 1
1508  endif
1509  endif
1510  endif
1511 
1512  return
1513 end subroutine ufbseq
1514 
1552 recursive subroutine drfini(lunit,mdrf,ndrf,drftag)
1553 
1554  use modv_vars, only: im8b
1555 
1556  use moda_usrint
1557  use moda_tables
1558 
1559  implicit none
1560 
1561  character*(*), intent(in) :: drftag
1562 
1563  integer, intent(in) :: mdrf(*), lunit, ndrf
1564  integer, parameter :: mxdrf = 2000
1565  integer my_mdrf(mxdrf), my_lunit, my_ndrf, lun, il, im, m, n, node
1566 
1567  ! Check for I8 integers
1568  if(im8b) then
1569  im8b=.false.
1570  call x84(lunit,my_lunit,1)
1571  call x84(ndrf,my_ndrf,1)
1572  call x84(mdrf(1),my_mdrf(1),my_ndrf)
1573  call drfini(my_lunit,my_mdrf,my_ndrf,drftag)
1574  im8b=.true.
1575  return
1576  endif
1577 
1578  call status(lunit,lun,il,im)
1579  ! Conform the template to the delayed replication factors
1580  m = 0
1581  n = 1
1582  do while ( n <= nval(lun) )
1583  node = inv(n,lun)
1584  if(itp(node)==1 .and. tag(node)==drftag) then
1585  m = m+1
1586  call usrtpl(lun,n,mdrf(m))
1587  endif
1588  n = n+1
1589  enddo
1590 
1591  return
1592 end subroutine drfini
1593 
1617 subroutine ufbrw(lun,usr,i1,i2,io,iret)
1618 
1619  use modv_vars, only: bmiss, iprt
1620 
1621  use moda_usrint
1622  use moda_tables
1623  use moda_msgcwd
1624 
1625  implicit none
1626 
1627  integer, intent(in) :: lun, i1, i2, io
1628  integer, intent(out) :: iret
1629  integer nnod, ncon, nods, nodc, ivls, kons, inc1, inc2, ins1, ins2, invn, i, j, invwin, ibfms, lstjpb
1630 
1631  real*8, intent(inout) :: usr(i1,i2)
1632 
1633  character*128 errstr
1634  character*10 tagstr, subset
1635 
1636  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1637 
1638  subset=tag(inode(lun))
1639  iret = 0
1640 
1641  ! Loop over condition windows
1642  inc1 = 1
1643  inc2 = 1
1644  outer: do while (.true.)
1645  call conwin(lun,inc1,inc2)
1646  if(nnod==0) then
1647  iret = i2
1648  return
1649  elseif(inc1==0) then
1650  return
1651  else
1652  do j=1,nnod
1653  if(nods(j)>0) then
1654  ins2 = inc1
1655  call getwin(nods(j),lun,ins1,ins2)
1656  if(ins1==0) return
1657  do while (.true.)
1658  ! Loop over store nodes
1659  iret = iret+1
1660  if(iprt>=2) then
1661  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1662  call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//subset)
1663  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1664  do i=1,nnod
1665  if(io==0) tagstr=tag(nods(i))(1:8)//' R'
1666  if(io==1) tagstr=tag(nods(i))(1:8)//' W'
1667  invn = invwin(nods(i),lun,ins1,ins2)
1668  if(invn==0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn)
1669  write(errstr,'("LEV=",I5,1X,A,3I7)') iret,tagstr,ins1,invn,ins2
1670  call errwrt(errstr)
1671  enddo
1672  endif
1673  ! Write user values
1674  if(io==1 .and. iret<=i2) then
1675  do i=1,nnod
1676  if(nods(i)>0) then
1677  if(ibfms(usr(i,iret))==0) then
1678  invn = invwin(nods(i),lun,ins1,ins2)
1679  if(invn==0) then
1680  call drstpl(nods(i),lun,ins1,ins2,invn)
1681  if(invn==0) then
1682  iret = 0
1683  return
1684  endif
1685  call newwin(lun,inc1,inc2)
1686  val(invn,lun) = usr(i,iret)
1687  elseif(lstjpb(nods(i),lun,'RPS')==0) then
1688  val(invn,lun) = usr(i,iret)
1689  elseif(ibfms(val(invn,lun))/=0) then
1690  val(invn,lun) = usr(i,iret)
1691  else
1692  call drstpl(nods(i),lun,ins1,ins2,invn)
1693  if(invn==0) then
1694  iret = 0
1695  return
1696  endif
1697  call newwin(lun,inc1,inc2)
1698  val(invn,lun) = usr(i,iret)
1699  endif
1700  endif
1701  endif
1702  enddo
1703  endif
1704  ! Read user values
1705  if(io==0 .and. iret<=i2) then
1706  do i=1,nnod
1707  usr(i,iret) = bmiss
1708  if(nods(i)>0) then
1709  invn = invwin(nods(i),lun,ins1,ins2)
1710  if(invn>0) usr(i,iret) = val(invn,lun)
1711  endif
1712  enddo
1713  endif
1714  ! Decide what to do next
1715  if(io==1.and.iret==i2) return
1716  call nxtwin(lun,ins1,ins2)
1717  if(ins1>0 .and. ins1<inc2) cycle
1718  if(ncon>0) cycle outer
1719  return
1720  enddo
1721  endif
1722  enddo
1723  iret = -1
1724  return
1725  endif
1726  enddo outer
1727 
1728  return
1729 end subroutine ufbrw
1730 
1754 subroutine ufbrp(lun,usr,i1,i2,io,iret)
1755 
1756  use moda_usrint
1757 
1758  implicit none
1759 
1760  integer, intent(in) :: lun, i1, i2, io
1761  integer, intent(out) :: iret
1762  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, i, nz, invtag
1763 
1764  real*8, intent(inout) :: usr(i1,i2)
1765 
1766  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1767 
1768  iret = 0
1769  ins1 = 0
1770  ins2 = 0
1771 
1772  ! Find first non-zero node in string
1773  do nz=1,nnod
1774  if(nods(nz)>0) then
1775  do while (.true.)
1776  ! Frame a section of the buffer - return when no frame
1777  if(ins1+1>nval(lun)) return
1778  if(io==1 .and. iret==i2) return
1779  ins1 = invtag(nods(nz),lun,ins1+1,nval(lun))
1780  if(ins1==0) return
1781  ins2 = invtag(nods(nz),lun,ins1+1,nval(lun))
1782  if(ins2==0) ins2 = nval(lun)
1783  iret = iret+1
1784  ! Read user values
1785  if(io==0 .and. iret<=i2) then
1786  do i=1,nnod
1787  if(nods(i)>0) then
1788  invn = invtag(nods(i),lun,ins1,ins2)
1789  if(invn>0) usr(i,iret) = val(invn,lun)
1790  endif
1791  enddo
1792  endif
1793  ! Write user values
1794  if(io==1 .and. iret<=i2) then
1795  do i=1,nnod
1796  if(nods(i)>0) then
1797  invn = invtag(nods(i),lun,ins1,ins2)
1798  if(invn>0) val(invn,lun) = usr(i,iret)
1799  endif
1800  enddo
1801  endif
1802  enddo
1803  endif
1804  enddo
1805 
1806  return
1807 end subroutine ufbrp
1808 
1838 subroutine ufbsp(lun,usr,i1,i2,io,iret)
1839 
1840  use moda_usrint
1841 
1842  implicit none
1843 
1844  integer, intent(in) :: lun, i1, i2, io
1845  integer, intent(out) :: iret
1846  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, invm, i, invtag
1847 
1848  real*8, intent(inout) :: usr(i1,i2)
1849 
1850  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1851 
1852  iret = 0
1853  ins1 = 0
1854  ins2 = 0
1855 
1856  do while (.true.)
1857  ! Frame a section of the buffer - return when no frame
1858  if(ins1+1>nval(lun)) return
1859  ins1 = invtag(nods(1),lun,ins1+1,nval(lun))
1860  if(ins1==0) return
1861  ins2 = invtag(nods(1),lun,ins1+1,nval(lun))
1862  if(ins2==0) ins2 = nval(lun)
1863  iret = iret+1
1864  ! Read user values
1865  if(io==0 .and. iret<=i2) then
1866  invm = ins1
1867  do i=1,nnod
1868  if(nods(i)>0) then
1869  invn = invtag(nods(i),lun,invm,ins2)
1870  if(invn>0) usr(i,iret) = val(invn,lun)
1871  invm = max(invn,invm)
1872  endif
1873  enddo
1874  endif
1875  ! Write user values
1876  if(io==1 .and. iret<=i2) then
1877  invm = ins1
1878  do i=1,nnod
1879  if(nods(i)>0) then
1880  invn = invtag(nods(i),lun,invm,ins2)
1881  if(invn>0) val(invn,lun) = usr(i,iret)
1882  invm = max(invn,invm)
1883  endif
1884  enddo
1885  endif
1886  enddo
1887 
1888  return
1889 end subroutine ufbsp
1890 
1939 recursive subroutine hold4wlc(lunit,chr,str)
1940 
1941  use modv_vars, only: im8b, mxh4wlc, iprt
1942 
1943  use moda_h4wlc
1944 
1945  implicit none
1946 
1947  integer, intent(in) :: lunit
1948  integer my_lunit, lens, lenc, i
1949 
1950  character*(*), intent(in) :: chr, str
1951 
1952  character*128 errstr
1953  character*14 mystr
1954 
1955  ! Check for I8 integers
1956  if(im8b) then
1957  im8b=.false.
1958  call x84(lunit,my_lunit,1)
1959  call hold4wlc(my_lunit,chr,str)
1960  im8b=.true.
1961  return
1962  endif
1963 
1964  call strsuc( str, mystr, lens )
1965  if ( lens == -1 ) return
1966 
1967  lenc = min( len( chr ), 120 )
1968 
1969  ! If this subroutine has already been called with this mnemonic for this particular subset, then overwrite the
1970  ! corresponding entry in the internal holding area
1971  if ( nh4wlc > 0 ) then
1972  do i = 1, nh4wlc
1973  if ( ( lunit == luh4wlc(i) ) .and. ( mystr(1:lens) == sth4wlc(i)(1:lens) ) ) then
1974  chh4wlc(i) = ''
1975  chh4wlc(i)(1:lenc) = chr(1:lenc)
1976  return
1977  endif
1978  enddo
1979  endif
1980 
1981  ! Otherwise, use the next available unused entry in the holding area
1982  if ( nh4wlc >= mxh4wlc ) then
1983  if(iprt>=0) then
1984  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1985  write ( unit=errstr, fmt='(A,A,I3)' ) 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', &
1986  'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
1987  call errwrt(errstr)
1988  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1989  endif
1990  else
1991  nh4wlc = nh4wlc + 1
1992  luh4wlc(nh4wlc) = lunit
1993  sth4wlc(nh4wlc) = ''
1994  sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
1995  chh4wlc(nh4wlc) = ''
1996  chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
1997  endif
1998 
1999  return
2000 end subroutine hold4wlc
2001 
2028 subroutine trybump(lun,usr,i1,i2,io,iret)
2029 
2030  use moda_usrint
2031 
2032  implicit none
2033 
2034  integer, intent(in) :: lun, i1, i2, io
2035  integer, intent(out) :: iret
2036  integer nnod, ncon, nods, nodc, ivls, kons, ndrp, invn, jnvn, knvn, invwin, lstjpb
2037 
2038  real*8, intent(inout) :: usr(i1,i2)
2039 
2040  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2041 
2042  ! See if there's a delayed replication group involved
2043 
2044  ndrp = lstjpb(nods(1),lun,'DRP')
2045  if(ndrp<=0) return
2046 
2047  ! If so, clean it out and bump it to i2
2048 
2049  invn = invwin(ndrp,lun,1,nval(lun))
2050  val(invn,lun) = 0
2051  jnvn = invn+1
2052  do while(nint(val(jnvn,lun))>0)
2053  jnvn = jnvn+nint(val(jnvn,lun))
2054  enddo
2055  do knvn=1,nval(lun)-jnvn+1
2056  inv(invn+knvn,lun) = inv(jnvn+knvn-1,lun)
2057  val(invn+knvn,lun) = val(jnvn+knvn-1,lun)
2058  enddo
2059  nval(lun) = nval(lun)-(jnvn-invn-1)
2060  call usrtpl(lun,invn,i2)
2061 
2062  ! Call the mnemonic writer
2063 
2064  call ufbrw(lun,usr,i1,i2,io,iret)
2065 
2066  return
2067 end subroutine trybump
2068 
2088 recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str)
2089 
2090  use modv_vars, only: im8b, iprt
2091 
2092  use moda_usrint
2093  use moda_msgcwd
2094 
2095  implicit none
2096 
2097  integer, intent(in) :: lunit, i1, i2
2098  integer, intent(out) :: iret
2099  integer ifirst1, my_lunit, my_i1, my_i2, lun, il, im, io
2100 
2101  character*(*), intent(in) :: str
2102  character*128 bort_str1, bort_str2, errstr
2103 
2104  real*8, intent(inout) :: usr(i1,i2)
2105 
2106  data ifirst1 /0/
2107 
2108  save ifirst1
2109 
2110  ! Check for I8 integers
2111 
2112  if(im8b) then
2113  im8b=.false.
2114  call x84(lunit,my_lunit,1)
2115  call x84(i1,my_i1,1)
2116  call x84(i2,my_i2,1)
2117  call ufbovr(my_lunit,usr,my_i1,my_i2,iret,str)
2118  call x48(iret,iret,1)
2119  im8b=.true.
2120  return
2121  endif
2122 
2123  iret = 0
2124 
2125  ! Check the file status and inode
2126 
2127  call status(lunit,lun,il,im)
2128  if(il==0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
2129  if(il<0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
2130  if(im==0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
2131  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// &
2132  'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2133 
2134  io = min(max(0,il),1)
2135 
2136  if(i1<=0) then
2137  if(iprt>=0) then
2138  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2139  errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2140  call errwrt(errstr)
2141  call errwrt(str)
2142  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2143  call errwrt(' ')
2144  endif
2145  return
2146  elseif(i2<=0) then
2147  if(iprt==-1) ifirst1 = 1
2148  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
2149  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2150  errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2151  call errwrt(errstr)
2152  call errwrt(str)
2153  if(iprt==0 .and. io==1) then
2154  errstr = 'Note: Only the first occurrence of this WARNING ' // &
2155  'message is printed, there may be more. To output all such messages,'
2156  call errwrt(errstr)
2157  errstr = 'modify your application program to add ' // &
2158  '"CALL OPENBF(0,''QUIET'',1)" prior to the first call to a BUFRLIB routine.'
2159  call errwrt(errstr)
2160  endif
2161  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2162  call errwrt(' ')
2163  ifirst1 = 1
2164  endif
2165  return
2166  endif
2167 
2168  ! Parse or recall the input string - write values
2169 
2170  call string(str,lun,i1,io)
2171  call trybump(lun,usr,i1,i2,io,iret)
2172 
2173  if(io==1 .and. iret/=i2) then
2174  write(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS: ",A)') str
2175  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
2176  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret, i2
2177  call bort2(bort_str1,bort_str2)
2178  endif
2179 
2180  return
2181 end subroutine ufbovr
2182 
2220 recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str)
2221 
2222  use modv_vars, only: im8b, bmiss, iprt
2223 
2224  use moda_usrint
2225  use moda_msgcwd
2226 
2227  implicit none
2228 
2229  character*(*), intent(in) :: str
2230  character*128 errstr
2231 
2232  integer, intent(in) :: lunit, i1, i2, i3
2233  integer, intent(out) :: iret
2234  integer invn(255), nnod, ncon, nods, nodc, ivls, kons, maxevn, my_lunit, my_i1, my_i2, my_i3, i, j, k, lun, il, im, &
2235  ins1, ins2, inc1, inc2, nnvn, nvnwin
2236 
2237  real*8, intent(out) :: usr(i1,i2,i3)
2238 
2239  logical nodgt0
2240 
2241  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2242 
2243  ! Check for I8 integers
2244 
2245  if(im8b) then
2246  im8b=.false.
2247  call x84(lunit,my_lunit,1)
2248  call x84(i1,my_i1,1)
2249  call x84(i2,my_i2,1)
2250  call x84(i3,my_i3,1)
2251  call ufbevn(my_lunit,usr,my_i1,my_i2,my_i3,iret,str)
2252  call x48(iret,iret,1)
2253  im8b=.true.
2254  return
2255  endif
2256 
2257  maxevn = 0
2258  iret = 0
2259 
2260  ! Check the file status and inode
2261 
2262  call status(lunit,lun,il,im)
2263  if(il==0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2264  if(il>0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2265  if(im==0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2266  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// &
2267  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2268 
2269  if(i1<=0) then
2270  if(iprt>=0) then
2271  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2272  errstr = .LE.'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2273  call errwrt(errstr)
2274  call errwrt(str)
2275  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2276  call errwrt(' ')
2277  endif
2278  return
2279  elseif(i2<=0) then
2280  if(iprt>=0) then
2281  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2282  errstr = .LE.'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2283  call errwrt(errstr)
2284  call errwrt(str)
2285  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2286  call errwrt(' ')
2287  endif
2288  return
2289  elseif(i3<=0) then
2290  if(iprt>=0) then
2291  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2292  errstr = .LE.'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2293  call errwrt(errstr)
2294  call errwrt(str)
2295  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2296  call errwrt(' ')
2297  endif
2298  return
2299  endif
2300 
2301  ! Parse or recall the input string
2302 
2303  call string(str,lun,i1,0)
2304 
2305  ! Initialize usr array
2306  usr(1:i1,1:i2,1:i3) = bmiss
2307 
2308  ! Loop over condition windows
2309 
2310  inc1 = 1
2311  inc2 = 1
2312  outer: do while (.true.)
2313  call conwin(lun,inc1,inc2)
2314  if(nnod==0) then
2315  iret = i2
2316  return
2317  elseif(inc1==0) then
2318  return
2319  else
2320  nodgt0 = .false.
2321  do i=1,nnod
2322  if(nods(i)>0) then
2323  ins2 = inc1
2324  call getwin(nods(i),lun,ins1,ins2)
2325  if(ins1==0) return
2326  nodgt0 = .true.
2327  exit
2328  endif
2329  enddo
2330  if(.not.nodgt0) then
2331  ins1 = inc1
2332  ins2 = inc2
2333  endif
2334  ! Read push down stack data into 3D arrays
2335  inner: do while (.true.)
2336  iret = iret+1
2337  if(iret<=i2) then
2338  do j=1,nnod
2339  if(nods(j)>0) then
2340  nnvn = nvnwin(nods(j),lun,ins1,ins2,invn,i3)
2341  maxevn = max(nnvn,maxevn)
2342  do k=1,nnvn
2343  usr(j,iret,k) = val(invn(k),lun)
2344  enddo
2345  endif
2346  enddo
2347  endif
2348  ! Decide what to do next
2349  call nxtwin(lun,ins1,ins2)
2350  if(ins1<=0 .or. ins1>=inc2) exit inner
2351  enddo inner
2352  if(ncon<=0) exit outer
2353  endif
2354  enddo outer
2355 
2356  if(iret==0) then
2357  if(iprt>=1) then
2358  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2359  errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2360  call errwrt(errstr)
2361  call errwrt(str)
2362  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2363  call errwrt(' ')
2364  endif
2365  endif
2366 
2367  return
2368 end subroutine ufbevn
2369 
2403 recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str)
2404 
2405  use modv_vars, only: im8b
2406 
2407  use moda_msgcwd
2408  use moda_bitbuf
2409 
2410  implicit none
2411 
2412  integer, intent(in) :: lunit, imsg, isub, i1, i2
2413  integer, intent(out) :: iret
2414  integer my_lunit, my_imsg, my_isub, my_i1, my_i2, lun, il, im, jdate, jret, i
2415 
2416  character*(*), intent(in) :: str
2417  character*128 bort_str
2418  character*8 subset
2419 
2420  real*8, intent(out) :: usr(i1,i2)
2421 
2422  logical openit
2423 
2424  ! Check for I8 integers
2425  if(im8b) then
2426  im8b=.false.
2427  call x84(lunit,my_lunit,1)
2428  call x84(imsg,my_imsg,1)
2429  call x84(isub,my_isub,1)
2430  call x84(i1,my_i1,1)
2431  call x84(i2,my_i2,1)
2432  call ufbinx(my_lunit,my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
2433  call x48(iret,iret,1)
2434  im8b=.true.
2435  return
2436  endif
2437 
2438  call status(lunit,lun,il,im)
2439  openit = il==0
2440 
2441  if(openit) then
2442  ! Open BUFR file connected to unit lunit if it isn't already open
2443  call openbf(lunit,'INX',lunit)
2444  else
2445  ! If BUFR file already opened, save position and rewind to first data message
2446  call rewnbf(lunit,0)
2447  endif
2448 
2449  ! Skip to the requested message
2450  do i=1,imsg
2451  call readmg(lunit,subset,jdate,jret)
2452  if(jret<0) then
2453  write(bort_str,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// &
2454  'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') imsg, lunit
2455  call bort(bort_str)
2456  endif
2457  enddo
2458 
2459  ! Position at the requested subset
2460  do i=1,isub
2461  call readsb(lunit,jret)
2462  if(jret/=0) then
2463  write(bort_str,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// &
2464  'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub, imsg, lunit
2465  call bort(bort_str)
2466  endif
2467  enddo
2468 
2469  ! Read the requested data values
2470  call ufbint(lunit,usr,i1,i2,iret,str)
2471 
2472  if(openit) then
2473  ! Close BUFR file if it was opened here
2474  call closbf(lunit)
2475  else
2476  ! Restore BUFR file to its previous status and position
2477  call rewnbf(lunit,1)
2478  endif
2479 
2480  return
2481 end subroutine ufbinx
2482 
2497 recursive subroutine ufbget(lunit,tab,i1,iret,str)
2498 
2499  use modv_vars, only: im8b, bmiss
2500 
2501  use moda_usrint
2502  use moda_usrbit
2503  use moda_msgcwd
2504  use moda_bitbuf
2505  use moda_tables
2506 
2507  implicit none
2508 
2509  integer*8 ival
2510  integer, intent(in) :: lunit, i1
2511  integer, intent(out) :: iret
2512  integer nnod, ncon, nods, nodc, ivls, kons, my_lunit, my_i1, lun, il, im, i, n, node, nbmp, kbit, invn, invwin
2513 
2514  character*(*), intent(in) :: str
2515  character*8 cval
2516 
2517  real*8, intent(out) :: tab(i1)
2518  real*8 rval, ups
2519 
2520  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2521 
2522  equivalence(cval,rval)
2523 
2524  ! Check for I8 integers
2525 
2526  if(im8b) then
2527  im8b=.false.
2528  call x84(lunit,my_lunit,1)
2529  call x84(i1,my_i1,1)
2530  call ufbget(my_lunit,tab,my_i1,iret,str)
2531  call x48(iret,iret,1)
2532  im8b=.true.
2533  return
2534  endif
2535 
2536  iret = 0
2537  tab(1:i1) = bmiss
2538 
2539  ! Make sure a file/message is open for input
2540 
2541  call status(lunit,lun,il,im)
2542  if(il==0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2543  if(il>0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2544  if(im==0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2545 
2546  ! See if there's another subset in the message
2547 
2548  if(nsub(lun)==msub(lun)) then
2549  iret = -1
2550  return
2551  endif
2552 
2553  ! Parse the string
2554 
2555  call string(str,lun,i1,0)
2556 
2557  ! Expand the template for this subset as little as possible
2558 
2559  n = 1
2560  nbit(n) = 0
2561  mbit(n) = mbyt(lun)*8 + 16
2562  call usrtpl(lun,n,n)
2563  do n=n+1,nval(lun)
2564  node = inv(n,lun)
2565  nbit(n) = ibt(node)
2566  mbit(n) = mbit(n-1)+nbit(n-1)
2567  if(node==nods(nnod)) then
2568  nval(lun) = n
2569  exit
2570  elseif(itp(node)==1) then
2571  call upb8(ival,nbit(n),mbit(n),mbay(1,lun))
2572  nbmp=int(ival)
2573  call usrtpl(lun,n,nbmp)
2574  endif
2575  enddo
2576 
2577  ! Unpack only the nodes found in the string
2578 
2579  do i=1,nnod
2580  node = nods(i)
2581  invn = invwin(node,lun,1,nval(lun))
2582  if(invn>0) then
2583  call upb8(ival,nbit(invn),mbit(invn),mbay(1,lun))
2584  if(itp(node)==1) then
2585  tab(i) = ival
2586  elseif(itp(node)==2) then
2587  if(ival<2_8**(ibt(node))-1) tab(i) = ups(ival,node)
2588  elseif(itp(node)==3) then
2589  cval = ' '
2590  kbit = mbit(invn)
2591  call upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
2592  tab(i) = rval
2593  endif
2594  else
2595  tab(i) = bmiss
2596  endif
2597  enddo
2598 
2599  return
2600 end subroutine ufbget
bort
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
bort2
subroutine bort2(str1, str2)
Log two error messages, then abort the application program.
Definition: borts.F90:39
upb
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
upbb
subroutine upbb(nval, nbits, ibit, ibay)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:154
upb8
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
ups
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
upc
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
pkc
subroutine pkc(chr, nchr, ibay, ibit)
Encode a character string within a specified number of bytes of an integer array, starting at the bit...
Definition: ciencode.F90:25
ipkm
recursive subroutine ipkm(cbay, nbyt, n)
Encode an integer value within a specified number of bytes of a character string, up to a maximum of ...
Definition: ciencode.F90:194
errwrt
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
strsuc
subroutine strsuc(str1, str2, lens)
Remove leading and trailing blanks from a character string.
Definition: misc.F90:199
moda_bitbuf
Declare arrays and variables used to store BUFR messages internally for multiple file IDs.
Definition: modules_arrs.F90:10
moda_bitbuf::ibit
integer ibit
Bit pointer within ibay.
Definition: modules_arrs.F90:20
moda_bitbuf::mbay
integer, dimension(:,:), allocatable mbay
Current BUFR message for each file ID.
Definition: modules_arrs.F90:14
moda_bitbuf::mbyt
integer, dimension(:), allocatable mbyt
Length (in bytes) of current BUFR message for each file ID.
Definition: modules_arrs.F90:16
moda_comprs
Declare arrays and variables needed for the storage of data values needed when writing compressed dat...
Definition: modules_arrs.F90:126
moda_comprs::ncol
integer ncol
Number of data subsets in message.
Definition: modules_arrs.F90:128
moda_comprs::catx
character *(:), dimension(:,:), allocatable catx
Character data values for all data subsets in message.
Definition: modules_arrs.F90:134
moda_comprs::matx
integer *8, dimension(:,:), allocatable matx
Non-character data values for all data subsets in message.
Definition: modules_arrs.F90:132
moda_h4wlc
Declare arrays and variables needed to store long character strings (greater than 8 bytes) via subrou...
Definition: modules_arrs.F90:216
moda_h4wlc::nh4wlc
integer nh4wlc
Number of long character strings being stored.
Definition: modules_arrs.F90:218
moda_h4wlc::sth4wlc
character *14, dimension(:), allocatable sth4wlc
Table B mnemonics associated with long character strings.
Definition: modules_arrs.F90:222
moda_h4wlc::luh4wlc
integer, dimension(:), allocatable luh4wlc
File ID for associated output file.
Definition: modules_arrs.F90:220
moda_h4wlc::chh4wlc
character *120, dimension(:), allocatable chh4wlc
Long character strings.
Definition: modules_arrs.F90:224
moda_msgcwd
Declare arrays used to store information about the current BUFR message that is in the process of bei...
Definition: modules_arrs.F90:318
moda_msgcwd::inode
integer, dimension(:), allocatable inode
Table A mnemonic for type of BUFR message.
Definition: modules_arrs.F90:326
moda_msgcwd::msub
integer, dimension(:), allocatable msub
Total number of data subsets in message.
Definition: modules_arrs.F90:324
moda_msgcwd::nsub
integer, dimension(:), allocatable nsub
Current subset pointer within message.
Definition: modules_arrs.F90:322
moda_rlccmn
Declare arrays and variables needed to store information about long character strings (greater than 8...
Definition: modules_arrs.F90:559
moda_rlccmn::nrst
integer nrst
Number of long character strings in data subset.
Definition: modules_arrs.F90:561
moda_rlccmn::irnch
integer, dimension(:), allocatable irnch
Lengths (in bytes) of long character strings.
Definition: modules_arrs.F90:563
moda_rlccmn::irbit
integer, dimension(:), allocatable irbit
Pointers in data subset to first bits of long character strings.
Definition: modules_arrs.F90:565
moda_rlccmn::crtag
character *10, dimension(:), allocatable crtag
Table B mnemonics associated with long character strings.
Definition: modules_arrs.F90:567
moda_tables
Declare arrays and variables used to store the internal jump/link table.
Definition: modules_arrs.F90:681
moda_tables::isc
integer, dimension(:), allocatable isc
Scale factors corresponding to tag and typ:
Definition: modules_arrs.F90:739
moda_tables::ibt
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
Definition: modules_arrs.F90:727
moda_tables::typ
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
Definition: modules_arrs.F90:700
moda_tables::jmpb
integer, dimension(:), allocatable jmpb
Jump backward indices corresponding to tag and typ:
Definition: modules_arrs.F90:723
moda_tables::tag
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
Definition: modules_arrs.F90:685
moda_tables::itp
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Definition: modules_arrs.F90:745
moda_tables::link
integer, dimension(:), allocatable link
Link indices corresponding to tag, typ and jmpb:
Definition: modules_arrs.F90:716
moda_unptyp
Declare an array used to store, for each file ID from which a BUFR message is currently being read as...
Definition: modules_arrs.F90:783
moda_unptyp::msgunp
integer, dimension(:), allocatable msgunp
Flag indicating how to unpack data subsets from BUFR message:
Definition: modules_arrs.F90:788
moda_usrbit
Declare arrays for internal storage of pointers to BUFR data subset values.
Definition: modules_arrs.F90:796
moda_usrbit::nbit
integer, dimension(:), allocatable nbit
Length (in bits) of each packed data value in data subset.
Definition: modules_arrs.F90:798
moda_usrbit::mbit
integer, dimension(:), allocatable mbit
Pointer in data subset to first bit of each packed data value.
Definition: modules_arrs.F90:800
moda_usrint
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
Definition: modules_arrs.F90:808
moda_usrint::nval
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
Definition: modules_arrs.F90:810
moda_usrint::val
real *8, dimension(:,:), allocatable, target val
Data values.
Definition: modules_arrs.F90:817
moda_usrint::inv
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
Definition: modules_arrs.F90:812
closbf
recursive subroutine closbf(lunit)
Close the connection between logical unit lunit and the NCEPLIBS-bufr software.
Definition: openclosebf.F90:331
rewnbf
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
Definition: openclosebf.F90:687
openbf
recursive subroutine openbf(lunit, io, lundx)
Connect a new file to the NCEPLIBS-bufr software for input or output operations, or initialize the li...
Definition: openclosebf.F90:168
status
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
Definition: openclosebf.F90:399
readmg
recursive subroutine readmg(lunxx, subset, jdate, iret)
Read the next BUFR message from logical unit abs(lunxx) into internal arrays.
Definition: readwritemg.F90:44
getlens
recursive subroutine getlens(mbay, ll, len0, len1, len2, len3, len4, len5)
Read the section lengths of a BUFR message, up to a specified point in the message.
Definition: readwritemg.F90:1190
usrtpl
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
Definition: readwritesb.F90:1288
readsb
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
Definition: readwritesb.F90:32
getvalnb
recursive real *8 function getvalnb(lunit, tagpv, ntagpv, tagnb, ntagnb)
Read a data value corresponding to a specific occurrence of a mnemonic within a data subset,...
Definition: readwriteval.F90:122
ufbinx
recursive subroutine ufbinx(lunit, imsg, isub, usr, i1, i2, iret, str)
Read one or more data values from a specified data subset.
Definition: readwriteval.F90:2404
ufbrp
subroutine ufbrp(lun, usr, i1, i2, io, iret)
Write or read specified data values to or from the current BUFR data subset within internal arrays,...
Definition: readwriteval.F90:1755
ufbseq
recursive subroutine ufbseq(lunin, usr, i1, i2, iret, str)
Read or write an entire sequence of data values from or to a data subset.
Definition: readwriteval.F90:1293
ufbrw
subroutine ufbrw(lun, usr, i1, i2, io, iret)
Write or read specified values to or from the current BUFR data subset within internal arrays,...
Definition: readwriteval.F90:1618
hold4wlc
recursive subroutine hold4wlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:1940
ufbovr
recursive subroutine ufbovr(lunit, usr, i1, i2, iret, str)
Overwrite one or more data values within a data subset.
Definition: readwriteval.F90:2089
ufbint
recursive subroutine ufbint(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.
Definition: readwriteval.F90:642
ufbsp
subroutine ufbsp(lun, usr, i1, i2, io, iret)
Write or read specified values to or from the current BUFR data subset within internal arrays,...
Definition: readwriteval.F90:1839
trybump
subroutine trybump(lun, usr, i1, i2, io, iret)
Try to expand a delayed replication sequence.
Definition: readwriteval.F90:2029
drfini
recursive subroutine drfini(lunit, mdrf, ndrf, drftag)
Explicitly initialize delayed replication factors and allocate a corresponding amount of space within...
Definition: readwriteval.F90:1553
ufbstp
recursive subroutine ufbstp(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.
Definition: readwriteval.F90:1080
readlc
recursive subroutine readlc(lunit, chr, str)
Read a long character string (greater than 8 bytes) from a data subset.
Definition: readwriteval.F90:405
setvalnb
recursive subroutine setvalnb(lunit, tagpv, ntagpv, tagnb, ntagnb, r8val, iret)
Write a data value corresponding to a specific occurrence of a mnemonic within a data subset,...
Definition: readwriteval.F90:38
ufbevn
recursive subroutine ufbevn(lunit, usr, i1, i2, i3, iret, str)
Read one or more data values from an NCEP prepbufr file.
Definition: readwriteval.F90:2221
writlc
recursive subroutine writlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:200
ufbget
recursive subroutine ufbget(lunit, tab, i1, iret, str)
Read one or more data values from a data subset without advancing the subset pointer.
Definition: readwriteval.F90:2498
ufbrep
recursive subroutine ufbrep(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.
Definition: readwriteval.F90:875
iupbs3
recursive integer function iupbs3(mbay, s3mnem)
Read a specified value from within Section 3 of a BUFR message.
Definition: s013vals.F90:348
parstr
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
parutg
subroutine parutg(lun, io, utg, nod, kon, val)
Parse a mnemonic from a character string.
Definition: strings.F90:349
string
subroutine string(str, lun, i1, io)
Check whether a string is in the internal mnemonic string cache.
Definition: strings.F90:25
x48
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x4884.F90:18
x84
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65