41 character*1,
intent(in) :: cf
42 character*128 bort_str
45 if(cf/=
'Y'.and. cf/=
'N')
then
46 write(bort_str,
'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf
72 recursive subroutine stndrd(lunit,msgin,lmsgot,msgot)
76 use modv_vars,
only: im8b, nbytw
82 integer,
intent(in) :: msgin(*), lunit, lmsgot
83 integer,
intent(out) :: msgot(*)
84 integer my_lunit, my_lmsgot, lun, il, im, len0, len1, len2, len3, len4, len5
85 integer iad3, iad4, lenn, lenm,
iupbs01,
iupbs3,
iupb, mxbyto, lbyto, ii, isub, itab, mtyp, msbt, inod
86 integer istdesc, ncd, iben, ibit, jbit, kbit, mbit, nad4, lsub, nsub, islen, kval, nval, i, k, l, n
88 character*128 bort_str
92 character*(*),
parameter :: bort_arrayoverflow = &
93 'BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY'
102 call x84 ( lunit, my_lunit, 1 )
103 call x84 ( lmsgot, my_lmsgot, 1 )
104 call stndrd ( my_lunit, msgin, my_lmsgot*2, msgot )
112 call status(lunit,lun,il,im)
113 if(il==0)
call bort(
'BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
117 call getlens(msgin,5,len0,len1,len2,len3,len4,len5)
119 iad3 = len0+len1+len2
122 lenn = len0+len1+len2+len3+len4+len5
127 write(bort_str,
'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL '// &
128 'SECTION LENGTHS (",I6,")")') lenm,lenn
133 call upc(sevn,4,msgin,mbit,.true.)
134 if(sevn/=
'7777')
then
135 write(bort_str,
'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT END WITH ""7777"" (ENDS WITH ",A)') sevn
141 mxbyto = (lmsgot*nbytw) - 8
144 if(lbyto>mxbyto)
call bort(bort_arrayoverflow)
145 call mvb(msgin,1,msgot,1,lbyto)
151 do while ((.not.found).and.(ii>=8))
152 isub =
iupb(msgin,iad3+ii,16)
153 call numtab(lun,isub,subset,tab,itab)
154 if((itab/=0).and.(tab==
'D'))
then
155 call nemtbax(lun,subset,mtyp,msbt,inod)
156 if(inod/=0) found = .true.
160 if(.not.found)
call bort(
'BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR NOT FOUND')
178 lbyto = lbyto + len3 - 7
179 if(lbyto>mxbyto)
call bort(bort_arrayoverflow)
185 call pkb(
ids3(n),16,msgot,ibit)
191 call pkb(0,8,msgot,ibit)
197 call pkb(len3,24,msgot,ibit)
201 if(
iupbs3(msgin,
'ICMP')==1)
then
205 if((lbyto+len4+4)>mxbyto)
call bort(bort_arrayoverflow)
207 call mvb(msgin,iad4+1,msgot,lbyto+1,len4)
208 jbit = (lbyto+len4)*8
221 nsub =
iupbs3(msgin,
'NSUB')
223 subset_copy:
do i=1,nsub
224 call upb(lsub,16,msgin,ibit)
231 islen = iad4+len4-(ibit/8)
232 if (mod(len4,2)==0) islen = islen - 1
235 call upb(nval,8,msgin,ibit)
237 if(lbyto>mxbyto)
call bort(bort_arrayoverflow)
238 call pkb(nval,8,msgot,jbit)
242 call upb(kval,8,msgin,kbit)
248 call bort(
'BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 FROM INPUT TO OUTPUT (STANDARD) MESSAGE')
255 if(lbyto+6>mxbyto)
call bort(bort_arrayoverflow)
259 do while(.not.(mod(jbit,8)==0))
260 call pkb(0,1,msgot,jbit)
266 if( (iben<4) .and. (mod(jbit/8,2)/=0) )
then
267 call pkb(0,8,msgot,jbit)
272 call pkb(len4,24,msgot,ibit)
273 call pkb(0,8,msgot,ibit)
279 lenn = len0+len1+len2+len3+len4+len5
280 call pkb(lenn,24,msgot,ibit)
282 call pkc(
'7777',4,msgot,jbit)
297 integer function istdesc( idn )
result( iret )
301 integer,
intent(in) :: idn
304 character*6 adsc,
adn30
306 adsc =
adn30( idn, 6 )
308 read(adsc,
'(I1,I2,I3)')
if,ix,iy
312 else if (
if == 2 )
then
315 else if ( ( ix < 48 ) .and. ( iy < 192 ) )
then
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,...
recursive integer function iupb(mbay, nbyt, nbit)
Decode an 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 pkc(chr, nchr, ibay, ibit)
Encode a character string within a specified number of bytes of an integer array, starting at the bit...
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...
subroutine mvb(ib1, nb1, ib2, nb2, nbm)
Copy a specified number of bytes from one packed binary array to another.
subroutine nemtbax(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
subroutine numtab(lun, idn, nemo, tab, iret)
Get information about a descriptor, based on the WMO bit-wise representation of an FXY value.
character *(*) function adn30(idn, ldn)
Convert an FXY value from its WMO bit-wise representation to a character string of length 5 or 6.
integer function iokoper(nemo)
Check whether a specified mnemonic is a Table C operator supported by the NCEPLIBS-bufr software.
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Declare a variable used to indicate whether output BUFR messages should be standardized.
character csmf
Flag indicating whether BUFR output messages are to be standardized; this variable is initialized to ...
Declare arrays used by various subroutines and functions to hold a temporary working copy of a Sectio...
integer, dimension(:), allocatable ids3
Temporary working copy of Section 3 descriptor list in integer form.
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.
recursive integer function iupbs01(mbay, s01mnem)
Read a specified value from within Section 0 or Section 1 of a BUFR message.
recursive integer function iupbs3(mbay, s3mnem)
Read a specified value from within Section 3 of a BUFR message.
subroutine stdmsg(cf)
Specify whether BUFR messages output by future calls to message-writing subroutines and subset-writin...
recursive subroutine stndrd(lunit, msgin, lmsgot, msgot)
Standardize a BUFR message.
integer function istdesc(idn)
Given the WMO bit-wise representation of an FXY value for a descriptor, check whether the descriptor ...
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.