NCEPLIBS-bufr  12.1.0
copydata.F90
Go to the documentation of this file.
1 
5 
22 recursive subroutine copybf(lunin,lunot)
23 
24  use modv_vars, only: im8b
25 
26  use moda_mgwa
27 
28  implicit none
29 
30  integer, intent(in) :: lunin, lunot
31  integer my_lunin, my_lunot, lun, il, im, ier, iupbs01
32 
33  ! Check for I8 integers
34 
35  if(im8b) then
36  im8b=.false.
37 
38  call x84(lunin,my_lunin,1)
39  call x84(lunot,my_lunot,1)
40  call copybf(my_lunin,my_lunot)
41 
42  im8b=.true.
43  return
44  endif
45 
46  ! Check BUFR file statuses
47 
48  call status(lunin,lun,il,im)
49  if(il/=0) call bort ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
50  call status(lunot,lun,il,im)
51  if(il/=0) call bort ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
52 
53  ! Connect the files for reading/writing to the C I/O interface
54 
55  call openbf(lunin,'INX',lunin)
56  call openbf(lunot,'OUX',lunin)
57 
58  ! Read and copy a BUFR file from unit lunin to unit lunot
59 
60  ier = 0
61  do while (ier==0)
62  call rdmsgw(lunin,mgwa,ier)
63  if(ier==0) call msgwrt(lunot,mgwa,iupbs01(mgwa,'LENM'))
64  enddo
65 
66  ! Free up the file connections for the two files
67 
68  call closbf(lunin)
69  call closbf(lunot)
70 
71  return
72 end subroutine copybf
73 
107 recursive subroutine copymg(lunin,lunot)
108 
109  use modv_vars, only: im8b
110 
111  use moda_msgcwd
112  use moda_bitbuf
113  use moda_tables
114 
115  implicit none
116 
117  integer, intent(in) :: lunin, lunot
118  integer my_lunin, my_lunot, lin, lot, il, im, mtyp, msbt, inod, mbym, iupbs01, iok2cpy
119 
120  character*8 subset
121 
122  ! Check for I8 integers
123 
124  if(im8b) then
125  im8b=.false.
126 
127  call x84(lunin,my_lunin,1)
128  call x84(lunot,my_lunot,1)
129  call copymg(my_lunin,my_lunot)
130 
131  im8b=.true.
132  return
133  endif
134 
135  ! Check the file statuses
136 
137  call status(lunin,lin,il,im)
138  if(il==0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
139  if(il>0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
140  if(im==0) call bort('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
141 
142  call status(lunot,lot,il,im)
143  if(il==0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
144  if(il<0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
145  if(im/=0) call bort('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN')
146 
147  ! Make sure both files have the same tables
148 
149  subset = tag(inode(lin))(1:8)
150  call nemtba(lot,subset,mtyp,msbt,inod)
151  if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) &
152  call bort('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
153 
154  ! Everything okay, so copy a message
155 
156  mbym = iupbs01(mbay(1,lin),'LENM')
157  call msgwrt(lunot,mbay(1,lin),mbym)
158 
159  ! Set the message control words for partition associated with lunot
160 
161  nmsg(lot) = nmsg(lot) + 1
162  nsub(lot) = msub(lin)
163  msub(lot) = msub(lin)
164  idate(lot) = idate(lin)
165  inode(lot) = inod
166 
167  return
168 end subroutine copymg
169 
202 recursive subroutine copysb(lunin,lunot,iret)
203 
204  use modv_vars, only: im8b
205 
206  use moda_msgcwd
207  use moda_bitbuf
208  use moda_tables
209 
210  implicit none
211 
212  integer, intent(in) :: lunin, lunot
213  integer, intent(out) :: iret
214  integer my_lunin, my_lunot, lin, lot, il, im, mest, icmp, nbyt, len0, len1, len2, len3, len4, l5, iok2cpy
215 
216  ! Check for I8 integers
217 
218  if(im8b) then
219  im8b=.false.
220 
221  call x84(lunin,my_lunin,1)
222  call x84(lunot,my_lunot,1)
223  call copysb(my_lunin,my_lunot,iret)
224  call x48(iret,iret,1)
225 
226  im8b=.true.
227  return
228  endif
229 
230  iret = 0
231 
232  ! Check the file statuses
233 
234  call status(lunin,lin,il,im)
235  if(il==0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
236  if(il>0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
237  if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
238 
239  if(lunot>0) then
240  call status(lunot,lot,il,im)
241  if(il==0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
242  if(il<0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
243  if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
244  if( (inode(lin)/=inode(lot)) .and. ( (tag(inode(lin))/=tag(inode(lot))) .or. (iok2cpy(lin,lot)/=1) ) ) &
245  call bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
246  endif
247 
248  ! See if there is another subset in the message
249 
250  if(nsub(lin)==msub(lin)) then
251  iret = -1
252  return
253  endif
254 
255  ! Check compression status of input message, output message will match
256 
257  call mesgbc(-lunin, mest, icmp)
258 
259  if(icmp==1) then
260 
261  ! The input message is compressed, so read in the next subset and copy it as compressed to the output message.
262 
263  call readsb(lunin,iret)
264  if(lunot>0) then
265  call ufbcpy(lunin,lunot)
266  call cmpmsg('Y')
267  call writsb(lunot)
268  call cmpmsg('N')
269  endif
270  else
271 
272  ! The input message is uncompressed, so read in the next subset and copy it as uncompressed to the output message.
273 
274  ibit = (mbyt(lin))*8
275  call upb(nbyt,16,mbay(1,lin),ibit)
276  if (nbyt>65530) then
277  ! This is an oversized subset, so we can't rely on the value of nbyt as being the true size (in bytes) of the subset.
278  if ( (nsub(lin)==0) .and. (msub(lin)==1) ) then
279  ! But it's also the first and only subset in the message, so we can determine its true size in a different way.
280  call getlens(mbay(1,lin), 4, len0, len1, len2, len3, len4, l5)
281  nbyt = len4 - 4
282  else
283  ! We have no way to easily determine the true size of this oversized subset.
284  iret = -1
285  return
286  endif
287  endif
288  if(lunot>0) call cpyupd(lunot, lin, lot, nbyt)
289  mbyt(lin) = mbyt(lin) + nbyt
290  nsub(lin) = nsub(lin) + 1
291  endif
292 
293  return
294 end subroutine copysb
295 
311 recursive integer function icopysb(lunin,lunot) result(iret)
312 
313  use modv_vars, only: im8b
314 
315  implicit none
316 
317  integer, intent(in) :: lunin, lunot
318  integer my_lunin, my_lunot
319 
320  if(im8b) then
321  im8b=.false.
322 
323  call x84(lunin,my_lunin,1)
324  call x84(lunot,my_lunot,1)
325  iret=icopysb(my_lunin,my_lunot)
326 
327  im8b=.true.
328  return
329  endif
330 
331  call copysb(lunin,lunot,iret)
332 
333  return
334 end function icopysb
335 
354 integer function iok2cpy(lui,luo) result(iret)
355 
356  use moda_msgcwd
357  use moda_tables
358 
359  implicit none
360 
361  integer, intent(in) :: lui, luo
362  integer icmpdx, mtyp, msbt, inod, ntei, nteo, i
363 
364  character*8 subset
365 
366  iret = 0
367 
368  ! Do both logical units have the same internal table information?
369 
370  if ( icmpdx(lui,luo) == 1 ) then
371  iret = 1
372  return
373  endif
374 
375  ! No, so get the Table A mnemonic from the message to be copied, then check whether that mnemonic is defined within the
376  ! dictionary tables for the logical unit to be copied to.
377 
378  subset = tag(inode(lui))(1:8)
379  call nemtbax(luo,subset,mtyp,msbt,inod)
380  if ( inod == 0 ) return
381 
382  ! The Table A mnemonic is defined within the dictionary tables for both units, so now make sure the definitions are identical.
383 
384  ntei = isc(inode(lui))-inode(lui)
385  nteo = isc(inod)-inod
386  if ( ntei /= nteo ) return
387 
388  do i = 1, ntei
389  if ( tag(inode(lui)+i) /= tag(inod+i) ) return
390  if ( typ(inode(lui)+i) /= typ(inod+i) ) return
391  if ( isc(inode(lui)+i) /= isc(inod+i) ) return
392  if ( irf(inode(lui)+i) /= irf(inod+i) ) return
393  if ( ibt(inode(lui)+i) /= ibt(inod+i) ) return
394  enddo
395 
396  iret = 1
397 
398  return
399 end function iok2cpy
400 
433 recursive subroutine cpymem(lunot)
434 
435  use modv_vars, only: im8b
436 
437  use moda_msgcwd
438  use moda_bitbuf
439  use moda_msgmem
440  use moda_tables
441 
442  implicit none
443 
444  integer, intent(in) :: lunot
445  integer my_lunot, lin, lot, il, im, mtyp, msbt, inod, mbym, iupbs01, iok2cpy
446 
447  character*8 subset
448 
449  ! Check for I8 integers
450 
451  if(im8b) then
452  im8b=.false.
453 
454  call x84(lunot,my_lunot,1)
455  call cpymem(my_lunot)
456 
457  im8b=.true.
458  return
459  endif
460 
461  ! Check the file statuses
462 
463  call status(munit,lin,il,im)
464  if(im==0) call bort('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE')
465 
466  call status(lunot,lot,il,im)
467  if(il==0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
468  if(il<0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
469  if(im/=0) call bort('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN')
470 
471  ! Make sure both files have the same tables
472 
473  subset = tag(inode(lin))(1:8)
474  call nemtba(lot,subset,mtyp,msbt,inod)
475  if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) &
476  call bort('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL '// &
477  'TABLES (DIFFERENT HERE)')
478 
479  ! Everything okay, so copy a message
480 
481  mbym = iupbs01(mbay(1,lin),'LENM')
482  call msgwrt(lunot,mbay(1,lin),mbym)
483 
484  ! Set the message control words for partition associated with lunot
485 
486  nmsg(lot) = nmsg(lot) + 1
487  nsub(lot) = msub(lin)
488  msub(lot) = msub(lin)
489  idate(lot) = idate(lin)
490  inode(lot) = inod
491 
492  return
493 end subroutine cpymem
494 
512 subroutine cpyupd(lunit,lin,lun,ibyt)
513 
514  use moda_msgcwd
515  use moda_bitbuf
516 
517  implicit none
518 
519  integer, intent(in) :: lunit, lin, lun, ibyt
520  integer nby0, nby1, nby2, nby3, nby4, nby5, iprt, lbit, lbyt, nbyt, iupb
521 
522  common /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
523 
524  common /quiet/ iprt
525 
526  character*128 bort_str, errstr
527 
528  logical msgfull
529 
530  ! Check whether the new subset should be written into the currently open message
531 
532  if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt>65530).and.(nsub(lun)>0))) then
533  ! NO it should not, either because:
534  ! 1) it doesn't fit,
535  ! -- OR --
536  ! 2) it has byte count > 65530 (sufficiently close to the upper limit for the 16 bit byte counter placed at the
537  ! beginning of each subset), AND the current message has at least one subset in it,
538  ! SO write the current message out and create a new one to hold the current subset
539  call msgwrt(lunit,mbay(1,lun),mbyt(lun))
540  call msgini(lun)
541  endif
542 
543  if(msgfull(mbyt(lun),ibyt,maxbyt)) then
544  write(bort_str,'("BUFRLIB: CPYUPD - THE LENGTH OF THIS SUBSET EXCEEDS THE MAXIMUM MESSAGE LENGTH (",I6,")")') maxbyt
545  call bort(bort_str)
546  endif
547 
548  ! Transfer subset from one message to the other.
549 
550  ! Note that we want to append the data for this subset to the end of Section 4, but the value in mbyt(lun) already includes
551  ! the length of Section 5 (i.e. 4 bytes). Therefore, we need to begin writing at the point 3 bytes prior to the byte
552  ! currently pointed to by mbyt(lun).
553 
554  call mvb(mbay(1,lin),mbyt(lin)+1,mbay(1,lun),mbyt(lun)-3,ibyt)
555 
556  ! Update the subset and byte counters
557 
558  mbyt(lun) = mbyt(lun) + ibyt
559  nsub(lun) = nsub(lun) + 1
560 
561  lbit = (nby0+nby1+nby2+4)*8
562  call pkb(nsub(lun),16,mbay(1,lun),lbit)
563 
564  lbyt = nby0+nby1+nby2+nby3
565  nbyt = iupb(mbay(1,lun),lbyt+1,24)
566  lbit = lbyt*8
567  call pkb(nbyt+ibyt,24,mbay(1,lun),lbit)
568 
569  ! If the subset byte count is > 65530, then give it its own one-subset message (i.e. we cannot have any other subsets
570  ! in this message because their beginning would be beyond the upper limit of 65535 in the 16-bit byte counter, meaning
571  ! they could not be located!)
572 
573  if(ibyt>65530) then
574  if(iprt>=1) then
575  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
576  write ( unit=errstr, fmt='(A,I7,A,A)') 'BUFRLIB: CPYUPD - SUBSET HAS BYTE COUNT = ',ibyt,' > UPPER LIMIT OF 65535'
577  call errwrt(errstr)
578  call errwrt('>>>>>>>WILL BE COPIED INTO ITS OWN MESSAGE<<<<<<<<')
579  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
580  call errwrt(' ')
581  endif
582  call msgwrt(lunit,mbay(1,lun),mbyt(lun))
583  call msgini(lun)
584  endif
585 
586  return
587 end subroutine cpyupd
588 
611 recursive subroutine ufbcpy(lubin,lubot)
612 
613  use modv_vars, only: im8b
614 
615  use moda_usrint
616  use moda_msgcwd
617  use moda_ufbcpl
618  use moda_tables
619 
620  implicit none
621 
622  integer, intent(in) :: lubin, lubot
623  integer my_lubin, my_lubot, lui, luo, il, im, n, iok2cpy
624 
625  ! Check for I8 integers
626 
627  if(im8b) then
628  im8b=.false.
629 
630  call x84(lubin,my_lubin,1)
631  call x84(lubot,my_lubot,1)
632  call ufbcpy(my_lubin,my_lubot)
633 
634  im8b=.true.
635  return
636  endif
637 
638  ! Check the file statuses and inode
639 
640  call status(lubin,lui,il,im)
641  if(il==0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
642  if(il>0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
643  if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
644  if(inode(lui)/=inv(1,lui)) &
645  call bort('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION '// &
646  'IN INTERNAL SUBSET ARRAY')
647 
648  call status(lubot,luo,il,im)
649  if(il==0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
650  if(il<0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
651  if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
652 
653  if( (inode(lui)/=inode(luo)) .and. ( (tag(inode(lui))/=tag(inode(luo))) .or. (iok2cpy(lui,luo)/=1) ) ) &
654  call bort('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
655 
656  ! Everything okay, so copy user array from lui to luo
657 
658  nval(luo) = nval(lui)
659 
660  do n=1,nval(lui)
661  inv(n,luo) = inv(n,lui)
662  nrfelm(n,luo) = nrfelm(n,lui)
663  val(n,luo) = val(n,lui)
664  enddo
665 
666  luncpy(luo)=lubin
667 
668  return
669 end subroutine ufbcpy
670 
677 subroutine cpbfdx(lud,lun)
678 
679  use moda_msgcwd
680  use moda_tababd
681 
682  implicit none
683 
684  integer, intent(in) :: lud, lun
685  integer i
686 
687  ! Initialize the dictionary table partition
688 
689  call dxinit(lun,0)
690 
691  ! Positional index for Table A mnem.
692  inode(lun) = inode(lud)
693 
694  ntba(lun) = ntba(lud)
695  ntbb(lun) = ntbb(lud)
696  ntbd(lun) = ntbd(lud)
697 
698  ! Table A entries
699  do i=1,ntba(lud)
700  idna(i,lun,1) = idna(i,lud,1)
701  idna(i,lun,2) = idna(i,lud,2)
702  taba(i,lun) = taba(i,lud)
703  mtab(i,lun) = mtab(i,lud)
704  enddo
705 
706  ! Table B entries
707  do i=1,ntbb(lud)
708  idnb(i,lun) = idnb(i,lud)
709  tabb(i,lun) = tabb(i,lud)
710  enddo
711 
712  ! Copy Table D entries
713  do i=1,ntbd(lud)
714  idnd(i,lun) = idnd(i,lud)
715  tabd(i,lun) = tabd(i,lud)
716  enddo
717 
718  return
719 end subroutine cpbfdx
720 
730 subroutine mvb(ib1,nb1,ib2,nb2,nbm)
731 
732  implicit none
733 
734  integer, intent(in) :: ib1(*), nb1, nb2, nbm
735  integer, intent(out) :: ib2(*)
736  integer jb1, jb2, n, nval
737 
738  jb1 = 8*(nb1-1)
739  jb2 = 8*(nb2-1)
740 
741  do n=1,nbm
742  call upb(nval,8,ib1,jb1)
743  call pkb(nval,8,ib2,jb2)
744  enddo
745 
746  return
747 end subroutine mvb
748 
767 recursive subroutine ufbcup(lubin,lubot)
768 
769  use modv_vars, only: im8b
770 
771  use moda_usrint
772  use moda_msgcwd
773  use moda_tables
774  use moda_ivttmp
775 
776  implicit none
777 
778  integer, intent(in) :: lubin, lubot
779  integer my_lubin, my_lubot, lui, luo, il, im, ntag, ni, no, nv, nin
780 
781  character*10 tago
782 
783  ! Check for I8 integers
784 
785  if(im8b) then
786  im8b=.false.
787  call x84(lubin,my_lubin,1)
788  call x84(lubot,my_lubot,1)
789  call ufbcup(my_lubin,my_lubot)
790  im8b=.true.
791  return
792  endif
793 
794  ! Check the file statuses and inode
795 
796  call status(lubin,lui,il,im)
797  if(il==0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
798  if(il>0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
799  if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
800  if(inode(lui)/=inv(1,lui)) call bort('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// &
801  'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
802 
803  call status(lubot,luo,il,im)
804  if(il==0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
805  if(il<0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
806  if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
807 
808  ! Make a list of unique tags in the input buffer
809 
810  ntag = 0
811 
812  outer1: do ni=1,nval(lui)
813  nin = inv(ni,lui)
814  if(itp(nin)>=2) then
815  do nv=1,ntag
816  if(ttmp(nv)==tag(nin)) cycle outer1
817  enddo
818  ntag = ntag+1
819  itmp(ntag) = ni
820  ttmp(ntag) = tag(nin)
821  endif
822  enddo outer1
823 
824  if(ntag==0) call bort('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN INPUT SUBSET BUFFER')
825 
826  ! Now, using the list of unique tags, make one copy of the common elements to the output buffer
827 
828  outer2: do nv=1,ntag
829  ni = itmp(nv)
830  do no=1,nval(luo)
831  tago = tag(inv(no,luo))
832  if(ttmp(nv)==tago) then
833  val(no,luo) = val(ni,lui)
834  cycle outer2
835  endif
836  enddo
837  enddo outer2
838 
839  return
840 end subroutine ufbcup
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:202
subroutine pkb(nval, nbits, ibay, ibit)
Encode an integer value within a specified number of bits of an integer array, starting at the bit im...
Definition: ciencode.F90:140
subroutine cmpmsg(cf)
Specify whether BUFR messages output by future calls to message-writing subroutines and subset-writin...
Definition: compress.F90:33
integer function iok2cpy(lui, luo)
Check whether a BUFR message, or a data subset from within a BUFR message, can be copied from one For...
Definition: copydata.F90:355
recursive integer function icopysb(lunin, lunot)
Copy a BUFR data subset from one Fortran logical unit to another.
Definition: copydata.F90:312
subroutine cpbfdx(lud, lun)
Copy all of the DX BUFR table information from one unit to another within internal memory.
Definition: copydata.F90:678
subroutine mvb(ib1, nb1, ib2, nb2, nbm)
Copy a specified number of bytes from one packed binary array to another.
Definition: copydata.F90:731
recursive subroutine copybf(lunin, lunot)
Copy an entire BUFR file from one Fortran logical unit to another.
Definition: copydata.F90:23
recursive subroutine ufbcup(lubin, lubot)
Copy unique elements of a data subset.
Definition: copydata.F90:768
recursive subroutine copysb(lunin, lunot, iret)
Copy a BUFR data subset from one Fortran logical unit to another.
Definition: copydata.F90:203
subroutine cpyupd(lunit, lin, lun, ibyt)
Copy a BUFR data subset from one unit to another within internal memory.
Definition: copydata.F90:513
recursive subroutine cpymem(lunot)
Copy a BUFR message from internal arrays to a file.
Definition: copydata.F90:434
recursive subroutine ufbcpy(lubin, lubot)
Copy a BUFR data subset from one Fortran logical unit to another.
Definition: copydata.F90:612
recursive subroutine copymg(lunin, lunot)
Copy a BUFR message from one file to another.
Definition: copydata.F90:108
subroutine nemtba(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1247
subroutine nemtbax(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1197
subroutine dxinit(lun, ioi)
Clear out the internal arrays (in module moda_tababd) holding the DX BUFR table, then optionally init...
Definition: dxtable.F90:606
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
Declare arrays and variables used to store BUFR messages internally for multiple file IDs.
integer ibit
Bit pointer within ibay.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each file ID.
integer, dimension(:), allocatable mbyt
Length (in bytes) of current BUFR message for each file ID.
integer maxbyt
Maximum length of an output BUFR message.
Declare arrays which provide working space in several subprograms (usrtpl() and ufbcup()) which manip...
character *10, dimension(:), allocatable ttmp
tag array elements for new sections of a growing subset buffer.
integer, dimension(:), allocatable itmp
inv array elements for new sections of a growing subset buffer.
Declare an array used by various subroutines and functions to hold a temporary working copy of a BUFR...
integer, dimension(:), allocatable mgwa
Temporary working copy of BUFR message.
Declare arrays used to store information about the current BUFR message that is in the process of bei...
integer, dimension(:), allocatable inode
Table A mnemonic for type of BUFR message.
integer, dimension(:), allocatable idate
Section 1 date-time of message.
integer, dimension(:), allocatable nmsg
Current message pointer within logical unit.
integer, dimension(:), allocatable msub
Total number of data subsets in message.
integer, dimension(:), allocatable nsub
Current subset pointer within message.
Declare arrays and variables used to store the contents of one or more BUFR files within internal mem...
integer munit
Fortran logical unit number for use in accessing contents of BUFR files within internal memory.
Declare arrays and variables used to store DX BUFR tables internally for multiple file IDs.
integer, dimension(:), allocatable ntba
Number of Table A entries for each file ID (up to a maximum of maxtba, whose value is stored in array...
character *600, dimension(:,:), allocatable tabd
Table D entries for each file ID.
character *128, dimension(:,:), allocatable taba
Table A entries for each file ID.
integer, dimension(:,:), allocatable mtab
Entries within jump/link table corresponding to taba.
integer, dimension(:,:,:), allocatable idna
Message types (in array element 1) and subtypes (in array element 2) corresponding to taba.
integer, dimension(:), allocatable ntbd
Number of Table D entries for each file ID (up to a maximum of maxtbd, whose value is stored in array...
integer, dimension(:), allocatable ntbb
Number of Table B entries for each file ID (up to a maximum of maxtbb, whose value is stored in array...
integer, dimension(:,:), allocatable idnd
WMO bit-wise representations of the FXY values corresponding to tabd.
integer, dimension(:,:), allocatable idnb
WMO bit-wise representations of the FXY values corresponding to tabb.
character *128, dimension(:,:), allocatable tabb
Table B entries for each file ID.
Declare arrays and variables used to store the internal jump/link table.
integer, dimension(:), allocatable irf
Reference values corresponding to tag and typ:
integer, dimension(:), allocatable isc
Scale factors corresponding to tag and typ:
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Declare an array used to store, for each file ID, the logical unit number corresponding to a separate...
integer, dimension(:), allocatable luncpy
Logical unit numbers used to copy long character strings between BUFR data subsets.
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
real *8, dimension(:,:), allocatable, target val
Data values.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
integer, dimension(:,:), allocatable nrfelm
Referenced data value, for data values which refer to a previous data value in the BUFR data subset v...
recursive subroutine closbf(lunit)
Close the connection between logical unit lunit and the NCEPLIBS-bufr software.
recursive subroutine openbf(lunit, io, lundx)
Connect a new file to the NCEPLIBS-bufr software for input or output operations, or initialize the li...
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
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.
subroutine rdmsgw(lunit, mesg, iret)
Read the next BUFR message from logical unit lunit as an array of integer words.
subroutine msgini(lun)
Initialize, within the internal arrays, a new uncompressed BUFR message for output.
subroutine msgwrt(lunit, mesg, mgbyt)
Perform final checks and updates on a BUFR message before writing it to a specified Fortran logical u...
recursive subroutine writsb(lunit)
Write a complete data subset into a BUFR message, for eventual output to logical unit lunit.
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
Definition: readwritesb.F90:32
recursive integer function iupbs01(mbay, s01mnem)
Read a specified value from within Section 0 or Section 1 of a BUFR message.
Definition: s013vals.F90:247
recursive subroutine mesgbc(lunin, mesgtyp, icomp)
Return the message type (from Section 1) and message compression indicator (from Section 3) of a BUFR...
Definition: s013vals.F90:1482
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x4884.F90:18
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65