21 recursive real*8 function pkftbv(nbits,ibit)
result(r8val)
23 use modv_vars,
only: im8b, bmiss
27 integer,
intent(in) :: nbits, ibit
28 integer my_nbits, my_ibit
35 call x84(nbits,my_nbits,1)
36 call x84(ibit,my_ibit,1)
37 r8val=
pkftbv(my_nbits,my_ibit)
43 if((nbits<=0).or.(ibit<=0).or.(ibit>nbits))
then
46 r8val = (2.)**(nbits-ibit)
69 recursive subroutine upftbv(lunit,nemo,val,mxib,ibit,nib)
71 use modv_vars,
only: im8b
77 integer,
intent(in) :: lunit, mxib
78 integer,
intent(out) :: ibit(*), nib
79 integer my_lunit, my_mxib, lun, il, im, idn, i, n, nbits, iersn
81 character*(*),
intent(in) :: nemo
82 character*128 bort_str
85 real*8,
intent(in) :: val
93 call x84(lunit,my_lunit,1)
94 call x84(mxib,my_mxib,1)
95 call upftbv( my_lunit, nemo, val, my_mxib*2, ibit, nib )
96 call x48(ibit(1),ibit(1),nib)
105 call status(lunit,lun,il,im)
106 if(il==0)
call bort(
'BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
108 call nemtab(lun,nemo,idn,tab,n)
110 write(bort_str,
'("BUFRLIB: UPFTBV - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
113 if(
tabb(n,lun)(71:74)/=
'FLAG')
then
114 write(bort_str,
'("BUFRLIB: UPFTBV - MNEMONIC ",A," IS NOT A FLAG TABLE")') nemo
125 if(abs(r8val-r82i)<(0.005))
then
127 if(nib>mxib)
call bort(
'BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
130 elseif(r82i<r8val)
then
132 if(nib>mxib)
call bort(
'BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
219 recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng, iret )
223 use modv_vars,
only: im8b
230 integer,
intent(in) :: lunit, ivali, ivald
231 integer,
intent(out) :: lnmng, iret
232 integer ifxyd(10), my_lunit, my_ivali, my_ivald, lun, il, im, itmp, ii, ifxyi, lcmg, n, ntg, iret2, ierbd,
ifxy,
ireadmt
234 character*(*),
intent(in) :: nemoi, nemod
235 character*(*),
intent(out) :: cmeang
236 character*128 bort_str
237 character*8 nemo, my_nemoi, my_nemod
245 call x84(lunit,my_lunit,1)
246 call x84(ivali,my_ivali,1)
247 call x84(ivald,my_ivald,1)
248 call getcfmng(my_lunit,nemoi,my_ivali,nemod,my_ivald,cmeang,lnmng,iret)
249 call x48(lnmng,lnmng,1)
250 call x48(iret,iret,1)
256 call status ( lunit, lun, il, im )
257 if ( il == 0 )
call bort(
'BUFRLIB: GETCFMNG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
258 if ( il > 0 )
call bort(
'BUFRLIB: GETCFMNG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
259 if ( im == 0 )
call bort(
'BUFRLIB: GETCFMNG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
263 if (
cdmf /=
'Y' )
call bort(
'BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// &
264 'FIRST CALL SUBROUTINE CODFLG WITH INPUT ARGUMENT SET TO Y')
275 do ii = 1, min( 8, len( nemoi ) )
276 my_nemoi(ii:ii) = nemoi(ii:ii)
279 do ii = 1, min( 8, len( nemod ) )
280 my_nemod(ii:ii) = nemod(ii:ii)
282 if ( my_nemoi(1:4) ==
'GSES' )
then
283 if ( ( my_nemod(1:6) ==
'GCLONG' ) .or. ( my_nemod(1:4) ==
'OGCE' ) .or. ( my_nemod(1:5) ==
'ORIGC' ) )
then
284 ifxyi =
ifxy(
'001034' )
285 ifxyd(1) =
ifxy(
'001035' )
287 lnmng = min( 24, lcmg )
288 if ( lnmng == 24 )
then
290 cmeang(1:24) =
'GCLONG OGCE ORIGC '
296 else if ( my_nemoi(1:6) ==
'GCLONG' )
then
297 ifxyi =
ifxy(
'001031' )
299 else if ( my_nemoi(1:4) ==
'OGCE' )
then
300 ifxyi =
ifxy(
'001033' )
302 else if ( my_nemoi(1:5) ==
'ORIGC' )
then
303 ifxyi =
ifxy(
'001035' )
305 else if ( ( my_nemoi(1:7) ==
'TABLASS' ) .or. ( my_nemoi(1:7) ==
'TABLASL' ) )
then
306 if ( ( my_nemod(1:6) ==
'TABLAT' ) )
then
307 if ( my_nemoi(1:7) ==
'TABLASS' )
then
308 ifxyi =
ifxy(
'055021' )
310 ifxyi =
ifxy(
'055022' )
312 ifxyd(1) =
ifxy(
'055020' )
314 lnmng = min( 8, lcmg )
315 if ( lnmng == 8 )
then
317 cmeang(1:8) =
'TABLAT '
323 else if ( my_nemoi(1:6) ==
'TABLAT' )
then
324 ifxyi =
ifxy(
'055020' )
327 call parstr ( my_nemoi, nemo, 1, ntg,
' ', .true. )
328 call nemtab ( lun, nemo, ifxyi, tab, n )
329 if ( ( n == 0 ) .or. ( tab /=
'B' ) )
then
330 write(bort_str,
'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
333 if ( (
tabb( n, lun )(71:74) /=
'CODE' ) .and. (
tabb( n, lun )(71:74) /=
'FLAG' ) )
then
334 write(bort_str,
'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo
337 if ( my_nemod(1:1) /=
' ' )
then
338 call parstr ( my_nemod, nemo, 1, ntg,
' ', .true. )
339 call nemtab ( lun, nemo, ifxyd(1), tab, n )
340 if ( ( n == 0 ) .or. ( tab /=
'B' ) )
then
341 write(bort_str,
'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
344 if ( (
tabb( n, lun )(71:74) /=
'CODE' ) .and. (
tabb( n, lun )(71:74) /=
'FLAG' ) )
then
345 write(bort_str,
'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo
355 call srchtbf_c ( ifxyi, ivali, ifxyd(1), 10, ivald, cmeang, lcmg, lnmng, iret )
356 if ( iret <= 0 )
return
364 call numtbd ( lun, ifxyd(ii), nemo, tab, ierbd )
365 if ( ( ierbd > 0 ) .and. ( tab ==
'B' ) .and. ( lcmg >= ( lnmng + 8 ) ) )
then
367 cmeang(lnmng+1:lnmng+8) = nemo
371 if ( iret == 0 ) iret = -1
395 recursive subroutine ufbqcd(lunit,nemo,iqcd)
397 use modv_vars,
only: im8b
401 integer,
intent(in) :: lunit
402 integer,
intent(out) :: iqcd
403 integer my_lunit, lun, il, im, idn, iret
405 character*(*),
intent(in) :: nemo
406 character*128 bort_str
407 character*6 fxy,
adn30
414 call x84(lunit,my_lunit,1)
415 call ufbqcd(my_lunit,nemo,iqcd)
416 call x48(iqcd,iqcd,1)
421 call status(lunit,lun,il,im)
422 if(il==0)
call bort(
'BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
424 call nemtab(lun,nemo,idn,tab,iret)
426 write(bort_str,
'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') nemo
431 if(fxy(2:3)/=
'63')
then
432 write(bort_str,
'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// &
433 'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," - CATEGORY MUST BE 63")') nemo, fxy(2:3)
436 read(fxy(4:6),
'(I3)') iqcd
455 recursive subroutine ufbqcp(lunit,iqcp,nemo)
457 use modv_vars,
only: im8b
461 integer,
intent(in) :: lunit, iqcp
462 integer my_lunit, my_iqcp, lun, il, im, idn, iret,
ifxy
464 character*(*),
intent(out) :: nemo
471 call x84(lunit,my_lunit,1)
472 call x84(iqcp,my_iqcp,1)
473 call ufbqcp(my_lunit,my_iqcp,nemo)
478 call status(lunit,lun,il,im)
479 if(il==0)
call bort(
'BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
481 idn =
ifxy(
'363000')+iqcp
482 call numtab(lun,idn,nemo,tab,iret)
subroutine bort(str)
Log an error message, then abort the application program.
recursive real *8 function pkftbv(nbits, ibit)
Compute the numerical value equivalent to the setting of bit #(ibit) within a flag table of nbits bit...
recursive subroutine ufbqcd(lunit, nemo, iqcd)
Given a mnemonic associated with a category 63 Table D descriptor from an NCEP prepbufr file,...
recursive subroutine ufbqcp(lunit, iqcp, nemo)
Given an event program code, which is equivalent to the Y value of a category 63 Table D descriptor f...
recursive subroutine upftbv(lunit, nemo, val, mxib, ibit, nib)
Given a Table B mnemonic with flag table units and a corresponding numerical data value,...
recursive subroutine getcfmng(lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng, iret)
Decode the meaning of a numerical value from a code or flag table.
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
subroutine numtab(lun, idn, nemo, tab, iret)
Get information about a descriptor, based on the WMO bit-wise representation of an FXY value.
subroutine numtbd(lun, idn, nemo, tab, iret)
Get information about a Table B or Table D descriptor, based on the WMO bit-wise representation of an...
integer function ifxy(adsc)
Convert an FXY value from its 6 character representation to its WMO bit-wise representation.
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 ireadmt(lun)
Check the most recent BUFR message that was read via a call to one of the message-reading subroutines...
recursive subroutine strnum(str, num, iret)
Decode an integer from a character string.
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 DX BUFR tables internally for multiple file IDs.
character *128, dimension(:,:), allocatable tabb
Table B entries for each file ID.
Declare a variable used to indicate whether master code and flag tables should be read.
character cdmf
Flag indicating whether to include code and flag table information during reads of master BUFR tables...
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
subroutine parstr(str, tags, mtag, ntag, sep, limit80)
Parse a string containing one or more substrings into an array of substrings.
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.