NCEPLIBS-bufr  12.1.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 
199 recursive subroutine writlc(lunit,chr,str)
200 
201  use modv_vars, only: im8b, mxlcc
202 
203  use moda_usrint
204  use moda_msgcwd
205  use moda_bitbuf
206  use moda_tables
207  use moda_comprs
208 
209  implicit none
210 
211  integer, intent(in) :: lunit
212  integer my_lunit, maxtg, iprt, lun, il, im, ntg, nnod, kon, ii, n, node, ioid, ival, mbit, nbit, nbmp, nchr, nbyt, nsubs, &
213  itagct, len0, len1, len2, len3, l4, l5, mbyte, iupbs3
214 
215  character*(*), intent(in) :: chr, str
216  character*128 bort_str, errstr
217  character*10 ctag
218  character*14 tgs(10)
219 
220  real roid
221 
222  common /quiet/ iprt
223 
224  data maxtg /10/
225 
226  ! Check for I8 integers
227  if(im8b) then
228  im8b=.false.
229  call x84(lunit,my_lunit,1)
230  call writlc(my_lunit,chr,str)
231  im8b=.true.
232  return
233  endiF
234 
235  ! Check the file status.
236  call status(lunit,lun,il,im)
237  if(il==0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
238  if(il<0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
239  if(im==0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
240 
241  ! Check for tags (mnemonics) in input string (there can only be one)
242  call parstr(str,tgs,maxtg,ntg,' ',.true.)
243  if(ntg>1) then
244  write(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// &
245  ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4,")")') str,ntg
246  call bort(bort_str)
247  endif
248 
249  ! Check if a specific occurrence of the input string was requested; if not, then the default is to write the first occurrence
250  call parutg(lun,1,tgs(1),nnod,kon,roid)
251  if(kon==6) then
252  ioid=nint(roid)
253  if(ioid<=0) ioid = 1
254  ctag = ' '
255  ii = 1
256  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
257  ctag(ii:ii)=tgs(1)(ii:ii)
258  ii = ii + 1
259  enddo
260  else
261  ioid = 1
262  ctag = tgs(1)(1:10)
263  endif
264 
265  if(iupbs3(mbay(1,lun),'ICMP')>0) then
266  ! The message is compressed
267  n = 1
268  itagct = 0
269  call usrtpl(lun,n,n)
270  do while (n+1<=nval(lun))
271  n = n+1
272  node = inv(n,lun)
273  if(itp(node)==1) then
274  nbmp=int(matx(n,ncol))
275  call usrtpl(lun,n,nbmp)
276  elseif(ctag==tag(node)) then
277  itagct = itagct + 1
278  if(itagct==ioid) then
279  if(itp(node)/=3) then
280  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
281  ctag,typ(node)
282  call bort(bort_str)
283  endif
284  catx(n,ncol)=' '
285  ! The following statement enforces a limit of mxlcc characters per long character string when writing
286  ! compressed messages. This limit keeps the array catx to a reasonable dimensioned size.
287  nchr=min(mxlcc,ibt(node)/8)
288  catx(n,ncol)=chr(1:nchr)
289  call usrtpl(lun,1,1)
290  return
291  endif
292  endif
293  enddo
294  else
295  ! The message is not compressed. Locate the beginning of the data (Section 4) in the message.
296  call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
297  mbyte = len0 + len1 + len2 + len3 + 4
298  nsubs = 1
299  ! Find the most recently written subset in the message.
300  do while(nsubs<nsub(lun))
301  ibit = mbyte*8
302  call upb(nbyt,16,mbay(1,lun),ibit)
303  mbyte = mbyte + nbyt
304  nsubs = nsubs + 1
305  enddo
306  if(nsubs/=nsub(lun)) then
307  if(iprt>=0) then
308  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
309  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // &
310  ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
311  call errwrt(errstr)
312  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
313  call errwrt(' ')
314  endif
315  return
316  endif
317  ! Locate and write the long character string within this subset.
318  itagct = 0
319  mbit = mbyte*8 + 16
320  nbit = 0
321  n = 1
322  call usrtpl(lun,n,n)
323  do while (n+1<=nval(lun))
324  n = n+1
325  node = inv(n,lun)
326  mbit = mbit+nbit
327  nbit = ibt(node)
328  if(itp(node)==1) then
329  call upbb(ival,nbit,mbit,mbay(1,lun))
330  call usrtpl(lun,n,ival)
331  elseif(ctag==tag(node)) then
332  itagct = itagct + 1
333  if(itagct==ioid) then
334  if(itp(node)/=3) then
335  write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
336  ctag,typ(node)
337  call bort(bort_str)
338  endif
339  nchr = nbit/8
340  ibit = mbit
341  do ii=1,nchr
342  call pkc(' ',1,mbay(1,lun),ibit)
343  enddo
344  call pkc(chr,nchr,mbay(1,lun),mbit)
345  call usrtpl(lun,1,1)
346  return
347  endif
348  endif
349  enddo
350  endif
351 
352  ! If we made it here, then we couldn't find the requested string.
353  if(iprt>=0) then
354  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
355  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE ' // &
356  'SUBSET DEFINITION'
357  call errwrt(errstr)
358  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
359  call errwrt(errstr)
360  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
361  call errwrt(' ')
362  endif
363 
364  return
365 end subroutine writlc
366 
406 recursive subroutine readlc(lunit,chr,str)
407 
408  use modv_vars, only: im8b
409 
410  use moda_usrint
411  use moda_usrbit
412  use moda_unptyp
413  use moda_bitbuf
414  use moda_tables
415  use moda_rlccmn
416 
417  implicit none
418 
419  integer, intent(in) :: lunit
420  integer my_lunit, maxtg, iprt, lchr, lun, il, im, ntg, nnod, kon, ii, n, nod, ioid, itagct, nchr, kbit
421 
422  character*(*), intent(in) :: str
423  character*(*), intent(out) :: chr
424 
425  character*128 bort_str, errstr
426  character*10 ctag
427  character*14 tgs(10)
428 
429  real roid
430 
431  common /quiet/ iprt
432 
433  data maxtg /10/
434 
435  ! Check for I8 integers
436  if(im8b) then
437  im8b=.false.
438  call x84(lunit,my_lunit,1)
439  call readlc(my_lunit,chr,str)
440  im8b=.true.
441  return
442  endif
443 
444  chr = ' '
445  lchr=len(chr)
446 
447  ! Check the file status
448  call status(lunit,lun,il,im)
449  if(il==0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
450  if(il>0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
451  if(im==0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
452 
453  ! Check for tags (mnemonics) in input string (there can only be one)
454  call parstr(str,tgs,maxtg,ntg,' ',.true.)
455  if(ntg>1) then
456  write(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// &
457  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntg
458  call bort(bort_str)
459  endif
460 
461  ! Check if a specific occurrence of the input string was requested; if not, then the default is to return the
462  ! first occurrence.
463  call parutg(lun,0,tgs(1),nnod,kon,roid)
464  if(kon==6) then
465  ioid=nint(roid)
466  if(ioid<=0) ioid = 1
467  ctag = ' '
468  ii = 1
469  do while((ii<=10).and.(tgs(1)(ii:ii)/='#'))
470  ctag(ii:ii)=tgs(1)(ii:ii)
471  ii = ii + 1
472  enddo
473  else
474  ioid = 1
475  ctag = tgs(1)(1:10)
476  endif
477 
478  ! Locate and decode the long character string
479  if(msgunp(lun)==0.or.msgunp(lun)==1) then
480  ! The message is not compressed
481  itagct = 0
482  do n=1,nval(lun)
483  nod = inv(n,lun)
484  if(ctag==tag(nod)) then
485  itagct = itagct + 1
486  if(itagct==ioid) then
487  if(itp(nod)/=3) then
488  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// &
489  'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
490  call bort(bort_str)
491  endif
492  nchr = nbit(n)/8
493  if(nchr>lchr) then
494  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
495  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
496  call bort(bort_str)
497  endif
498  kbit = mbit(n)
499  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
500  return
501  endif
502  endif
503  enddo
504  else
505  ! The message is compressed
506  if(nrst>0) then
507  itagct = 0
508  do ii=1,nrst
509  if(ctag==crtag(ii)) then
510  itagct = itagct + 1
511  if(itagct==ioid) then
512  nchr = irnch(ii)
513  if(nchr>lchr) then
514  write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// &
515  'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
516  call bort(bort_str)
517  endif
518  kbit = irbit(ii)
519  call upc(chr,nchr,mbay(1,lun),kbit,.true.)
520  return
521  endif
522  endif
523  enddo
524  endif
525  endif
526 
527  ! If we made it here, then we couldn't find the requested string.
528  if(iprt>=0) then
529  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
530  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // &
531  ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT'
532  call errwrt(errstr)
533  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
534  call errwrt(' ')
535  endif
536  do ii=1,lchr
537  call ipkm(chr(ii:ii),1,255)
538  enddo
539 
540  return
541 end subroutine readlc
542 
645 recursive subroutine ufbint(lunin,usr,i1,i2,iret,str)
646 
647  use modv_vars, only: im8b, bmiss
648 
649  use moda_usrint
650  use moda_msgcwd
651 
652  implicit none
653 
654  character*(*), intent(in) :: str
655  character*128 bort_str1, bort_str2, errstr
656 
657  real*8, intent(inout) :: usr(i1,i2)
658 
659  integer, intent(in) :: lunin, i1, i2
660  integer, intent(out) :: iret
661  integer iprt, nnod, ncon, nods, nodc, ivls, kons, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j
662 
663  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
664  common /quiet/ iprt
665 
666  data ifirst1 /0/, ifirst2 /0/
667 
668  save ifirst1, ifirst2
669 
670  ! Check for I8 integers
671  if(im8b) then
672  im8b=.false.
673  call x84(lunin,my_lunin,1)
674  call x84(i1,my_i1,1)
675  call x84(i2,my_i2,1)
676  call ufbint(my_lunin,usr,my_i1,my_i2,iret,str)
677  call x48(iret,iret,1)
678  im8b=.true.
679  return
680  endif
681 
682  iret = 0
683 
684  ! Check the file status and inode
685  lunit = abs(lunin)
686  call status(lunit,lun,il,im)
687  if(il==0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN')
688  if(im==0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
689  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
690  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
691 
692  io = min(max(0,il),1)
693  if(lunit/=lunin) io = 0
694 
695  if(i1<=0) then
696  if(iprt>=0) then
697  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
698  errstr = .LE.'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
699  call errwrt(errstr)
700  call errwrt(str)
701  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
702  call errwrt(' ')
703  endif
704  return
705  elseif(i2<=0) then
706  if(iprt==-1) ifirst1 = 1
707  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
708  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
709  errstr = .LE.'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
710  call errwrt(errstr)
711  call errwrt(str)
712  if(iprt==0 .and. io==1) then
713  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
714  'all such messages,'
715  call errwrt(errstr)
716  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
717  'BUFRLIB routine.'
718  call errwrt(errstr)
719  endif
720  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
721  call errwrt(' ')
722  ifirst1 = 1
723  endif
724  return
725  endif
726 
727  ! Parse or recall the input string
728  call string(str,lun,i1,io)
729 
730  ! Initialize usr array preceeding an input operation
731  if(io==0) then
732  do j=1,i2
733  do i=1,i1
734  usr(i,j) = bmiss
735  enddo
736  enddo
737  endif
738 
739  ! Call the mnemonic reader/writer
740  call ufbrw(lun,usr,i1,i2,io,iret)
741 
742  ! If incomplete write try to initialize replication sequence or return
743  if(io==1 .and. iret/=i2 .and. iret>=0) then
744  call trybump(lun,usr,i1,i2,io,iret)
745  if(iret/=i2) then
746  write(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ",A)') str
747  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
748  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
749  call bort2(bort_str1,bort_str2)
750  endif
751  elseif(iret==-1) then
752  iret = 0
753  endif
754 
755  if(iret==0) then
756  if(io==0) then
757  if(iprt>=1) then
758  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
759  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
760  call errwrt(errstr)
761  call errwrt(str)
762  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
763  call errwrt(' ')
764  endif
765  else
766  if(iprt==-1) ifirst2 = 1
767  if(ifirst2==0 .or. iprt>=1) then
768  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
769  errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
770  call errwrt(errstr)
771  call errwrt(str)
772  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
773  if(iprt==0) then
774  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
775  'all such messages,'
776  call errwrt(errstr)
777  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // &
778  'to a BUFRLIB routine.'
779  call errwrt(errstr)
780  endif
781  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
782  call errwrt(' ')
783  ifirst2 = 1
784  endif
785  endif
786  endif
787 
788  return
789 end subroutine ufbint
790 
885 recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str)
886 
887  use modv_vars, only: im8b, bmiss, iac
888 
889  use moda_usrint
890  use moda_msgcwd
891 
892  implicit none
893 
894  character*(*), intent(in) :: str
895  character*128 bort_str1, bort_str2, errstr
896 
897  real*8, intent(inout) :: usr(i1,i2)
898 
899  integer, intent(in) :: lunin, i1, i2
900  integer, intent(out) :: iret
901  integer iprt, ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, iac_prev, i, j
902 
903  common /quiet/ iprt
904 
905  data ifirst1 /0/
906 
907  save ifirst1
908 
909  ! Check for I8 integers
910  if(im8b) then
911  im8b=.false.
912  call x84(lunin,my_lunin,1)
913  call x84(i1,my_i1,1)
914  call x84(i2,my_i2,1)
915  call ufbrep(my_lunin,usr,my_i1,my_i2,iret,str)
916  call x48(iret,iret,1)
917  im8b=.true.
918  return
919  endif
920 
921  iret = 0
922 
923  ! Check the file status and inode
924  lunit = abs(lunin)
925  call status(lunit,lun,il,im)
926  if(il==0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
927  if(im==0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
928  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // &
929  'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
930 
931  io = min(max(0,il),1)
932  if(lunit/=lunin) io = 0
933 
934  if(i1<=0) then
935  if(iprt>=0) then
936  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
937  errstr = .LE.'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
938  call errwrt(errstr)
939  call errwrt(str)
940  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
941  call errwrt(' ')
942  endif
943  return
944  elseif(i2<=0) then
945  if(iprt==-1) ifirst1 = 1
946  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
947  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
948  errstr = .LE.'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
949  call errwrt(errstr)
950  call errwrt(str)
951  if(iprt==0 .and. io==1) then
952  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
953  'all such messages,'
954  call errwrt(errstr)
955  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
956  'BUFRLIB routine.'
957  call errwrt(errstr)
958  endif
959  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
960  call errwrt(' ')
961  ifirst1 = 1
962  endif
963  return
964  endif
965 
966  ! Initialize usr array preceeding an input operation
967  if(io==0) then
968  do j=1,i2
969  do i=1,i1
970  usr(i,j) = bmiss
971  enddo
972  enddo
973  endif
974 
975  ! Parse or recall the input string
976  iac_prev = iac
977  iac = 1
978  call string(str,lun,i1,io)
979  iac = iac_prev
980 
981  ! Call the mnemonic reader/writer
982  call ufbrp(lun,usr,i1,i2,io,iret)
983 
984  if(io==1 .and. iret<i2) then
985  write(bort_str1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ",A)') str
986  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
987  'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
988  call bort2(bort_str1,bort_str2)
989  endif
990 
991  if(iret==0 .and. io==0 .and. iprt>=1) then
992  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
993  errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
994  call errwrt(errstr)
995  call errwrt(str)
996  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
997  call errwrt(' ')
998  endif
999 
1000  return
1001 end subroutine ufbrep
1002 
1098 recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str)
1099 
1100  use modv_vars, only: im8b, bmiss
1101 
1102  use moda_usrint
1103  use moda_msgcwd
1104 
1105  implicit none
1106 
1107  character*(*), intent(in) :: str
1108  character*128 bort_str1, bort_str2, errstr
1109 
1110  real*8, intent(inout) :: usr(i1,i2)
1111 
1112  integer, intent(in) :: lunin, i1, i2
1113  integer, intent(out) :: iret
1114  integer iprt, ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j
1115 
1116  common /quiet/ iprt
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) then
1181  do j=1,i2
1182  do i=1,i1
1183  usr(i,j) = bmiss
1184  enddo
1185  enddo
1186  endif
1187 
1188  ! Parse or recall the input string
1189  call string(str,lun,i1,io)
1190 
1191  ! Call the mnemonic reader/writer
1192  call ufbsp(lun,usr,i1,i2,io,iret)
1193 
1194  if(io==1 .and. iret/=i2) then
1195  write(bort_str1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ",A)') str
1196  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
1197  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
1198  call bort2(bort_str1,bort_str2)
1199  endif
1200 
1201  if(iret==0 .and. io==0 .and. iprt>=1) then
1202  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1203  errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1204  call errwrt(errstr)
1205  call errwrt(str)
1206  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1207  call errwrt(' ')
1208  endif
1209 
1210  return
1211 end subroutine ufbstp
1212 
1319 recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str)
1320 
1321  use modv_vars, only: im8b, bmiss
1322 
1323  use moda_usrint
1324  use moda_msgcwd
1325  use moda_tables
1326 
1327  implicit none
1328 
1329  integer, intent(in) :: lunin, i1, i2
1330  integer, intent(out) :: iret
1331  integer, parameter :: mtag = 10
1332  integer iprt, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j, ntag, node, nods, ins1, ins2, insx, &
1333  nseq, isq, ityp, invwin, invtag
1334 
1335  real*8, intent(inout) :: usr(i1,i2)
1336 
1337  character*(*), intent(in) :: str
1338  character*156 bort_str
1339  character*128 errstr
1340  character*10 tags(mtag)
1341 
1342  common /quiet/ iprt
1343 
1344  data ifirst1 /0/, ifirst2 /0/
1345 
1346  save ifirst1, ifirst2
1347 
1348  ! Check for I8 integers
1349  if(im8b) then
1350  im8b=.false.
1351  call x84(lunin,my_lunin,1)
1352  call x84(i1,my_i1,1)
1353  call x84(i2,my_i2,1)
1354  call ufbseq(my_lunin,usr,my_i1,my_i2,iret,str)
1355  call x48(iret,iret,1)
1356  im8b=.true.
1357  return
1358  endif
1359 
1360  iret = 0
1361 
1362  ! Check the file status and inode
1363  lunit = abs(lunin)
1364  call status(lunit,lun,il,im)
1365  if(il==0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN')
1366  if(im==0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE')
1367 
1368  io = min(max(0,il),1)
1369  if(lunit/=lunin) io = 0
1370 
1371  if(i1<=0) then
1372  if(iprt>=0) then
1373  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1374  errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1375  call errwrt(errstr)
1376  call errwrt(str)
1377  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1378  call errwrt(' ')
1379  endif
1380  return
1381  elseif(i2<=0) then
1382  if(iprt==-1) ifirst1 = 1
1383  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
1384  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1385  errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1386  call errwrt(errstr)
1387  call errwrt(str)
1388  if(iprt==0 .and. io==1) then
1389  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1390  'all such messages,'
1391  call errwrt(errstr)
1392  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1393  'BUFRLIB routine.'
1394  call errwrt(errstr)
1395  endif
1396  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1397  call errwrt(' ')
1398  ifirst1 = 1
1399  endif
1400  return
1401  endif
1402 
1403  ! Check for valid sequence and sequence length arguments
1404  call parstr(str,tags,mtag,ntag,' ',.true.)
1405  if(ntag<1) then
1406  write(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") DOES NOT CONTAIN ANY MNEMONICS!!")') str
1407  call bort(bort_str)
1408  endif
1409  if(ntag>1) then
1410  write(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// &
1411  'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntag
1412  call bort(bort_str)
1413  endif
1414  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// &
1415  'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
1416 
1417  ! Initialize usr array preceeding an input operation
1418  if(io==0) then
1419  do j=1,i2
1420  do i=1,i1
1421  usr(i,j) = bmiss
1422  enddo
1423  enddo
1424  endif
1425 
1426  ! Find the parameters of the specified sequence
1427  outer: do node=inode(lun),isc(inode(lun))
1428  if(str==tag(node)) then
1429  if(typ(node)=='SEQ' .or. typ(node)=='RPC') then
1430  ins1 = 1
1431  do while (.true.)
1432  ins1 = invtag(node,lun,ins1,nval(lun))
1433  if(ins1==0) exit outer
1434  if(typ(node)/='RPC' .or. val(ins1,lun)/=0.) exit
1435  ins1 = ins1+1
1436  enddo
1437  ins2 = invtag(node,lun,ins1+1,nval(lun))
1438  if(ins2==0) ins2 = 10e5
1439  nods = node
1440  do while(link(nods)==0 .and. jmpb(nods)>0)
1441  nods = jmpb(nods)
1442  enddo
1443  if(link(nods)==0) then
1444  insx = nval(lun)
1445  elseif(link(nods)>0) then
1446  insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
1447  endif
1448  ins2 = min(ins2,insx)
1449  elseif(typ(node)=='SUB') then
1450  ins1 = 1
1451  ins2 = nval(lun)
1452  else
1453  write(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// &
1454  'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
1455  call bort(bort_str)
1456  endif
1457  nseq = 0
1458  do isq=ins1,ins2
1459  ityp = itp(inv(isq,lun))
1460  if(ityp>1) nseq = nseq+1
1461  enddo
1462  if(nseq>i1) then
1463  write(bort_str,.GT.'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A," CONSISTS OF",I4," TABLE B MNEM., THE MAX. '// &
1464  'SPECIFIED IN (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
1465  call bort(bort_str)
1466  endif
1467  ! Frame a section of the buffer - return when no frame
1468  inner: do while (.true.)
1469  ins1 = invtag(node,lun,ins1,nval(lun))
1470  if(ins1>nval(lun)) exit outer
1471  if(ins1>0) then
1472  if(typ(node)=='RPC' .and. val(ins1,lun)==0.) then
1473  ins1 = ins1+1
1474  cycle
1475  elseif(io==0 .and. iret+1>i2) then
1476  if(iprt>=0) then
1477  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1478  write ( unit=errstr, fmt='(A,I5,A,A,A)' ) 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2, &
1479  ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1), ' WERE READ'
1480  call errwrt(errstr)
1481  call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
1482  call errwrt(' ')
1483  endif
1484  exit outer
1485  endif
1486  elseif(ins1==0) then
1487  if(io==1 .and. iret<i2) then
1488  write(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'.LT.' WRITTEN (",I5,") NO. REQUESTED (",I5,") - '// &
1489  'INCOMPLETE WRITE (INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
1490  call bort(bort_str)
1491  endif
1492  else
1493  write(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE ZERO, HERE IT IS",I4," - INPUT MNEMONIC '// &
1494  'IS ",A)') ins1,tags(1)
1495  call bort(bort_str)
1496  endif
1497  if(ins1==0 .or. iret==i2) exit outer
1498  iret = iret+1
1499  ins1 = ins1+1
1500  ! Read/write user values
1501  j = ins1
1502  do i=1,nseq
1503  do while(itp(inv(j,lun))<2)
1504  j = j+1
1505  enddo
1506  if(io==0) usr(i,iret) = val(j,lun)
1507  if(io==1) val(j,lun) = usr(i,iret)
1508  j = j+1
1509  enddo
1510  enddo inner
1511  endif
1512  enddo outer
1513 
1514  if(iret==0) then
1515  if(io==0) then
1516  if(iprt>=1) then
1517  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1518  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1519  call errwrt(errstr)
1520  call errwrt(str)
1521  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1522  call errwrt(' ')
1523  endif
1524  else
1525  if(iprt==-1) ifirst2 = 1
1526  if(ifirst2==0 .or. iprt>=1) then
1527  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1528  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
1529  call errwrt(errstr)
1530  call errwrt(str)
1531  call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
1532  if(iprt==0) then
1533  errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
1534  'all such messages,'
1535  call errwrt(errstr)
1536  errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
1537  'BUFRLIB routine.'
1538  call errwrt(errstr)
1539  endif
1540  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1541  call errwrt(' ')
1542  ifirst2 = 1
1543  endif
1544  endif
1545  endif
1546 
1547  return
1548 end subroutine ufbseq
1549 
1587 recursive subroutine drfini(lunit,mdrf,ndrf,drftag)
1588 
1589  use modv_vars, only: im8b
1590 
1591  use moda_usrint
1592  use moda_tables
1593 
1594  implicit none
1595 
1596  character*(*), intent(in) :: drftag
1597 
1598  integer, intent(in) :: mdrf(*), lunit, ndrf
1599  integer, parameter :: mxdrf = 2000
1600  integer my_mdrf(mxdrf), my_lunit, my_ndrf, mdrf4, ii, lun, il, im, m, n, node
1601 
1602  ! Check for I8 integers
1603  if(im8b) then
1604  im8b=.false.
1605  call x84(lunit,my_lunit,1)
1606  do ii = 1, ndrf
1607  call x84(mdrf(ii),mdrf4,1)
1608  my_mdrf(ii) = mdrf4
1609  enddo
1610  call x84(ndrf,my_ndrf,1)
1611  call drfini(my_lunit,my_mdrf,my_ndrf,drftag)
1612  im8b=.true.
1613  return
1614  endif
1615 
1616  call status(lunit,lun,il,im)
1617  ! Conform the template to the delayed replication factors
1618  m = 0
1619  n = 0
1620  do n = n+1, nval(lun)
1621  node = inv(n,lun)
1622  if(itp(node)==1 .and. tag(node)==drftag) then
1623  m = m+1
1624  call usrtpl(lun,n,mdrf(m))
1625  endif
1626  enddo
1627 
1628  return
1629 end subroutine drfini
1630 
1654 subroutine ufbrw(lun,usr,i1,i2,io,iret)
1655 
1656  use modv_vars, only: bmiss
1657 
1658  use moda_usrint
1659  use moda_tables
1660  use moda_msgcwd
1661 
1662  implicit none
1663 
1664  integer, intent(in) :: lun, i1, i2, io
1665  integer, intent(out) :: iret
1666  integer iprt, nnod, ncon, nods, nodc, ivls, kons, inc1, inc2, ins1, ins2, invn, i, j, invwin, ibfms, lstjpb
1667 
1668  real*8, intent(inout) :: usr(i1,i2)
1669 
1670  character*128 errstr
1671  character*10 tagstr, subset
1672 
1673  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1674  common /quiet/ iprt
1675 
1676  subset=tag(inode(lun))
1677  iret = 0
1678 
1679  ! Loop over condition windows
1680  inc1 = 1
1681  inc2 = 1
1682  outer: do while (.true.)
1683  call conwin(lun,inc1,inc2)
1684  if(nnod==0) then
1685  iret = i2
1686  return
1687  elseif(inc1==0) then
1688  return
1689  else
1690  do j=1,nnod
1691  if(nods(j)>0) then
1692  ins2 = inc1
1693  call getwin(nods(j),lun,ins1,ins2)
1694  if(ins1==0) return
1695  do while (.true.)
1696  ! Loop over store nodes
1697  iret = iret+1
1698  if(iprt>=2) then
1699  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1700  call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//subset)
1701  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1702  do i=1,nnod
1703  if(io==0) tagstr=tag(nods(i))(1:8)//' R'
1704  if(io==1) tagstr=tag(nods(i))(1:8)//' W'
1705  invn = invwin(nods(i),lun,ins1,ins2)
1706  if(invn==0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn)
1707  write(errstr,'("LEV=",I5,1X,A,3I7)') iret,tagstr,ins1,invn,ins2
1708  call errwrt(errstr)
1709  enddo
1710  endif
1711  ! Write user values
1712  if(io==1 .and. iret<=i2) then
1713  do i=1,nnod
1714  if(nods(i)>0) then
1715  if(ibfms(usr(i,iret))==0) then
1716  invn = invwin(nods(i),lun,ins1,ins2)
1717  if(invn==0) then
1718  call drstpl(nods(i),lun,ins1,ins2,invn)
1719  if(invn==0) then
1720  iret = 0
1721  return
1722  endif
1723  call newwin(lun,inc1,inc2)
1724  val(invn,lun) = usr(i,iret)
1725  elseif(lstjpb(nods(i),lun,'RPS')==0) then
1726  val(invn,lun) = usr(i,iret)
1727  elseif(ibfms(val(invn,lun))/=0) then
1728  val(invn,lun) = usr(i,iret)
1729  else
1730  call drstpl(nods(i),lun,ins1,ins2,invn)
1731  if(invn==0) then
1732  iret = 0
1733  return
1734  endif
1735  call newwin(lun,inc1,inc2)
1736  val(invn,lun) = usr(i,iret)
1737  endif
1738  endif
1739  endif
1740  enddo
1741  endif
1742  ! Read user values
1743  if(io==0 .and. iret<=i2) then
1744  do i=1,nnod
1745  usr(i,iret) = bmiss
1746  if(nods(i)>0) then
1747  invn = invwin(nods(i),lun,ins1,ins2)
1748  if(invn>0) usr(i,iret) = val(invn,lun)
1749  endif
1750  enddo
1751  endif
1752  ! Decide what to do next
1753  if(io==1.and.iret==i2) return
1754  call nxtwin(lun,ins1,ins2)
1755  if(ins1>0 .and. ins1<inc2) cycle
1756  if(ncon>0) cycle outer
1757  return
1758  enddo
1759  endif
1760  enddo
1761  iret = -1
1762  return
1763  endif
1764  enddo outer
1765 
1766  return
1767 end subroutine ufbrw
1768 
1792 subroutine ufbrp(lun,usr,i1,i2,io,iret)
1793 
1794  use moda_usrint
1795 
1796  implicit none
1797 
1798  integer, intent(in) :: lun, i1, i2, io
1799  integer, intent(out) :: iret
1800  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, i, nz, invtag
1801 
1802  real*8, intent(inout) :: usr(i1,i2)
1803 
1804  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1805 
1806  iret = 0
1807  ins1 = 0
1808  ins2 = 0
1809 
1810  ! Find first non-zero node in string
1811  do nz=1,nnod
1812  if(nods(nz)>0) then
1813  do while (.true.)
1814  ! Frame a section of the buffer - return when no frame
1815  if(ins1+1>nval(lun)) return
1816  if(io==1 .and. iret==i2) return
1817  ins1 = invtag(nods(nz),lun,ins1+1,nval(lun))
1818  if(ins1==0) return
1819  ins2 = invtag(nods(nz),lun,ins1+1,nval(lun))
1820  if(ins2==0) ins2 = nval(lun)
1821  iret = iret+1
1822  ! Read user values
1823  if(io==0 .and. iret<=i2) then
1824  do i=1,nnod
1825  if(nods(i)>0) then
1826  invn = invtag(nods(i),lun,ins1,ins2)
1827  if(invn>0) usr(i,iret) = val(invn,lun)
1828  endif
1829  enddo
1830  endif
1831  ! Write user values
1832  if(io==1 .and. iret<=i2) then
1833  do i=1,nnod
1834  if(nods(i)>0) then
1835  invn = invtag(nods(i),lun,ins1,ins2)
1836  if(invn>0) val(invn,lun) = usr(i,iret)
1837  endif
1838  enddo
1839  endif
1840  enddo
1841  endif
1842  enddo
1843 
1844  return
1845 end subroutine ufbrp
1846 
1876 subroutine ufbsp(lun,usr,i1,i2,io,iret)
1877 
1878  use moda_usrint
1879 
1880  implicit none
1881 
1882  integer, intent(in) :: lun, i1, i2, io
1883  integer, intent(out) :: iret
1884  integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, invm, i, invtag
1885 
1886  real*8, intent(inout) :: usr(i1,i2)
1887 
1888  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1889 
1890  iret = 0
1891  ins1 = 0
1892  ins2 = 0
1893 
1894  do while (.true.)
1895  ! Frame a section of the buffer - return when no frame
1896  if(ins1+1>nval(lun)) return
1897  ins1 = invtag(nods(1),lun,ins1+1,nval(lun))
1898  if(ins1==0) return
1899  ins2 = invtag(nods(1),lun,ins1+1,nval(lun))
1900  if(ins2==0) ins2 = nval(lun)
1901  iret = iret+1
1902  ! Read user values
1903  if(io==0 .and. iret<=i2) then
1904  invm = ins1
1905  do i=1,nnod
1906  if(nods(i)>0) then
1907  invn = invtag(nods(i),lun,invm,ins2)
1908  if(invn>0) usr(i,iret) = val(invn,lun)
1909  invm = max(invn,invm)
1910  endif
1911  enddo
1912  endif
1913  ! Write user values
1914  if(io==1 .and. iret<=i2) then
1915  invm = ins1
1916  do i=1,nnod
1917  if(nods(i)>0) then
1918  invn = invtag(nods(i),lun,invm,ins2)
1919  if(invn>0) val(invn,lun) = usr(i,iret)
1920  invm = max(invn,invm)
1921  endif
1922  enddo
1923  endif
1924  enddo
1925 
1926  return
1927 end subroutine ufbsp
1928 
1977 recursive subroutine hold4wlc(lunit,chr,str)
1978 
1979  use modv_vars, only: im8b, mxh4wlc
1980 
1981  use moda_h4wlc
1982 
1983  implicit none
1984 
1985  integer, intent(in) :: lunit
1986  integer my_lunit, iprt, lens, lenc, i
1987 
1988  character*(*), intent(in) :: chr, str
1989 
1990  character*128 errstr
1991  character*14 mystr
1992 
1993  common /quiet/ iprt
1994 
1995  ! Check for I8 integers
1996  if(im8b) then
1997  im8b=.false.
1998  call x84(lunit,my_lunit,1)
1999  call hold4wlc(my_lunit,chr,str)
2000  im8b=.true.
2001  return
2002  endif
2003 
2004  call strsuc( str, mystr, lens )
2005  if ( lens == -1 ) return
2006 
2007  lenc = min( len( chr ), 120 )
2008 
2009  ! If this subroutine has already been called with this mnemonic for this particular subset, then overwrite the
2010  ! corresponding entry in the internal holding area
2011  if ( nh4wlc > 0 ) then
2012  do i = 1, nh4wlc
2013  if ( ( lunit == luh4wlc(i) ) .and. ( mystr(1:lens) == sth4wlc(i)(1:lens) ) ) then
2014  chh4wlc(i) = ''
2015  chh4wlc(i)(1:lenc) = chr(1:lenc)
2016  return
2017  endif
2018  enddo
2019  endif
2020 
2021  ! Otherwise, use the next available unused entry in the holding area
2022  if ( nh4wlc >= mxh4wlc ) then
2023  if(iprt>=0) then
2024  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2025  write ( unit=errstr, fmt='(A,A,I3)' ) 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', &
2026  'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
2027  call errwrt(errstr)
2028  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2029  endif
2030  else
2031  nh4wlc = nh4wlc + 1
2032  luh4wlc(nh4wlc) = lunit
2033  sth4wlc(nh4wlc) = ''
2034  sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
2035  chh4wlc(nh4wlc) = ''
2036  chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
2037  endif
2038 
2039  return
2040 end subroutine hold4wlc
2041 
2068 subroutine trybump(lun,usr,i1,i2,io,iret)
2069 
2070  use moda_usrint
2071 
2072  implicit none
2073 
2074  integer, intent(in) :: lun, i1, i2, io
2075  integer, intent(out) :: iret
2076  integer nnod, ncon, nods, nodc, ivls, kons, ndrp, invn, jnvn, knvn, invwin, lstjpb
2077 
2078  real*8, intent(inout) :: usr(i1,i2)
2079 
2080  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2081 
2082  ! See if there's a delayed replication group involved
2083 
2084  ndrp = lstjpb(nods(1),lun,'DRP')
2085  if(ndrp<=0) return
2086 
2087  ! If so, clean it out and bump it to i2
2088 
2089  invn = invwin(ndrp,lun,1,nval(lun))
2090  val(invn,lun) = 0
2091  jnvn = invn+1
2092  do while(nint(val(jnvn,lun))>0)
2093  jnvn = jnvn+nint(val(jnvn,lun))
2094  enddo
2095  do knvn=1,nval(lun)-jnvn+1
2096  inv(invn+knvn,lun) = inv(jnvn+knvn-1,lun)
2097  val(invn+knvn,lun) = val(jnvn+knvn-1,lun)
2098  enddo
2099  nval(lun) = nval(lun)-(jnvn-invn-1)
2100  call usrtpl(lun,invn,i2)
2101 
2102  ! Call the mnemonic writer
2103 
2104  call ufbrw(lun,usr,i1,i2,io,iret)
2105 
2106  return
2107 end subroutine trybump
2108 
2128 recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str)
2129 
2130  use modv_vars, only: im8b
2131 
2132  use moda_usrint
2133  use moda_msgcwd
2134 
2135  implicit none
2136 
2137  integer, intent(in) :: lunit, i1, i2
2138  integer, intent(out) :: iret
2139  integer iprt, ifirst1, my_lunit, my_i1, my_i2, lun, il, im, io
2140 
2141  character*(*), intent(in) :: str
2142  character*128 bort_str1, bort_str2, errstr
2143 
2144  real*8, intent(inout) :: usr(i1,i2)
2145 
2146  common /quiet/ iprt
2147 
2148  data ifirst1 /0/
2149 
2150  save ifirst1
2151 
2152  ! Check for I8 integers
2153 
2154  if(im8b) then
2155  im8b=.false.
2156  call x84(lunit,my_lunit,1)
2157  call x84(i1,my_i1,1)
2158  call x84(i2,my_i2,1)
2159  call ufbovr(my_lunit,usr,my_i1,my_i2,iret,str)
2160  call x48(iret,iret,1)
2161  im8b=.true.
2162  return
2163  endif
2164 
2165  iret = 0
2166 
2167  ! Check the file status and inode
2168 
2169  call status(lunit,lun,il,im)
2170  if(il==0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
2171  if(il<0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
2172  if(im==0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
2173  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// &
2174  'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2175 
2176  io = min(max(0,il),1)
2177 
2178  if(i1<=0) then
2179  if(iprt>=0) then
2180  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2181  errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2182  call errwrt(errstr)
2183  call errwrt(str)
2184  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2185  call errwrt(' ')
2186  endif
2187  return
2188  elseif(i2<=0) then
2189  if(iprt==-1) ifirst1 = 1
2190  if(io==0 .or. ifirst1==0 .or. iprt>=1) then
2191  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2192  errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
2193  call errwrt(errstr)
2194  call errwrt(str)
2195  if(iprt==0 .and. io==1) then
2196  errstr = 'Note: Only the first occurrence of this WARNING ' // &
2197  'message is printed, there may be more. To output all such messages,'
2198  call errwrt(errstr)
2199  errstr = 'modify your application program to add ' // &
2200  '"CALL OPENBF(0,''QUIET'',1)" prior to the first call to a BUFRLIB routine.'
2201  call errwrt(errstr)
2202  endif
2203  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2204  call errwrt(' ')
2205  ifirst1 = 1
2206  endif
2207  return
2208  endif
2209 
2210  ! Parse or recall the input string - write values
2211 
2212  call string(str,lun,i1,io)
2213  call trybump(lun,usr,i1,i2,io,iret)
2214 
2215  if(io==1 .and. iret/=i2) then
2216  write(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS: ",A)') str
2217  write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
2218  'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret, i2
2219  call bort2(bort_str1,bort_str2)
2220  endif
2221 
2222  return
2223 end subroutine ufbovr
2224 
2267 recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str)
2268 
2269  use modv_vars, only: im8b, bmiss
2270 
2271  use moda_usrint
2272  use moda_msgcwd
2273 
2274  implicit none
2275 
2276  character*(*), intent(in) :: str
2277  character*128 errstr
2278 
2279  integer, intent(in) :: lunit, i1, i2, i3
2280  integer, intent(out) :: iret
2281  integer invn(255), nnod, ncon, nods, nodc, ivls, kons, maxevn, iprt, my_lunit, my_i1, my_i2, my_i3, i, j, k, lun, il, im, &
2282  ins1, ins2, inc1, inc2, nnvn, nvnwin
2283 
2284  real*8, intent(out) :: usr(i1,i2,i3)
2285 
2286  logical nodgt0
2287 
2288  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2289  common /ufbn3c/ maxevn
2290  common /quiet/ iprt
2291 
2292  ! Check for I8 integers
2293 
2294  if(im8b) then
2295  im8b=.false.
2296  call x84(lunit,my_lunit,1)
2297  call x84(i1,my_i1,1)
2298  call x84(i2,my_i2,1)
2299  call x84(i3,my_i3,1)
2300  call ufbevn(my_lunit,usr,my_i1,my_i2,my_i3,iret,str)
2301  call x48(iret,iret,1)
2302  im8b=.true.
2303  return
2304  endif
2305 
2306  maxevn = 0
2307  iret = 0
2308 
2309  ! Check the file status and inode
2310 
2311  call status(lunit,lun,il,im)
2312  if(il==0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2313  if(il>0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2314  if(im==0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2315  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// &
2316  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2317 
2318  if(i1<=0) then
2319  if(iprt>=0) then
2320  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2321  errstr = .LE.'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2322  call errwrt(errstr)
2323  call errwrt(str)
2324  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2325  call errwrt(' ')
2326  endif
2327  return
2328  elseif(i2<=0) then
2329  if(iprt>=0) then
2330  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2331  errstr = .LE.'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2332  call errwrt(errstr)
2333  call errwrt(str)
2334  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2335  call errwrt(' ')
2336  endif
2337  return
2338  elseif(i3<=0) then
2339  if(iprt>=0) then
2340  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2341  errstr = .LE.'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2342  call errwrt(errstr)
2343  call errwrt(str)
2344  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2345  call errwrt(' ')
2346  endif
2347  return
2348  endif
2349 
2350  ! Parse or recall the input string
2351 
2352  call string(str,lun,i1,0)
2353 
2354  ! Initialize usr array
2355 
2356  do k=1,i3
2357  do j=1,i2
2358  do i=1,i1
2359  usr(i,j,k) = bmiss
2360  enddo
2361  enddo
2362  enddo
2363 
2364  ! Loop over condition windows
2365 
2366  inc1 = 1
2367  inc2 = 1
2368  outer: do while (.true.)
2369  call conwin(lun,inc1,inc2)
2370  if(nnod==0) then
2371  iret = i2
2372  return
2373  elseif(inc1==0) then
2374  return
2375  else
2376  nodgt0 = .false.
2377  do i=1,nnod
2378  if(nods(i)>0) then
2379  ins2 = inc1
2380  call getwin(nods(i),lun,ins1,ins2)
2381  if(ins1==0) return
2382  nodgt0 = .true.
2383  exit
2384  endif
2385  enddo
2386  if(.not.nodgt0) then
2387  ins1 = inc1
2388  ins2 = inc2
2389  endif
2390  ! Read push down stack data into 3D arrays
2391  inner: do while (.true.)
2392  iret = iret+1
2393  if(iret<=i2) then
2394  do j=1,nnod
2395  if(nods(j)>0) then
2396  nnvn = nvnwin(nods(j),lun,ins1,ins2,invn,i3)
2397  maxevn = max(nnvn,maxevn)
2398  do k=1,nnvn
2399  usr(j,iret,k) = val(invn(k),lun)
2400  enddo
2401  endif
2402  enddo
2403  endif
2404  ! Decide what to do next
2405  call nxtwin(lun,ins1,ins2)
2406  if(ins1<=0 .or. ins1>=inc2) exit inner
2407  enddo inner
2408  if(ncon<=0) exit outer
2409  endif
2410  enddo outer
2411 
2412  if(iret==0) then
2413  if(iprt>=1) then
2414  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2415  errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
2416  call errwrt(errstr)
2417  call errwrt(str)
2418  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2419  call errwrt(' ')
2420  endif
2421  endif
2422 
2423  return
2424 end subroutine ufbevn
2425 
2471 recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str)
2472 
2473  use modv_vars, only: im8b, bmiss
2474 
2475  use moda_usrint
2476  use moda_msgcwd
2477 
2478  implicit none
2479 
2480  character*(*), intent(in) :: str
2481  character*128 errstr
2482 
2483  integer, intent(in) :: lunit, i1, i2, i3
2484  integer, intent(out) :: iret, jret
2485  integer nnod, ncon, nods, nodc, ivls, kons, iprt, my_lunit, my_i1, my_i2, my_i3, i, j, k, lun, il, im, &
2486  ins1, ins2, inc1, inc2, nnvn, nevn
2487 
2488  real*8, intent(out) :: usr(i1,i2,i3)
2489 
2490  logical nodgt0
2491 
2492  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2493  common /quiet/ iprt
2494 
2495  ! Check for I8 integers
2496 
2497  if(im8b) then
2498  im8b=.false.
2499  call x84(lunit,my_lunit,1)
2500  call x84(i1,my_i1,1)
2501  call x84(i2,my_i2,1)
2502  call x84(i3,my_i3,1)
2503  call ufbin3(my_lunit,usr,my_i1,my_i2,my_i3,iret,jret,str)
2504  call x48(iret,iret,1)
2505  call x48(jret,jret,1)
2506  im8b=.true.
2507  return
2508  endif
2509 
2510  iret = 0
2511  jret = 0
2512 
2513  ! Check the file status and inode
2514 
2515  call status(lunit,lun,il,im)
2516  if(il==0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2517  if(il>0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2518  if(im==0) call bort('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2519  if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// &
2520  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
2521 
2522  if(i1<=0) then
2523  if(iprt>=0) then
2524  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2525  errstr = .LE.'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS 0, ' // &
2526  'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) ='
2527  call errwrt(errstr)
2528  call errwrt(str)
2529  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2530  call errwrt(' ')
2531  endif
2532  return
2533  elseif(i2<=0) then
2534  if(iprt>=0) then
2535  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2536  errstr = .LE.'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS 0, ' // &
2537  'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) ='
2538  call errwrt(errstr)
2539  call errwrt(str)
2540  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2541  call errwrt(' ')
2542  endif
2543  return
2544  elseif(i3<=0) then
2545  if(iprt>=0) then
2546  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2547  errstr = .LE.'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS 0, ' // &
2548  'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) ='
2549  call errwrt(errstr)
2550  call errwrt(str)
2551  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2552  call errwrt(' ')
2553  endif
2554  return
2555  endif
2556 
2557  ! Parse or recall the input string
2558 
2559  call string(str,lun,i1,0)
2560 
2561  ! Initialize usr array
2562 
2563  do k=1,i3
2564  do j=1,i2
2565  do i=1,i1
2566  usr(i,j,k) = bmiss
2567  enddo
2568  enddo
2569  enddo
2570 
2571  ! Loop over condition windows
2572 
2573  inc1 = 1
2574  inc2 = 1
2575  outer: do while (.true.)
2576  call conwin(lun,inc1,inc2)
2577  if(nnod==0) then
2578  iret = i2
2579  return
2580  elseif(inc1==0) then
2581  return
2582  else
2583  nodgt0 = .false.
2584  do i=1,nnod
2585  if(nods(i)>0) then
2586  ins2 = inc1
2587  call getwin(nods(i),lun,ins1,ins2)
2588  if(ins1==0) return
2589  nodgt0 = .true.
2590  exit
2591  endif
2592  enddo
2593  if(.not.nodgt0) then
2594  ins1 = inc1
2595  ins2 = inc2
2596  endif
2597  ! Read push down stack data into 3D arrays
2598  inner: do while (.true.)
2599  iret = iret+1
2600  if(iret<=i2) then
2601  do j=1,nnod
2602  nnvn = nevn(nods(j),lun,ins1,ins2,i1,i2,i3,usr(j,iret,1))
2603  jret = max(jret,nnvn)
2604  enddo
2605  endif
2606  ! Decide what to do next
2607  call nxtwin(lun,ins1,ins2)
2608  if(ins1<=0 .or. ins1>=inc2) exit inner
2609  enddo inner
2610  if(ncon<=0) exit outer
2611  endif
2612  enddo outer
2613 
2614  if(iret==0 .or. jret==0) then
2615  if(iprt>=1) then
2616  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2617  errstr = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' // &
2618  'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) ='
2619  call errwrt(errstr)
2620  call errwrt(str)
2621  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
2622  call errwrt(' ')
2623  endif
2624  endif
2625 
2626  return
2627 end subroutine ufbin3
2628 
2662 recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str)
2663 
2664  use modv_vars, only: im8b
2665 
2666  use moda_msgcwd
2667  use moda_bitbuf
2668 
2669  implicit none
2670 
2671  integer, intent(in) :: lunit, imsg, isub, i1, i2
2672  integer, intent(out) :: iret
2673  integer my_lunit, my_imsg, my_isub, my_i1, my_i2, lun, il, im, jdate, jret, i
2674 
2675  character*(*), intent(in) :: str
2676  character*128 bort_str
2677  character*8 subset
2678 
2679  real*8, intent(out) :: usr(i1,i2)
2680 
2681  logical openit
2682 
2683  ! Check for I8 integers
2684  if(im8b) then
2685  im8b=.false.
2686  call x84(lunit,my_lunit,1)
2687  call x84(imsg,my_imsg,1)
2688  call x84(isub,my_isub,1)
2689  call x84(i1,my_i1,1)
2690  call x84(i2,my_i2,1)
2691  call ufbinx(my_lunit,my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
2692  call x48(iret,iret,1)
2693  im8b=.true.
2694  return
2695  endif
2696 
2697  call status(lunit,lun,il,im)
2698  openit = il==0
2699 
2700  if(openit) then
2701  ! Open BUFR file connected to unit lunit if it isn't already open
2702  call openbf(lunit,'INX',lunit)
2703  else
2704  ! If BUFR file already opened, save position and rewind to first data message
2705  call rewnbf(lunit,0)
2706  endif
2707 
2708  ! Skip to the requested message
2709  do i=1,imsg
2710  call readmg(lunit,subset,jdate,jret)
2711  if(jret<0) then
2712  write(bort_str,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// &
2713  'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') imsg, lunit
2714  call bort(bort_str)
2715  endif
2716  enddo
2717 
2718  ! Position at the requested subset
2719  do i=1,isub
2720  call readsb(lunit,jret)
2721  if(jret/=0) then
2722  write(bort_str,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// &
2723  'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub, imsg, lunit
2724  call bort(bort_str)
2725  endif
2726  enddo
2727 
2728  ! Read the requested data values
2729  call ufbint(lunit,usr,i1,i2,iret,str)
2730 
2731  if(openit) then
2732  ! Close BUFR file if it was opened here
2733  call closbf(lunit)
2734  else
2735  ! Restore BUFR file to its previous status and position
2736  call rewnbf(lunit,1)
2737  endif
2738 
2739  return
2740 end subroutine ufbinx
2741 
2756 recursive subroutine ufbget(lunit,tab,i1,iret,str)
2757 
2758  use modv_vars, only: im8b, bmiss
2759 
2760  use moda_usrint
2761  use moda_usrbit
2762  use moda_msgcwd
2763  use moda_bitbuf
2764  use moda_tables
2765 
2766  implicit none
2767 
2768  integer*8 ival
2769  integer, intent(in) :: lunit, i1
2770  integer, intent(out) :: iret
2771  integer nnod, ncon, nods, nodc, ivls, kons, my_lunit, my_i1, lun, il, im, i, n, node, nbmp, kbit, invn, invwin
2772 
2773  character*(*), intent(in) :: str
2774  character*8 cval
2775 
2776  real*8, intent(out) :: tab(i1)
2777  real*8 rval, ups
2778 
2779  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
2780 
2781  equivalence(cval,rval)
2782 
2783  ! Check for I8 integers
2784 
2785  if(im8b) then
2786  im8b=.false.
2787  call x84(lunit,my_lunit,1)
2788  call x84(i1,my_i1,1)
2789  call ufbget(my_lunit,tab,my_i1,iret,str)
2790  call x48(iret,iret,1)
2791  im8b=.true.
2792  return
2793  endif
2794 
2795  iret = 0
2796 
2797  do i=1,i1
2798  tab(i) = bmiss
2799  enddo
2800 
2801  ! Make sure a file/message is open for input
2802 
2803  call status(lunit,lun,il,im)
2804  if(il==0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
2805  if(il>0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
2806  if(im==0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
2807 
2808  ! See if there's another subset in the message
2809 
2810  if(nsub(lun)==msub(lun)) then
2811  iret = -1
2812  return
2813  endif
2814 
2815  ! Parse the string
2816 
2817  call string(str,lun,i1,0)
2818 
2819  ! Expand the template for this subset as little as possible
2820 
2821  n = 1
2822  nbit(n) = 0
2823  mbit(n) = mbyt(lun)*8 + 16
2824  call usrtpl(lun,n,n)
2825  do n=n+1,nval(lun)
2826  node = inv(n,lun)
2827  nbit(n) = ibt(node)
2828  mbit(n) = mbit(n-1)+nbit(n-1)
2829  if(node==nods(nnod)) then
2830  nval(lun) = n
2831  exit
2832  elseif(itp(node)==1) then
2833  call upb8(ival,nbit(n),mbit(n),mbay(1,lun))
2834  nbmp=int(ival)
2835  call usrtpl(lun,n,nbmp)
2836  endif
2837  enddo
2838 
2839  ! Unpack only the nodes found in the string
2840 
2841  do i=1,nnod
2842  node = nods(i)
2843  invn = invwin(node,lun,1,nval(lun))
2844  if(invn>0) then
2845  call upb8(ival,nbit(invn),mbit(invn),mbay(1,lun))
2846  if(itp(node)==1) then
2847  tab(i) = ival
2848  elseif(itp(node)==2) then
2849  if(ival<2_8**(ibt(node))-1) tab(i) = ups(ival,node)
2850  elseif(itp(node)==3) then
2851  cval = ' '
2852  kbit = mbit(invn)
2853  call upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
2854  tab(i) = rval
2855  endif
2856  else
2857  tab(i) = bmiss
2858  endif
2859  enddo
2860 
2861  return
2862 end subroutine ufbget
2863 
2888 integer function nevn(node,lun,inv1,inv2,i1,i2,i3,usr) result(iret)
2889 
2890  use moda_usrint
2891 
2892  implicit none
2893 
2894  integer, intent(in) :: node, lun, inv1, inv2, i1, i2, i3
2895  integer ndrs, invn, n1, n2, l, n, invwin, lstjpb
2896 
2897  character*128 bort_str
2898 
2899  real*8, intent(out) :: usr(i1,i2,i3)
2900 
2901  iret = 0
2902 
2903  ! Find the enclosing event stack descriptor
2904 
2905  ndrs = lstjpb(node,lun,'DRS')
2906  if(ndrs<=0) return
2907 
2908  invn = invwin(ndrs,lun,inv1,inv2)
2909  if(invn==0) call bort('BUFRLIB: iret - CAN''T FIND THE EVENT STACK!!!!!!')
2910 
2911  iret = nint(val(invn,lun))
2912  if(iret>i3) then
2913  write(bort_str,'("BUFRLIB: NEVN - THE NO. OF EVENTS FOR THE '// &
2914  'REQUESTED STACK (",I3,") EXCEEDS THE VALUE OF THE 3RD DIM. OF THE USR ARRAY (",I3,")")') iret, i3
2915  call bort(bort_str)
2916  endif
2917 
2918  ! Search each stack level for the requested node and copy the value
2919 
2920  n2 = invn + 1
2921 
2922  do l=1,iret
2923  n1 = n2
2924  n2 = n2 + nint(val(n1,lun))
2925  do n=n1,n2
2926  if(inv(n,lun)==node) usr(1,1,l) = val(n,lun)
2927  enddo
2928  enddo
2929 
2930  return
2931 end function nevn
bort
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
bort2
subroutine bort2(str1, str2)
Log two error messages, then abort the application program.
Definition: borts.F90:39
upb
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:202
upbb
subroutine upbb(nval, nbits, ibit, ibay)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:154
upb8
subroutine upb8(nval, nbits, ibit, ibay)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:80
ups
real *8 function ups(ival, node)
Unpack a real*8 value from an integer by applying the proper scale and reference values.
Definition: cidecode.F90:319
upc
subroutine upc(chr, nchr, ibay, ibit, cnvnull)
Decode a character string from within a specified number of bytes of an integer array,...
Definition: cidecode.F90:26
pkc
subroutine pkc(chr, nchr, ibay, ibit)
Encode a character string within a specified number of bytes of an integer array, starting at the bit...
Definition: ciencode.F90:25
ipkm
recursive subroutine ipkm(cbay, nbyt, n)
Encode an integer value within a specified number of bytes of a character string, up to a maximum of ...
Definition: ciencode.F90:194
errwrt
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
strsuc
subroutine strsuc(str1, str2, lens)
Remove leading and trailing blanks from a character string.
Definition: misc.F90:220
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:540
moda_rlccmn::nrst
integer nrst
Number of long character strings in data subset.
Definition: modules_arrs.F90:542
moda_rlccmn::irnch
integer, dimension(:), allocatable irnch
Lengths (in bytes) of long character strings.
Definition: modules_arrs.F90:544
moda_rlccmn::irbit
integer, dimension(:), allocatable irbit
Pointers in data subset to first bits of long character strings.
Definition: modules_arrs.F90:546
moda_rlccmn::crtag
character *10, dimension(:), allocatable crtag
Table B mnemonics associated with long character strings.
Definition: modules_arrs.F90:548
moda_tables
Declare arrays and variables used to store the internal jump/link table.
Definition: modules_arrs.F90:664
moda_tables::isc
integer, dimension(:), allocatable isc
Scale factors corresponding to tag and typ:
Definition: modules_arrs.F90:722
moda_tables::ibt
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
Definition: modules_arrs.F90:710
moda_tables::typ
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
Definition: modules_arrs.F90:683
moda_tables::jmpb
integer, dimension(:), allocatable jmpb
Jump backward indices corresponding to tag and typ:
Definition: modules_arrs.F90:706
moda_tables::tag
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
Definition: modules_arrs.F90:668
moda_tables::itp
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Definition: modules_arrs.F90:728
moda_tables::link
integer, dimension(:), allocatable link
Link indices corresponding to tag, typ and jmpb:
Definition: modules_arrs.F90:699
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:766
moda_unptyp::msgunp
integer, dimension(:), allocatable msgunp
Flag indicating how to unpack data subsets from BUFR message:
Definition: modules_arrs.F90:771
moda_usrbit
Declare arrays for internal storage of pointers to BUFR data subset values.
Definition: modules_arrs.F90:779
moda_usrbit::nbit
integer, dimension(:), allocatable nbit
Length (in bits) of each packed data value in data subset.
Definition: modules_arrs.F90:781
moda_usrbit::mbit
integer, dimension(:), allocatable mbit
Pointer in data subset to first bit of each packed data value.
Definition: modules_arrs.F90:783
moda_usrint
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
Definition: modules_arrs.F90:791
moda_usrint::nval
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
Definition: modules_arrs.F90:793
moda_usrint::val
real *8, dimension(:,:), allocatable, target val
Data values.
Definition: modules_arrs.F90:800
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:795
closbf
recursive subroutine closbf(lunit)
Close the connection between logical unit lunit and the NCEPLIBS-bufr software.
Definition: openclosebf.F90:338
rewnbf
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
Definition: openclosebf.F90:694
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:169
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:406
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:1213
usrtpl
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
Definition: readwritesb.F90:1307
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
ufbin3
recursive subroutine ufbin3(lunit, usr, i1, i2, i3, iret, jret, str)
Read one or more data values from an NCEP prepfits file.
Definition: readwriteval.F90:2472
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:2663
nevn
integer function nevn(node, lun, inv1, inv2, i1, i2, i3, usr)
Read one or more data values from a stacked data event within a specified portion of the current data...
Definition: readwriteval.F90:2889
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:1793
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:1320
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:1655
hold4wlc
recursive subroutine hold4wlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:1978
ufbovr
recursive subroutine ufbovr(lunit, usr, i1, i2, iret, str)
Overwrite one or more data values within a data subset.
Definition: readwriteval.F90:2129
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:646
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:1877
trybump
subroutine trybump(lun, usr, i1, i2, io, iret)
Try to expand a delayed replication sequence.
Definition: readwriteval.F90:2069
drfini
recursive subroutine drfini(lunit, mdrf, ndrf, drftag)
Explicitly initialize delayed replication factors and allocate a corresponding amount of space within...
Definition: readwriteval.F90:1588
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:1099
readlc
recursive subroutine readlc(lunit, chr, str)
Read a long character string (greater than 8 bytes) from a data subset.
Definition: readwriteval.F90:407
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:2268
writlc
recursive subroutine writlc(lunit, chr, str)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: readwriteval.F90:200
ufbget
recursive subroutine ufbget(lunit, tab, i1, iret, str)
Read one or more data values from a data subset without advancing the subset pointer.
Definition: readwriteval.F90:2757
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:886
iupbs3
recursive integer function iupbs3(mbay, s3mnem)
Read a specified value from within Section 3 of a BUFR message.
Definition: s013vals.F90:349
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