NCEPLIBS-bufr  12.2.0
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 
205 recursive subroutine writlc(lunit,chr,str)
206 
207  use modv_vars, only: im8b, mxlcc, iprt
208 
209  use moda_usrint
210  use moda_msgcwd
211  use moda_bitbuf
212  use moda_tables
213  use moda_comprs
214 
215  implicit none
216 
217  integer, intent(in) :: lunit
218  integer my_lunit, maxtg, lun, il, im, ntg, nnod, kon, ii, n, node, ioid, ival, mbit, nbit, nbmp, nchr, nbyt, nsubs, &
219  itagct, len0, len1, len2, len3, l4, l5, mbyte, iupbs3
220 
221  character*(*), intent(in) :: chr, str
222  character*128 bort_str, errstr
223  character*10 ctag
224  character*14 tgs(10)
225 
226  real roid
227 
228  data maxtg /10/
229 
230  ! Check for I8 integers
231  if(im8b) then
232  im8b=.false.
233  call x84(lunit,my_lunit,1)
234  call writlc(my_lunit,chr,str)
235  im8b=.true.
236  return
237  endiF
238 
239  ! Check the file status.
240  call status(lunit,lun,il,im)
241  if(il==0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
242  if(il<0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
243  if(im==0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
244 
245  ! Check for tags (mnemonics) in input string (there can only be one)
246  call parstr(str,tgs,maxtg,ntg,' ',.true.)
247  if(ntg>1) then
248  write(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// &
249  ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4,")")') str,ntg
250  call bort(bort_str)
251  endif
252 
253  ! Check if a specific occurrence of the input string was requested; if not, then the default is to write the first occurrence
254  call parutg(lun,1,tgs(1),nnod,kon,roid)
255  if(kon==6) then
256  ioid=nint(roid)
257  if(ioid<=0) ioid = 1
258  ctag = ' '
259  ii = 1
260  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
261  ctag(ii:ii)=tgs(1)(ii:ii)
262  ii = ii + 1
263  enddo
264  else
265  ioid = 1
266  ctag = tgs(1)(1:10)
267  endif
268 
269  if(iupbs3(mbay(1,lun),'ICMP')>0) then
270  ! The message is compressed
271  n = 1
272  itagct = 0
273  call usrtpl(lun,n,n)
274  do while (n+1<=nval(lun))
275  n = n+1
276  node = inv(n,lun)
277  if(itp(node)==1) then
278  nbmp=int(matx(n,ncol))
279  call usrtpl(lun,n,nbmp)
280  elseif(ctag==tag(node)) then
281  itagct = itagct + 1
282  if(itagct==ioid) then
283  if(itp(node)/=3) then
284  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
285  ctag,typ(node)
286  call bort(bort_str)
287  endif
288  catx(n,ncol)=' '
289  ! The following statement enforces a limit of mxlcc characters per long character string when writing
290  ! compressed messages. This limit keeps the array catx to a reasonable dimensioned size.
291  nchr=min(mxlcc,len(chr),ibt(node)/8)
292  catx(n,ncol)=chr(1:nchr)
293  call usrtpl(lun,1,1)
294  return
295  endif
296  endif
297  enddo
298  else
299  ! The message is not compressed. Locate the beginning of the data (Section 4) in the message.
300  call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
301  mbyte = len0 + len1 + len2 + len3 + 4
302  nsubs = 1
303  ! Find the most recently written subset in the message.
304  do while(nsubs<nsub(lun))
305  ibit = mbyte*8
306  call upb(nbyt,16,mbay(1,lun),ibit)
307  mbyte = mbyte + nbyt
308  nsubs = nsubs + 1
309  enddo
310  if(nsubs/=nsub(lun)) then
311  if(iprt>=0) then
312  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
313  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // &
314  ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
315  call errwrt(errstr)
316  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
317  call errwrt(' ')
318  endif
319  return
320  endif
321  ! Locate and write the long character string within this subset.
322  itagct = 0
323  mbit = mbyte*8 + 16
324  nbit = 0
325  n = 1
326  call usrtpl(lun,n,n)
327  do while (n+1<=nval(lun))
328  n = n+1
329  node = inv(n,lun)
330  mbit = mbit+nbit
331  nbit = ibt(node)
332  if(itp(node)==1) then
333  call upbb(ival,nbit,mbit,mbay(1,lun))
334  call usrtpl(lun,n,ival)
335  elseif(ctag==tag(node)) then
336  itagct = itagct + 1
337  if(itagct==ioid) then
338  if(itp(node)/=3) then
339  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
340  ctag,typ(node)
341  call bort(bort_str)
342  endif
343  nchr = nbit/8
344  ibit = mbit
345  do ii=1,nchr
346  call pkc(' ',1,mbay(1,lun),ibit)
347  enddo
348  call pkc(chr,nchr,mbay(1,lun),mbit)
349  call usrtpl(lun,1,1)
350  return
351  endif
352  endif
353  enddo
354  endif
355 
356  ! If we made it here, then we couldn't find the requested string.
357  if(iprt>=0) then
358  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
359  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE ' // &
360  'SUBSET DEFINITION'
361  call errwrt(errstr)
362  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
363  call errwrt(errstr)
364  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
365  call errwrt(' ')
366  endif
367 
368  return
369 end subroutine writlc
370 
410 recursive subroutine readlc(lunit,chr,str)
411 
412  use modv_vars, only: im8b, iprt
413 
414  use moda_usrint
415  use moda_usrbit
416  use moda_unptyp
417  use moda_bitbuf
418  use moda_tables
419  use moda_rlccmn
420 
421  implicit none
422 
423  integer, intent(in) :: lunit
424  integer my_lunit, maxtg, lchr, lun, il, im, ntg, nnod, kon, ii, n, nod, ioid, itagct, nchr, kbit
425 
426  character*(*), intent(in) :: str
427  character*(*), intent(out) :: chr
428 
429  character*128 bort_str, errstr
430  character*10 ctag
431  character*14 tgs(10)
432 
433  real roid
434 
435  data maxtg /10/
436 
437  ! Check for I8 integers
438  if(im8b) then
439  im8b=.false.
440  call x84(lunit,my_lunit,1)
441  call readlc(my_lunit,chr,str)
442  im8b=.true.
443  return
444  endif
445 
446  chr = ' '
447  lchr=len(chr)
448 
449  ! Check the file status
450  call status(lunit,lun,il,im)
451  if(il==0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
452  if(il>0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
453  if(im==0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
454 
455  ! Check for tags (mnemonics) in input string (there can only be one)
456  call parstr(str,tgs,maxtg,ntg,' ',.true.)
457  if(ntg>1) then
458  write(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// &
459  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntg
460  call bort(bort_str)
461  endif
462 
463  ! Check if a specific occurrence of the input string was requested; if not, then the default is to return the
464  ! first occurrence.
465  call parutg(lun,0,tgs(1),nnod,kon,roid)
466  if(kon==6) then
467  ioid=nint(roid)
468  if(ioid<=0) ioid = 1
469  ctag = ' '
470  ii = 1
471  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
472  ctag(ii:ii)=tgs(1)(ii:ii)
473  ii = ii + 1
474  enddo
475  else
476  ioid = 1
477  ctag = tgs(1)(1:10)
478  endif
479 
480  ! Locate and decode the long character string
481  if(msgunp(lun)==0.or.msgunp(lun)==1) then
482  ! The message is not compressed
483  itagct = 0
484  do n=1,nval(lun)
485  nod = inv(n,lun)
486  if(ctag==tag(nod)) then
487  itagct = itagct + 1
488  if(itagct==ioid) then
489  if(itp(nod)/=3) then
490  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// &
491  'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
492  call bort(bort_str)
493  endif
494  nchr = nbit(n)/8
495  if(nchr>lchr) then
496  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
497  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
498  call bort(bort_str)
499  endif
500  kbit = mbit(n)
501  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
502  return
503  endif
504  endif
505  enddo
506  else
507  ! The message is compressed
508  if(nrst>0) then
509  itagct = 0
510  do ii=1,nrst
511  if(ctag==crtag(ii)) then
512  itagct = itagct + 1
513  if(itagct==ioid) then
514  nchr = irnch(ii)
515  if(nchr>lchr) then
516  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
517  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
518  call bort(bort_str)
519  endif
520  kbit = irbit(ii)
521  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
522  return
523  endif
524  endif
525  enddo
526  endif
527  endif
528 
529  ! If we made it here, then we couldn't find the requested string.
530  if(iprt>=0) then
531  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
532  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // &
533  ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT'
534  call errwrt(errstr)
535  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
536  call errwrt(' ')
537  endif
538  do ii=1,lchr
539  call ipkm(chr(ii:ii),1,255)
540  enddo
541 
542  return
543 end subroutine readlc
544 
647 recursive subroutine ufbint(lunin,usr,i1,i2,iret,str)
648 
649  use bufrlib
650 
651  use modv_vars, only: im8b, bmiss, iprt
652 
653  use moda_usrint
654  use moda_msgcwd
655  use moda_borts
656 
657  implicit none
658 
659  character*(*), intent(in) :: str
660  character*128 bort_str1, bort_str2, errstr
661  character*85 cstr
662 
663  integer, intent(in) :: lunin, i1, i2
664  integer, intent(out) :: iret
665  integer nnod, ncon, nods, nodc, ivls, kons, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, lcstr
666 
667  real*8, intent(inout) :: usr(i1,i2)
668 
669  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
670 
671  data ifirst1 /0/, ifirst2 /0/
672 
673  save ifirst1, ifirst2
674 
675  ! Check for I8 integers
676  if(im8b) then
677  im8b=.false.
678  call x84(lunin,my_lunin,1)
679  call x84(i1,my_i1,1)
680  call x84(i2,my_i2,1)
681  call ufbint(my_lunin,usr,my_i1,my_i2,iret,str)
682  call x48(iret,iret,1)
683  im8b=.true.
684  return
685  endif
686 
687  ! If we're catching bort errors, set a target return location if one doesn't already exist.
688 
689  if (bort_target_is_unset) then
690  bort_target_is_unset = .false.
691  caught_str_len = 0
692  call strsuc(str,cstr,lcstr)
693  call catch_bort_ufbint_c(lunin,usr,i1,i2,iret,cstr,lcstr)
694  bort_target_is_unset = .true.
695  return
696  endif
697 
698  iret = 0
699 
700  ! Check the file status and inode
701  lunit = abs(lunin)
702  call status(lunit,lun,il,im)
703  if(il==0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN')
704  if(im==0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
705  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
706  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
707 
708  io = min(max(0,il),1)
709  if(lunit/=lunin) io = 0
710 
711  if(i1<=0) then
712  if(iprt>=0) then
713  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
714  errstr = .LE.'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
715  call errwrt(errstr)
716  call errwrt(str)
717  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
718  call errwrt(' ')
719  endif
720  return
721  elseif(i2<=0) then
722  if(iprt==-1) ifirst1 = 1
723  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
724  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
725  errstr = .LE.'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
726  call errwrt(errstr)
727  call errwrt(str)
728  if(iprt==0 .and. io==1) then
729  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
730  'all such messages,'
731  call errwrt(errstr)
732  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
733  'BUFRLIB routine.'
734  call errwrt(errstr)
735  endif
736  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
737  call errwrt(' ')
738  ifirst1 = 1
739  endif
740  return
741  endif
742 
743  ! Parse or recall the input string
744  call string(str,lun,i1,io)
745 
746  ! Initialize usr array preceeding an input operation
747  if(io==0) usr(1:i1,1:i2) = bmiss
748 
749  ! Call the mnemonic reader/writer
750  call ufbrw(lun,usr,i1,i2,io,iret)
751 
752  ! If incomplete write try to initialize replication sequence or return
753  if(io==1 .and. iret/=i2 .and. iret>=0) then
754  call trybump(lun,usr,i1,i2,io,iret)
755  if(iret/=i2) then
756  write(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ",A)') str
757  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
758  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
759  call bort2(bort_str1,bort_str2)
760  endif
761  elseif(iret==-1) then
762  iret = 0
763  endif
764 
765  if(iret==0) then
766  if(io==0) then
767  if(iprt>=1) then
768  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
769  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
770  call errwrt(errstr)
771  call errwrt(str)
772  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
773  call errwrt(' ')
774  endif
775  else
776  if(iprt==-1) ifirst2 = 1
777  if(ifirst2==0 .or. iprt>=1) then
778  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
779  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
780  call errwrt(errstr)
781  call errwrt(str)
782  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
783  if(iprt==0) then
784  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
785  'all such messages,'
786  call errwrt(errstr)
787  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // &
788  'to a BUFRLIB routine.'
789  call errwrt(errstr)
790  endif
791  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
792  call errwrt(' ')
793  ifirst2 = 1
794  endif
795  endif
796  endif
797 
798  return
799 end subroutine ufbint
800 
895 recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str)
896 
897  use modv_vars, only: im8b, bmiss, iac, iprt
898 
899  use moda_usrint
900  use moda_msgcwd
901 
902  implicit none
903 
904  character*(*), intent(in) :: str
905  character*128 bort_str1, bort_str2, errstr
906 
907  integer, intent(in) :: lunin, i1, i2
908  integer, intent(out) :: iret
909  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, iac_prev
910 
911  real*8, intent(inout) :: usr(i1,i2)
912 
913  data ifirst1 /0/
914 
915  save ifirst1
916 
917  ! Check for I8 integers
918  if(im8b) then
919  im8b=.false.
920  call x84(lunin,my_lunin,1)
921  call x84(i1,my_i1,1)
922  call x84(i2,my_i2,1)
923  call ufbrep(my_lunin,usr,my_i1,my_i2,iret,str)
924  call x48(iret,iret,1)
925  im8b=.true.
926  return
927  endif
928 
929  iret = 0
930 
931  ! Check the file status and inode
932  lunit = abs(lunin)
933  call status(lunit,lun,il,im)
934  if(il==0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
935  if(im==0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
936  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
937  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
938 
939  io = min(max(0,il),1)
940  if(lunit/=lunin) io = 0
941 
942  if(i1<=0) then
943  if(iprt>=0) then
944  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
945  errstr = .LE.'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
946  call errwrt(errstr)
947  call errwrt(str)
948  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
949  call errwrt(' ')
950  endif
951  return
952  elseif(i2<=0) then
953  if(iprt==-1) ifirst1 = 1
954  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
955  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
956  errstr = .LE.'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
957  call errwrt(errstr)
958  call errwrt(str)
959  if(iprt==0 .and. io==1) then
960  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
961  'all such messages,'
962  call errwrt(errstr)
963  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
964  'BUFRLIB routine.'
965  call errwrt(errstr)
966  endif
967  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
968  call errwrt(' ')
969  ifirst1 = 1
970  endif
971  return
972  endif
973 
974  ! Initialize usr array preceeding an input operation
975  if(io==0) usr(1:i1,1:i2) = bmiss
976 
977  ! Parse or recall the input string
978  iac_prev = iac
979  iac = 1
980  call string(str,lun,i1,io)
981  iac = iac_prev
982 
983  ! Call the mnemonic reader/writer
984  call ufbrp(lun,usr,i1,i2,io,iret)
985 
986  if(io==1 .and. iret<i2) then
987  write(bort_str1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ",A)') str
988  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
989  'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
990  call bort2(bort_str1,bort_str2)
991  endif
992 
993  if(iret==0 .and. io==0 .and. iprt>=1) then
994  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
995  errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
996  call errwrt(errstr)
997  call errwrt(str)
998  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
999  call errwrt(' ')
1000  endif
1001 
1002  return
1003 end subroutine ufbrep
1004 
1100 recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str)
1101 
1102  use modv_vars, only: im8b, bmiss, iprt
1103 
1104  use moda_usrint
1105  use moda_msgcwd
1106 
1107  implicit none
1108 
1109  character*(*), intent(in) :: str
1110  character*128 bort_str1, bort_str2, errstr
1111 
1112  integer, intent(in) :: lunin, i1, i2
1113  integer, intent(out) :: iret
1114  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io
1115 
1116  real*8, intent(inout) :: usr(i1,i2)
1117 
1118  data ifirst1 /0/
1119 
1120  save ifirst1
1121 
1122  ! Check for I8 integers
1123  if(im8b) then
1124  im8b=.false.
1125  call x84(lunin,my_lunin,1)
1126  call x84(i1,my_i1,1)
1127  call x84(i2,my_i2,1)
1128  call ufbstp(my_lunin,usr,my_i1,my_i2,iret,str)
1129  call x48(iret,iret,1)
1130  im8b=.true.
1131  return
1132  endif
1133 
1134  iret = 0
1135 
1136  ! Check the file status and inode
1137  lunit = abs(lunin)
1138  call status(lunit,lun,il,im)
1139  if(il==0) call bort('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1140  if(im==0) call bort('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1141  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
1142  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1143 
1144  io = min(max(0,il),1)
1145  if(lunit/=lunin) io = 0
1146 
1147  if(i1<=0) then
1148  if(iprt>=0) then
1149  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1150  errstr = .LE.'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1151  call errwrt(errstr)
1152  call errwrt(str)
1153  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1154  call errwrt(' ')
1155  endif
1156  return
1157  elseif(i2<=0) then
1158  if(iprt==-1) ifirst1 = 1
1159  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1160  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1161  errstr = .LE.'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1162  call errwrt(errstr)
1163  call errwrt(str)
1164  if(iprt==0 .and. io==1) then
1165  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1166  'all such messages,'
1167  call errwrt(errstr)
1168  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1169  'BUFRLIB routine.'
1170  call errwrt(errstr)
1171  endif
1172  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1173  call errwrt(' ')
1174  ifirst1 = 1
1175  endif
1176  return
1177  endif
1178 
1179  ! Initialize usr array preceeding an input operation
1180  if(io==0) usr(1:i1,1:i2) = bmiss
1181 
1182  ! Parse or recall the input string
1183  call string(str,lun,i1,io)
1184 
1185  ! Call the mnemonic reader/writer
1186  call ufbsp(lun,usr,i1,i2,io,iret)
1187 
1188  if(io==1 .and. iret/=i2) then
1189  write(bort_str1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ",A)') str
1190  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
1191  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
1192  call bort2(bort_str1,bort_str2)
1193  endif
1194 
1195  if(iret==0 .and. io==0 .and. iprt>=1) then
1196  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1197  errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1198  call errwrt(errstr)
1199  call errwrt(str)
1200  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1201  call errwrt(' ')
1202  endif
1203 
1204  return
1205 end subroutine ufbstp
1206 
1313 recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str)
1314 
1315  use modv_vars, only: im8b, bmiss, iprt
1316 
1317  use moda_usrint
1318  use moda_msgcwd
1319  use moda_tables
1320 
1321  implicit none
1322 
1323  integer, intent(in) :: lunin, i1, i2
1324  integer, intent(out) :: iret
1325  integer, parameter :: mtag = 10
1326  integer ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j, ntag, node, nods, ins1, ins2, insx, &
1327  nseq, isq, ityp, invwin, invtag
1328 
1329  real*8, intent(inout) :: usr(i1,i2)
1330 
1331  character*(*), intent(in) :: str
1332  character*156 bort_str
1333  character*128 errstr
1334  character*10 tags(mtag)
1335 
1336  data ifirst1 /0/, ifirst2 /0/
1337 
1338  save ifirst1, ifirst2
1339 
1340  ! Check for I8 integers
1341  if(im8b) then
1342  im8b=.false.
1343  call x84(lunin,my_lunin,1)
1344  call x84(i1,my_i1,1)
1345  call x84(i2,my_i2,1)
1346  call ufbseq(my_lunin,usr,my_i1,my_i2,iret,str)
1347  call x48(iret,iret,1)
1348  im8b=.true.
1349  return
1350  endif
1351 
1352  iret = 0
1353 
1354  ! Check the file status and inode
1355  lunit = abs(lunin)
1356  call status(lunit,lun,il,im)
1357  if(il==0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1358  if(im==0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1359 
1360  io = min(max(0,il),1)
1361  if(lunit/=lunin) io = 0
1362 
1363  if(i1<=0) then
1364  if(iprt>=0) then
1365  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1366  errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1367  call errwrt(errstr)
1368  call errwrt(str)
1369  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1370  call errwrt(' ')
1371  endif
1372  return
1373  elseif(i2<=0) then
1374  if(iprt==-1) ifirst1 = 1
1375  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1376  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1377  errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1378  call errwrt(errstr)
1379  call errwrt(str)
1380  if(iprt==0 .and. io==1) then
1381  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1382  'all such messages,'
1383  call errwrt(errstr)
1384  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1385  'BUFRLIB routine.'
1386  call errwrt(errstr)
1387  endif
1388  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1389  call errwrt(' ')
1390  ifirst1 = 1
1391  endif
1392  return
1393  endif
1394 
1395  ! Check for valid sequence and sequence length arguments
1396  call parstr(str,tags,mtag,ntag,' ',.true.)
1397  if(ntag<1) then
1398  write(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") DOES NOT CONTAIN ANY MNEMONICS!!")') str
1399  call bort(bort_str)
1400  endif
1401  if(ntag>1) then
1402  write(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// &
1403  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntag
1404  call bort(bort_str)
1405  endif
1406  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// &
1407  'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1408 
1409  ! Initialize usr array preceeding an input operation
1410  if(io==0) usr(1:i1,1:i2) = bmiss
1411 
1412  ! Find the parameters of the specified sequence
1413  outer: do node=inode(lun),isc(inode(lun))
1414  if(str==tag(node)) then
1415  if(typ(node)=='SEQ' .or. typ(node)=='RPC') then
1416  ins1 = 1
1417  do while (.true.)
1418  ins1 = invtag(node,lun,ins1,nval(lun))
1419  if(ins1==0) exit outer
1420  if(typ(node)/='RPC' .or. val(ins1,lun)/=0.) exit
1421  ins1 = ins1+1
1422  enddo
1423  ins2 = invtag(node,lun,ins1+1,nval(lun))
1424  if(ins2==0) ins2 = 10e5
1425  nods = node
1426  do while(link(nods)==0 .and. jmpb(nods)>0)
1427  nods = jmpb(nods)
1428  enddo
1429  if(link(nods)==0) then
1430  insx = nval(lun)
1431  elseif(link(nods)>0) then
1432  insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
1433  endif
1434  ins2 = min(ins2,insx)
1435  elseif(typ(node)=='SUB') then
1436  ins1 = 1
1437  ins2 = nval(lun)
1438  else
1439  write(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// &
1440  'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
1441  call bort(bort_str)
1442  endif
1443  nseq = 0
1444  do isq=ins1,ins2
1445  ityp = itp(inv(isq,lun))
1446  if(ityp>1) nseq = nseq+1
1447  enddo
1448  if(nseq>i1) then
1449  write(bort_str,.GT.'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A," CONSISTS OF",I4," TABLE B MNEM., THE MAX. '// &
1450  'SPECIFIED IN (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
1451  call bort(bort_str)
1452  endif
1453  ! Frame a section of the buffer - return when no frame
1454  inner: do while (.true.)
1455  ins1 = invtag(node,lun,ins1,nval(lun))
1456  if(ins1>nval(lun)) exit outer
1457  if(ins1>0) then
1458  if(typ(node)=='RPC' .and. val(ins1,lun)==0.) then
1459  ins1 = ins1+1
1460  cycle
1461  elseif(io==0 .and. iret+1>i2) then
1462  if(iprt>=0) then
1463  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1464  write ( unit=errstr, fmt='(A,I5,A,A,A)' ) 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2, &
1465  ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1), ' WERE READ'
1466  call errwrt(errstr)
1467  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1468  call errwrt(' ')
1469  endif
1470  exit outer
1471  endif
1472  elseif(ins1==0) then
1473  if(io==1 .and. iret<i2) then
1474  write(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'.LT.' WRITTEN (",I5,") NO. REQUESTED (",I5,") - '// &
1475  'INCOMPLETE WRITE (INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
1476  call bort(bort_str)
1477  endif
1478  else
1479  write(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE ZERO, HERE IT IS",I4," - INPUT MNEMONIC '// &
1480  'IS ",A)') ins1,tags(1)
1481  call bort(bort_str)
1482  endif
1483  if(ins1==0 .or. iret==i2) exit outer
1484  iret = iret+1
1485  ins1 = ins1+1
1486  ! Read/write user values
1487  j = ins1
1488  do i=1,nseq
1489  do while(itp(inv(j,lun))<2)
1490  j = j+1
1491  enddo
1492  if(io==0) usr(i,iret) = val(j,lun)
1493  if(io==1) val(j,lun) = usr(i,iret)
1494  j = j+1
1495  enddo
1496  enddo inner
1497  endif
1498  enddo outer
1499 
1500  if(iret==0) then
1501  if(io==0) then
1502  if(iprt>=1) then
1503  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1504  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1505  call errwrt(errstr)
1506  call errwrt(str)
1507  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1508  call errwrt(' ')
1509  endif
1510  else
1511  if(iprt==-1) ifirst2 = 1
1512  if(ifirst2==0 .or. iprt>=1) then
1513  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1514  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1515  call errwrt(errstr)
1516  call errwrt(str)
1517  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
1518  if(iprt==0) then
1519  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1520  'all such messages,'
1521  call errwrt(errstr)
1522  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1523  'BUFRLIB routine.'
1524  call errwrt(errstr)
1525  endif
1526  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1527  call errwrt(' ')
1528  ifirst2 = 1
1529  endif
1530  endif
1531  endif
1532 
1533  return
1534 end subroutine ufbseq
1535 
1573 recursive subroutine drfini(lunit,mdrf,ndrf,drftag)
1574 
1575  use modv_vars, only: im8b
1576 
1577  use moda_usrint
1578  use moda_tables
1579 
1580  implicit none
1581 
1582  character*(*), intent(in) :: drftag
1583 
1584  integer, intent(in) :: mdrf(*), lunit, ndrf
1585  integer, parameter :: mxdrf = 2000
1586  integer my_mdrf(mxdrf), my_lunit, my_ndrf, lun, il, im, m, n, node
1587 
1588  ! Check for I8 integers
1589  if(im8b) then
1590  im8b=.false.
1591  call x84(lunit,my_lunit,1)
1592  call x84(ndrf,my_ndrf,1)
1593  call x84(mdrf(1),my_mdrf(1),my_ndrf)
1594  call drfini(my_lunit,my_mdrf,my_ndrf,drftag)
1595  im8b=.true.
1596  return
1597  endif
1598 
1599  call status(lunit,lun,il,im)
1600  ! Conform the template to the delayed replication factors
1601  m = 0
1602  n = 1
1603  do while ( n <= nval(lun) )
1604  node = inv(n,lun)
1605  if(itp(node)==1 .and. tag(node)==drftag) then
1606  m = m+1
1607  call usrtpl(lun,n,mdrf(m))
1608  endif
1609  n = n+1
1610  enddo
1611 
1612  return
1613 end subroutine drfini
1614 
1638 subroutine ufbrw(lun,usr,i1,i2,io,iret)
1639 
1640  use modv_vars, only: bmiss, iprt
1641 
1642  use moda_usrint
1643  use moda_tables
1644  use moda_msgcwd
1645 
1646  implicit none
1647 
1648  integer, intent(in) :: lun, i1, i2, io
1649  integer, intent(out) :: iret
1650  integer nnod, ncon, nods, nodc, ivls, kons, inc1, inc2, ins1, ins2, invn, i, j, invwin, ibfms, lstjpb
1651 
1652  real*8, intent(inout) :: usr(i1,i2)
1653 
1654  character*128 errstr
1655  character*10 tagstr, subset
1656 
1657  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1658 
1659  subset=tag(inode(lun))
1660  iret = 0
1661 
1662  ! Loop over condition windows
1663  inc1 = 1
1664  inc2 = 1
1665  outer: do while (.true.)
1666  call conwin(lun,inc1,inc2)
1667  if(nnod==0) then
1668  iret = i2
1669  return
1670  elseif(inc1==0) then
1671  return
1672  else
1673  do j=1,nnod
1674  if(nods(j)>0) then
1675  ins2 = inc1
1676  call getwin(nods(j),lun,ins1,ins2)
1677  if(ins1==0) return
1678  do while (.true.)
1679  ! Loop over store nodes
1680  iret = iret+1
1681  if(iprt>=2) then
1682  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1683  call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//subset)
1684  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1685  do i=1,nnod
1686  if(io==0) tagstr=tag(nods(i))(1:8)//' R'
1687  if(io==1) tagstr=tag(nods(i))(1:8)//' W'
1688  invn = invwin(nods(i),lun,ins1,ins2)
1689  if(invn==0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn)
1690  write(errstr,'("LEV=",I5,1X,A,3I7)') iret,tagstr,ins1,invn,ins2
1691  call errwrt(errstr)
1692  enddo
1693  endif
1694  ! Write user values
1695  if(io==1 .and. iret<=i2) then
1696  do i=1,nnod
1697  if(nods(i)>0) then
1698  if(ibfms(usr(i,iret))==0) then
1699  invn = invwin(nods(i),lun,ins1,ins2)
1700  if(invn==0) then
1701  call drstpl(nods(i),lun,ins1,ins2,invn)
1702  if(invn==0) then
1703  iret = 0
1704  return
1705  endif
1706  call newwin(lun,inc1,inc2)
1707  val(invn,lun) = usr(i,iret)
1708  elseif(lstjpb(nods(i),lun,'RPS')==0) then
1709  val(invn,lun) = usr(i,iret)
1710  elseif(ibfms(val(invn,lun))/=0) then
1711  val(invn,lun) = usr(i,iret)
1712  else
1713  call drstpl(nods(i),lun,ins1,ins2,invn)
1714  if(invn==0) then
1715  iret = 0
1716  return
1717  endif
1718  call newwin(lun,inc1,inc2)
1719  val(invn,lun) = usr(i,iret)
1720  endif
1721  endif
1722  endif
1723  enddo
1724  endif
1725  ! Read user values
1726  if(io==0 .and. iret<=i2) then
1727  do i=1,nnod
1728  usr(i,iret) = bmiss
1729  if(nods(i)>0) then
1730  invn = invwin(nods(i),lun,ins1,ins2)
1731  if(invn>0) usr(i,iret) = val(invn,lun)
1732  endif
1733  enddo
1734  endif
1735  ! Decide what to do next
1736  if(io==1.and.iret==i2) return
1737  call nxtwin(lun,ins1,ins2)
1738  if(ins1>0 .and. ins1<inc2) cycle
1739  if(ncon>0) cycle outer
1740  return
1741  enddo
1742  endif
1743  enddo
1744  iret = -1
1745  return
1746  endif
1747  enddo outer
1748 
1749  return
1750 end subroutine ufbrw
1751 
1775 subroutine ufbrp(lun,usr,i1,i2,io,iret)
1776 
1777  use moda_usrint
1778 
1779  implicit none
1780 
1781  integer, intent(in) :: lun, i1, i2, io
1782  integer, intent(out) :: iret
1783  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, i, nz, invtag
1784 
1785  real*8, intent(inout) :: usr(i1,i2)
1786 
1787  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1788 
1789  iret = 0
1790  ins1 = 0
1791  ins2 = 0
1792 
1793  ! Find first non-zero node in string
1794  do nz=1,nnod
1795  if(nods(nz)>0) then
1796  do while (.true.)
1797  ! Frame a section of the buffer - return when no frame
1798  if(ins1+1>nval(lun)) return
1799  if(io==1 .and. iret==i2) return
1800  ins1 = invtag(nods(nz),lun,ins1+1,nval(lun))
1801  if(ins1==0) return
1802  ins2 = invtag(nods(nz),lun,ins1+1,nval(lun))
1803  if(ins2==0) ins2 = nval(lun)
1804  iret = iret+1
1805  ! Read user values
1806  if(io==0 .and. iret<=i2) then
1807  do i=1,nnod
1808  if(nods(i)>0) then
1809  invn = invtag(nods(i),lun,ins1,ins2)
1810  if(invn>0) usr(i,iret) = val(invn,lun)
1811  endif
1812  enddo
1813  endif
1814  ! Write user values
1815  if(io==1 .and. iret<=i2) then
1816  do i=1,nnod
1817  if(nods(i)>0) then
1818  invn = invtag(nods(i),lun,ins1,ins2)
1819  if(invn>0) val(invn,lun) = usr(i,iret)
1820  endif
1821  enddo
1822  endif
1823  enddo
1824  endif
1825  enddo
1826 
1827  return
1828 end subroutine ufbrp
1829 
1859 subroutine ufbsp(lun,usr,i1,i2,io,iret)
1860 
1861  use moda_usrint
1862 
1863  implicit none
1864 
1865  integer, intent(in) :: lun, i1, i2, io
1866  integer, intent(out) :: iret
1867  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, invm, i, invtag
1868 
1869  real*8, intent(inout) :: usr(i1,i2)
1870 
1871  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1872 
1873  iret = 0
1874  ins1 = 0
1875  ins2 = 0
1876 
1877  do while (.true.)
1878  ! Frame a section of the buffer - return when no frame
1879  if(ins1+1>nval(lun)) return
1880  ins1 = invtag(nods(1),lun,ins1+1,nval(lun))
1881  if(ins1==0) return
1882  ins2 = invtag(nods(1),lun,ins1+1,nval(lun))
1883  if(ins2==0) ins2 = nval(lun)
1884  iret = iret+1
1885  ! Read user values
1886  if(io==0 .and. iret<=i2) then
1887  invm = ins1
1888  do i=1,nnod
1889  if(nods(i)>0) then
1890  invn = invtag(nods(i),lun,invm,ins2)
1891  if(invn>0) usr(i,iret) = val(invn,lun)
1892  invm = max(invn,invm)
1893  endif
1894  enddo
1895  endif
1896  ! Write user values
1897  if(io==1 .and. iret<=i2) then
1898  invm = ins1
1899  do i=1,nnod
1900  if(nods(i)>0) then
1901  invn = invtag(nods(i),lun,invm,ins2)
1902  if(invn>0) val(invn,lun) = usr(i,iret)
1903  invm = max(invn,invm)
1904  endif
1905  enddo
1906  endif
1907  enddo
1908 
1909  return
1910 end subroutine ufbsp
1911 
1960 recursive subroutine hold4wlc(lunit,chr,str)
1961 
1962  use modv_vars, only: im8b, mxh4wlc, iprt
1963 
1964  use moda_h4wlc
1965 
1966  implicit none
1967 
1968  integer, intent(in) :: lunit
1969  integer my_lunit, lens, lenc, i
1970 
1971  character*(*), intent(in) :: chr, str
1972 
1973  character*128 errstr
1974  character*14 mystr
1975 
1976  ! Check for I8 integers
1977  if(im8b) then
1978  im8b=.false.
1979  call x84(lunit,my_lunit,1)
1980  call hold4wlc(my_lunit,chr,str)
1981  im8b=.true.
1982  return
1983  endif
1984 
1985  call strsuc( str, mystr, lens )
1986  if ( lens == -1 ) return
1987 
1988  lenc = min( len( chr ), 120 )
1989 
1990  ! If this subroutine has already been called with this mnemonic for this particular subset, then overwrite the
1991  ! corresponding entry in the internal holding area
1992  if ( nh4wlc > 0 ) then
1993  do i = 1, nh4wlc
1994  if ( ( lunit == luh4wlc(i) ) .and. ( mystr(1:lens) == sth4wlc(i)(1:lens) ) ) then
1995  chh4wlc(i) = ''
1996  chh4wlc(i)(1:lenc) = chr(1:lenc)
1997  return
1998  endif
1999  enddo
2000  endif
2001 
2002  ! Otherwise, use the next available unused entry in the holding area
2003  if ( nh4wlc >= mxh4wlc ) then
2004  if(iprt>=0) then
2005  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2006  write ( unit=errstr, fmt='(A,A,I3)' ) 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', &
2007  'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
2008  call errwrt(errstr)
2009  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2010  endif
2011  else
2012  nh4wlc = nh4wlc + 1
2013  luh4wlc(nh4wlc) = lunit
2014  sth4wlc(nh4wlc) = ''
2015  sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
2016  chh4wlc(nh4wlc) = ''
2017  chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
2018  endif
2019 
2020  return
2021 end subroutine hold4wlc
2022 
2049 subroutine trybump(lun,usr,i1,i2,io,iret)
2050 
2051  use moda_usrint
2052 
2053  implicit none
2054 
2055  integer, intent(in) :: lun, i1, i2, io
2056  integer, intent(out) :: iret
2057  integer nnod, ncon, nods, nodc, ivls, kons, ndrp, invn, jnvn, knvn, invwin, lstjpb
2058 
2059  real*8, intent(inout) :: usr(i1,i2)
2060 
2061  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2062 
2063  ! See if there's a delayed replication group involved
2064 
2065  ndrp = lstjpb(nods(1),lun,'DRP')
2066  if(ndrp<=0) return
2067 
2068  ! If so, clean it out and bump it to i2
2069 
2070  invn = invwin(ndrp,lun,1,nval(lun))
2071  val(invn,lun) = 0
2072  jnvn = invn+1
2073  do while(nint(val(jnvn,lun))>0)
2074  jnvn = jnvn+nint(val(jnvn,lun))
2075  enddo
2076  do knvn=1,nval(lun)-jnvn+1
2077  inv(invn+knvn,lun) = inv(jnvn+knvn-1,lun)
2078  val(invn+knvn,lun) = val(jnvn+knvn-1,lun)
2079  enddo
2080  nval(lun) = nval(lun)-(jnvn-invn-1)
2081  call usrtpl(lun,invn,i2)
2082 
2083  ! Call the mnemonic writer
2084 
2085  call ufbrw(lun,usr,i1,i2,io,iret)
2086 
2087  return
2088 end subroutine trybump
2089 
2109 recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str)
2110 
2111  use modv_vars, only: im8b, iprt
2112 
2113  use moda_usrint
2114  use moda_msgcwd
2115 
2116  implicit none
2117 
2118  integer, intent(in) :: lunit, i1, i2
2119  integer, intent(out) :: iret
2120  integer ifirst1, my_lunit, my_i1, my_i2, lun, il, im, io
2121 
2122  character*(*), intent(in) :: str
2123  character*128 bort_str1, bort_str2, errstr
2124 
2125  real*8, intent(inout) :: usr(i1,i2)
2126 
2127  data ifirst1 /0/
2128 
2129  save ifirst1
2130 
2131  ! Check for I8 integers
2132 
2133  if(im8b) then
2134  im8b=.false.
2135  call x84(lunit,my_lunit,1)
2136  call x84(i1,my_i1,1)
2137  call x84(i2,my_i2,1)
2138  call ufbovr(my_lunit,usr,my_i1,my_i2,iret,str)
2139  call x48(iret,iret,1)
2140  im8b=.true.
2141  return
2142  endif
2143 
2144  iret = 0
2145 
2146  ! Check the file status and inode
2147 
2148  call status(lunit,lun,il,im)
2149  if(il==0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
2150  if(il<0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
2151  if(im==0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
2152  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// &
2153  'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2154 
2155  io = min(max(0,il),1)
2156 
2157  if(i1<=0) then
2158  if(iprt>=0) then
2159  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2160  errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2161  call errwrt(errstr)
2162  call errwrt(str)
2163  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2164  call errwrt(' ')
2165  endif
2166  return
2167  elseif(i2<=0) then
2168  if(iprt==-1) ifirst1 = 1
2169  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
2170  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2171  errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2172  call errwrt(errstr)
2173  call errwrt(str)
2174  if(iprt==0 .and. io==1) then
2175  errstr = 'Note: Only the first occurrence of this WARNING ' // &
2176  'message is printed, there may be more. To output all such messages,'
2177  call errwrt(errstr)
2178  errstr = 'modify your application program to add ' // &
2179  '"CALL OPENBF(0,''QUIET'',1)" prior to the first call to a BUFRLIB routine.'
2180  call errwrt(errstr)
2181  endif
2182  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2183  call errwrt(' ')
2184  ifirst1 = 1
2185  endif
2186  return
2187  endif
2188 
2189  ! Parse or recall the input string - write values
2190 
2191  call string(str,lun,i1,io)
2192  call trybump(lun,usr,i1,i2,io,iret)
2193 
2194  if(io==1 .and. iret/=i2) then
2195  write(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS: ",A)') str
2196  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
2197  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret, i2
2198  call bort2(bort_str1,bort_str2)
2199  endif
2200 
2201  return
2202 end subroutine ufbovr
2203 
2241 recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str)
2242 
2243  use modv_vars, only: im8b, bmiss, iprt
2244 
2245  use moda_usrint
2246  use moda_msgcwd
2247 
2248  implicit none
2249 
2250  character*(*), intent(in) :: str
2251  character*128 errstr
2252 
2253  integer, intent(in) :: lunit, i1, i2, i3
2254  integer, intent(out) :: iret
2255  integer invn(255), nnod, ncon, nods, nodc, ivls, kons, maxevn, my_lunit, my_i1, my_i2, my_i3, i, j, k, lun, il, im, &
2256  ins1, ins2, inc1, inc2, nnvn, nvnwin
2257 
2258  real*8, intent(out) :: usr(i1,i2,i3)
2259 
2260  logical nodgt0
2261 
2262  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2263 
2264  ! Check for I8 integers
2265 
2266  if(im8b) then
2267  im8b=.false.
2268  call x84(lunit,my_lunit,1)
2269  call x84(i1,my_i1,1)
2270  call x84(i2,my_i2,1)
2271  call x84(i3,my_i3,1)
2272  call ufbevn(my_lunit,usr,my_i1,my_i2,my_i3,iret,str)
2273  call x48(iret,iret,1)
2274  im8b=.true.
2275  return
2276  endif
2277 
2278  maxevn = 0
2279  iret = 0
2280 
2281  ! Check the file status and inode
2282 
2283  call status(lunit,lun,il,im)
2284  if(il==0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2285  if(il>0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2286  if(im==0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2287  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// &
2288  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2289 
2290  if(i1<=0) then
2291  if(iprt>=0) then
2292  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2293  errstr = .LE.'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2294  call errwrt(errstr)
2295  call errwrt(str)
2296  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2297  call errwrt(' ')
2298  endif
2299  return
2300  elseif(i2<=0) then
2301  if(iprt>=0) then
2302  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2303  errstr = .LE.'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2304  call errwrt(errstr)
2305  call errwrt(str)
2306  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2307  call errwrt(' ')
2308  endif
2309  return
2310  elseif(i3<=0) then
2311  if(iprt>=0) then
2312  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2313  errstr = .LE.'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2314  call errwrt(errstr)
2315  call errwrt(str)
2316  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2317  call errwrt(' ')
2318  endif
2319  return
2320  endif
2321 
2322  ! Parse or recall the input string
2323 
2324  call string(str,lun,i1,0)
2325 
2326  ! Initialize usr array
2327  usr(1:i1,1:i2,1:i3) = bmiss
2328 
2329  ! Loop over condition windows
2330 
2331  inc1 = 1
2332  inc2 = 1
2333  outer: do while (.true.)
2334  call conwin(lun,inc1,inc2)
2335  if(nnod==0) then
2336  iret = i2
2337  return
2338  elseif(inc1==0) then
2339  return
2340  else
2341  nodgt0 = .false.
2342  do i=1,nnod
2343  if(nods(i)>0) then
2344  ins2 = inc1
2345  call getwin(nods(i),lun,ins1,ins2)
2346  if(ins1==0) return
2347  nodgt0 = .true.
2348  exit
2349  endif
2350  enddo
2351  if(.not.nodgt0) then
2352  ins1 = inc1
2353  ins2 = inc2
2354  endif
2355  ! Read push down stack data into 3D arrays
2356  inner: do while (.true.)
2357  iret = iret+1
2358  if(iret<=i2) then
2359  do j=1,nnod
2360  if(nods(j)>0) then
2361  nnvn = nvnwin(nods(j),lun,ins1,ins2,invn,i3)
2362  maxevn = max(nnvn,maxevn)
2363  do k=1,nnvn
2364  usr(j,iret,k) = val(invn(k),lun)
2365  enddo
2366  endif
2367  enddo
2368  endif
2369  ! Decide what to do next
2370  call nxtwin(lun,ins1,ins2)
2371  if(ins1<=0 .or. ins1>=inc2) exit inner
2372  enddo inner
2373  if(ncon<=0) exit outer
2374  endif
2375  enddo outer
2376 
2377  if(iret==0) then
2378  if(iprt>=1) then
2379  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2380  errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2381  call errwrt(errstr)
2382  call errwrt(str)
2383  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2384  call errwrt(' ')
2385  endif
2386  endif
2387 
2388  return
2389 end subroutine ufbevn
2390 
2424 recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str)
2425 
2426  use modv_vars, only: im8b
2427 
2428  use moda_msgcwd
2429  use moda_bitbuf
2430 
2431  implicit none
2432 
2433  integer, intent(in) :: lunit, imsg, isub, i1, i2
2434  integer, intent(out) :: iret
2435  integer my_lunit, my_imsg, my_isub, my_i1, my_i2, lun, il, im, jdate, jret, i
2436 
2437  character*(*), intent(in) :: str
2438  character*128 bort_str
2439  character*8 subset
2440 
2441  real*8, intent(out) :: usr(i1,i2)
2442 
2443  logical openit
2444 
2445  ! Check for I8 integers
2446  if(im8b) then
2447  im8b=.false.
2448  call x84(lunit,my_lunit,1)
2449  call x84(imsg,my_imsg,1)
2450  call x84(isub,my_isub,1)
2451  call x84(i1,my_i1,1)
2452  call x84(i2,my_i2,1)
2453  call ufbinx(my_lunit,my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
2454  call x48(iret,iret,1)
2455  im8b=.true.
2456  return
2457  endif
2458 
2459  call status(lunit,lun,il,im)
2460  openit = il==0
2461 
2462  if(openit) then
2463  ! Open BUFR file connected to unit lunit if it isn't already open
2464  call openbf(lunit,'INX',lunit)
2465  else
2466  ! If BUFR file already opened, save position and rewind to first data message
2467  call rewnbf(lunit,0)
2468  endif
2469 
2470  ! Skip to the requested message
2471  do i=1,imsg
2472  call readmg(lunit,subset,jdate,jret)
2473  if(jret<0) then
2474  write(bort_str,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// &
2475  'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') imsg, lunit
2476  call bort(bort_str)
2477  endif
2478  enddo
2479 
2480  ! Position at the requested subset
2481  do i=1,isub
2482  call readsb(lunit,jret)
2483  if(jret/=0) then
2484  write(bort_str,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// &
2485  'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub, imsg, lunit
2486  call bort(bort_str)
2487  endif
2488  enddo
2489 
2490  ! Read the requested data values
2491  call ufbint(lunit,usr,i1,i2,iret,str)
2492 
2493  if(openit) then
2494  ! Close BUFR file if it was opened here
2495  call closbf(lunit)
2496  else
2497  ! Restore BUFR file to its previous status and position
2498  call rewnbf(lunit,1)
2499  endif
2500 
2501  return
2502 end subroutine ufbinx
2503 
2518 recursive subroutine ufbget(lunit,tab,i1,iret,str)
2519 
2520  use modv_vars, only: im8b, bmiss
2521 
2522  use moda_usrint
2523  use moda_usrbit
2524  use moda_msgcwd
2525  use moda_bitbuf
2526  use moda_tables
2527 
2528  implicit none
2529 
2530  integer*8 ival
2531  integer, intent(in) :: lunit, i1
2532  integer, intent(out) :: iret
2533  integer nnod, ncon, nods, nodc, ivls, kons, my_lunit, my_i1, lun, il, im, i, n, node, nbmp, kbit, invn, invwin
2534 
2535  character*(*), intent(in) :: str
2536  character*8 cval
2537 
2538  real*8, intent(out) :: tab(i1)
2539  real*8 rval, ups
2540 
2541  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2542 
2543  equivalence(cval,rval)
2544 
2545  ! Check for I8 integers
2546 
2547  if(im8b) then
2548  im8b=.false.
2549  call x84(lunit,my_lunit,1)
2550  call x84(i1,my_i1,1)
2551  call ufbget(my_lunit,tab,my_i1,iret,str)
2552  call x48(iret,iret,1)
2553  im8b=.true.
2554  return
2555  endif
2556 
2557  iret = 0
2558  tab(1:i1) = bmiss
2559 
2560  ! Make sure a file/message is open for input
2561 
2562  call status(lunit,lun,il,im)
2563  if(il==0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2564  if(il>0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2565  if(im==0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2566 
2567  ! See if there's another subset in the message
2568 
2569  if(nsub(lun)==msub(lun)) then
2570  iret = -1
2571  return
2572  endif
2573 
2574  ! Parse the string
2575 
2576  call string(str,lun,i1,0)
2577 
2578  ! Expand the template for this subset as little as possible
2579 
2580  n = 1
2581  nbit(n) = 0
2582  mbit(n) = mbyt(lun)*8 + 16
2583  call usrtpl(lun,n,n)
2584  do n=n+1,nval(lun)
2585  node = inv(n,lun)
2586  nbit(n) = ibt(node)
2587  mbit(n) = mbit(n-1)+nbit(n-1)
2588  if(node==nods(nnod)) then
2589  nval(lun) = n
2590  exit
2591  elseif(itp(node)==1) then
2592  call upb8(ival,nbit(n),mbit(n),mbay(1,lun))
2593  nbmp=int(ival)
2594  call usrtpl(lun,n,nbmp)
2595  endif
2596  enddo
2597 
2598  ! Unpack only the nodes found in the string
2599 
2600  do i=1,nnod
2601  node = nods(i)
2602  invn = invwin(node,lun,1,nval(lun))
2603  if(invn>0) then
2604  call upb8(ival,nbit(invn),mbit(invn),mbay(1,lun))
2605  if(itp(node)==1) then
2606  tab(i) = ival
2607  elseif(itp(node)==2) then
2608  if(ival<2_8**(ibt(node))-1) tab(i) = ups(ival,node)
2609  elseif(itp(node)==3) then
2610  cval = ' '
2611  kbit = mbit(invn)
2612  call upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
2613  tab(i) = rval
2614  endif
2615  else
2616  tab(i) = bmiss
2617  endif
2618  enddo
2619 
2620  return
2621 end subroutine ufbget
bort
recursive subroutine bort(str)
Log an error message, then either return to or abort the application program.
Definition: borts.F90:15
bort2
recursive subroutine bort2(str1, str2)
Log two error messages, then either return to or abort the application program.
Definition: borts.F90:48
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:320
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
bufrlib::catch_bort_ufbint_c
Definition: bufrlib.F90:441
strsuc
subroutine strsuc(str1, str2, lens)
Remove leading and trailing blanks from a character string.
Definition: misc.F90:199
bufrlib
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Definition: bufrlib.F90:11
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_borts
Declare variables used to optionally catch and return any future bort error string to the application...
Definition: modules_arrs.F90:910
moda_borts::caught_str_len
integer caught_str_len
Length of bort error string.
Definition: modules_arrs.F90:922
moda_borts::bort_target_is_unset
logical bort_target_is_unset
.true.
Definition: modules_arrs.F90:918
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:342
rewnbf
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
Definition: openclosebf.F90:707
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:419
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:1199
usrtpl
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
Definition: readwritesb.F90:1309
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:2425
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:1776
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:1314
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:1639
hold4wlc
recursive subroutine hold4wlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:1961
ufbovr
recursive subroutine ufbovr(lunit, usr, i1, i2, iret, str)
Overwrite one or more data values within a data subset.
Definition: readwriteval.F90:2110
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:648
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:1860
trybump
subroutine trybump(lun, usr, i1, i2, io, iret)
Try to expand a delayed replication sequence.
Definition: readwriteval.F90:2050
drfini
recursive subroutine drfini(lunit, mdrf, ndrf, drftag)
Explicitly initialize delayed replication factors and allocate a corresponding amount of space within...
Definition: readwriteval.F90:1574
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:1101
readlc
recursive subroutine readlc(lunit, chr, str)
Read a long character string (greater than 8 bytes) from a data subset.
Definition: readwriteval.F90:411
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:2242
writlc
recursive subroutine writlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:206
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:2519
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:896
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