NCEPLIBS-bufr  12.1.0
cftbvs.F90
Go to the documentation of this file.
1 
5 
21 recursive real*8 function pkftbv(nbits,ibit) result(r8val)
22 
23  use modv_vars, only: im8b, bmiss
24 
25  implicit none
26 
27  integer, intent(in) :: nbits, ibit
28  integer my_nbits, my_ibit
29 
30  ! Check for I8 integers.
31 
32  if(im8b) then
33  im8b=.false.
34 
35  call x84(nbits,my_nbits,1)
36  call x84(ibit,my_ibit,1)
37  r8val=pkftbv(my_nbits,my_ibit)
38 
39  im8b=.true.
40  return
41  endif
42 
43  if((nbits<=0).or.(ibit<=0).or.(ibit>nbits)) then
44  r8val = bmiss
45  else
46  r8val = (2.)**(nbits-ibit)
47  endif
48 
49  return
50 end function pkftbv
51 
69 recursive subroutine upftbv(lunit,nemo,val,mxib,ibit,nib)
70 
71  use modv_vars, only: im8b
72 
73  use moda_tababd
74 
75  implicit none
76 
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
80 
81  character*(*), intent(in) :: nemo
82  character*128 bort_str
83  character tab
84 
85  real*8, intent(in) :: val
86  real*8 r8val, r82i
87 
88  ! Check for I8 integers.
89 
90  if(im8b) then
91  im8b=.false.
92 
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)
97  call x48(nib,nib,1)
98 
99  im8b=.true.
100  return
101  endif
102 
103  ! Perform some sanity checks.
104 
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')
107 
108  call nemtab(lun,nemo,idn,tab,n)
109  if(n==0) then
110  write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
111  call bort(bort_str)
112  endif
113  if(tabb(n,lun)(71:74)/='FLAG') then
114  write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," IS NOT A FLAG TABLE")') nemo
115  call bort(bort_str)
116  endif
117 
118  ! Figure out which bits are set.
119 
120  nib = 0
121  r8val = val
122  call strnum(tabb(n,lun)(110:112),nbits,iersn)
123  do i=(nbits-1),0,-1
124  r82i = (2.)**i
125  if(abs(r8val-r82i)<(0.005)) then
126  nib = nib + 1
127  if(nib>mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
128  ibit(nib) = nbits-i
129  return
130  elseif(r82i<r8val) then
131  nib = nib + 1
132  if(nib>mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
133  ibit(nib) = nbits-i
134  r8val = r8val - r82i
135  endif
136  enddo
137 
138  return
139 end subroutine upftbv
140 
219 recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng, iret )
220 
221  use bufrlib
222 
223  use modv_vars, only: im8b
224 
225  use moda_tababd
226  use moda_tablef
227 
228  implicit none
229 
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
233 
234  character*(*), intent(in) :: nemoi, nemod
235  character*(*), intent(out) :: cmeang
236  character*128 bort_str
237  character*8 nemo, my_nemoi, my_nemod
238  character tab
239 
240  ! Check for I8 integers
241 
242  if(im8b) then
243  im8b=.false.
244 
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)
251 
252  im8b=.true.
253  return
254  endif
255 
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')
260 
261  ! Make sure the appropriate code/flag information has already been read into internal memory.
262 
263  if ( cdmf /= 'Y' ) call bort('BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// &
264  'FIRST CALL SUBROUTINE CODFLG WITH INPUT ARGUMENT SET TO Y')
265 
266  itmp = ireadmt( lun )
267 
268  ! Check the validity of the input mnemonic(s). Include special handling for originating centers, originating subcenters, data
269  ! types and data subtypes, since those can be reported in Section 1 of a BUFR message as well as in Section 3, so if a user
270  ! requests those mnemonics we can't necessarily assume they came from within Section 3.
271 
272  lcmg = len( cmeang )
273 
274  my_nemoi = ' '
275  do ii = 1, min( 8, len( nemoi ) )
276  my_nemoi(ii:ii) = nemoi(ii:ii)
277  end do
278  my_nemod = ' '
279  do ii = 1, min( 8, len( nemod ) )
280  my_nemod(ii:ii) = nemod(ii:ii)
281  end do
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' )
286  else
287  lnmng = min( 24, lcmg )
288  if ( lnmng == 24 ) then
289  iret = 3
290  cmeang(1:24) = 'GCLONG OGCE ORIGC '
291  else
292  iret = -1
293  end if
294  return
295  end if
296  else if ( my_nemoi(1:6) == 'GCLONG' ) then
297  ifxyi = ifxy( '001031' )
298  ifxyd(1) = (-1)
299  else if ( my_nemoi(1:4) == 'OGCE' ) then
300  ifxyi = ifxy( '001033' )
301  ifxyd(1) = (-1)
302  else if ( my_nemoi(1:5) == 'ORIGC' ) then
303  ifxyi = ifxy( '001035' )
304  ifxyd(1) = (-1)
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' )
309  else
310  ifxyi = ifxy( '055022' )
311  endif
312  ifxyd(1) = ifxy( '055020' )
313  else
314  lnmng = min( 8, lcmg )
315  if ( lnmng == 8 ) then
316  iret = 1
317  cmeang(1:8) = 'TABLAT '
318  else
319  iret = -1
320  end if
321  return
322  end if
323  else if ( my_nemoi(1:6) == 'TABLAT' ) then
324  ifxyi = ifxy( '055020' )
325  ifxyd(1) = (-1)
326  else
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
331  call bort(bort_str)
332  endif
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
335  call bort(bort_str)
336  endif
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
342  call bort(bort_str)
343  endif
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
346  call bort(bort_str)
347  endif
348  else
349  ifxyd(1) = (-1)
350  end if
351  end if
352 
353  ! Search the internal table for the requested meaning.
354 
355  call srchtbf_c ( ifxyi, ivali, ifxyd(1), 10, ivald, cmeang, lcmg, lnmng, iret )
356  if ( iret <= 0 ) return
357 
358  ! The meaning of this value is dependent on the value of another mnemonic in the report.
359 
360  iret2 = iret
361  lnmng = 0
362  iret = 0
363  do ii = 1, iret2
364  call numtbd ( lun, ifxyd(ii), nemo, tab, ierbd )
365  if ( ( ierbd > 0 ) .and. ( tab == 'B' ) .and. ( lcmg >= ( lnmng + 8 ) ) ) then
366  iret = iret + 1
367  cmeang(lnmng+1:lnmng+8) = nemo
368  lnmng = lnmng + 8
369  end if
370  end do
371  if ( iret == 0 ) iret = -1
372 
373  return
374 end subroutine getcfmng
375 
395 recursive subroutine ufbqcd(lunit,nemo,iqcd)
396 
397  use modv_vars, only: im8b
398 
399  implicit none
400 
401  integer, intent(in) :: lunit
402  integer, intent(out) :: iqcd
403  integer my_lunit, lun, il, im, idn, iret
404 
405  character*(*), intent(in) :: nemo
406  character*128 bort_str
407  character*6 fxy, adn30
408  character tab
409 
410  ! Check for I8 integers
411 
412  if(im8b) then
413  im8b=.false.
414  call x84(lunit,my_lunit,1)
415  call ufbqcd(my_lunit,nemo,iqcd)
416  call x48(iqcd,iqcd,1)
417  im8b=.true.
418  return
419  endif
420 
421  call status(lunit,lun,il,im)
422  if(il==0) call bort('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
423 
424  call nemtab(lun,nemo,idn,tab,iret)
425  if(tab/='D') then
426  write(bort_str,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') nemo
427  call bort(bort_str)
428  endif
429 
430  fxy = adn30(idn,6)
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)
434  call bort(bort_str)
435  endif
436  read(fxy(4:6),'(I3)') iqcd
437 
438  return
439 end subroutine ufbqcd
440 
455 recursive subroutine ufbqcp(lunit,iqcp,nemo)
456 
457  use modv_vars, only: im8b
458 
459  implicit none
460 
461  integer, intent(in) :: lunit, iqcp
462  integer my_lunit, my_iqcp, lun, il, im, idn, iret, ifxy
463 
464  character*(*), intent(out) :: nemo
465  character tab
466 
467  ! Check for I8 integers
468 
469  if(im8b) then
470  im8b=.false.
471  call x84(lunit,my_lunit,1)
472  call x84(iqcp,my_iqcp,1)
473  call ufbqcp(my_lunit,my_iqcp,nemo)
474  im8b=.true.
475  return
476  endif
477 
478  call status(lunit,lun,il,im)
479  if(il==0) call bort('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
480 
481  idn = ifxy('363000')+iqcp
482  call numtab(lun,idn,nemo,tab,iret)
483 
484  return
485 end subroutine ufbqcp
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
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...
Definition: cftbvs.F90:22
recursive subroutine ufbqcd(lunit, nemo, iqcd)
Given a mnemonic associated with a category 63 Table D descriptor from an NCEP prepbufr file,...
Definition: cftbvs.F90:396
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...
Definition: cftbvs.F90:456
recursive subroutine upftbv(lunit, nemo, val, mxib, ibit, nib)
Given a Table B mnemonic with flag table units and a corresponding numerical data value,...
Definition: cftbvs.F90:70
recursive subroutine getcfmng(lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng, iret)
Decode the meaning of a numerical value from a code or flag table.
Definition: cftbvs.F90:220
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
Definition: fxy.F90:432
subroutine numtab(lun, idn, nemo, tab, iret)
Get information about a descriptor, based on the WMO bit-wise representation of an FXY value.
Definition: fxy.F90:357
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...
Definition: fxy.F90:290
integer function ifxy(adsc)
Convert an FXY value from its 6 character representation to its WMO bit-wise representation.
Definition: fxy.F90:152
character *(*) function adn30(idn, ldn)
Convert an FXY value from its WMO bit-wise representation to a character string of length 5 or 6.
Definition: fxy.F90:18
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.
Definition: misc.F90:177
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Definition: bufrlib.F90:11
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.
Definition: strings.F90:473
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