NCEPLIBS-bufr  12.1.0
fxy.F90
Go to the documentation of this file.
1 
5 
17 function adn30(idn,ldn)
18 
19  use modv_vars, only: nbitw
20 
21  implicit none
22 
23  integer, intent(in) :: idn, ldn
24 
25  integer i, idf, idx, idy
26 
27  character*(*) adn30
28  character*128 bort_str
29 
30  if(len(adn30)<ldn) call bort('BUFRLIB: ADN30 - FUNCTION RETURN STRING TOO SHORT')
31  if(idn<0 .or. idn>65535) call bort('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF DESCRIPTOR OUT OF 16-BIT RANGE')
32 
33  if(ldn==5) then
34  write(adn30,'(i5)') idn
35  elseif(ldn==6) then
36  idf = ishft(idn,-14)
37  idx = ishft(ishft(idn,nbitw-14),-(nbitw-6))
38  idy = ishft(ishft(idn,nbitw- 8),-(nbitw-8))
39  write(adn30,'(i1,i2,i3)') idf,idx,idy
40  else
41  write(bort_str,'("BUFRLIB: ADN30 - CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') ldn
42  call bort(bort_str)
43  endif
44 
45  do i=1,ldn
46  if(adn30(i:i)==' ') adn30(i:i) = '0'
47  enddo
48 
49  return
50 end function adn30
51 
64 subroutine cadn30( idn, adn )
65 
66  implicit none
67 
68  integer, intent(in) :: idn
69 
70  character*(*), intent(out) :: adn
71 
72  character*6 adn30
73 
74  adn = adn30( idn, 6 )
75 
76  return
77 end subroutine cadn30
78 
90 integer function idn30(adn,ldn) result(iret)
91 
92  implicit none
93 
94  integer, intent(in) :: ldn
95 
96  character*(*), intent(in) :: adn
97 
98  character*128 bort_str
99 
100  integer ifxy
101 
102  if(len(adn)<ldn) then
103  write(bort_str,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A," CHARACTER LENGTH (",I4,") IS TOO SHORT (< LDN,",I5)') &
104  adn, len(adn), ldn
105  call bort(bort_str)
106  endif
107 
108  if(ldn==5) then
109  read(adn,'(i5)') iret
110  if(iret<0 .or. iret>65535) then
111  write(bort_str, &
112  '("BUFRLIB: IDN30 - DESCRIPTOR INTEGER REPRESENTATION, IDN30 (",I8,"), IS OUTSIDE 16-BIT RANGE (0-65535)")') iret
113  call bort(bort_str)
114  endif
115  elseif(ldn==6) then
116  iret = ifxy(adn)
117  else
118  write(bort_str,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A," CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') &
119  adn,ldn
120  call bort(bort_str)
121  endif
122 
123  return
124 end function idn30
125 
151 integer function ifxy(adsc) result(iret)
152 
153  implicit none
154 
155  integer if, ix, iy
156 
157  character*6, intent(in) :: adsc
158 
159  read(adsc,'(i1,i2,i3)') if,ix,iy
160  iret = if*2**14 + ix*2**8 + iy
161 
162  return
163 end function ifxy
164 
178 integer function igetfxy ( str, cfxy ) result ( iret )
179 
180  implicit none
181 
182  character*(*), intent(in) :: str
183  character*6, intent(out) :: cfxy
184 
185  integer, parameter :: lstr2 = 120
186  character*(lstr2) str2
187 
188  integer lstr, numbck
189 
190  iret = -1
191 
192  lstr = len( str )
193  if ( lstr < 6 ) return
194 
195  ! Left-justify a copy of the input string.
196 
197  if ( lstr > lstr2 ) then
198  str2(1:lstr2) = str(1:lstr2)
199  else
200  str2 = str
201  endif
202  str2 = adjustl( str2 )
203  if ( str2 == ' ' ) return
204 
205  ! Look for an FXY number.
206 
207  if ( index( str2, '-' ) /= 0 ) then
208  ! Format of field is F-XX-YYY.
209  cfxy(1:1) = str2(1:1)
210  cfxy(2:3) = str2(3:4)
211  cfxy(4:6) = str2(6:8)
212  else
213  ! Format of field is FXXYYY.
214  cfxy = str2(1:6)
215  endif
216 
217  ! Check that the FXY number is valid.
218 
219  if ( numbck( cfxy ) == 0 ) iret = 0
220 
221  return
222 end function igetfxy
223 
236 integer function numbck(numb) result(iret)
237 
238  implicit none
239 
240  character*6, intent(in) :: numb
241 
242  integer ix, iy
243 
244  ! Check the first character of numb.
245 
246  if( llt(numb(1:1),'0') .or. lgt(numb(1:1),'3') ) then
247  iret = -1
248  return
249  endif
250 
251  ! Check for a valid descriptor.
252 
253  if( verify(numb(2:6),'1234567890') == 0 ) then
254  read(numb,'(1x,i2,i3)') ix,iy
255  else
256  iret = -2
257  return
258  endif
259 
260  if(ix<0 .or. ix> 63) then
261  iret = -3
262  return
263  else if(iy<0 .or. iy>255) then
264  iret = -4
265  return
266  endif
267 
268  iret = 0
269 
270  return
271 end function numbck
272 
289 subroutine numtbd(lun,idn,nemo,tab,iret)
290 
291  use moda_tababd
292 
293  implicit none
294 
295  integer, intent(in) :: lun, idn
296  integer, intent(out) :: iret
297  integer i, ifxy
298 
299  character*(*), intent(out) :: nemo
300  character, intent(out) :: tab
301 
302  nemo = ' '
303  iret = 0
304  tab = ' '
305 
306  if(idn>=ifxy('300000')) then
307  ! Look for idn in Table D
308  do i=1,ntbd(lun)
309  if(idn==idnd(i,lun)) then
310  nemo = tabd(i,lun)(7:14)
311  tab = 'D'
312  iret = i
313  return
314  endif
315  enddo
316  else
317  ! Look for idn in Table B
318  do i=1,ntbb(lun)
319  if(idn==idnb(i,lun)) then
320  nemo = tabb(i,lun)(7:14)
321  tab = 'B'
322  iret = i
323  return
324  endif
325  enddo
326  endif
327 
328  return
329 end subroutine numtbd
330 
356 subroutine numtab(lun,idn,nemo,tab,iret)
357 
358  use modv_vars, only: idnr
359 
360  implicit none
361 
362  integer, intent(in) :: lun, idn
363  integer, intent(out) :: iret
364  integer i, iokoper
365 
366  character*(*), intent(out) :: nemo
367  character, intent(out) :: tab
368  character*6 adn30, cid
369 
370  nemo = ' '
371  iret = 0
372  tab = ' '
373 
374  ! Look for a replicator or a replication factor descriptor
375 
376  if(idn>=idnr(1) .and. idn<=idnr(6)) then
377  ! Note that the above test is checking whether idn is the bit-wise representation of a FXY (descriptor) value
378  ! denoting F=1 regular (i.e. non-delayed) replication, since, as was initialized within subroutine bfrini(),
379  ! idnr(1) = ifxy('101000'), and idnr(6) = ifxy('101255').
380  tab = 'R'
381  iret = -mod(idn,256)
382  return
383  endif
384 
385  do i=2,5
386  if(idn==idnr(i)) then
387  tab = 'R'
388  iret = i
389  return
390  elseif(idn==idnr(i+5)) then
391  tab = 'F'
392  iret = i
393  return
394  endif
395  enddo
396 
397  ! Look for idn in Table B and Table D
398 
399  call numtbd(lun,idn,nemo,tab,iret)
400  if(iret/=0) return
401 
402  ! Look for idn in Table C
403 
404  cid = adn30(idn,6)
405  if (iokoper(cid)==1) then
406  nemo = cid(1:6)
407  read(nemo,'(1X,I2)') iret
408  tab = 'C'
409  return
410  endif
411 
412  return
413 end subroutine numtab
414 
431 subroutine nemtab(lun,nemo,idn,tab,iret)
432 
433  use moda_tababd
434 
435  implicit none
436 
437  integer, intent(in) :: lun
438  integer, intent(out) :: idn, iret
439  integer i, j, ifxy, iokoper
440 
441  character*(*), intent(in) :: nemo
442  character, intent(out) :: tab
443  character*8 nemt
444 
445  logical folval
446 
447  folval = nemo(1:1)=='.'
448  iret = 0
449  tab = ' '
450 
451  ! Look for nemo in Table B
452 
453  outer: do i=1,ntbb(lun)
454  nemt = tabb(i,lun)(7:14)
455  if(nemt==nemo) then
456  idn = idnb(i,lun)
457  tab = 'B'
458  iret = i
459  return
460  elseif(folval.and.nemt(1:1)=='.') then
461  do j=2,len(nemt)
462  if(nemt(j:j)/='.' .and. nemt(j:j)/=nemo(j:j)) cycle outer
463  enddo
464  idn = idnb(i,lun)
465  tab = 'B'
466  iret = i
467  return
468  endif
469  enddo outer
470 
471  ! Don't look in Table D for following value-mnemonics
472 
473  if(folval) return
474 
475  ! Look in Table D if we got this far
476 
477  do i=1,ntbd(lun)
478  nemt = tabd(i,lun)(7:14)
479  if(nemt==nemo) then
480  idn = idnd(i,lun)
481  tab = 'D'
482  iret = i
483  return
484  endif
485  enddo
486 
487  ! If still nothing, check for Table C operator descriptors
488 
489  if (iokoper(nemo)==1) then
490  read(nemo,'(1X,I2)') iret
491  idn = ifxy(nemo)
492  tab = 'C'
493  return
494  endif
495 
496  return
497 end subroutine nemtab
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
Definition: fxy.F90:432
integer function numbck(numb)
Check an FXY number for validity.
Definition: fxy.F90:237
subroutine cadn30(idn, adn)
Convert an FXY value from its WMO bit-wise representation to its 6 character representation.
Definition: fxy.F90:65
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
integer function idn30(adn, ldn)
Convert an FXY value from a character string to the WMO bit-wise representation.
Definition: fxy.F90:91
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 igetfxy(str, cfxy)
Search for and return a valid FXY number from within a character string.
Definition: fxy.F90:179
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
Declare arrays and variables used to store DX BUFR tables internally for multiple file IDs.
character *600, dimension(:,:), allocatable tabd
Table D entries for each file ID.
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.