NCEPLIBS-bufr  12.1.0
tankrcpt.F90
Go to the documentation of this file.
1 
4 
23 recursive subroutine atrcpt(msgin,lmsgot,msgot)
24 
25  use modv_vars, only: im8b, nbytw
26 
27  use moda_tnkrcp
28 
29  implicit none
30 
31  integer, intent(in) :: msgin(*), lmsgot
32  integer, intent(out) :: msgot(*)
33  integer my_lmsgot, len0, len1, l2, l3, l4, l5, iad1, iad2, lenm, lenmot, len1ot, ibit, iupbs01
34 
35  ! Check for I8 integers.
36 
37  if(im8b) then
38  im8b=.false.
39 
40  call x84 ( lmsgot, my_lmsgot, 1 )
41  call atrcpt ( msgin, my_lmsgot*2, msgot )
42 
43  im8b=.true.
44  return
45  endif
46 
47  ! Get some section lengths and addresses from the input message.
48 
49  call getlens(msgin,1,len0,len1,l2,l3,l4,l5)
50 
51  iad1 = len0
52  iad2 = iad1 + len1
53 
54  lenm = iupbs01(msgin,'LENM')
55 
56  ! Check for overflow of the output array. Note that the new message will be 6 bytes longer than the input message.
57 
58  lenmot = lenm + 6
59  if(lenmot>(lmsgot*nbytw)) &
60  call bort('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
61 
62  len1ot = len1 + 6
63 
64  ! Write Section 0 of the new message into the output array.
65 
66  call mvb ( msgin, 1, msgot, 1, 4 )
67  ibit = 32
68  call pkb ( lenmot, 24, msgot, ibit )
69  call mvb ( msgin, 8, msgot, 8, 1 )
70 
71  ! Store the length of the new Section 1.
72 
73  ibit = iad1*8
74  call pkb ( len1ot, 24, msgot, ibit )
75 
76  ! Copy the remainder of Section 1 from the input array to the output array.
77 
78  call mvb ( msgin, iad1+4, msgot, (ibit/8)+1, len1-3 )
79 
80  ! Append the tank receipt time data to the new Section 1.
81 
82  ibit = iad2*8
83  call pkb ( itryr, 16, msgot, ibit )
84  call pkb ( itrmo, 8, msgot, ibit )
85  call pkb ( itrdy, 8, msgot, ibit )
86  call pkb ( itrhr, 8, msgot, ibit )
87  call pkb ( itrmi, 8, msgot, ibit )
88 
89  ! Copy Sections 2, 3, 4 and 5 from the input array to the output array.
90 
91  call mvb ( msgin, iad2+1, msgot, (ibit/8)+1, lenm-iad2 )
92 
93  return
94 end subroutine atrcpt
95 
113 recursive subroutine rtrcptb(mbay,iyr,imo,idy,ihr,imi,iret)
114 
115  use modv_vars, only: im8b
116 
117  implicit none
118 
119  integer, intent(in) :: mbay(*)
120  integer, intent(out) :: iyr, imo, idy, ihr, imi, iret
121  integer is1byt, imgbyt, iupbs01, iupb
122 
123  ! Check for I8 integers.
124 
125  if(im8b) then
126  im8b=.false.
127 
128  call rtrcptb(mbay,iyr,imo,idy,ihr,imi,iret)
129  call x48(iyr,iyr,1)
130  call x48(imo,imo,1)
131  call x48(idy,idy,1)
132  call x48(ihr,ihr,1)
133  call x48(imi,imi,1)
134  call x48(iret,iret,1)
135 
136  im8b=.true.
137  return
138  endif
139 
140  iret = -1
141 
142  ! Check whether the message contains a tank receipt time.
143 
144  if(iupbs01(mbay,'BEN')==4) then
145  is1byt = 23
146  else
147  is1byt = 19
148  endif
149  if( (is1byt+5) > iupbs01(mbay,'LEN1') ) return
150 
151  ! Unpack the tank receipt time.
152 
153  ! Note that is1byt is a starting byte number relative to the beginning of Section 1, so we still need to account for
154  ! Section 0 when specifying the actual byte numbers to unpack within the overall message.
155 
156  imgbyt = is1byt + iupbs01(mbay,'LEN0')
157 
158  iyr = iupb(mbay,imgbyt,16)
159  imo = iupb(mbay,imgbyt+2,8)
160  idy = iupb(mbay,imgbyt+3,8)
161  ihr = iupb(mbay,imgbyt+4,8)
162  imi = iupb(mbay,imgbyt+5,8)
163 
164  iret = 0
165 
166  return
167 end subroutine rtrcptb
168 
186 recursive subroutine rtrcpt(lunit,iyr,imo,idy,ihr,imi,iret)
187 
188  use modv_vars, only: im8b
189 
190  use moda_bitbuf
191 
192  implicit none
193 
194  integer, intent(in) :: lunit
195  integer, intent(out) :: iyr, imo, idy, ihr, imi, iret
196  integer my_lunit, lun, il, im
197 
198  ! Check for I8 integers.
199 
200  if(im8b) then
201  im8b=.false.
202 
203  call x84(lunit,my_lunit,1)
204  call rtrcpt(my_lunit,iyr,imo,idy,ihr,imi,iret)
205  call x48(iyr,iyr,1)
206  call x48(imo,imo,1)
207  call x48(idy,idy,1)
208  call x48(ihr,ihr,1)
209  call x48(imi,imi,1)
210  call x48(iret,iret,1)
211 
212  im8b=.true.
213  return
214  endif
215 
216  ! Check the file status.
217 
218  call status(lunit,lun,il,im)
219  if(il==0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT MUST BE OPEN FOR INPUT')
220  if(il>0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR OUTPUT; IT MUST BE OPEN FOR INPUT')
221  if(im==0) call bort('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE; NONE ARE')
222 
223  ! Unpack the tank receipt time.
224 
225  call rtrcptb(mbay(1,lun),iyr,imo,idy,ihr,imi,iret)
226 
227  return
228 end subroutine rtrcpt
229 
257 recursive subroutine strcpt(cf,iyr,imo,idy,ihr,imi)
258 
259  use modv_vars, only: im8b
260 
261  use moda_tnkrcp
262 
263  implicit none
264 
265  character*1, intent(in) :: cf
266  character*128 bort_str
267 
268  integer, intent(in) :: iyr, imo, idy, ihr, imi
269  integer my_iyr, my_imo, my_idy, my_ihr, my_imi
270 
271  ! Check for I8 integers
272 
273  if(im8b) then
274  im8b=.false.
275 
276  call x84(iyr,my_iyr,1)
277  call x84(imo,my_imo,1)
278  call x84(idy,my_idy,1)
279  call x84(ihr,my_ihr,1)
280  call x84(imi,my_imi,1)
281  call strcpt(cf,my_iyr,my_imo,my_idy,my_ihr,my_imi)
282 
283  im8b=.true.
284  return
285  endif
286 
287  call capit(cf)
288  if(cf/='Y' .and. cf/='N') then
289  write(bort_str,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf
290  call bort(bort_str)
291  endif
292 
293  ctrt = cf
294  if(ctrt=='Y') then
295  itryr = iyr
296  itrmo = imo
297  itrdy = idy
298  itrhr = ihr
299  itrmi = imi
300  endif
301 
302  return
303 end subroutine strcpt
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
recursive integer function iupb(mbay, nbyt, nbit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:226
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...
Definition: ciencode.F90:140
subroutine mvb(ib1, nb1, ib2, nb2, nbm)
Copy a specified number of bytes from one packed binary array to another.
Definition: copydata.F90:731
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
Definition: misc.F90:355
Declare arrays and variables used to store BUFR messages internally for multiple file IDs.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each file ID.
Declare variables used to store tank receipt time information within Section 1 of BUFR messages.
integer itrhr
Tank receipt hour.
integer itryr
Tank receipt year.
integer itrdy
Tank receipt day.
character *1 ctrt
Flag indicating whether tank receipt times are to be included within output BUFR messages; this varia...
integer itrmi
Tank receipt minute.
integer itrmo
Tank receipt month.
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.
Definition: s013vals.F90:247
recursive subroutine strcpt(cf, iyr, imo, idy, ihr, imi)
Specify a tank receipt time to be included within Section 1 of all BUFR messages output by future cal...
Definition: tankrcpt.F90:258
recursive subroutine rtrcpt(lunit, iyr, imo, idy, ihr, imi, iret)
Read the tank receipt time (if one exists) from Section 1 of a BUFR message.
Definition: tankrcpt.F90:187
recursive subroutine rtrcptb(mbay, iyr, imo, idy, ihr, imi, iret)
Read the tank receipt time (if one exists) from Section 1 of a BUFR message.
Definition: tankrcpt.F90:114
recursive subroutine atrcpt(msgin, lmsgot, msgot)
Read an input message and output an equivalent BUFR message with a tank receipt time added to Section...
Definition: tankrcpt.F90:24
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