15 recursive subroutine fortran_open(filename, lunit, format, position, iret)
17 use modv_vars,
only: im8b
20 character*(*),
intent(in) :: filename, format, position
21 integer,
intent(in) :: lunit
22 integer,
intent(out) :: iret
30 call x84(lunit,my_lunit,1)
31 call fortran_open(filename,my_lunit,
format,position,iret)
38 open(lunit, file=trim(filename), form=trim(format), position=trim(position), iostat=iret)
50 use modv_vars,
only: im8b
53 integer,
intent(in) :: lunit
54 integer,
intent(out) :: iret
62 call x84(lunit,my_lunit,1)
70 close(lunit, iostat=iret)
168 recursive subroutine openbf(lunit,io,lundx)
172 use modv_vars,
only: im8b, ifopbf, nfiles
183 integer,
intent(in) :: lunit, lundx
184 integer my_lunit, my_lundx, iprt, iprtprv, lun, il, im
186 character*(*),
intent(in) :: io
187 character*255 filename, fileacc
188 character*128 bort_str, errstr
189 character*28 cprint(0:4)
195 ' (limited -default) ', &
196 ' (all warnings) ', &
197 ' (all warnings+infos) ', &
198 ' (all warnings+infos+debugs)'/
205 call x84(lunit,my_lunit,1)
206 call x84(lundx,my_lundx,1)
207 call openbf(my_lunit,io,my_lundx)
215 if(ifopbf==0) iprt = 0
221 if(iprt<-1) iprt = -1
224 call errwrt(
'++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
225 write ( unit=errstr, fmt=
'(A,I3,A,A,I3,A)' )
'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR CHNGED FROM', &
226 iprtprv,cprint(iprtprv+1),
' TO',iprt,cprint(iprt+1)
228 call errwrt(
'++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
246 if( (io==
'FIRST') .or. (io==
'QUIET') )
return
250 call status(lunit,lun,il,im)
252 write(bort_str,
'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3," BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') &
257 write(bort_str,
'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT",I5," IS ALREADY OPEN")') lunit
267 if (io/=
'NUL' .and. io/=
'INUL')
then
268 inquire(lunit,access=fileacc)
269 if(fileacc==
'UNDEFINED')
open(lunit)
270 inquire(lunit,name=filename)
271 filename=trim(filename)//char(0)
284 call wtstat(lunit,lun,-1,0)
285 call readdx(lunit,lun,lundx)
286 else if(io==
'INUL')
then
287 call wtstat(lunit,lun,-1,0)
288 if(lunit/=lundx)
call readdx(lunit,lun,lundx)
290 else if(io==
'NUL')
then
291 call wtstat(lunit,lun,1,0)
292 if(lunit/=lundx)
call readdx(lunit,lun,lundx)
294 else if(io==
'INX')
then
296 call wtstat(lunit,lun,-1,0)
298 else if(io==
'OUX')
then
300 call wtstat(lunit,lun,1,0)
301 else if(io==
'SEC3')
then
303 call wtstat(lunit,lun,-1,0)
305 else if(io==
'OUT')
then
307 call wtstat(lunit,lun,1,0)
308 call writdx(lunit,lun,lundx)
309 else if(io==
'NODX')
then
311 call wtstat(lunit,lun,1,0)
312 call readdx(lunit,lun,lundx)
313 else if(io==
'APN' .or. io==
'APX')
then
315 call wtstat(lunit,lun,1,0)
316 if(lunit/=lundx)
call readdx(lunit,lun,lundx)
319 call bort(
'BUFRLIB: OPENBF - ILLEGAL SECOND (INPUT) ARGUMENT')
341 use modv_vars,
only: im8b
349 integer,
intent(in) :: lunit
350 integer my_lunit, lun, il, im
357 call x84(lunit,my_lunit,1)
364 if ( .not.
allocated(
null) )
then
365 call errwrt(
'++++++++++++++++++++WARNING++++++++++++++++++++++')
366 errstr =
'BUFRLIB: CLOSBF WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
368 call errwrt(
'++++++++++++++++++++WARNING++++++++++++++++++++++')
372 call status(lunit,lun,il,im)
373 if(il>0 .and. im/=0)
call closmg(lunit)
375 call wtstat(lunit,lun,0,0)
379 if(
null(lun)==0)
close(lunit)
405 recursive subroutine status(lunit,lun,il,im)
407 use modv_vars,
only: im8b, nfiles
413 integer,
intent(in) :: lunit
414 integer,
intent(out) :: lun, il, im
417 character*128 bort_str, errstr
424 call x84(lunit,my_lunit,1)
425 call status(my_lunit,lun,il,im)
434 if(lunit<=0 .or. lunit>99)
then
435 write(bort_str,
'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") OUTSIDE LEGAL RANGE OF 1-99")') lunit
447 if ( .not.
allocated(
iolun) )
then
448 call errwrt(
'++++++++++++++++++++WARNING++++++++++++++++++++++')
449 errstr =
'BUFRLIB: STATUS WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
451 call errwrt(
'++++++++++++++++++++WARNING++++++++++++++++++++++')
456 if(abs(
iolun(i))==lunit) lun = i
475 il = sign(1,
iolun(lun))
514 integer,
intent(in) :: lunit, lun, il, im
516 character*128 bort_str
521 write(bort_str,
'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED INTO FIRST ARGUMENT (INPUT) (=",I3,")")') lunit
525 write(bort_str,
'("BUFRLIB: WTSTAT - INVALID FILE ID PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') lun
528 if(il<-1 .or. il>1)
then
529 write(bort_str,
'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS INDICATOR PASSED INTO THIRD ARGUMENT '// &
530 '(INPUT) (=",I4,")")') il
533 if(im< 0 .or. im>1)
then
534 write(bort_str,
'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS INDICATOR PASSED INTO FOURTH ARGUMENT '// &
535 '(INPUT) (=",I4,")")') im
541 if(abs(
iolun(lun))/=lunit .and. (
iolun(lun)/=0))
then
542 write(bort_str,
'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE EXISTING FILE UNIT (LOGICAL UNIT '// &
543 'NUMBER ",I3,")")')
iolun(lun)
550 iolun(lun) = sign(lunit,il)
585 recursive subroutine ufbcnt(lunit,kmsg,ksub)
587 use modv_vars,
only: im8b
593 integer,
intent(in) :: lunit
594 integer,
intent(out) :: kmsg, ksub
595 integer my_lunit, lun, il, im
601 call x84(lunit,my_lunit,1)
602 call ufbcnt(my_lunit,kmsg,ksub)
603 call x48(kmsg,kmsg,1)
604 call x48(ksub,ksub,1)
611 call status(lunit,lun,il,im)
612 if(il==0)
call bort(
'BUFRLIB: UFBCNT - BUFR FILE IS CLOSED, IT MUST BE OPEN FOR EITHER INPUT OR OUTPUT')
638 integer,
intent(in) :: lunxx
639 integer lunit, lun, il, im, ier, idxmsg
643 call status(lunit,lun,il,im)
644 if(il==0)
call bort(
'BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
645 if(il<0)
call bort(
'BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
652 if(idxmsg(
mgwa)==1)
then
703 integer,
intent(in) :: lunit, isr
704 integer lun, il, im, i, kdate, ier
706 character*128 bort_str
711 call status(lunit,lun,il,im)
713 write(bort_str,
'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
714 'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED (AND NOT YET RESTORED) (UNIT",I3,")")') lunit
718 write(bort_str,
'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
719 'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT OR OUTPUT) (UNIT",I3,")")') lunit
724 write(bort_str,
'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// &
725 'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') lunit
730 write(bort_str,
'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// &
731 'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') isr, lunit
751 call wtstat(lunit,lun,-1,0)
767 call readmg(lunit,subset,kdate,ier)
769 write(bort_str,
'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// &
770 'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE NO.",I5)') lunit,
jmsg
793 call wtstat(lunit,lun,il,im)
797 jsr(lun) = mod(
jsr(lun)+1,2)
856 recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str)
858 use modv_vars,
only: im8b, bmiss, iac
868 integer*8 ival, lref, ninc, mps, lps
869 integer,
intent(in) :: lunin, i1, i2
870 integer,
intent(out) :: iret
871 integer,
parameter :: maxtg = 100
872 integer nnod, ncon, nods, nodc, ivls, kons, iprt, my_lunin, my_i1, my_i2, lunit, lun, il, im, irec, isub, i, j, n, ntg, &
873 jdate, jbit, kbit, lbit, mbit, nbit, nibit, nbyt, nsb, node, nbmp, nrep, lret, linc, iac_prev, ityp, &
876 character*(*),
intent(in) :: str
879 character*10 tgs(maxtg)
880 character*8 subset, cval
882 logical openit, overflow, just_count, need_node
884 real*8,
intent(out) :: tab(i1,i2)
887 common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
890 equivalence(cval,rval)
893 mps(node) = 2_8**(
ibt(node))-1
894 lps(lbit) = max(2_8**(lbit)-1,1)
899 call x84(lunin,my_lunin,1)
902 call ufbtab(my_lunin,tab,my_i1,my_i2,iret,str)
903 call x48(iret,iret,1)
913 call status(lunit,lun,il,im)
918 call openbf(lunit,
'INX',lunit)
942 just_count = lunin<lunit
944 do while(
ireadmg(-lunit,subset,jdate)>=0)
945 iret = iret+
nmsub(lunit)
949 call parstr(str,tgs,maxtg,ntg,
' ',.true.)
951 if(tgs(i)==
'IREC') irec = i
952 if(tgs(i)==
'ISUB') isub = i
956 outer:
do while (.not. just_count)
958 if(
ireadmg(-lunit,subset,jdate)<0)
exit
960 if(irec>0) nods(irec) = 0
961 if(isub>0) nods(isub) = 0
966 inner1:
do while (.true.)
968 if(
nsub(lun)==
msub(lun)) cycle outer
975 nods(i) = abs(nods(i))
978 mbit =
mbyt(lun)*8 + 16
985 inner2:
do while (.true.)
987 if(n+1<=
nval(lun))
then
992 if(
itp(node)==1)
then
993 call upb8(ival,nbit,mbit,
mbay(1,lun))
998 if(nods(i)==node)
then
999 if(
itp(node)==1)
then
1000 call upb8(ival,nbit,mbit,
mbay(1,lun))
1002 elseif(
itp(node)==2)
then
1003 call upb8(ival,nbit,mbit,
mbay(1,lun))
1004 if(ival<mps(node)) tab(i,iret) =
ups(ival,node)
1005 elseif(
itp(node)==3)
then
1008 call upc(cval,nbit/8,
mbay(1,lun),kbit,.true.)
1016 if(nods(i)>0) cycle inner2
1030 if(irec>0) tab(irec,iret) =
nmsg(lun)
1031 if(isub>0) tab(isub,iret) =
nsub(lun)
1037 if(iret+
msub(lun)>i2)
then
1041 if(irec>0.or.isub>0)
then
1043 if(irec>0) tab(irec,iret+nsb) =
nmsg(lun)
1044 if(isub>0) tab(isub,iret+nsb) = nsb
1050 inner3:
do n = n+1,
nval(lun)
1058 nods(i) = abs(nods(i))
1069 if(.not. need_node)
exit inner3
1071 if(ityp==1 .or. ityp==2)
then
1075 elseif(ityp==3)
then
1086 call up8(ninc,linc,
mbay(1,lun),jbit)
1088 call usrtpl(lun,n,int(ival))
1092 if(node==nods(i))
then
1096 if(ityp==1 .or. ityp==2)
then
1098 jbit =
ibit + linc*(nsb-1)
1099 call up8(ninc,linc,
mbay(1,lun),jbit)
1102 if(ninc<lps(linc)) tab(i,lret) =
ups(ival,node)
1104 elseif(ityp==3)
then
1109 jbit =
ibit + linc*(nsb-1)*8
1111 call upc(cval,linc,
mbay(1,lun),jbit,.true.)
1117 call bort(
'UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
1123 iret = iret+
msub(lun)
1134 do while(
ireadmg(-lunit,subset,jdate)>=0)
1135 nrep = nrep+
nmsub(lunit)
1138 call errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1139 write ( unit=errstr, fmt=
'(A,A,I8,A)' )
'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', &
1140 .GT.
'IS LIMIT OF ', i2,
' IN THE 4TH ARG. (INPUT) - INCOMPLETE READ'
1142 write ( unit=errstr, fmt=
'(A,I8,A,I8,A)' )
'>>>UFBTAB STORED ', iret,
' REPORTS OUT OF ', nrep,
'<<<'
1144 call errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
subroutine arallocf
Dynamically allocate Fortran language arrays.
subroutine bort(str)
Log an error message, then abort the application program.
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
subroutine upb8(nval, nbits, ibit, ibay)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
real *8 function ups(ival, node)
Unpack a real*8 value from an integer by applying the proper scale and reference values.
subroutine up8(nval, nbits, ibay, ibit)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
subroutine upc(chr, nchr, ibay, ibit, cnvnull)
Decode a character string from within a specified number of bytes of an integer array,...
subroutine writdx(lunit, lun, lundx)
Write DX BUFR table (dictionary) messages to the beginning of an output BUFR file in lunit.
subroutine readdx(lunit, lun, lundx)
Initialize modules moda_tababd and moda_msgcwd with DX BUFR (dictionary) tables.
subroutine rdbfdx(lunit, lun)
Beginning at the current file pointer location within lunit, read a complete DX BUFR table into inter...
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
subroutine bfrini
Initialize numerous global variables and arrays within internal modules and COMMON blocks throughout ...
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
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.
Declare arrays and variables needed to store the current position within a BUFR file.
integer jill
File status indicator of BUFR file.
integer jimm
Message status indicator of BUFR file.
integer, dimension(:), allocatable jsr
Indicator of stack status when entering subroutine rewnbf().
integer jmsg
Sequential number of BUFR message, counting from the beginning of the file.
integer jbit
Bit pointer within BUFR message.
integer jsub
Sequential number of BUFR data subset, counting from the beginning of the current BUFR message.
integer junn
File ID of BUFR file.
integer jbyt
Length (in bytes) of BUFR message.
integer, dimension(:), allocatable jbay
BUFR message.
Declare an array used by subroutine makestab() to keep track of which logical units share DX BUFR tab...
integer, dimension(:), allocatable lus
Tracking index for each file ID.
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 an array used to store a switch for each file ID, indicating whether any BUFR messages should...
integer, dimension(:), allocatable null
Output switch for each file ID:
Declare an array used to store a switch for each file ID, indicating whether BUFR messages read from ...
integer, dimension(:), allocatable isc3
Section 3 switch for each file ID:
Declare arrays used to store file and message status indicators for all logical units that have been ...
integer, dimension(:), allocatable iolun
File status indicators.
integer, dimension(:), allocatable iomsg
Message status indicator corresponding to iolun, denoting whether a BUFR message is currently open wi...
Declare an array used to store a status code for each file ID if an error or other abnormal result oc...
integer, dimension(:), allocatable iscodes
Abnormal status codes.
Declare arrays and variables used to store the internal jump/link table.
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Declare an array used to store, for each file ID from which a BUFR message is currently being read as...
integer, dimension(:), allocatable msgunp
Flag indicating how to unpack data subsets from BUFR message:
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.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
recursive subroutine closbf(lunit)
Close the connection between logical unit lunit and the NCEPLIBS-bufr software.
subroutine rewnbf(lunit, isr)
Store or restore parameters associated with a BUFR file.
recursive subroutine fortran_open(filename, lunit, format, position, iret)
Open a Fortran file on the local system.
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 fortran_close(lunit, iret)
Close a Fortran file on the local system.
recursive subroutine ufbcnt(lunit, kmsg, ksub)
Get the current location of the file pointer within a BUFR file, in terms of a message number countin...
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
subroutine wtstat(lunit, lun, il, im)
Update file status in library internals.
recursive subroutine ufbtab(lunin, tab, i1, i2, iret, str)
Read through every data subset in a BUFR file and return one or more specified data values from each ...
subroutine posapx(lunxx)
Position an output BUFR file for appending.
recursive subroutine closmg(lunin)
Close the BUFR message that is currently open for writing within internal arrays associated with logi...
recursive integer function nmsub(lunit)
Get the total number of data subsets available within the BUFR message that was most recently opened ...
recursive subroutine readmg(lunxx, subset, jdate, iret)
Read the next BUFR message from logical unit abs(lunxx) into internal arrays.
subroutine rdmsgw(lunit, mesg, iret)
Read the next BUFR message from logical unit lunit as an array of integer words.
recursive integer function ireadmg(lunit, subset, idate)
Call subroutine readmg() and pass back its return code as the function value.
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
recursive integer function ireadsb(lunit)
Call subroutine readsb() and pass back its return code as the function value.
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
subroutine parstr(str, tags, mtag, ntag, sep, limit80)
Parse a string containing one or more substrings into an array of substrings.
subroutine string(str, lun, i1, io)
Check whether a string is in the internal mnemonic string cache.
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.