NCEPLIBS-bufr  12.3.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 bufrlib
40 
41  use modv_vars, only: im8b
42 
43  use moda_usrint
44  use moda_msgcwd
45  use moda_tables
46 
47  implicit none
48 
49  integer, intent(in) :: lunit, ntagpv, ntagnb
50  integer, intent(out) :: iret
51  integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft, lpv, lnb, bort_target_set
52 
53  character*(*), intent(in) :: tagpv, tagnb
54  character*9 ctagpv, ctagnb
55 
56  real*8, intent(in) :: r8val
57 
58  ! Check for I8 integers.
59  if(im8b) then
60  im8b=.false.
61  call x84 ( lunit, my_lunit, 1 )
62  call x84 ( ntagpv, my_ntagpv, 1 )
63  call x84 ( ntagnb, my_ntagnb, 1 )
64  call setvalnb ( my_lunit, tagpv, my_ntagpv, tagnb, my_ntagnb, r8val, iret )
65  call x48 ( iret, iret, 1 )
66  im8b=.true.
67  return
68  endif
69 
70  ! If we're catching bort errors, set a target return location if one doesn't already exist.
71 
72  if ( bort_target_set() == 1 ) then
73  call strsuc( tagpv, ctagpv, lpv )
74  call strsuc( tagnb, ctagnb, lnb )
75  call catch_bort_setvalnb_c( lunit, ctagpv, lpv, ntagpv, ctagnb, lnb, ntagnb, r8val, iret )
76  call bort_target_unset
77  return
78  endif
79 
80  iret = -1
81 
82  ! Get lun from lunit.
83  call status (lunit, lun, il, im )
84  if ( il <= 0 ) return
85  if ( inode(lun) /= inv(1,lun) ) return
86 
87  ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv.
88  call fstag( lun, tagpv, ntagpv, 1, npv, ierft )
89  if ( ierft /= 0 ) return
90 
91  ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb.
92  call fstag( lun, tagnb, ntagnb, npv, nnb, ierft )
93  if ( ierft /= 0 ) return
94 
95  iret = 0
96  val(nnb,lun) = r8val
97 
98  return
99 end subroutine setvalnb
100 
134 recursive real*8 function getvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb ) result ( r8val )
135 
136  use bufrlib
137 
138  use modv_vars, only: im8b, bmiss
139 
140  use moda_usrint
141  use moda_msgcwd
142  use moda_tables
143 
144  implicit none
145 
146  integer, intent(in) :: lunit, ntagpv, ntagnb
147  integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft, lpv, lnb, bort_target_set
148 
149  character*(*), intent(in) :: tagpv, tagnb
150  character*9 ctagpv, ctagnb
151 
152  ! Check for I8 integers.
153  if(im8b) then
154  im8b=.false.
155  call x84(lunit,my_lunit,1)
156  call x84(ntagpv,my_ntagpv,1)
157  call x84(ntagnb,my_ntagnb,1)
158  r8val=getvalnb(my_lunit,tagpv,my_ntagpv,tagnb,my_ntagnb)
159  im8b=.true.
160  return
161  endif
162 
163  if ( bort_target_set() == 1 ) then
164  call strsuc( tagpv, ctagpv, lpv )
165  call strsuc( tagnb, ctagnb, lnb )
166  call catch_bort_getvalnb_c( lunit, ctagpv, lpv, ntagpv, ctagnb, lnb, ntagnb, r8val )
167  call bort_target_unset
168  return
169  endif
170 
171  r8val = bmiss
172 
173  ! Get lun from lunit.
174  call status (lunit, lun, il, im )
175  if ( il >= 0 ) return
176  if ( inode(lun) /= inv(1,lun) ) return
177 
178  ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv.
179  call fstag( lun, tagpv, ntagpv, 1, npv, ierft )
180  if ( ierft /= 0 ) return
181 
182  ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb.
183  call fstag( lun, tagnb, ntagnb, npv, nnb, ierft )
184  if ( ierft /= 0 ) return
185 
186  r8val = val(nnb,lun)
187 
188  return
189 end function getvalnb
190 
229 recursive subroutine writlc(lunit,chr,str)
230 
231  use bufrlib
232 
233  use modv_vars, only: im8b, mxlcc, iprt
234 
235  use moda_usrint
236  use moda_msgcwd
237  use moda_bitbuf
238  use moda_tables
239  use moda_comprs
240 
241  implicit none
242 
243  integer, intent(in) :: lunit
244  integer my_lunit, maxtg, lun, il, im, ntg, nnod, kon, ii, n, node, ioid, ival, mbit, nbit, nbmp, nchr, nbyt, nsubs, &
245  itagct, len0, len1, len2, len3, l4, l5, mbyte, iupbs3, lcstr, lcchr, bort_target_set
246 
247  character*(*), intent(in) :: chr, str
248  character*128 bort_str, errstr
249  character*10 ctag
250  character*14 tgs(10)
251  character*15 cstr
252  character*256 cchr
253 
254  real roid
255 
256  data maxtg /10/
257 
258  ! Check for I8 integers
259  if(im8b) then
260  im8b=.false.
261  call x84(lunit,my_lunit,1)
262  call writlc(my_lunit,chr,str)
263  im8b=.true.
264  return
265  endif
266 
267  ! If we're catching bort errors, set a target return location if one doesn't already exist.
268  if (bort_target_set() == 1) then
269  call strsuc(str,cstr,lcstr)
270  call strsuc(chr,cchr,lcchr)
271  call catch_bort_writlc_c(lunit,cstr,lcstr,cchr,lcchr)
272  call bort_target_unset
273  return
274  endif
275 
276  ! Check the file status.
277  call status(lunit,lun,il,im)
278  if(il==0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
279  if(il<0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
280  if(im==0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
281 
282  ! Check for tags (mnemonics) in input string (there can only be one)
283  call parstr(str,tgs,maxtg,ntg,' ',.true.)
284  if(ntg>1) then
285  write(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// &
286  ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4,")")') str,ntg
287  call bort(bort_str)
288  endif
289 
290  ! Check if a specific occurrence of the input string was requested; if not, then the default is to write the first occurrence
291  call parutg(lun,1,tgs(1),nnod,kon,roid)
292  if(kon==6) then
293  ioid=nint(roid)
294  if(ioid<=0) ioid = 1
295  ctag = ' '
296  ii = 1
297  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
298  ctag(ii:ii)=tgs(1)(ii:ii)
299  ii = ii + 1
300  enddo
301  else
302  ioid = 1
303  ctag = tgs(1)(1:10)
304  endif
305 
306  if(iupbs3(mbay(1,lun),'ICMP')>0) then
307  ! The message is compressed
308  n = 1
309  itagct = 0
310  call usrtpl(lun,n,n)
311  do while (n+1<=nval(lun))
312  n = n+1
313  node = inv(n,lun)
314  if(itp(node)==1) then
315  nbmp=int(matx(n,ncol))
316  call usrtpl(lun,n,nbmp)
317  elseif(ctag==tag(node)) then
318  itagct = itagct + 1
319  if(itagct==ioid) then
320  if(itp(node)/=3) then
321  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
322  ctag,typ(node)
323  call bort(bort_str)
324  endif
325  catx(n,ncol)=' '
326  ! The following statement enforces a limit of mxlcc characters per long character string when writing
327  ! compressed messages. This limit keeps the array catx to a reasonable dimensioned size.
328  nchr=min(mxlcc,len(chr),ibt(node)/8)
329  catx(n,ncol)=chr(1:nchr)
330  call usrtpl(lun,1,1)
331  return
332  endif
333  endif
334  enddo
335  else
336  ! The message is not compressed. Locate the beginning of the data (Section 4) in the message.
337  call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
338  mbyte = len0 + len1 + len2 + len3 + 4
339  nsubs = 1
340  ! Find the most recently written subset in the message.
341  do while(nsubs<nsub(lun))
342  ibit = mbyte*8
343  call upb(nbyt,16,mbay(1,lun),ibit)
344  mbyte = mbyte + nbyt
345  nsubs = nsubs + 1
346  enddo
347  if(nsubs/=nsub(lun)) then
348  if(iprt>=0) then
349  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
350  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // &
351  ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
352  call errwrt(errstr)
353  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
354  call errwrt(' ')
355  endif
356  return
357  endif
358  ! Locate and write the long character string within this subset.
359  itagct = 0
360  mbit = mbyte*8 + 16
361  nbit = 0
362  n = 1
363  call usrtpl(lun,n,n)
364  do while (n+1<=nval(lun))
365  n = n+1
366  node = inv(n,lun)
367  mbit = mbit+nbit
368  nbit = ibt(node)
369  if(itp(node)==1) then
370  call upbb(ival,nbit,mbit,mbay(1,lun))
371  call usrtpl(lun,n,ival)
372  elseif(ctag==tag(node)) then
373  itagct = itagct + 1
374  if(itagct==ioid) then
375  if(itp(node)/=3) then
376  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
377  ctag,typ(node)
378  call bort(bort_str)
379  endif
380  nchr = nbit/8
381  ibit = mbit
382  do ii=1,nchr
383  call pkc(' ',1,mbay(1,lun),ibit)
384  enddo
385  call pkc(chr,nchr,mbay(1,lun),mbit)
386  call usrtpl(lun,1,1)
387  return
388  endif
389  endif
390  enddo
391  endif
392 
393  ! If we made it here, then we couldn't find the requested string.
394  if(iprt>=0) then
395  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
396  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE ' // &
397  'SUBSET DEFINITION'
398  call errwrt(errstr)
399  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
400  call errwrt(errstr)
401  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
402  call errwrt(' ')
403  endif
404 
405  return
406 end subroutine writlc
407 
447 recursive subroutine readlc(lunit,chr,str)
448 
449  use bufrlib
450 
451  use modv_vars, only: im8b, iprt
452 
453  use moda_usrint
454  use moda_usrbit
455  use moda_unptyp
456  use moda_bitbuf
457  use moda_tables
458  use moda_rlccmn
459 
460  implicit none
461 
462  integer, intent(in) :: lunit
463  integer my_lunit, maxtg, lchr, lun, il, im, ntg, nnod, kon, ii, n, nod, ioid, itagct, nchr, kbit, lcstr, lcchr, ncchr, &
464  bort_target_set
465 
466  character*(*), intent(in) :: str
467  character*(*), intent(out) :: chr
468 
469  character*128 bort_str, errstr
470  character*10 ctag
471  character*14 tgs(10)
472  character*15 cstr
473  character*(:), allocatable :: cchr
474 
475  real roid
476 
477  data maxtg /10/
478 
479  ! Check for I8 integers
480  if(im8b) then
481  im8b=.false.
482  call x84(lunit,my_lunit,1)
483  call readlc(my_lunit,chr,str)
484  im8b=.true.
485  return
486  endif
487 
488  chr = ' '
489  lchr=len(chr)
490 
491  ! If we're catching bort errors, set a target return location if one doesn't already exist.
492  if (bort_target_set() == 1) then
493  call strsuc(str,cstr,lcstr)
494  lcchr = lchr + 1 ! Allow extra byte in cchr for the trailing null in C
495  allocate(character*(lcchr) :: cchr)
496  call catch_bort_readlc_c(lunit,cstr,lcstr,cchr,lcchr,ncchr)
497  chr(1:ncchr) = cchr(1:ncchr)
498  deallocate(cchr)
499  call bort_target_unset
500  return
501  endif
502 
503  ! Check the file status
504  call status(lunit,lun,il,im)
505  if(il==0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
506  if(il>0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
507  if(im==0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
508 
509  ! Check for tags (mnemonics) in input string (there can only be one)
510  call parstr(str,tgs,maxtg,ntg,' ',.true.)
511  if(ntg>1) then
512  write(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// &
513  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntg
514  call bort(bort_str)
515  endif
516 
517  ! Check if a specific occurrence of the input string was requested; if not, then the default is to return the
518  ! first occurrence.
519  call parutg(lun,0,tgs(1),nnod,kon,roid)
520  if(kon==6) then
521  ioid=nint(roid)
522  if(ioid<=0) ioid = 1
523  ctag = ' '
524  ii = 1
525  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
526  ctag(ii:ii)=tgs(1)(ii:ii)
527  ii = ii + 1
528  enddo
529  else
530  ioid = 1
531  ctag = tgs(1)(1:10)
532  endif
533 
534  ! Locate and decode the long character string
535  if(msgunp(lun)==0.or.msgunp(lun)==1) then
536  ! The message is not compressed
537  itagct = 0
538  do n=1,nval(lun)
539  nod = inv(n,lun)
540  if(ctag==tag(nod)) then
541  itagct = itagct + 1
542  if(itagct==ioid) then
543  if(itp(nod)/=3) then
544  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// &
545  'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
546  call bort(bort_str)
547  endif
548  nchr = nbit(n)/8
549  if(nchr>lchr) then
550  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
551  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
552  call bort(bort_str)
553  endif
554  kbit = mbit(n)
555  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
556  return
557  endif
558  endif
559  enddo
560  else
561  ! The message is compressed
562  if(nrst>0) then
563  itagct = 0
564  do ii=1,nrst
565  if(ctag==crtag(ii)) then
566  itagct = itagct + 1
567  if(itagct==ioid) then
568  nchr = irnch(ii)
569  if(nchr>lchr) then
570  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
571  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
572  call bort(bort_str)
573  endif
574  kbit = irbit(ii)
575  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
576  return
577  endif
578  endif
579  enddo
580  endif
581  endif
582 
583  ! If we made it here, then we couldn't find the requested string.
584  if(iprt>=0) then
585  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
586  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // &
587  ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT'
588  call errwrt(errstr)
589  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
590  call errwrt(' ')
591  endif
592  do ii=1,lchr
593  call ipkm(chr(ii:ii),1,255)
594  enddo
595 
596  return
597 end subroutine readlc
598 
701 recursive subroutine ufbint(lunin,usr,i1,i2,iret,str)
702 
703  use bufrlib
704 
705  use modv_vars, only: im8b, bmiss, iprt
706 
707  use moda_usrint
708  use moda_msgcwd
709 
710  implicit none
711 
712  character*(*), intent(in) :: str
713  character*128 bort_str1, bort_str2, errstr
714  character*90 cstr
715 
716  integer, intent(in) :: lunin, i1, i2
717  integer, intent(out) :: iret
718  integer nnod, ncon, nods, nodc, ivls, kons, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, lcstr, &
719  bort_target_set
720 
721  real*8, intent(inout) :: usr(i1,i2)
722 
723  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
724 
725  data ifirst1 /0/, ifirst2 /0/
726 
727  save ifirst1, ifirst2
728 
729  ! Check for I8 integers
730  if(im8b) then
731  im8b=.false.
732  call x84(lunin,my_lunin,1)
733  call x84(i1,my_i1,1)
734  call x84(i2,my_i2,1)
735  call ufbint(my_lunin,usr,my_i1,my_i2,iret,str)
736  call x48(iret,iret,1)
737  im8b=.true.
738  return
739  endif
740 
741  ! If we're catching bort errors, set a target return location if one doesn't already exist.
742  if (bort_target_set() == 1) then
743  call strsuc(str,cstr,lcstr)
744  call catch_bort_ufbint_c(lunin,usr,i1,i2,iret,cstr,lcstr)
745  call bort_target_unset
746  return
747  endif
748 
749  iret = 0
750 
751  ! Check the file status and inode
752  lunit = abs(lunin)
753  call status(lunit,lun,il,im)
754  if(il==0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN')
755  if(im==0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
756  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
757  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
758 
759  io = min(max(0,il),1)
760  if(lunit/=lunin) io = 0
761 
762  if(i1<=0) then
763  if(iprt>=0) then
764  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
765  errstr = .LE.'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
766  call errwrt(errstr)
767  call errwrt(str)
768  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
769  call errwrt(' ')
770  endif
771  return
772  elseif(i2<=0) then
773  if(iprt==-1) ifirst1 = 1
774  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
775  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
776  errstr = .LE.'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
777  call errwrt(errstr)
778  call errwrt(str)
779  if(iprt==0 .and. io==1) then
780  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
781  'all such messages,'
782  call errwrt(errstr)
783  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
784  'BUFRLIB routine.'
785  call errwrt(errstr)
786  endif
787  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
788  call errwrt(' ')
789  ifirst1 = 1
790  endif
791  return
792  endif
793 
794  ! Parse or recall the input string
795  call string(str,lun,i1,io)
796 
797  ! Initialize usr array preceeding an input operation
798  if(io==0) usr(1:i1,1:i2) = bmiss
799 
800  ! Call the mnemonic reader/writer
801  call ufbrw(lun,usr,i1,i2,io,iret)
802 
803  ! If incomplete read then write a diagnostic and reset iret.
804  if(io==0 .and. iret>i2) then
805  if(iprt>=0) then
806  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
807  errstr = 'BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ' // str
808  call errwrt(errstr)
809  write (errstr,'("THE NUMBER OF ''LEVELS'' AVAILABLE IN THE SUBSET '// &
810  '(",I5,") IS GREATER THAN THE NUMBER REQUESTED (",I5,") - INCOMPLETE READ")') iret,i2
811  call errwrt(errstr)
812  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
813  call errwrt(' ')
814  endif
815  iret = i2
816  endif
817 
818  ! If incomplete write try to initialize replication sequence or return
819  if(io==1 .and. iret/=i2 .and. iret>=0) then
820  call trybump(lun,usr,i1,i2,io,iret)
821  if(iret/=i2) then
822  write(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ",A)') str
823  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
824  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
825  call bort2(bort_str1,bort_str2)
826  endif
827  elseif(iret==-1) then
828  iret = 0
829  endif
830 
831  if(iret==0) then
832  if(io==0) then
833  if(iprt>=1) then
834  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
835  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
836  call errwrt(errstr)
837  call errwrt(str)
838  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
839  call errwrt(' ')
840  endif
841  else
842  if(iprt==-1) ifirst2 = 1
843  if(ifirst2==0 .or. iprt>=1) then
844  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
845  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
846  call errwrt(errstr)
847  call errwrt(str)
848  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
849  if(iprt==0) then
850  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
851  'all such messages,'
852  call errwrt(errstr)
853  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // &
854  'to a BUFRLIB routine.'
855  call errwrt(errstr)
856  endif
857  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
858  call errwrt(' ')
859  ifirst2 = 1
860  endif
861  endif
862  endif
863 
864  return
865 end subroutine ufbint
866 
961 recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str)
962 
963  use bufrlib
964 
965  use modv_vars, only: im8b, bmiss, iac, iprt
966 
967  use moda_usrint
968  use moda_msgcwd
969 
970  implicit none
971 
972  character*(*), intent(in) :: str
973  character*128 bort_str1, bort_str2, errstr
974  character*90 cstr
975 
976  integer, intent(in) :: lunin, i1, i2
977  integer, intent(out) :: iret
978  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, iac_prev, lcstr, bort_target_set
979 
980  real*8, intent(inout) :: usr(i1,i2)
981 
982  data ifirst1 /0/
983 
984  save ifirst1
985 
986  ! Check for I8 integers
987  if(im8b) then
988  im8b=.false.
989  call x84(lunin,my_lunin,1)
990  call x84(i1,my_i1,1)
991  call x84(i2,my_i2,1)
992  call ufbrep(my_lunin,usr,my_i1,my_i2,iret,str)
993  call x48(iret,iret,1)
994  im8b=.true.
995  return
996  endif
997 
998  ! If we're catching bort errors, set a target return location if one doesn't already exist.
999  if (bort_target_set() == 1) then
1000  call strsuc(str,cstr,lcstr)
1001  call catch_bort_ufbrep_c(lunin,usr,i1,i2,iret,cstr,lcstr)
1002  call bort_target_unset
1003  return
1004  endif
1005 
1006  iret = 0
1007 
1008  ! Check the file status and inode
1009  lunit = abs(lunin)
1010  call status(lunit,lun,il,im)
1011  if(il==0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1012  if(im==0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1013  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
1014  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1015 
1016  io = min(max(0,il),1)
1017  if(lunit/=lunin) io = 0
1018 
1019  if(i1<=0) then
1020  if(iprt>=0) then
1021  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1022  errstr = .LE.'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1023  call errwrt(errstr)
1024  call errwrt(str)
1025  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1026  call errwrt(' ')
1027  endif
1028  return
1029  elseif(i2<=0) then
1030  if(iprt==-1) ifirst1 = 1
1031  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1032  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1033  errstr = .LE.'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1034  call errwrt(errstr)
1035  call errwrt(str)
1036  if(iprt==0 .and. io==1) then
1037  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1038  'all such messages,'
1039  call errwrt(errstr)
1040  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1041  'BUFRLIB routine.'
1042  call errwrt(errstr)
1043  endif
1044  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1045  call errwrt(' ')
1046  ifirst1 = 1
1047  endif
1048  return
1049  endif
1050 
1051  ! Initialize usr array preceeding an input operation
1052  if(io==0) usr(1:i1,1:i2) = bmiss
1053 
1054  ! Parse or recall the input string
1055  iac_prev = iac
1056  iac = 1
1057  call string(str,lun,i1,io)
1058  iac = iac_prev
1059 
1060  ! Call the mnemonic reader/writer
1061  call ufbrp(lun,usr,i1,i2,io,iret)
1062 
1063  ! If incomplete read then write a diagnostic and reset iret.
1064  if(io==0 .and. iret>i2) then
1065  if(iprt>=0) then
1066  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1067  errstr = 'BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ' // str
1068  call errwrt(errstr)
1069  write (errstr,'("THE NUMBER OF ''LEVELS'' AVAILABLE IN THE SUBSET '// &
1070  '(",I5,") IS GREATER THAN THE NUMBER REQUESTED (",I5,") - INCOMPLETE READ")') iret,i2
1071  call errwrt(errstr)
1072  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1073  call errwrt(' ')
1074  endif
1075  iret = i2
1076  endif
1077 
1078  if(io==1 .and. iret<i2) then
1079  write(bort_str1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ",A)') str
1080  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
1081  'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
1082  call bort2(bort_str1,bort_str2)
1083  endif
1084 
1085  if(iret==0 .and. io==0 .and. iprt>=1) then
1086  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1087  errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1088  call errwrt(errstr)
1089  call errwrt(str)
1090  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1091  call errwrt(' ')
1092  endif
1093 
1094  return
1095 end subroutine ufbrep
1096 
1192 recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str)
1193 
1194  use bufrlib
1195 
1196  use modv_vars, only: im8b, bmiss, iprt
1197 
1198  use moda_usrint
1199  use moda_msgcwd
1200 
1201  implicit none
1202 
1203  character*(*), intent(in) :: str
1204  character*128 bort_str1, bort_str2, errstr
1205  character*90 cstr
1206 
1207  integer, intent(in) :: lunin, i1, i2
1208  integer, intent(out) :: iret
1209  integer ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, lcstr, bort_target_set
1210 
1211  real*8, intent(inout) :: usr(i1,i2)
1212 
1213  data ifirst1 /0/
1214 
1215  save ifirst1
1216 
1217  ! Check for I8 integers
1218  if(im8b) then
1219  im8b=.false.
1220  call x84(lunin,my_lunin,1)
1221  call x84(i1,my_i1,1)
1222  call x84(i2,my_i2,1)
1223  call ufbstp(my_lunin,usr,my_i1,my_i2,iret,str)
1224  call x48(iret,iret,1)
1225  im8b=.true.
1226  return
1227  endif
1228 
1229  ! If we're catching bort errors, set a target return location if one doesn't already exist.
1230  if (bort_target_set() == 1) then
1231  call strsuc(str,cstr,lcstr)
1232  call catch_bort_ufbstp_c(lunin,usr,i1,i2,iret,cstr,lcstr)
1233  call bort_target_unset
1234  return
1235  endif
1236 
1237  iret = 0
1238 
1239  ! Check the file status and inode
1240  lunit = abs(lunin)
1241  call status(lunit,lun,il,im)
1242  if(il==0) call bort('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1243  if(im==0) call bort('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1244  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
1245  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1246 
1247  io = min(max(0,il),1)
1248  if(lunit/=lunin) io = 0
1249 
1250  if(i1<=0) then
1251  if(iprt>=0) then
1252  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1253  errstr = .LE.'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1254  call errwrt(errstr)
1255  call errwrt(str)
1256  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1257  call errwrt(' ')
1258  endif
1259  return
1260  elseif(i2<=0) then
1261  if(iprt==-1) ifirst1 = 1
1262  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1263  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1264  errstr = .LE.'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1265  call errwrt(errstr)
1266  call errwrt(str)
1267  if(iprt==0 .and. io==1) then
1268  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1269  'all such messages,'
1270  call errwrt(errstr)
1271  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1272  'BUFRLIB routine.'
1273  call errwrt(errstr)
1274  endif
1275  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1276  call errwrt(' ')
1277  ifirst1 = 1
1278  endif
1279  return
1280  endif
1281 
1282  ! Initialize usr array preceeding an input operation
1283  if(io==0) usr(1:i1,1:i2) = bmiss
1284 
1285  ! Parse or recall the input string
1286  call string(str,lun,i1,io)
1287 
1288  ! Call the mnemonic reader/writer
1289  call ufbsp(lun,usr,i1,i2,io,iret)
1290 
1291  ! If incomplete read then write a diagnostic and reset iret.
1292  if(io==0 .and. iret>i2) then
1293  if(iprt>=0) then
1294  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1295  errstr = 'BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ' // str
1296  call errwrt(errstr)
1297  write (errstr,'("THE NUMBER OF ''LEVELS'' AVAILABLE IN THE SUBSET '// &
1298  '(",I5,") IS GREATER THAN THE NUMBER REQUESTED (",I5,") - INCOMPLETE READ")') iret,i2
1299  call errwrt(errstr)
1300  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1301  call errwrt(' ')
1302  endif
1303  iret = i2
1304  endif
1305 
1306  if(io==1 .and. iret/=i2) then
1307  write(bort_str1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ",A)') str
1308  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
1309  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
1310  call bort2(bort_str1,bort_str2)
1311  endif
1312 
1313  if(iret==0 .and. io==0 .and. iprt>=1) then
1314  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1315  errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1316  call errwrt(errstr)
1317  call errwrt(str)
1318  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1319  call errwrt(' ')
1320  endif
1321 
1322  return
1323 end subroutine ufbstp
1324 
1431 recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str)
1432 
1433  use bufrlib
1434 
1435  use modv_vars, only: im8b, bmiss, iprt
1436 
1437  use moda_usrint
1438  use moda_msgcwd
1439  use moda_tables
1440 
1441  implicit none
1442 
1443  integer, intent(in) :: lunin, i1, i2
1444  integer, intent(out) :: iret
1445  integer, parameter :: mtag = 10
1446  integer ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j, ntag, node, nods, ins1, ins2, insx, &
1447  nseq, isq, ityp, invwin, invtag, lcstr, bort_target_set
1448 
1449  real*8, intent(inout) :: usr(i1,i2)
1450 
1451  character*(*), intent(in) :: str
1452  character*156 bort_str
1453  character*128 errstr
1454  character*90 cstr
1455  character*10 tags(mtag)
1456 
1457  data ifirst1 /0/, ifirst2 /0/
1458 
1459  save ifirst1, ifirst2
1460 
1461  ! Check for I8 integers
1462  if(im8b) then
1463  im8b=.false.
1464  call x84(lunin,my_lunin,1)
1465  call x84(i1,my_i1,1)
1466  call x84(i2,my_i2,1)
1467  call ufbseq(my_lunin,usr,my_i1,my_i2,iret,str)
1468  call x48(iret,iret,1)
1469  im8b=.true.
1470  return
1471  endif
1472 
1473  ! If we're catching bort errors, set a target return location if one doesn't already exist.
1474  if (bort_target_set() == 1) then
1475  call strsuc(str,cstr,lcstr)
1476  call catch_bort_ufbseq_c(lunin,usr,i1,i2,iret,cstr,lcstr)
1477  call bort_target_unset
1478  return
1479  endif
1480 
1481  iret = 0
1482 
1483  ! Check the file status and inode
1484  lunit = abs(lunin)
1485  call status(lunit,lun,il,im)
1486  if(il==0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1487  if(im==0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1488 
1489  io = min(max(0,il),1)
1490  if(lunit/=lunin) io = 0
1491 
1492  if(i1<=0) then
1493  if(iprt>=0) then
1494  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1495  errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1496  call errwrt(errstr)
1497  call errwrt(str)
1498  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1499  call errwrt(' ')
1500  endif
1501  return
1502  elseif(i2<=0) then
1503  if(iprt==-1) ifirst1 = 1
1504  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1505  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1506  errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1507  call errwrt(errstr)
1508  call errwrt(str)
1509  if(iprt==0 .and. io==1) then
1510  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1511  'all such messages,'
1512  call errwrt(errstr)
1513  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1514  'BUFRLIB routine.'
1515  call errwrt(errstr)
1516  endif
1517  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1518  call errwrt(' ')
1519  ifirst1 = 1
1520  endif
1521  return
1522  endif
1523 
1524  ! Check for valid sequence and sequence length arguments
1525  call parstr(str,tags,mtag,ntag,' ',.true.)
1526  if(ntag<1) then
1527  write(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") DOES NOT CONTAIN ANY MNEMONICS!!")') str
1528  call bort(bort_str)
1529  endif
1530  if(ntag>1) then
1531  write(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// &
1532  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntag
1533  call bort(bort_str)
1534  endif
1535  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// &
1536  'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1537 
1538  ! Initialize usr array preceeding an input operation
1539  if(io==0) usr(1:i1,1:i2) = bmiss
1540 
1541  ! Find the parameters of the specified sequence
1542  outer: do node=inode(lun),isc(inode(lun))
1543  if(str==tag(node)) then
1544  if(typ(node)=='SEQ' .or. typ(node)=='RPC') then
1545  ins1 = 1
1546  do while (.true.)
1547  ins1 = invtag(node,lun,ins1,nval(lun))
1548  if(ins1==0) exit outer
1549  if(typ(node)/='RPC' .or. val(ins1,lun)/=0.) exit
1550  ins1 = ins1+1
1551  enddo
1552  ins2 = invtag(node,lun,ins1+1,nval(lun))
1553  if(ins2==0) ins2 = 10e5
1554  nods = node
1555  do while(link(nods)==0 .and. jmpb(nods)>0)
1556  nods = jmpb(nods)
1557  enddo
1558  if(link(nods)==0) then
1559  insx = nval(lun)
1560  elseif(link(nods)>0) then
1561  insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
1562  endif
1563  ins2 = min(ins2,insx)
1564  elseif(typ(node)=='SUB') then
1565  ins1 = 1
1566  ins2 = nval(lun)
1567  else
1568  write(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// &
1569  'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
1570  call bort(bort_str)
1571  endif
1572  nseq = 0
1573  do isq=ins1,ins2
1574  ityp = itp(inv(isq,lun))
1575  if(ityp>1) nseq = nseq+1
1576  enddo
1577  if(nseq>i1) then
1578  write(bort_str,.GT.'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A," CONSISTS OF",I4," TABLE B MNEM., THE MAX. '// &
1579  'SPECIFIED IN (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
1580  call bort(bort_str)
1581  endif
1582  ! Frame a section of the buffer - return when no frame
1583  inner: do while (.true.)
1584  ins1 = invtag(node,lun,ins1,nval(lun))
1585  if(ins1>nval(lun)) exit outer
1586  if(ins1>0) then
1587  if(typ(node)=='RPC' .and. val(ins1,lun)==0.) then
1588  ins1 = ins1+1
1589  cycle
1590  elseif(io==0 .and. iret+1>i2) then
1591  if(iprt>=0) then
1592  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1593  write ( unit=errstr, fmt='(A,I5,A,A,A)' ) 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2, &
1594  ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1), ' WERE READ'
1595  call errwrt(errstr)
1596  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1597  call errwrt(' ')
1598  endif
1599  exit outer
1600  endif
1601  elseif(ins1==0) then
1602  if(io==1 .and. iret<i2) then
1603  write(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'.LT.' WRITTEN (",I5,") NO. REQUESTED (",I5,") - '// &
1604  'INCOMPLETE WRITE (INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
1605  call bort(bort_str)
1606  endif
1607  else
1608  write(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE ZERO, HERE IT IS",I4," - INPUT MNEMONIC '// &
1609  'IS ",A)') ins1,tags(1)
1610  call bort(bort_str)
1611  endif
1612  if(ins1==0 .or. iret==i2) exit outer
1613  iret = iret+1
1614  ins1 = ins1+1
1615  ! Read/write user values
1616  j = ins1
1617  do i=1,nseq
1618  do while(itp(inv(j,lun))<2)
1619  j = j+1
1620  enddo
1621  if(io==0) usr(i,iret) = val(j,lun)
1622  if(io==1) val(j,lun) = usr(i,iret)
1623  j = j+1
1624  enddo
1625  enddo inner
1626  endif
1627  enddo outer
1628 
1629  if(iret==0) then
1630  if(io==0) then
1631  if(iprt>=1) then
1632  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1633  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1634  call errwrt(errstr)
1635  call errwrt(str)
1636  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1637  call errwrt(' ')
1638  endif
1639  else
1640  if(iprt==-1) ifirst2 = 1
1641  if(ifirst2==0 .or. iprt>=1) then
1642  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1643  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1644  call errwrt(errstr)
1645  call errwrt(str)
1646  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
1647  if(iprt==0) then
1648  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1649  'all such messages,'
1650  call errwrt(errstr)
1651  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1652  'BUFRLIB routine.'
1653  call errwrt(errstr)
1654  endif
1655  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1656  call errwrt(' ')
1657  ifirst2 = 1
1658  endif
1659  endif
1660  endif
1661 
1662  return
1663 end subroutine ufbseq
1664 
1702 recursive subroutine drfini(lunit,mdrf,ndrf,drftag)
1703 
1704  use bufrlib
1705 
1706  use modv_vars, only: im8b
1707 
1708  use moda_usrint
1709  use moda_tables
1710 
1711  implicit none
1712 
1713  character*(*), intent(in) :: drftag
1714  character*12 cdrftag
1715 
1716  integer, intent(in) :: mdrf(*), lunit, ndrf
1717  integer, parameter :: mxdrf = 2000
1718  integer my_mdrf(mxdrf), my_lunit, my_ndrf, lun, il, im, m, n, node, lcdrftag, bort_target_set
1719 
1720  ! Check for I8 integers
1721  if(im8b) then
1722  im8b=.false.
1723  call x84(lunit,my_lunit,1)
1724  call x84(ndrf,my_ndrf,1)
1725  call x84(mdrf(1),my_mdrf(1),my_ndrf)
1726  call drfini(my_lunit,my_mdrf,my_ndrf,drftag)
1727  im8b=.true.
1728  return
1729  endif
1730 
1731  ! If we're catching bort errors, set a target return location if one doesn't already exist.
1732  if (bort_target_set() == 1) then
1733  call strsuc(drftag,cdrftag,lcdrftag)
1734  call catch_bort_drfini_c(lunit,mdrf,ndrf,cdrftag,lcdrftag)
1735  call bort_target_unset
1736  return
1737  endif
1738 
1739  call status(lunit,lun,il,im)
1740  ! Conform the template to the delayed replication factors
1741  m = 0
1742  n = 1
1743  do while ( n <= nval(lun) )
1744  node = inv(n,lun)
1745  if(itp(node)==1 .and. tag(node)==drftag) then
1746  m = m+1
1747  call usrtpl(lun,n,mdrf(m))
1748  endif
1749  n = n+1
1750  enddo
1751 
1752  return
1753 end subroutine drfini
1754 
1778 subroutine ufbrw(lun,usr,i1,i2,io,iret)
1779 
1780  use modv_vars, only: bmiss, iprt
1781 
1782  use moda_usrint
1783  use moda_tables
1784  use moda_msgcwd
1785 
1786  implicit none
1787 
1788  integer, intent(in) :: lun, i1, i2, io
1789  integer, intent(out) :: iret
1790  integer nnod, ncon, nods, nodc, ivls, kons, inc1, inc2, ins1, ins2, invn, i, j, invwin, ibfms, lstjpb
1791 
1792  real*8, intent(inout) :: usr(i1,i2)
1793 
1794  character*128 errstr
1795  character*10 tagstr, subset
1796 
1797  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1798 
1799  subset=tag(inode(lun))
1800  iret = 0
1801 
1802  ! Loop over condition windows
1803  inc1 = 1
1804  inc2 = 1
1805  outer: do while (.true.)
1806  call conwin(lun,inc1,inc2)
1807  if(nnod==0) then
1808  iret = i2
1809  return
1810  elseif(inc1==0) then
1811  return
1812  else
1813  do j=1,nnod
1814  if(nods(j)>0) then
1815  ins2 = inc1
1816  call getwin(nods(j),lun,ins1,ins2)
1817  if(ins1==0) return
1818  do while (.true.)
1819  ! Loop over store nodes
1820  iret = iret+1
1821  if(iprt>=2) then
1822  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1823  call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//subset)
1824  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1825  do i=1,nnod
1826  if(io==0) tagstr=tag(nods(i))(1:8)//' R'
1827  if(io==1) tagstr=tag(nods(i))(1:8)//' W'
1828  invn = invwin(nods(i),lun,ins1,ins2)
1829  if(invn==0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn)
1830  write(errstr,'("LEV=",I5,1X,A,3I7)') iret,tagstr,ins1,invn,ins2
1831  call errwrt(errstr)
1832  enddo
1833  endif
1834  ! Write user values
1835  if(io==1 .and. iret<=i2) then
1836  do i=1,nnod
1837  if(nods(i)>0) then
1838  if(ibfms(usr(i,iret))==0) then
1839  invn = invwin(nods(i),lun,ins1,ins2)
1840  if(invn==0) then
1841  call drstpl(nods(i),lun,ins1,ins2,invn)
1842  if(invn==0) then
1843  iret = 0
1844  return
1845  endif
1846  call newwin(lun,inc1,inc2)
1847  val(invn,lun) = usr(i,iret)
1848  elseif(lstjpb(nods(i),lun,'RPS')==0) then
1849  val(invn,lun) = usr(i,iret)
1850  elseif(ibfms(val(invn,lun))/=0) then
1851  val(invn,lun) = usr(i,iret)
1852  else
1853  call drstpl(nods(i),lun,ins1,ins2,invn)
1854  if(invn==0) then
1855  iret = 0
1856  return
1857  endif
1858  call newwin(lun,inc1,inc2)
1859  val(invn,lun) = usr(i,iret)
1860  endif
1861  endif
1862  endif
1863  enddo
1864  endif
1865  ! Read user values
1866  if(io==0 .and. iret<=i2) then
1867  do i=1,nnod
1868  usr(i,iret) = bmiss
1869  if(nods(i)>0) then
1870  invn = invwin(nods(i),lun,ins1,ins2)
1871  if(invn>0) usr(i,iret) = val(invn,lun)
1872  endif
1873  enddo
1874  endif
1875  ! Decide what to do next
1876  if(io==1 .and. iret==i2) return
1877  call nxtwin(lun,ins1,ins2)
1878  if(ins1>0 .and. ins1<inc2) cycle
1879  if(ncon>0) cycle outer
1880  return
1881  enddo
1882  endif
1883  enddo
1884  iret = -1
1885  return
1886  endif
1887  enddo outer
1888 
1889  return
1890 end subroutine ufbrw
1891 
1915 subroutine ufbrp(lun,usr,i1,i2,io,iret)
1916 
1917  use moda_usrint
1918 
1919  implicit none
1920 
1921  integer, intent(in) :: lun, i1, i2, io
1922  integer, intent(out) :: iret
1923  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, i, nz, invtag
1924 
1925  real*8, intent(inout) :: usr(i1,i2)
1926 
1927  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1928 
1929  iret = 0
1930  ins1 = 0
1931  ins2 = 0
1932 
1933  ! Find first non-zero node in string
1934  do nz=1,nnod
1935  if(nods(nz)>0) then
1936  do while (.true.)
1937  ! Frame a section of the buffer - return when no frame
1938  if(ins1+1>nval(lun)) return
1939  if(io==1 .and. iret==i2) return
1940  ins1 = invtag(nods(nz),lun,ins1+1,nval(lun))
1941  if(ins1==0) return
1942  ins2 = invtag(nods(nz),lun,ins1+1,nval(lun))
1943  if(ins2==0) ins2 = nval(lun)
1944  iret = iret+1
1945  ! Read user values
1946  if(io==0 .and. iret<=i2) then
1947  do i=1,nnod
1948  if(nods(i)>0) then
1949  invn = invtag(nods(i),lun,ins1,ins2)
1950  if(invn>0) usr(i,iret) = val(invn,lun)
1951  endif
1952  enddo
1953  endif
1954  ! Write user values
1955  if(io==1 .and. iret<=i2) then
1956  do i=1,nnod
1957  if(nods(i)>0) then
1958  invn = invtag(nods(i),lun,ins1,ins2)
1959  if(invn>0) val(invn,lun) = usr(i,iret)
1960  endif
1961  enddo
1962  endif
1963  enddo
1964  endif
1965  enddo
1966 
1967  return
1968 end subroutine ufbrp
1969 
1999 subroutine ufbsp(lun,usr,i1,i2,io,iret)
2000 
2001  use moda_usrint
2002 
2003  implicit none
2004 
2005  integer, intent(in) :: lun, i1, i2, io
2006  integer, intent(out) :: iret
2007  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, invm, i, invtag
2008 
2009  real*8, intent(inout) :: usr(i1,i2)
2010 
2011  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2012 
2013  iret = 0
2014  ins1 = 0
2015  ins2 = 0
2016 
2017  do while (.true.)
2018  ! Frame a section of the buffer - return when no frame
2019  if(ins1+1>nval(lun)) return
2020  ins1 = invtag(nods(1),lun,ins1+1,nval(lun))
2021  if(ins1==0) return
2022  ins2 = invtag(nods(1),lun,ins1+1,nval(lun))
2023  if(ins2==0) ins2 = nval(lun)
2024  iret = iret+1
2025  ! Read user values
2026  if(io==0 .and. iret<=i2) then
2027  invm = ins1
2028  do i=1,nnod
2029  if(nods(i)>0) then
2030  invn = invtag(nods(i),lun,invm,ins2)
2031  if(invn>0) usr(i,iret) = val(invn,lun)
2032  invm = max(invn,invm)
2033  endif
2034  enddo
2035  endif
2036  ! Write user values
2037  if(io==1 .and. iret<=i2) then
2038  invm = ins1
2039  do i=1,nnod
2040  if(nods(i)>0) then
2041  invn = invtag(nods(i),lun,invm,ins2)
2042  if(invn>0) val(invn,lun) = usr(i,iret)
2043  invm = max(invn,invm)
2044  endif
2045  enddo
2046  endif
2047  enddo
2048 
2049  return
2050 end subroutine ufbsp
2051 
2100 recursive subroutine hold4wlc(lunit,chr,str)
2101 
2102  use modv_vars, only: im8b, mxh4wlc, iprt
2103 
2104  use moda_h4wlc
2105 
2106  implicit none
2107 
2108  integer, intent(in) :: lunit
2109  integer my_lunit, lens, lenc, i
2110 
2111  character*(*), intent(in) :: chr, str
2112 
2113  character*128 errstr
2114  character*14 mystr
2115 
2116  ! Check for I8 integers
2117  if(im8b) then
2118  im8b=.false.
2119  call x84(lunit,my_lunit,1)
2120  call hold4wlc(my_lunit,chr,str)
2121  im8b=.true.
2122  return
2123  endif
2124 
2125  call strsuc( str, mystr, lens )
2126  if ( lens == -1 ) return
2127 
2128  lenc = min( len( chr ), 120 )
2129 
2130  ! If this subroutine has already been called with this mnemonic for this particular subset, then overwrite the
2131  ! corresponding entry in the internal holding area
2132  if ( nh4wlc > 0 ) then
2133  do i = 1, nh4wlc
2134  if ( ( lunit == luh4wlc(i) ) .and. ( mystr(1:lens) == sth4wlc(i)(1:lens) ) ) then
2135  chh4wlc(i) = ''
2136  chh4wlc(i)(1:lenc) = chr(1:lenc)
2137  return
2138  endif
2139  enddo
2140  endif
2141 
2142  ! Otherwise, use the next available unused entry in the holding area
2143  if ( nh4wlc >= mxh4wlc ) then
2144  if(iprt>=0) then
2145  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2146  write ( unit=errstr, fmt='(A,A,I3)' ) 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', &
2147  'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
2148  call errwrt(errstr)
2149  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2150  endif
2151  else
2152  nh4wlc = nh4wlc + 1
2153  luh4wlc(nh4wlc) = lunit
2154  sth4wlc(nh4wlc) = ''
2155  sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
2156  chh4wlc(nh4wlc) = ''
2157  chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
2158  endif
2159 
2160  return
2161 end subroutine hold4wlc
2162 
2189 subroutine trybump(lun,usr,i1,i2,io,iret)
2190 
2191  use moda_usrint
2192 
2193  implicit none
2194 
2195  integer, intent(in) :: lun, i1, i2, io
2196  integer, intent(out) :: iret
2197  integer nnod, ncon, nods, nodc, ivls, kons, ndrp, invn, jnvn, knvn, invwin, lstjpb
2198 
2199  real*8, intent(inout) :: usr(i1,i2)
2200 
2201  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2202 
2203  ! See if there's a delayed replication group involved
2204 
2205  ndrp = lstjpb(nods(1),lun,'DRP')
2206  if(ndrp<=0) return
2207 
2208  ! If so, clean it out and bump it to i2
2209 
2210  invn = invwin(ndrp,lun,1,nval(lun))
2211  val(invn,lun) = 0
2212  jnvn = invn+1
2213  do while(nint(val(jnvn,lun))>0)
2214  jnvn = jnvn+nint(val(jnvn,lun))
2215  enddo
2216  do knvn=1,nval(lun)-jnvn+1
2217  inv(invn+knvn,lun) = inv(jnvn+knvn-1,lun)
2218  val(invn+knvn,lun) = val(jnvn+knvn-1,lun)
2219  enddo
2220  nval(lun) = nval(lun)-(jnvn-invn-1)
2221  call usrtpl(lun,invn,i2)
2222 
2223  ! Call the mnemonic writer
2224 
2225  call ufbrw(lun,usr,i1,i2,io,iret)
2226 
2227  return
2228 end subroutine trybump
2229 
2249 recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str)
2250 
2251  use bufrlib
2252 
2253  use modv_vars, only: im8b, iprt
2254 
2255  use moda_usrint
2256  use moda_msgcwd
2257 
2258  implicit none
2259 
2260  integer, intent(in) :: lunit, i1, i2
2261  integer, intent(out) :: iret
2262  integer ifirst1, my_lunit, my_i1, my_i2, lun, il, im, io, lcstr, bort_target_set
2263 
2264  character*(*), intent(in) :: str
2265  character*128 bort_str1, bort_str2, errstr
2266  character*90 cstr
2267 
2268  real*8, intent(inout) :: usr(i1,i2)
2269 
2270  data ifirst1 /0/
2271 
2272  save ifirst1
2273 
2274  ! Check for I8 integers
2275 
2276  if(im8b) then
2277  im8b=.false.
2278  call x84(lunit,my_lunit,1)
2279  call x84(i1,my_i1,1)
2280  call x84(i2,my_i2,1)
2281  call ufbovr(my_lunit,usr,my_i1,my_i2,iret,str)
2282  call x48(iret,iret,1)
2283  im8b=.true.
2284  return
2285  endif
2286 
2287  ! If we're catching bort errors, set a target return location if one doesn't already exist.
2288  if (bort_target_set() == 1) then
2289  call strsuc(str,cstr,lcstr)
2290  call catch_bort_ufbovr_c(lunit,usr,i1,i2,iret,cstr,lcstr)
2291  call bort_target_unset
2292  return
2293  endif
2294 
2295  iret = 0
2296 
2297  ! Check the file status and inode
2298 
2299  call status(lunit,lun,il,im)
2300  if(il==0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
2301  if(il<0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
2302  if(im==0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
2303  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// &
2304  'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2305 
2306  io = min(max(0,il),1)
2307 
2308  if(i1<=0) then
2309  if(iprt>=0) then
2310  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2311  errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2312  call errwrt(errstr)
2313  call errwrt(str)
2314  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2315  call errwrt(' ')
2316  endif
2317  return
2318  elseif(i2<=0) then
2319  if(iprt==-1) ifirst1 = 1
2320  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
2321  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2322  errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2323  call errwrt(errstr)
2324  call errwrt(str)
2325  if(iprt==0 .and. io==1) then
2326  errstr = 'Note: Only the first occurrence of this WARNING ' // &
2327  'message is printed, there may be more. To output all such messages,'
2328  call errwrt(errstr)
2329  errstr = 'modify your application program to add ' // &
2330  '"CALL OPENBF(0,''QUIET'',1)" prior to the first call to a BUFRLIB routine.'
2331  call errwrt(errstr)
2332  endif
2333  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2334  call errwrt(' ')
2335  ifirst1 = 1
2336  endif
2337  return
2338  endif
2339 
2340  ! Parse or recall the input string - write values
2341 
2342  call string(str,lun,i1,io)
2343  call trybump(lun,usr,i1,i2,io,iret)
2344 
2345  if(io==1 .and. iret/=i2) then
2346  write(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS: ",A)') str
2347  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
2348  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret, i2
2349  call bort2(bort_str1,bort_str2)
2350  endif
2351 
2352  return
2353 end subroutine ufbovr
2354 
2392 recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str)
2393 
2394  use bufrlib
2395 
2396  use modv_vars, only: im8b, bmiss, iprt
2397 
2398  use moda_usrint
2399  use moda_msgcwd
2400 
2401  implicit none
2402 
2403  character*(*), intent(in) :: str
2404  character*128 errstr
2405  character*90 cstr
2406 
2407  integer, intent(in) :: lunit, i1, i2, i3
2408  integer, intent(out) :: iret
2409  integer invn(255), nnod, ncon, nods, nodc, ivls, kons, maxevn, my_lunit, my_i1, my_i2, my_i3, i, j, k, lun, il, im, &
2410  ins1, ins2, inc1, inc2, nnvn, nvnwin, lcstr, bort_target_set
2411 
2412  real*8, intent(out) :: usr(i1,i2,i3)
2413 
2414  logical nodgt0
2415 
2416  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2417 
2418  ! Check for I8 integers
2419 
2420  if(im8b) then
2421  im8b=.false.
2422  call x84(lunit,my_lunit,1)
2423  call x84(i1,my_i1,1)
2424  call x84(i2,my_i2,1)
2425  call x84(i3,my_i3,1)
2426  call ufbevn(my_lunit,usr,my_i1,my_i2,my_i3,iret,str)
2427  call x48(iret,iret,1)
2428  im8b=.true.
2429  return
2430  endif
2431 
2432  ! If we're catching bort errors, set a target return location if one doesn't already exist.
2433 
2434  if (bort_target_set() == 1) then
2435  call strsuc(str,cstr,lcstr)
2436  call catch_bort_ufbevn_c(lunit,usr,i1,i2,i3,iret,cstr,lcstr)
2437  call bort_target_unset
2438  return
2439  endif
2440 
2441  maxevn = 0
2442  iret = 0
2443 
2444  ! Check the file status and inode
2445 
2446  call status(lunit,lun,il,im)
2447  if(il==0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2448  if(il>0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2449  if(im==0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2450  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// &
2451  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2452 
2453  if(i1<=0) then
2454  if(iprt>=0) then
2455  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2456  errstr = .LE.'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2457  call errwrt(errstr)
2458  call errwrt(str)
2459  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2460  call errwrt(' ')
2461  endif
2462  return
2463  elseif(i2<=0) then
2464  if(iprt>=0) then
2465  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2466  errstr = .LE.'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2467  call errwrt(errstr)
2468  call errwrt(str)
2469  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2470  call errwrt(' ')
2471  endif
2472  return
2473  elseif(i3<=0) then
2474  if(iprt>=0) then
2475  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2476  errstr = .LE.'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2477  call errwrt(errstr)
2478  call errwrt(str)
2479  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2480  call errwrt(' ')
2481  endif
2482  return
2483  endif
2484 
2485  ! Parse or recall the input string
2486 
2487  call string(str,lun,i1,0)
2488 
2489  ! Initialize usr array
2490  usr(1:i1,1:i2,1:i3) = bmiss
2491 
2492  ! Loop over condition windows
2493 
2494  inc1 = 1
2495  inc2 = 1
2496  outer: do while (.true.)
2497  call conwin(lun,inc1,inc2)
2498  if(nnod==0) then
2499  iret = i2
2500  return
2501  elseif(inc1==0) then
2502  return
2503  else
2504  nodgt0 = .false.
2505  do i=1,nnod
2506  if(nods(i)>0) then
2507  ins2 = inc1
2508  call getwin(nods(i),lun,ins1,ins2)
2509  if(ins1==0) return
2510  nodgt0 = .true.
2511  exit
2512  endif
2513  enddo
2514  if(.not.nodgt0) then
2515  ins1 = inc1
2516  ins2 = inc2
2517  endif
2518  ! Read push down stack data into 3D arrays
2519  inner: do while (.true.)
2520  iret = iret+1
2521  if(iret<=i2) then
2522  do j=1,nnod
2523  if(nods(j)>0) then
2524  nnvn = nvnwin(nods(j),lun,ins1,ins2,invn,i3)
2525  maxevn = max(nnvn,maxevn)
2526  do k=1,nnvn
2527  usr(j,iret,k) = val(invn(k),lun)
2528  enddo
2529  endif
2530  enddo
2531  endif
2532  ! Decide what to do next
2533  call nxtwin(lun,ins1,ins2)
2534  if(ins1<=0 .or. ins1>=inc2) exit inner
2535  enddo inner
2536  if(ncon<=0) exit outer
2537  endif
2538  enddo outer
2539 
2540  if(iret==0) then
2541  if(iprt>=1) then
2542  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2543  errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2544  call errwrt(errstr)
2545  call errwrt(str)
2546  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2547  call errwrt(' ')
2548  endif
2549  endif
2550 
2551  return
2552 end subroutine ufbevn
2553 
2587 recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str)
2588 
2589  use bufrlib
2590 
2591  use modv_vars, only: im8b
2592 
2593  use moda_msgcwd
2594  use moda_bitbuf
2595 
2596  implicit none
2597 
2598  integer, intent(in) :: lunit, imsg, isub, i1, i2
2599  integer, intent(out) :: iret
2600  integer my_lunit, my_imsg, my_isub, my_i1, my_i2, lun, il, im, jdate, jret, i, lcstr, bort_target_set
2601 
2602  character*(*), intent(in) :: str
2603  character*128 bort_str
2604  character*90 cstr
2605  character*8 subset
2606 
2607  real*8, intent(out) :: usr(i1,i2)
2608 
2609  logical openit
2610 
2611  ! Check for I8 integers
2612  if(im8b) then
2613  im8b=.false.
2614  call x84(lunit,my_lunit,1)
2615  call x84(imsg,my_imsg,1)
2616  call x84(isub,my_isub,1)
2617  call x84(i1,my_i1,1)
2618  call x84(i2,my_i2,1)
2619  call ufbinx(my_lunit,my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
2620  call x48(iret,iret,1)
2621  im8b=.true.
2622  return
2623  endif
2624 
2625  ! If we're catching bort errors, set a target return location if one doesn't already exist.
2626  if (bort_target_set() == 1) then
2627  call strsuc(str,cstr,lcstr)
2628  call catch_bort_ufbinx_c(lunit,imsg,isub,usr,i1,i2,iret,cstr,lcstr)
2629  call bort_target_unset
2630  return
2631  endif
2632 
2633  call status(lunit,lun,il,im)
2634  openit = il==0
2635 
2636  if(openit) then
2637  ! Open BUFR file connected to unit lunit if it isn't already open
2638  call openbf(lunit,'INX',lunit)
2639  else
2640  ! If BUFR file already opened, save position and rewind to first data message
2641  call rewnbf(lunit,0)
2642  endif
2643 
2644  ! Skip to the requested message
2645  do i=1,imsg
2646  call readmg(lunit,subset,jdate,jret)
2647  if(jret<0) then
2648  write(bort_str,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// &
2649  'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') imsg, lunit
2650  call bort(bort_str)
2651  endif
2652  enddo
2653 
2654  ! Position at the requested subset
2655  do i=1,isub
2656  call readsb(lunit,jret)
2657  if(jret/=0) then
2658  write(bort_str,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// &
2659  'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub, imsg, lunit
2660  call bort(bort_str)
2661  endif
2662  enddo
2663 
2664  ! Read the requested data values
2665  call ufbint(lunit,usr,i1,i2,iret,str)
2666 
2667  if(openit) then
2668  ! Close BUFR file if it was opened here
2669  call closbf(lunit)
2670  else
2671  ! Restore BUFR file to its previous status and position
2672  call rewnbf(lunit,1)
2673  endif
2674 
2675  return
2676 end subroutine ufbinx
2677 
2692 recursive subroutine ufbget(lunit,tab,i1,iret,str)
2693 
2694  use bufrlib
2695 
2696  use modv_vars, only: im8b, bmiss
2697 
2698  use moda_usrint
2699  use moda_usrbit
2700  use moda_msgcwd
2701  use moda_bitbuf
2702  use moda_tables
2703 
2704  implicit none
2705 
2706  integer*8 ival
2707  integer, intent(in) :: lunit, i1
2708  integer, intent(out) :: iret
2709  integer nnod, ncon, nods, nodc, ivls, kons, my_lunit, my_i1, lun, il, im, i, n, node, nbmp, kbit, invn, invwin, &
2710  lcstr, bort_target_set
2711 
2712  character*(*), intent(in) :: str
2713  character*90 cstr
2714  character*8 cval
2715 
2716  real*8, intent(out) :: tab(i1)
2717  real*8 rval, ups
2718 
2719  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2720 
2721  equivalence(cval,rval)
2722 
2723  ! Check for I8 integers
2724 
2725  if(im8b) then
2726  im8b=.false.
2727  call x84(lunit,my_lunit,1)
2728  call x84(i1,my_i1,1)
2729  call ufbget(my_lunit,tab,my_i1,iret,str)
2730  call x48(iret,iret,1)
2731  im8b=.true.
2732  return
2733  endif
2734 
2735  ! If we're catching bort errors, set a target return location if one doesn't already exist.
2736  if (bort_target_set() == 1) then
2737  call strsuc(str,cstr,lcstr)
2738  call catch_bort_ufbget_c(lunit,tab,i1,iret,cstr,lcstr)
2739  call bort_target_unset
2740  return
2741  endif
2742 
2743  iret = 0
2744  tab(1:i1) = bmiss
2745 
2746  ! Make sure a file/message is open for input
2747 
2748  call status(lunit,lun,il,im)
2749  if(il==0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2750  if(il>0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2751  if(im==0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2752 
2753  ! See if there's another subset in the message
2754 
2755  if(nsub(lun)==msub(lun)) then
2756  iret = -1
2757  return
2758  endif
2759 
2760  ! Parse the string
2761 
2762  call string(str,lun,i1,0)
2763 
2764  ! Expand the template for this subset as little as possible
2765 
2766  n = 1
2767  nbit(n) = 0
2768  mbit(n) = mbyt(lun)*8 + 16
2769  call usrtpl(lun,n,n)
2770  do n=n+1,nval(lun)
2771  node = inv(n,lun)
2772  nbit(n) = ibt(node)
2773  mbit(n) = mbit(n-1)+nbit(n-1)
2774  if(node==nods(nnod)) then
2775  nval(lun) = n
2776  exit
2777  elseif(itp(node)==1) then
2778  call upb8(ival,nbit(n),mbit(n),mbay(1,lun))
2779  nbmp=int(ival)
2780  call usrtpl(lun,n,nbmp)
2781  endif
2782  enddo
2783 
2784  ! Unpack only the nodes found in the string
2785 
2786  do i=1,nnod
2787  node = nods(i)
2788  invn = invwin(node,lun,1,nval(lun))
2789  if(invn>0) then
2790  call upb8(ival,nbit(invn),mbit(invn),mbay(1,lun))
2791  if(itp(node)==1) then
2792  tab(i) = ival
2793  elseif(itp(node)==2) then
2794  if(ival<2_8**(ibt(node))-1) tab(i) = ups(ival,node)
2795  elseif(itp(node)==3) then
2796  cval = ' '
2797  kbit = mbit(invn)
2798  call upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
2799  tab(i) = rval
2800  endif
2801  else
2802  tab(i) = bmiss
2803  endif
2804  enddo
2805 
2806  return
2807 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
bort_target_unset
subroutine bort_target_unset
Clear any existing bort target.
Definition: borts.F90:180
bort2
recursive subroutine bort2(str1, str2)
Log two error messages, then either return to or abort the application program.
Definition: borts.F90:48
bort_target_set
integer function bort_target_set()
Sets a new bort target, if bort catching is enabled and such a target doesn't already exist.
Definition: borts.F90:160
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:332
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_drfini_c
Definition: bufrlib.F90:622
bufrlib::catch_bort_getvalnb_c
Definition: bufrlib.F90:1597
bufrlib::catch_bort_readlc_c
Definition: bufrlib.F90:664
bufrlib::catch_bort_setvalnb_c
Definition: bufrlib.F90:1573
bufrlib::catch_bort_ufbevn_c
Definition: bufrlib.F90:602
bufrlib::catch_bort_ufbget_c
Definition: bufrlib.F90:1636
bufrlib::catch_bort_ufbint_c
Definition: bufrlib.F90:535
bufrlib::catch_bort_ufbinx_c
Definition: bufrlib.F90:1660
bufrlib::catch_bort_ufbovr_c
Definition: bufrlib.F90:1682
bufrlib::catch_bort_ufbrep_c
Definition: bufrlib.F90:557
bufrlib::catch_bort_ufbseq_c
Definition: bufrlib.F90:643
bufrlib::catch_bort_ufbstp_c
Definition: bufrlib.F90:579
bufrlib::catch_bort_writlc_c
Definition: bufrlib.F90:684
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_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:335
rewnbf
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
Definition: openclosebf.F90:715
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:164
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:409
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:1242
usrtpl
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
Definition: readwritesb.F90:1347
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:135
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:2588
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:1916
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:1432
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:1779
hold4wlc
recursive subroutine hold4wlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:2101
ufbovr
recursive subroutine ufbovr(lunit, usr, i1, i2, iret, str)
Overwrite one or more data values within a data subset.
Definition: readwriteval.F90:2250
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:702
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:2000
trybump
subroutine trybump(lun, usr, i1, i2, io, iret)
Try to expand a delayed replication sequence.
Definition: readwriteval.F90:2190
drfini
recursive subroutine drfini(lunit, mdrf, ndrf, drftag)
Explicitly initialize delayed replication factors and allocate a corresponding amount of space within...
Definition: readwriteval.F90:1703
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:1193
readlc
recursive subroutine readlc(lunit, chr, str)
Read a long character string (greater than 8 bytes) from a data subset.
Definition: readwriteval.F90:448
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:2393
writlc
recursive subroutine writlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:230
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:2693
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:962
iupbs3
recursive integer function iupbs3(mbay, s3mnem)
Read a specified value from within Section 3 of a BUFR message.
Definition: s013vals.F90:344
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