| 1 | PROGRAM robufr2ropp
|
|---|
| 2 |
|
|---|
| 3 | !****pi* Tests/robufr2ropp *
|
|---|
| 4 |
|
|---|
| 5 | ! NAME
|
|---|
| 6 | ! robufr2ropp - Reads BUFR file holding single profile of
|
|---|
| 7 | ! RO data and converts to ROPP netCDF format.
|
|---|
| 8 | !
|
|---|
| 9 | ! SYNOPSIS
|
|---|
| 10 | ! robufr2ropp infile.bfr -o ofile.nc [-d]
|
|---|
| 11 | !
|
|---|
| 12 | ! DESCRIPTION
|
|---|
| 13 | ! Emulates bufr2ropp but avoids the use of BUFR libraries.
|
|---|
| 14 | ! This allows us to test the results of ropp2bufr without incurring
|
|---|
| 15 | ! the circular logic of depending on bufr2ropp, which could have
|
|---|
| 16 | ! undergone the same changes as ropp2bufr. It does this by chopping up
|
|---|
| 17 | ! the bitstream that constitutes Sec. 4 of a BUFR message into chunks,
|
|---|
| 18 | ! each one representing a particular datum. The size of the chunks is
|
|---|
| 19 | ! taken from the ROM SAF BUFR document.
|
|---|
| 20 | !
|
|---|
| 21 | ! INPUT
|
|---|
| 22 | ! Single profile RO BUFR message. ARH and FTP headers are allowed.
|
|---|
| 23 | !
|
|---|
| 24 | ! OUTPUT
|
|---|
| 25 | ! Single profile ROPP format netCDF file. If the '-d' option is used,
|
|---|
| 26 | ! a detailed bit dump of the input message is written to stdout. This
|
|---|
| 27 | ! allows very close checking of the results of the bufr2ropp, which
|
|---|
| 28 | ! can be built with a variety of BUFR libraries.
|
|---|
| 29 | !
|
|---|
| 30 | ! NOTES
|
|---|
| 31 | ! Could have application as a debugging too in its own right.
|
|---|
| 32 | ! Probably slower than bufr2ropp.
|
|---|
| 33 | !
|
|---|
| 34 | ! REFERENCES
|
|---|
| 35 | ! WMO FM94 (BUFR) Specification For Radio Occultation Data,
|
|---|
| 36 | ! SAF/ROM/METO/FMT/BUFR/001
|
|---|
| 37 | !
|
|---|
| 38 | ! AUTHOR
|
|---|
| 39 | ! Met Office, Exeter, UK.
|
|---|
| 40 | ! Any comments on this software should be given via the ROM SAF
|
|---|
| 41 | ! Helpdesk at http://www.romsaf.org
|
|---|
| 42 | !
|
|---|
| 43 | ! COPYRIGHT
|
|---|
| 44 | ! (c) EUMETSAT. All rights reserved.
|
|---|
| 45 | ! For further details please refer to the file COPYRIGHT
|
|---|
| 46 | ! which you should have received as part of this distribution.
|
|---|
| 47 | !
|
|---|
| 48 | !****
|
|---|
| 49 |
|
|---|
| 50 | USE messages
|
|---|
| 51 | USE ropp_utils
|
|---|
| 52 | USE ropp_io
|
|---|
| 53 | USE ropp_io_types
|
|---|
| 54 | USE geodesy, ONLY: geometric2geopotential
|
|---|
| 55 |
|
|---|
| 56 | IMPLICIT NONE
|
|---|
| 57 |
|
|---|
| 58 | TYPE(ROprof) :: ro_data
|
|---|
| 59 |
|
|---|
| 60 | TYPE sec4_type
|
|---|
| 61 | CHARACTER(LEN=32) :: name=''
|
|---|
| 62 | INTEGER :: nbits=31
|
|---|
| 63 | INTEGER :: shift=0
|
|---|
| 64 | INTEGER :: scale=0
|
|---|
| 65 | END TYPE sec4_type
|
|---|
| 66 |
|
|---|
| 67 | CHARACTER(LEN=256) :: ifile='robufr2ropp_in.bfr' ! (Default) input file name
|
|---|
| 68 | CHARACTER(LEN=256) :: ofile='robufr2ropp_out.nc' ! (Default) output file name
|
|---|
| 69 | CHARACTER(LEN=256) :: arg ! Command line arguments
|
|---|
| 70 |
|
|---|
| 71 | LOGICAL :: padding = .FALSE.
|
|---|
| 72 |
|
|---|
| 73 | INTEGER :: iargc, iarg, narg
|
|---|
| 74 |
|
|---|
| 75 | !-------------------------------------------------------------
|
|---|
| 76 | ! 1. Initialise
|
|---|
| 77 | !-------------------------------------------------------------
|
|---|
| 78 |
|
|---|
| 79 | CALL message_set_routine ( 'robufr_read' )
|
|---|
| 80 |
|
|---|
| 81 | CALL message(msg_noin, '')
|
|---|
| 82 | CALL message(msg_noin, &
|
|---|
| 83 | '---------------------------------------------------------------------')
|
|---|
| 84 | CALL message(msg_noin, &
|
|---|
| 85 | ' ROBUFR to ROPP converter' )
|
|---|
| 86 | CALL message(msg_noin, &
|
|---|
| 87 | '---------------------------------------------------------------------')
|
|---|
| 88 | CALL message(msg_noin, '')
|
|---|
| 89 |
|
|---|
| 90 | !-------------------------------------------------------------
|
|---|
| 91 | ! 2. Parse command line options
|
|---|
| 92 | !-------------------------------------------------------------
|
|---|
| 93 |
|
|---|
| 94 | narg = IARGC()
|
|---|
| 95 |
|
|---|
| 96 | ifile = 'robufr2ropp_in.bfr' ! Default input file name
|
|---|
| 97 | ofile = 'robufr2ropp_out.nc' ! Default output file name
|
|---|
| 98 |
|
|---|
| 99 | iarg = 1
|
|---|
| 100 |
|
|---|
| 101 | DO WHILE ( iarg <= narg )
|
|---|
| 102 |
|
|---|
| 103 | CALL GETARG ( iarg, arg )
|
|---|
| 104 |
|
|---|
| 105 | SELECT CASE (arg)
|
|---|
| 106 |
|
|---|
| 107 | CASE ('-d', '-D', '--debug')
|
|---|
| 108 | msg_MODE = VerboseMode
|
|---|
| 109 |
|
|---|
| 110 | CASE ('-o', '-O', '--output')
|
|---|
| 111 | iarg = iarg + 1
|
|---|
| 112 | CALL GETARG ( iarg, arg )
|
|---|
| 113 | ofile = arg
|
|---|
| 114 |
|
|---|
| 115 | CASE DEFAULT
|
|---|
| 116 | IF ( arg(1:1) /= '-' ) THEN
|
|---|
| 117 | ifile = arg
|
|---|
| 118 | END IF
|
|---|
| 119 |
|
|---|
| 120 | END SELECT
|
|---|
| 121 |
|
|---|
| 122 | iarg = iarg + 1
|
|---|
| 123 |
|
|---|
| 124 | END DO
|
|---|
| 125 |
|
|---|
| 126 | IF ( ifile == ' ' ) THEN
|
|---|
| 127 | CALL message ( msg_error, 'No input file(s) specified' )
|
|---|
| 128 | narg = 0
|
|---|
| 129 | END IF
|
|---|
| 130 |
|
|---|
| 131 | IF ( narg == 0 ) THEN
|
|---|
| 132 | CALL EXIT(msg_exit_status)
|
|---|
| 133 | ENDIF
|
|---|
| 134 |
|
|---|
| 135 | CALL message(msg_noin, '')
|
|---|
| 136 | CALL message(msg_noin, 'Converting ' // TRIM(ADJUSTL(ifile)) // &
|
|---|
| 137 | ' to ' // TRIM(ADJUSTL(ofile)))
|
|---|
| 138 |
|
|---|
| 139 | ! 3.0 Read input file into ROprof structure
|
|---|
| 140 | ! -----------------------------------------
|
|---|
| 141 |
|
|---|
| 142 | CALL robufr_read(ifile, ro_data)
|
|---|
| 143 |
|
|---|
| 144 | ! 4.0 Write ROprof structure into netCDF file
|
|---|
| 145 | ! -------------------------------------------
|
|---|
| 146 |
|
|---|
| 147 | CALL ropp_io_write(ro_data, ofile)
|
|---|
| 148 |
|
|---|
| 149 | ! 5.0 Clean up
|
|---|
| 150 | ! ------------
|
|---|
| 151 |
|
|---|
| 152 | CALL ropp_io_free(ro_data)
|
|---|
| 153 |
|
|---|
| 154 |
|
|---|
| 155 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 156 |
|
|---|
| 157 | CONTAINS
|
|---|
| 158 |
|
|---|
| 159 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 160 |
|
|---|
| 161 | SUBROUTINE robufr_read(file, ro_data)
|
|---|
| 162 |
|
|---|
| 163 | CHARACTER(LEN=256), INTENT(in) :: file
|
|---|
| 164 | TYPE(ROprof), INTENT(inout) :: ro_data
|
|---|
| 165 |
|
|---|
| 166 | INTEGER, PARAMETER :: n_bytes_max=50000 ! Max size of bufr file in bytes
|
|---|
| 167 | INTEGER, PARAMETER :: n_sec4_fields_max=50000 ! Max number of data values
|
|---|
| 168 | CHARACTER(LEN=n_bytes_max) :: cdata
|
|---|
| 169 |
|
|---|
| 170 | INTEGER :: file_id=11 ! Should never need this default
|
|---|
| 171 | INTEGER, PARAMETER :: dp=KIND(1.D0)
|
|---|
| 172 | INTEGER, PARAMETER :: ropp_mifv=-999
|
|---|
| 173 | REAL(dp), PARAMETER :: ropp_mdfv=-9.9999E7_dp
|
|---|
| 174 | INTEGER :: n_lev1b, n_lev2a, n_lev2b, n_lev2c, n_freq
|
|---|
| 175 | INTEGER :: n_sec4_fields
|
|---|
| 176 |
|
|---|
| 177 | INTEGER :: n_bytes ! size of bufr file in bytes
|
|---|
| 178 | INTEGER :: n_edn ! BUFR edition
|
|---|
| 179 | INTEGER :: wrapper_length=0 ! no. of bytes in ARH(+FTP) wrapper
|
|---|
| 180 | INTEGER :: i, j, ifirst, ilast
|
|---|
| 181 |
|
|---|
| 182 | INTEGER :: ivalue
|
|---|
| 183 | REAL(dp) :: rvalue
|
|---|
| 184 |
|
|---|
| 185 | INTEGER :: idata(n_sec4_fields_max)
|
|---|
| 186 | REAL(dp) :: rdata(n_sec4_fields_max)
|
|---|
| 187 |
|
|---|
| 188 | CHARACTER(LEN=128) :: msg
|
|---|
| 189 |
|
|---|
| 190 | TYPE(sec4_type), ALLOCATABLE :: sec4_data(:)
|
|---|
| 191 |
|
|---|
| 192 | CHARACTER(LEN=8) :: ctemp
|
|---|
| 193 | CHARACTER(LEN=8*n_bytes_max) :: sec4_bitstream
|
|---|
| 194 | INTEGER :: n_sec4_octets
|
|---|
| 195 | CHARACTER(LEN=13) :: s_octet
|
|---|
| 196 |
|
|---|
| 197 | !-------------------------------------------------------------
|
|---|
| 198 | ! 1. Initialise
|
|---|
| 199 | !-------------------------------------------------------------
|
|---|
| 200 |
|
|---|
| 201 | idata(:) = ropp_mifv
|
|---|
| 202 | rdata(:) = ropp_mdfv
|
|---|
| 203 |
|
|---|
| 204 | ! 2.0 Check whether we need to strip off the ARH and the FTP header
|
|---|
| 205 | ! -----------------------------------------------------------------
|
|---|
| 206 |
|
|---|
| 207 | file_id = get_io_unit()
|
|---|
| 208 | OPEN (file_id, FILE=file, STATUS='OLD', FORM='UNFORMATTED', ACCESS='DIRECT', RECL=4)
|
|---|
| 209 | READ (file_id, rec=1) cdata(1:4)
|
|---|
| 210 | CLOSE (file_id)
|
|---|
| 211 |
|
|---|
| 212 | SELECT CASE ( cdata(1:4) )
|
|---|
| 213 | CASE ( 'BUFR' ) ! 'pure' BUFR message
|
|---|
| 214 | wrapper_length = 0
|
|---|
| 215 | CASE ( char(1)//char(13)//char(13)//char(10) ) ! BUFR message wrapped in ARH
|
|---|
| 216 | wrapper_length = 31
|
|---|
| 217 | CASE DEFAULT ! BUFR message wrapped in ARH+FTP, we assume - this could be improved.
|
|---|
| 218 | wrapper_length = 41
|
|---|
| 219 | END SELECT
|
|---|
| 220 |
|
|---|
| 221 | ! 3.0 Extract message length and BUFR edition from bytes 5-7 and byte 8 of bufr message
|
|---|
| 222 | ! -------------------------------------------------------------------------------------
|
|---|
| 223 |
|
|---|
| 224 | file_id = get_io_unit()
|
|---|
| 225 | OPEN (file_id, FILE=file, STATUS='OLD', FORM='UNFORMATTED', ACCESS='DIRECT', RECL=8+wrapper_length)
|
|---|
| 226 | READ (file_id, rec=1) cdata(1:8+wrapper_length)
|
|---|
| 227 | CLOSE (file_id)
|
|---|
| 228 |
|
|---|
| 229 | CALL BUFR_decode_sample(cdata(1+wrapper_length:8+wrapper_length), 'Message length', 5, 7, size=n_bytes, quiet=.TRUE.)
|
|---|
| 230 | CALL BUFR_decode_sample(cdata(1+wrapper_length:8+wrapper_length), 'BUFR edition', 8, 8, size=n_edn, quiet=.TRUE.)
|
|---|
| 231 | IF ( n_edn /= 4 ) THEN
|
|---|
| 232 | WRITE(msg, '(A,I1,A)') 'BUFR Ed. = ', n_edn, ' ... can only process BUFR Ed. 4 data currently.'
|
|---|
| 233 | CALL message(msg_fatal, ADJUSTL(msg))
|
|---|
| 234 | ENDIF
|
|---|
| 235 |
|
|---|
| 236 | ! 4.0 Read entire dataset as sequence of 1-byte characters
|
|---|
| 237 | ! --------------------------------------------------------
|
|---|
| 238 |
|
|---|
| 239 | file_id = get_io_unit()
|
|---|
| 240 | OPEN (file_id, FILE=file, STATUS='OLD', FORM='UNFORMATTED', ACCESS='DIRECT', RECL=n_bytes+wrapper_length)
|
|---|
| 241 | READ (file_id, rec=1) cdata(1:n_bytes+wrapper_length)
|
|---|
| 242 | CLOSE (file_id)
|
|---|
| 243 |
|
|---|
| 244 | ! 5.0 IF ARH or FTP present, strip them off cdata
|
|---|
| 245 | ! -----------------------------------------------
|
|---|
| 246 |
|
|---|
| 247 | IF ( wrapper_length > 0 ) cdata(1:n_bytes) = cdata(1+wrapper_length:n_bytes+wrapper_length)
|
|---|
| 248 |
|
|---|
| 249 | ! 6.0 Write out contents of file
|
|---|
| 250 | ! ------------------------------
|
|---|
| 251 |
|
|---|
| 252 | IF ( msg_MODE == VerboseMode ) THEN
|
|---|
| 253 |
|
|---|
| 254 | CALL message(msg_noin, '')
|
|---|
| 255 | CALL message(msg_noin, '-------------------------------------------------------------------')
|
|---|
| 256 | CALL message(msg_noin, ' Contents of ' // TRIM(ADJUSTL(file)))
|
|---|
| 257 | CALL message(msg_noin, '-------------------------------------------------------------------')
|
|---|
| 258 | CALL message(msg_noin, '')
|
|---|
| 259 |
|
|---|
| 260 | ! 6.1 Section 0
|
|---|
| 261 | CALL message(msg_noin, '')
|
|---|
| 262 | CALL message(msg_noin, '-------------------')
|
|---|
| 263 | CALL message(msg_noin, ' Contents of Sec 0 ')
|
|---|
| 264 | CALL message(msg_noin, '-------------------')
|
|---|
| 265 | CALL message(msg_noin, '')
|
|---|
| 266 | CALL message(msg_noin, ' octet name value ')
|
|---|
| 267 | CALL message(msg_noin, '--------------------------------------------')
|
|---|
| 268 |
|
|---|
| 269 | CALL message(msg_noin, ' 1- 4 BUFR ' // cdata(1:4))
|
|---|
| 270 | CALL BUFR_decode_sample(cdata, 'Message length', 5, 7)
|
|---|
| 271 | CALL BUFR_decode_sample(cdata, 'BUFR edition', 8, 8)
|
|---|
| 272 | CALL message(msg_noin, '')
|
|---|
| 273 |
|
|---|
| 274 | ! 6.2 Section 1 (Ed. 4)
|
|---|
| 275 | CALL message(msg_noin, '')
|
|---|
| 276 | CALL message(msg_noin, '-------------------')
|
|---|
| 277 | CALL message(msg_noin, ' Contents of Sec 1 ')
|
|---|
| 278 | CALL message(msg_noin, '-------------------')
|
|---|
| 279 | CALL message(msg_noin, '')
|
|---|
| 280 | CALL message(msg_noin, ' octet name value ')
|
|---|
| 281 | CALL message(msg_noin, '--------------------------------------------')
|
|---|
| 282 |
|
|---|
| 283 | CALL BUFR_decode_sample(cdata, 'Length of section 1', 9, 11)
|
|---|
| 284 | CALL BUFR_decode_sample(cdata, 'BUFR Master Table', 12, 12)
|
|---|
| 285 | CALL BUFR_decode_sample(cdata, 'Originating Centre', 13, 14)
|
|---|
| 286 | CALL BUFR_decode_sample(cdata, 'Originating Subcentre', 15, 16)
|
|---|
| 287 | CALL BUFR_decode_sample(cdata, 'Update sequence Number', 17, 17)
|
|---|
| 288 | CALL BUFR_decode_sample(cdata, 'Optional section 2 flag', 18, 18)
|
|---|
| 289 | CALL BUFR_decode_sample(cdata, 'Data category (Table A)', 19, 19)
|
|---|
| 290 | CALL BUFR_decode_sample(cdata, 'Intnl data sub-category', 20, 20)
|
|---|
| 291 | CALL BUFR_decode_sample(cdata, 'Local data sub-category', 21, 21)
|
|---|
| 292 | CALL BUFR_decode_sample(cdata, 'Version of Master Table', 22, 22)
|
|---|
| 293 | CALL BUFR_decode_sample(cdata, 'Version of Local Table', 23, 23)
|
|---|
| 294 | CALL BUFR_decode_sample(cdata, 'Year', 24, 25)
|
|---|
| 295 | CALL BUFR_decode_sample(cdata, 'Month', 26, 26)
|
|---|
| 296 | CALL BUFR_decode_sample(cdata, 'Day', 27, 27)
|
|---|
| 297 | CALL BUFR_decode_sample(cdata, 'Hour', 28, 28)
|
|---|
| 298 | CALL BUFR_decode_sample(cdata, 'Minute', 29, 29)
|
|---|
| 299 | CALL BUFR_decode_sample(cdata, 'Second', 30, 30)
|
|---|
| 300 | CALL message(msg_noin, '')
|
|---|
| 301 |
|
|---|
| 302 | ! 6.3 Section 3
|
|---|
| 303 | CALL message(msg_noin, '')
|
|---|
| 304 | CALL message(msg_noin, '-------------------')
|
|---|
| 305 | CALL message(msg_noin, ' Contents of Sec 3 ')
|
|---|
| 306 | CALL message(msg_noin, '-------------------')
|
|---|
| 307 | CALL message(msg_noin, '')
|
|---|
| 308 | CALL message(msg_noin, ' octet name value ')
|
|---|
| 309 | CALL message(msg_noin, '--------------------------------------------')
|
|---|
| 310 | CALL BUFR_decode_sample(cdata, 'Length of section 3', 31, 33)
|
|---|
| 311 | CALL BUFR_decode_sample(cdata, 'Reserved', 34, 34)
|
|---|
| 312 | CALL BUFR_decode_sample(cdata, 'Number of datasets', 35, 36)
|
|---|
| 313 | CALL BUFR_decode_sample(cdata, 'Section 4 data flags', 37, 37)
|
|---|
| 314 | CALL BUFR_decode_sample(cdata, 'Descriptor', 38, 39)
|
|---|
| 315 | CALL BUFR_decode_sample(cdata, 'Pad byte', 40, 40)
|
|---|
| 316 | CALL message(msg_noin, '')
|
|---|
| 317 |
|
|---|
| 318 | ENDIF ! IF ( msg_MODE == VerboseMode )
|
|---|
| 319 |
|
|---|
| 320 | CALL BUFR_decode_sample(cdata, 'Length of section 3', 31, 33, pad=padding, quiet=.TRUE.)
|
|---|
| 321 | IF ( padding ) cdata(40:n_bytes-1) = cdata(41:n_bytes) ! remove padding octet
|
|---|
| 322 |
|
|---|
| 323 | ! 6.4 Section 4
|
|---|
| 324 | IF ( msg_MODE == VerboseMode ) THEN
|
|---|
| 325 |
|
|---|
| 326 | CALL message(msg_noin, '')
|
|---|
| 327 | CALL message(msg_noin, '----------------------------')
|
|---|
| 328 | CALL message(msg_noin, ' Contents of Sec 4 (header) ')
|
|---|
| 329 | CALL message(msg_noin, '----------------------------')
|
|---|
| 330 | CALL message(msg_noin, '')
|
|---|
| 331 | CALL message(msg_noin, ' octet name value ')
|
|---|
| 332 | CALL message(msg_noin, '--------------------------------------------')
|
|---|
| 333 | CALL BUFR_decode_sample(cdata, 'Length of section 4', 40, 42)
|
|---|
| 334 | CALL BUFR_decode_sample(cdata, 'Reserved octet of sec 4', 43, 43)
|
|---|
| 335 | CALL message(msg_noin, '')
|
|---|
| 336 |
|
|---|
| 337 | CALL message(msg_noin, '')
|
|---|
| 338 | CALL message(msg_noin, '--------------------------')
|
|---|
| 339 | CALL message(msg_noin, ' Contents of Sec 4 (data) ')
|
|---|
| 340 | CALL message(msg_noin, '--------------------------')
|
|---|
| 341 | CALL message(msg_noin, '')
|
|---|
| 342 | CALL message(msg_noin, &
|
|---|
| 343 | ' field name shift ref. val binary value real value ')
|
|---|
| 344 | CALL message(msg_noin, &
|
|---|
| 345 | '---------------------------------------------------------------------------------------------------')
|
|---|
| 346 |
|
|---|
| 347 | ENDIF ! IF ( msg_MODE == VerboseMode )
|
|---|
| 348 |
|
|---|
| 349 | CALL BUFR_decode_sample(cdata, 'Length of section 4', 40, 42, size=n_sec4_octets, quiet=.TRUE.)
|
|---|
| 350 |
|
|---|
| 351 | ! 6.4.1 Read ALL the data in Sec 4 into one long bitstream, sec4_bitstream
|
|---|
| 352 | DO i=1, n_sec4_octets
|
|---|
| 353 | ctemp = '00000000'
|
|---|
| 354 | DO j=0,7
|
|---|
| 355 | IF ( BTEST(ICHAR(cdata(i+43:i+43)), j) ) ctemp(8-j:8-j) = '1'
|
|---|
| 356 | ENDDO
|
|---|
| 357 | sec4_bitstream(8*i-7:8*i) = ctemp
|
|---|
| 358 | ENDDO
|
|---|
| 359 |
|
|---|
| 360 | ! 6.4.2 Extract dimensions from sec4_bitstream
|
|---|
| 361 | ! All ifirst and ilasts calculated from field widths in ROM SAF BUFR doc
|
|---|
| 362 | ifirst = 824 + 1 ; ilast = ifirst + 8 - 1
|
|---|
| 363 | n_freq = ival(sec4_bitstream(ifirst:ilast))
|
|---|
| 364 |
|
|---|
| 365 | ifirst = 741 + 1 ; ilast = ifirst + 16 - 1
|
|---|
| 366 | n_lev1b = ival(sec4_bitstream(ifirst:ilast))
|
|---|
| 367 |
|
|---|
| 368 | ifirst = 757 + (82 + 84*n_freq)*n_lev1b + 1 ; ilast = ifirst + 16 - 1
|
|---|
| 369 | n_lev2a = ival(sec4_bitstream(ifirst:ilast))
|
|---|
| 370 |
|
|---|
| 371 | ifirst = 773 + (82 + 84*n_freq)*n_lev1b + 69*n_lev2a + 1 ; ilast = ifirst + 16 - 1
|
|---|
| 372 | n_lev2b = ival(sec4_bitstream(ifirst:ilast))
|
|---|
| 373 |
|
|---|
| 374 | n_lev2c = 0
|
|---|
| 375 |
|
|---|
| 376 | n_sec4_fields = 47 + (5 + 6*n_freq)*n_lev1b + 6*n_lev2a + 10*n_lev2b
|
|---|
| 377 |
|
|---|
| 378 | ! 6.4.3 Initialise sec4_data and metadata
|
|---|
| 379 | ALLOCATE (sec4_data(n_sec4_fields))
|
|---|
| 380 | CALL BUFR_sec4_init(sec4_data, n_lev1b, n_lev2a, n_lev2b, n_freq)
|
|---|
| 381 |
|
|---|
| 382 | ! 6.4.4 Populate idata/rdata with the decoded fields
|
|---|
| 383 | ifirst = 0 ; ilast = 0
|
|---|
| 384 | DO i=1, n_sec4_fields
|
|---|
| 385 | ifirst = ilast + 1 ; ilast = ifirst + sec4_data(i)%nbits - 1
|
|---|
| 386 | IF ( sec4_data(i)%scale == 0 ) THEN ! integer
|
|---|
| 387 | IF ( sec4_bitstream(ifirst:ilast) == REPEAT('1', ilast-ifirst+1) ) THEN
|
|---|
| 388 | ivalue = ropp_mifv
|
|---|
| 389 | ELSE
|
|---|
| 390 | ivalue = ival(sec4_bitstream(ifirst:ilast)) + sec4_data(i)%shift
|
|---|
| 391 | ENDIF
|
|---|
| 392 | idata(i) = ivalue
|
|---|
| 393 | IF ( msg_MODE == VerboseMode ) THEN
|
|---|
| 394 | WRITE(msg, '(I6,2X,A20,2X,I2,2X,I12,2X,A32,I16)') &
|
|---|
| 395 | i, sec4_data(i)%name, sec4_data(i)%scale, sec4_data(i)%shift, sec4_bitstream(ifirst:ilast), ivalue
|
|---|
| 396 | CALL message(msg_noin, ' ' // msg)
|
|---|
| 397 | ENDIF
|
|---|
| 398 | ELSE ! real(dp)
|
|---|
| 399 | IF ( sec4_bitstream(ifirst:ilast) == REPEAT('1', ilast-ifirst+1) ) THEN
|
|---|
| 400 | rvalue = ropp_mdfv
|
|---|
| 401 | ELSE
|
|---|
| 402 | rvalue = (ival(sec4_bitstream(ifirst:ilast)) + sec4_data(i)%shift) / (10.0_dp**sec4_data(i)%scale)
|
|---|
| 403 | ENDIF
|
|---|
| 404 | rdata(i) = rvalue
|
|---|
| 405 | IF ( msg_MODE == VerboseMode ) THEN
|
|---|
| 406 | WRITE(msg, '(I6,2X,A20,2X,I2,2X,I12,2X,A32,G20.10)') &
|
|---|
| 407 | i, sec4_data(i)%name, sec4_data(i)%scale, sec4_data(i)%shift, sec4_bitstream(ifirst:ilast), rvalue
|
|---|
| 408 | CALL message(msg_noin, ' ' // msg)
|
|---|
| 409 | ENDIF
|
|---|
| 410 | ENDIF
|
|---|
| 411 | ENDDO
|
|---|
| 412 | CALL message(msg_noin, '')
|
|---|
| 413 |
|
|---|
| 414 | ! 6.4.5 Initialise RO profile
|
|---|
| 415 | CALL ropp_io_free(ro_data)
|
|---|
| 416 | CALL ropp_io_init(ro_data, 0, n_lev1b, n_lev2a, n_lev2b, n_lev2c, 0)
|
|---|
| 417 |
|
|---|
| 418 | ! 6.4.6 Fill RO profile with Sec 4 data
|
|---|
| 419 | CALL BUFR_sec4_to_ROPP(ro_data, idata, rdata)
|
|---|
| 420 |
|
|---|
| 421 | ! 6.5 Section 5
|
|---|
| 422 | ! (This won't be affected by the possible removing of the padding byte in Sec 6.3.)
|
|---|
| 423 | IF ( msg_MODE == VerboseMode ) THEN
|
|---|
| 424 |
|
|---|
| 425 | CALL message(msg_noin, '')
|
|---|
| 426 | CALL message(msg_noin, '-------------------')
|
|---|
| 427 | CALL message(msg_noin, ' Contents of Sec 5 ')
|
|---|
| 428 | CALL message(msg_noin, '-------------------')
|
|---|
| 429 | CALL message(msg_noin, '')
|
|---|
| 430 | CALL message(msg_noin, ' octet name value ')
|
|---|
| 431 | CALL message(msg_noin, '--------------------------------------------')
|
|---|
| 432 | WRITE(s_octet, '(I6,A1,I6)') n_bytes-3, '-', n_bytes
|
|---|
| 433 | WRITE(msg, '(A)') s_octet // ' 7777 ' // cdata(n_bytes-3:n_bytes)
|
|---|
| 434 | CALL message(msg_noin, ' ' // ADJUSTL(msg))
|
|---|
| 435 | CALL message(msg_noin, '')
|
|---|
| 436 |
|
|---|
| 437 | ENDIF ! IF ( msg_MODE == VerboseMode )
|
|---|
| 438 |
|
|---|
| 439 | DEALLOCATE (sec4_data)
|
|---|
| 440 |
|
|---|
| 441 | ! 6.6 Write summary of input file
|
|---|
| 442 | CALL message(msg_noin, 'Summary of input BUFR file:')
|
|---|
| 443 |
|
|---|
| 444 | SELECT CASE (wrapper_length)
|
|---|
| 445 | CASE ( 0 )
|
|---|
| 446 | CALL message(msg_cont, 'Contains a BUFR message without an ARH or FTP header')
|
|---|
| 447 | CASE ( 31 )
|
|---|
| 448 | CALL message(msg_cont, 'Contains a BUFR message wrapped in an ARH')
|
|---|
| 449 | CASE ( 41 )
|
|---|
| 450 | CALL message(msg_cont, 'Contains a BUFR message wrapped in an ARH and an FTP header')
|
|---|
| 451 | END SELECT
|
|---|
| 452 |
|
|---|
| 453 | WRITE(msg, '(A,I6,A)') 'Message length = ', n_bytes, ' bytes'
|
|---|
| 454 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 455 |
|
|---|
| 456 | WRITE(msg, '(A,I1)') 'BUFR edition = ', n_edn
|
|---|
| 457 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 458 |
|
|---|
| 459 | WRITE(msg, '(A,I1)') 'No. of frequencies = ', n_freq
|
|---|
| 460 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 461 |
|
|---|
| 462 | WRITE(msg, '(A,I4)') 'No. of level 1b variables = ', n_lev1b
|
|---|
| 463 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 464 |
|
|---|
| 465 | WRITE(msg, '(A,I4)') 'No. of level 2a variables = ', n_lev2a
|
|---|
| 466 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 467 |
|
|---|
| 468 | WRITE(msg, '(A,I4)') 'No. of level 2b variables = ', n_lev2b
|
|---|
| 469 | CALL message(msg_cont, ADJUSTL(msg))
|
|---|
| 470 |
|
|---|
| 471 | END SUBROUTINE robufr_read
|
|---|
| 472 |
|
|---|
| 473 |
|
|---|
| 474 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 475 |
|
|---|
| 476 | SUBROUTINE BUFR_sec4_init(sec4_data, n_lev1b, n_lev2a, n_lev2b, n_freq)
|
|---|
| 477 | !
|
|---|
| 478 | ! Initialise the sec4_data structure, which holds the metadata for each Sec 4 field.
|
|---|
| 479 | !
|
|---|
| 480 | TYPE(sec4_type), INTENT(inout) :: sec4_data(:)
|
|---|
| 481 | INTEGER, INTENT(in) :: n_lev1b, n_lev2a, n_lev2b, n_freq
|
|---|
| 482 |
|
|---|
| 483 | INTEGER :: index, i, j
|
|---|
| 484 |
|
|---|
| 485 | ! Headers
|
|---|
| 486 | ! -------
|
|---|
| 487 |
|
|---|
| 488 | index = 0
|
|---|
| 489 |
|
|---|
| 490 | index = index + 1
|
|---|
| 491 | sec4_data(index)%name = 'LEO ID'
|
|---|
| 492 | sec4_data(index)%nbits = 10
|
|---|
| 493 | sec4_data(index)%scale = 0
|
|---|
| 494 | sec4_data(index)%shift = 0
|
|---|
| 495 |
|
|---|
| 496 | index = index + 1
|
|---|
| 497 | sec4_data(index)%name = 'Instrument ID'
|
|---|
| 498 | sec4_data(index)%nbits = 11
|
|---|
| 499 | sec4_data(index)%scale = 0
|
|---|
| 500 | sec4_data(index)%shift = 0
|
|---|
| 501 |
|
|---|
| 502 | index = index + 1
|
|---|
| 503 | sec4_data(index)%name = 'Orig centre'
|
|---|
| 504 | sec4_data(index)%nbits = 8
|
|---|
| 505 | sec4_data(index)%scale = 0
|
|---|
| 506 | sec4_data(index)%shift = 0
|
|---|
| 507 |
|
|---|
| 508 | index = index + 1
|
|---|
| 509 | sec4_data(index)%name = 'Product type'
|
|---|
| 510 | sec4_data(index)%nbits = 8
|
|---|
| 511 | sec4_data(index)%scale = 0
|
|---|
| 512 | sec4_data(index)%shift = 0
|
|---|
| 513 |
|
|---|
| 514 | index = index + 1
|
|---|
| 515 | sec4_data(index)%name = 'Software ID'
|
|---|
| 516 | sec4_data(index)%nbits = 14
|
|---|
| 517 | sec4_data(index)%scale = 0
|
|---|
| 518 | sec4_data(index)%shift = 0
|
|---|
| 519 |
|
|---|
| 520 | index = index + 1
|
|---|
| 521 | sec4_data(index)%name = 'Time significance'
|
|---|
| 522 | sec4_data(index)%nbits = 5
|
|---|
| 523 | sec4_data(index)%scale = 0
|
|---|
| 524 | sec4_data(index)%shift = 0
|
|---|
| 525 |
|
|---|
| 526 | index = index + 1
|
|---|
| 527 | sec4_data(index)%name = 'Year'
|
|---|
| 528 | sec4_data(index)%nbits = 12
|
|---|
| 529 | sec4_data(index)%scale = 0
|
|---|
| 530 | sec4_data(index)%shift = 0
|
|---|
| 531 |
|
|---|
| 532 | index = index + 1
|
|---|
| 533 | sec4_data(index)%name = 'Month'
|
|---|
| 534 | sec4_data(index)%nbits = 4
|
|---|
| 535 | sec4_data(index)%scale = 0
|
|---|
| 536 | sec4_data(index)%shift = 0
|
|---|
| 537 |
|
|---|
| 538 | index = index + 1
|
|---|
| 539 | sec4_data(index)%name = 'Day'
|
|---|
| 540 | sec4_data(index)%nbits = 6
|
|---|
| 541 | sec4_data(index)%scale = 0
|
|---|
| 542 | sec4_data(index)%shift = 0
|
|---|
| 543 |
|
|---|
| 544 | index = index + 1
|
|---|
| 545 | sec4_data(index)%name = 'Hour'
|
|---|
| 546 | sec4_data(index)%nbits = 5
|
|---|
| 547 | sec4_data(index)%scale = 0
|
|---|
| 548 | sec4_data(index)%shift = 0
|
|---|
| 549 |
|
|---|
| 550 | index = index + 1
|
|---|
| 551 | sec4_data(index)%name = 'Minute'
|
|---|
| 552 | sec4_data(index)%nbits = 6
|
|---|
| 553 | sec4_data(index)%scale = 0
|
|---|
| 554 | sec4_data(index)%shift = 0
|
|---|
| 555 |
|
|---|
| 556 | index = index + 1
|
|---|
| 557 | sec4_data(index)%name = 'Second'
|
|---|
| 558 | sec4_data(index)%nbits = 16
|
|---|
| 559 | sec4_data(index)%scale = 3
|
|---|
| 560 | sec4_data(index)%shift = 0
|
|---|
| 561 |
|
|---|
| 562 | index = index + 1
|
|---|
| 563 | sec4_data(index)%name = 'Quality flags'
|
|---|
| 564 | sec4_data(index)%nbits = 16
|
|---|
| 565 | sec4_data(index)%scale = 0
|
|---|
| 566 | sec4_data(index)%shift = 0
|
|---|
| 567 |
|
|---|
| 568 | index = index + 1
|
|---|
| 569 | sec4_data(index)%name = 'Percent confidence'
|
|---|
| 570 | sec4_data(index)%nbits = 7
|
|---|
| 571 | sec4_data(index)%scale = 0
|
|---|
| 572 | sec4_data(index)%shift = 0
|
|---|
| 573 |
|
|---|
| 574 | index = index + 1
|
|---|
| 575 | sec4_data(index)%name = 'LEO x coord'
|
|---|
| 576 | sec4_data(index)%nbits = 31
|
|---|
| 577 | sec4_data(index)%scale = 2
|
|---|
| 578 | sec4_data(index)%shift = -1073741824
|
|---|
| 579 |
|
|---|
| 580 | index = index + 1
|
|---|
| 581 | sec4_data(index)%name = 'LEO y coord'
|
|---|
| 582 | sec4_data(index)%nbits = 31
|
|---|
| 583 | sec4_data(index)%scale = 2
|
|---|
| 584 | sec4_data(index)%shift = -1073741824
|
|---|
| 585 |
|
|---|
| 586 | index = index + 1
|
|---|
| 587 | sec4_data(index)%name = 'LEO z coord'
|
|---|
| 588 | sec4_data(index)%nbits = 31
|
|---|
| 589 | sec4_data(index)%scale = 2
|
|---|
| 590 | sec4_data(index)%shift = -1073741824
|
|---|
| 591 |
|
|---|
| 592 | index = index + 1
|
|---|
| 593 | sec4_data(index)%name = 'LEO x vel'
|
|---|
| 594 | sec4_data(index)%nbits = 31
|
|---|
| 595 | sec4_data(index)%scale = 5
|
|---|
| 596 | sec4_data(index)%shift = -1073741824
|
|---|
| 597 |
|
|---|
| 598 | index = index + 1
|
|---|
| 599 | sec4_data(index)%name = 'LEO y vel'
|
|---|
| 600 | sec4_data(index)%nbits = 31
|
|---|
| 601 | sec4_data(index)%scale = 5
|
|---|
| 602 | sec4_data(index)%shift = -1073741824
|
|---|
| 603 |
|
|---|
| 604 | index = index + 1
|
|---|
| 605 | sec4_data(index)%name = 'LEO z vel'
|
|---|
| 606 | sec4_data(index)%nbits = 31
|
|---|
| 607 | sec4_data(index)%scale = 5
|
|---|
| 608 | sec4_data(index)%shift = -1073741824
|
|---|
| 609 |
|
|---|
| 610 | index = index + 1
|
|---|
| 611 | sec4_data(index)%name = 'GNSS ID'
|
|---|
| 612 | sec4_data(index)%nbits = 9
|
|---|
| 613 | sec4_data(index)%scale = 0
|
|---|
| 614 | sec4_data(index)%shift = 0
|
|---|
| 615 |
|
|---|
| 616 | index = index + 1
|
|---|
| 617 | sec4_data(index)%name = 'GNSS PRN'
|
|---|
| 618 | sec4_data(index)%nbits = 17
|
|---|
| 619 | sec4_data(index)%scale = 0
|
|---|
| 620 | sec4_data(index)%shift = 0
|
|---|
| 621 |
|
|---|
| 622 | index = index + 1
|
|---|
| 623 | sec4_data(index)%name = 'GNSS x coord'
|
|---|
| 624 | sec4_data(index)%nbits = 31
|
|---|
| 625 | sec4_data(index)%scale = 1
|
|---|
| 626 | sec4_data(index)%shift = -1073741824
|
|---|
| 627 |
|
|---|
| 628 | index = index + 1
|
|---|
| 629 | sec4_data(index)%name = 'GNSS y coord'
|
|---|
| 630 | sec4_data(index)%nbits = 31
|
|---|
| 631 | sec4_data(index)%scale = 1
|
|---|
| 632 | sec4_data(index)%shift = -1073741824
|
|---|
| 633 |
|
|---|
| 634 | index = index + 1
|
|---|
| 635 | sec4_data(index)%name = 'GNSS z coord'
|
|---|
| 636 | sec4_data(index)%nbits = 31
|
|---|
| 637 | sec4_data(index)%scale = 1
|
|---|
| 638 | sec4_data(index)%shift = -1073741824
|
|---|
| 639 |
|
|---|
| 640 | index = index + 1
|
|---|
| 641 | sec4_data(index)%name = 'GNSS x vel'
|
|---|
| 642 | sec4_data(index)%nbits = 31
|
|---|
| 643 | sec4_data(index)%scale = 5
|
|---|
| 644 | sec4_data(index)%shift = -1073741824
|
|---|
| 645 |
|
|---|
| 646 | index = index + 1
|
|---|
| 647 | sec4_data(index)%name = 'GNSS y vel'
|
|---|
| 648 | sec4_data(index)%nbits = 31
|
|---|
| 649 | sec4_data(index)%scale = 5
|
|---|
| 650 | sec4_data(index)%shift = -1073741824
|
|---|
| 651 |
|
|---|
| 652 | index = index + 1
|
|---|
| 653 | sec4_data(index)%name = 'GNSS z vel'
|
|---|
| 654 | sec4_data(index)%nbits = 31
|
|---|
| 655 | sec4_data(index)%scale = 5
|
|---|
| 656 | sec4_data(index)%shift = -1073741824
|
|---|
| 657 |
|
|---|
| 658 | index = index + 1
|
|---|
| 659 | sec4_data(index)%name = 'Time inc'
|
|---|
| 660 | sec4_data(index)%nbits = 18
|
|---|
| 661 | sec4_data(index)%scale = 3
|
|---|
| 662 | sec4_data(index)%shift = -4096
|
|---|
| 663 |
|
|---|
| 664 | index = index + 1
|
|---|
| 665 | sec4_data(index)%name = 'Latitude'
|
|---|
| 666 | sec4_data(index)%nbits = 25
|
|---|
| 667 | sec4_data(index)%scale = 5
|
|---|
| 668 | sec4_data(index)%shift = -9000000
|
|---|
| 669 |
|
|---|
| 670 | index = index + 1
|
|---|
| 671 | sec4_data(index)%name = 'Longitude'
|
|---|
| 672 | sec4_data(index)%nbits = 26
|
|---|
| 673 | sec4_data(index)%scale = 5
|
|---|
| 674 | sec4_data(index)%shift = -18000000
|
|---|
| 675 |
|
|---|
| 676 | index = index + 1
|
|---|
| 677 | sec4_data(index)%name = 'CoC x coord'
|
|---|
| 678 | sec4_data(index)%nbits = 31
|
|---|
| 679 | sec4_data(index)%scale = 2
|
|---|
| 680 | sec4_data(index)%shift = -1073741824
|
|---|
| 681 |
|
|---|
| 682 | index = index + 1
|
|---|
| 683 | sec4_data(index)%name = 'CoC y coord'
|
|---|
| 684 | sec4_data(index)%nbits = 31
|
|---|
| 685 | sec4_data(index)%scale = 2
|
|---|
| 686 | sec4_data(index)%shift = -1073741824
|
|---|
| 687 |
|
|---|
| 688 | index = index + 1
|
|---|
| 689 | sec4_data(index)%name = 'CoC z coord'
|
|---|
| 690 | sec4_data(index)%nbits = 31
|
|---|
| 691 | sec4_data(index)%scale = 2
|
|---|
| 692 | sec4_data(index)%shift = -1073741824
|
|---|
| 693 |
|
|---|
| 694 | index = index + 1
|
|---|
| 695 | sec4_data(index)%name = 'RoC'
|
|---|
| 696 | sec4_data(index)%nbits = 22
|
|---|
| 697 | sec4_data(index)%scale = 1
|
|---|
| 698 | sec4_data(index)%shift = 62000000
|
|---|
| 699 |
|
|---|
| 700 | index = index + 1
|
|---|
| 701 | sec4_data(index)%name = 'Azimuth'
|
|---|
| 702 | sec4_data(index)%nbits = 16
|
|---|
| 703 | sec4_data(index)%scale = 2
|
|---|
| 704 | sec4_data(index)%shift = 0
|
|---|
| 705 |
|
|---|
| 706 | index = index + 1
|
|---|
| 707 | sec4_data(index)%name = 'Undulation'
|
|---|
| 708 | sec4_data(index)%nbits = 15
|
|---|
| 709 | sec4_data(index)%scale = 2
|
|---|
| 710 | sec4_data(index)%shift = -15000
|
|---|
| 711 |
|
|---|
| 712 | ! Lev1b
|
|---|
| 713 | ! -----
|
|---|
| 714 |
|
|---|
| 715 | index = index + 1
|
|---|
| 716 | sec4_data(index)%name = 'No. of level 1b data'
|
|---|
| 717 | sec4_data(index)%nbits = 16
|
|---|
| 718 | sec4_data(index)%scale = 0
|
|---|
| 719 | sec4_data(index)%shift = 0
|
|---|
| 720 |
|
|---|
| 721 | IF ( n_lev1b > 0 ) THEN
|
|---|
| 722 |
|
|---|
| 723 | DO i=1,n_lev1b
|
|---|
| 724 |
|
|---|
| 725 | index = index + 1
|
|---|
| 726 | sec4_data(index)%name = 'Latitude_tp'
|
|---|
| 727 | sec4_data(index)%nbits = 25
|
|---|
| 728 | sec4_data(index)%scale = 5
|
|---|
| 729 | sec4_data(index)%shift = -9000000
|
|---|
| 730 |
|
|---|
| 731 | index = index + 1
|
|---|
| 732 | sec4_data(index)%name = 'Longitude_tp'
|
|---|
| 733 | sec4_data(index)%nbits = 26
|
|---|
| 734 | sec4_data(index)%scale = 5
|
|---|
| 735 | sec4_data(index)%shift = -18000000
|
|---|
| 736 |
|
|---|
| 737 | index = index + 1
|
|---|
| 738 | sec4_data(index)%name = 'Azimuth_tp'
|
|---|
| 739 | sec4_data(index)%nbits = 16
|
|---|
| 740 | sec4_data(index)%scale = 2
|
|---|
| 741 | sec4_data(index)%shift = 0
|
|---|
| 742 |
|
|---|
| 743 | index = index + 1
|
|---|
| 744 | sec4_data(index)%name = 'No. of freqs'
|
|---|
| 745 | sec4_data(index)%nbits = 8
|
|---|
| 746 | sec4_data(index)%scale = 0
|
|---|
| 747 | sec4_data(index)%shift = 0
|
|---|
| 748 |
|
|---|
| 749 | DO j=1,n_freq
|
|---|
| 750 |
|
|---|
| 751 | index = index + 1
|
|---|
| 752 | sec4_data(index)%name = 'Nominal freq'
|
|---|
| 753 | sec4_data(index)%nbits = 7
|
|---|
| 754 | sec4_data(index)%scale = -8
|
|---|
| 755 | sec4_data(index)%shift = 0
|
|---|
| 756 |
|
|---|
| 757 | index = index + 1
|
|---|
| 758 | sec4_data(index)%name = 'Impact param'
|
|---|
| 759 | sec4_data(index)%nbits = 22
|
|---|
| 760 | sec4_data(index)%scale = 1
|
|---|
| 761 | sec4_data(index)%shift = 62000000
|
|---|
| 762 |
|
|---|
| 763 | index = index + 1
|
|---|
| 764 | sec4_data(index)%name = 'Bending angle'
|
|---|
| 765 | sec4_data(index)%nbits = 23
|
|---|
| 766 | sec4_data(index)%scale = 8
|
|---|
| 767 | sec4_data(index)%shift = -100000
|
|---|
| 768 |
|
|---|
| 769 | index = index + 1
|
|---|
| 770 | sec4_data(index)%name = 'First order stats'
|
|---|
| 771 | sec4_data(index)%nbits = 6
|
|---|
| 772 | sec4_data(index)%scale = 0
|
|---|
| 773 | sec4_data(index)%shift = 0
|
|---|
| 774 |
|
|---|
| 775 | index = index + 1
|
|---|
| 776 | sec4_data(index)%name = 'Bangle error'
|
|---|
| 777 | sec4_data(index)%nbits = 20
|
|---|
| 778 | sec4_data(index)%scale = 8
|
|---|
| 779 | sec4_data(index)%shift = -100000
|
|---|
| 780 |
|
|---|
| 781 | index = index + 1
|
|---|
| 782 | sec4_data(index)%name = 'First order stats'
|
|---|
| 783 | sec4_data(index)%nbits = 6
|
|---|
| 784 | sec4_data(index)%scale = 0
|
|---|
| 785 | sec4_data(index)%shift = 0
|
|---|
| 786 |
|
|---|
| 787 | ENDDO
|
|---|
| 788 |
|
|---|
| 789 | index = index + 1
|
|---|
| 790 | sec4_data(index)%name = 'Percent confidence'
|
|---|
| 791 | sec4_data(index)%nbits = 7
|
|---|
| 792 | sec4_data(index)%scale = 0
|
|---|
| 793 | sec4_data(index)%shift = 0
|
|---|
| 794 |
|
|---|
| 795 | ENDDO
|
|---|
| 796 |
|
|---|
| 797 | ENDIF
|
|---|
| 798 |
|
|---|
| 799 | ! Lev2a
|
|---|
| 800 | ! -----
|
|---|
| 801 |
|
|---|
| 802 | index = index + 1
|
|---|
| 803 | sec4_data(index)%name = 'No. of level 2a data'
|
|---|
| 804 | sec4_data(index)%nbits = 16
|
|---|
| 805 | sec4_data(index)%scale = 0
|
|---|
| 806 | sec4_data(index)%shift = 0
|
|---|
| 807 |
|
|---|
| 808 | IF ( n_lev2a > 0 ) THEN
|
|---|
| 809 |
|
|---|
| 810 | DO i=1,n_lev2a
|
|---|
| 811 |
|
|---|
| 812 | index = index + 1
|
|---|
| 813 | sec4_data(index)%name = 'Geom altitude'
|
|---|
| 814 | sec4_data(index)%nbits = 17
|
|---|
| 815 | sec4_data(index)%scale = 0
|
|---|
| 816 | sec4_data(index)%shift = -1000
|
|---|
| 817 |
|
|---|
| 818 | index = index + 1
|
|---|
| 819 | sec4_data(index)%name = 'Refrac'
|
|---|
| 820 | sec4_data(index)%nbits = 19
|
|---|
| 821 | sec4_data(index)%scale = 3
|
|---|
| 822 | sec4_data(index)%shift = 0
|
|---|
| 823 |
|
|---|
| 824 | index = index + 1
|
|---|
| 825 | sec4_data(index)%name = 'First order stats'
|
|---|
| 826 | sec4_data(index)%nbits = 6
|
|---|
| 827 | sec4_data(index)%scale = 0
|
|---|
| 828 | sec4_data(index)%shift = 0
|
|---|
| 829 |
|
|---|
| 830 | index = index + 1
|
|---|
| 831 | sec4_data(index)%name = 'Refrac error'
|
|---|
| 832 | sec4_data(index)%nbits = 14
|
|---|
| 833 | sec4_data(index)%scale = 3
|
|---|
| 834 | sec4_data(index)%shift = 0
|
|---|
| 835 |
|
|---|
| 836 | index = index + 1
|
|---|
| 837 | sec4_data(index)%name = 'First order stats'
|
|---|
| 838 | sec4_data(index)%nbits = 6
|
|---|
| 839 | sec4_data(index)%scale = 0
|
|---|
| 840 | sec4_data(index)%shift = 0
|
|---|
| 841 |
|
|---|
| 842 | index = index + 1
|
|---|
| 843 | sec4_data(index)%name = 'Percent confidence'
|
|---|
| 844 | sec4_data(index)%nbits = 7
|
|---|
| 845 | sec4_data(index)%scale = 0
|
|---|
| 846 | sec4_data(index)%shift = 0
|
|---|
| 847 |
|
|---|
| 848 | ENDDO
|
|---|
| 849 |
|
|---|
| 850 | ENDIF
|
|---|
| 851 |
|
|---|
| 852 | ! Lev2b
|
|---|
| 853 | ! -----
|
|---|
| 854 |
|
|---|
| 855 | index = index + 1
|
|---|
| 856 | sec4_data(index)%name = 'No. of level 2b data'
|
|---|
| 857 | sec4_data(index)%nbits = 16
|
|---|
| 858 | sec4_data(index)%scale = 0
|
|---|
| 859 | sec4_data(index)%shift = 0
|
|---|
| 860 |
|
|---|
| 861 | IF ( n_lev2b > 0 ) THEN
|
|---|
| 862 |
|
|---|
| 863 | DO i=1,n_lev2b
|
|---|
| 864 |
|
|---|
| 865 | index = index + 1
|
|---|
| 866 | sec4_data(index)%name = 'Geop height'
|
|---|
| 867 | sec4_data(index)%nbits = 17
|
|---|
| 868 | sec4_data(index)%scale = 0
|
|---|
| 869 | sec4_data(index)%shift = -1000
|
|---|
| 870 |
|
|---|
| 871 | index = index + 1
|
|---|
| 872 | sec4_data(index)%name = 'Pressure'
|
|---|
| 873 | sec4_data(index)%nbits = 14
|
|---|
| 874 | sec4_data(index)%scale = -1
|
|---|
| 875 | sec4_data(index)%shift = 0
|
|---|
| 876 |
|
|---|
| 877 | index = index + 1
|
|---|
| 878 | sec4_data(index)%name = 'Temperature'
|
|---|
| 879 | sec4_data(index)%nbits = 12
|
|---|
| 880 | sec4_data(index)%scale = 1
|
|---|
| 881 | sec4_data(index)%shift = 0
|
|---|
| 882 |
|
|---|
| 883 | index = index + 1
|
|---|
| 884 | sec4_data(index)%name = 'Spec hum'
|
|---|
| 885 | sec4_data(index)%nbits = 14
|
|---|
| 886 | sec4_data(index)%scale = 5
|
|---|
| 887 | sec4_data(index)%shift = 0
|
|---|
| 888 |
|
|---|
| 889 | index = index + 1
|
|---|
| 890 | sec4_data(index)%name = 'First order stats'
|
|---|
| 891 | sec4_data(index)%nbits = 6
|
|---|
| 892 | sec4_data(index)%scale = 0
|
|---|
| 893 | sec4_data(index)%shift = 0
|
|---|
| 894 |
|
|---|
| 895 | index = index + 1
|
|---|
| 896 | sec4_data(index)%name = 'Pressure error'
|
|---|
| 897 | sec4_data(index)%nbits = 6
|
|---|
| 898 | sec4_data(index)%scale = -1
|
|---|
| 899 | sec4_data(index)%shift = 0
|
|---|
| 900 |
|
|---|
| 901 | index = index + 1
|
|---|
| 902 | sec4_data(index)%name = 'Temperature error'
|
|---|
| 903 | sec4_data(index)%nbits = 6
|
|---|
| 904 | sec4_data(index)%scale = 1
|
|---|
| 905 | sec4_data(index)%shift = 0
|
|---|
| 906 |
|
|---|
| 907 | index = index + 1
|
|---|
| 908 | sec4_data(index)%name = 'Spec hum error'
|
|---|
| 909 | sec4_data(index)%nbits = 9
|
|---|
| 910 | sec4_data(index)%scale = 5
|
|---|
| 911 | sec4_data(index)%shift = 0
|
|---|
| 912 |
|
|---|
| 913 | index = index + 1
|
|---|
| 914 | sec4_data(index)%name = 'First order stats'
|
|---|
| 915 | sec4_data(index)%nbits = 6
|
|---|
| 916 | sec4_data(index)%scale = 0
|
|---|
| 917 | sec4_data(index)%shift = 0
|
|---|
| 918 |
|
|---|
| 919 | index = index + 1
|
|---|
| 920 | sec4_data(index)%name = 'Percent confidence'
|
|---|
| 921 | sec4_data(index)%nbits = 7
|
|---|
| 922 | sec4_data(index)%scale = 0
|
|---|
| 923 | sec4_data(index)%shift = 0
|
|---|
| 924 |
|
|---|
| 925 | ENDDO
|
|---|
| 926 |
|
|---|
| 927 | ENDIF
|
|---|
| 928 |
|
|---|
| 929 | ! Lev2c
|
|---|
| 930 | ! -----
|
|---|
| 931 |
|
|---|
| 932 | index = index + 1
|
|---|
| 933 | sec4_data(index)%name = 'Vert sig'
|
|---|
| 934 | sec4_data(index)%nbits = 6
|
|---|
| 935 | sec4_data(index)%scale = 0
|
|---|
| 936 | sec4_data(index)%shift = 0
|
|---|
| 937 |
|
|---|
| 938 | index = index + 1
|
|---|
| 939 | sec4_data(index)%name = 'Sfc geop height'
|
|---|
| 940 | sec4_data(index)%nbits = 17
|
|---|
| 941 | sec4_data(index)%scale = 0
|
|---|
| 942 | sec4_data(index)%shift = -1000
|
|---|
| 943 |
|
|---|
| 944 | index = index + 1
|
|---|
| 945 | sec4_data(index)%name = 'Sfc press'
|
|---|
| 946 | sec4_data(index)%nbits = 14
|
|---|
| 947 | sec4_data(index)%scale = -1
|
|---|
| 948 | sec4_data(index)%shift = 0
|
|---|
| 949 |
|
|---|
| 950 | index = index + 1
|
|---|
| 951 | sec4_data(index)%name = 'First order stats'
|
|---|
| 952 | sec4_data(index)%nbits = 6
|
|---|
| 953 | sec4_data(index)%scale = 0
|
|---|
| 954 | sec4_data(index)%shift = 0
|
|---|
| 955 |
|
|---|
| 956 | index = index + 1
|
|---|
| 957 | sec4_data(index)%name = 'Sfc press error'
|
|---|
| 958 | sec4_data(index)%nbits = 6
|
|---|
| 959 | sec4_data(index)%scale = -1
|
|---|
| 960 | sec4_data(index)%shift = 0
|
|---|
| 961 |
|
|---|
| 962 | index = index + 1
|
|---|
| 963 | sec4_data(index)%name = 'First order stats'
|
|---|
| 964 | sec4_data(index)%nbits = 6
|
|---|
| 965 | sec4_data(index)%scale = 0
|
|---|
| 966 | sec4_data(index)%shift = 0
|
|---|
| 967 |
|
|---|
| 968 | index = index + 1
|
|---|
| 969 | sec4_data(index)%name = 'Percent confidence'
|
|---|
| 970 | sec4_data(index)%nbits = 7
|
|---|
| 971 | sec4_data(index)%scale = 0
|
|---|
| 972 | sec4_data(index)%shift = 0
|
|---|
| 973 |
|
|---|
| 974 |
|
|---|
| 975 | END SUBROUTINE BUFR_sec4_init
|
|---|
| 976 |
|
|---|
| 977 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 978 |
|
|---|
| 979 | SUBROUTINE BUFR_sec4_to_ROPP(ro_data, ival, rval)
|
|---|
| 980 |
|
|---|
| 981 | TYPE(ROprof), INTENT(inout) :: ro_data
|
|---|
| 982 | INTEGER, INTENT(inout) :: ival(:)
|
|---|
| 983 | REAL(dp), INTENT(inout) :: rval(:)
|
|---|
| 984 |
|
|---|
| 985 | CHARACTER (LEN=20) :: sw_no ! software version
|
|---|
| 986 | REAL(dp), PARAMETER :: ropp_mdtv=-9999.0_dp
|
|---|
| 987 | INTEGER :: k, l, n1b, n2a, n2b, nfq, index
|
|---|
| 988 | REAL(dp) :: freq, impact, bangle, sigma, dum
|
|---|
| 989 |
|
|---|
| 990 | ! LEO ID
|
|---|
| 991 | SELECT CASE(ival(1))
|
|---|
| 992 | CASE (3)
|
|---|
| 993 | ro_data%leo_id(1:4) = 'METB'
|
|---|
| 994 | CASE (4)
|
|---|
| 995 | ro_data%leo_id(1:4) = 'META'
|
|---|
| 996 | CASE (5)
|
|---|
| 997 | ro_data%leo_id(1:4) = 'METC'
|
|---|
| 998 | CASE (40)
|
|---|
| 999 | ro_data%leo_id(1:4) = 'OERS'
|
|---|
| 1000 | CASE (41)
|
|---|
| 1001 | ro_data%leo_id(1:4) = 'CHMP'
|
|---|
| 1002 | CASE (42)
|
|---|
| 1003 | ro_data%leo_id(1:4) = 'TSRX'
|
|---|
| 1004 | CASE (43)
|
|---|
| 1005 | ro_data%leo_id(1:4) = 'TDMX'
|
|---|
| 1006 | CASE (44)
|
|---|
| 1007 | ro_data%leo_id(1:4) = 'PAZE'
|
|---|
| 1008 | CASE (66)
|
|---|
| 1009 | ro_data%leo_id(1:4) = 'SE6A'
|
|---|
| 1010 | CASE (67)
|
|---|
| 1011 | ro_data%leo_id(1:4) = 'SE6B'
|
|---|
| 1012 | CASE (265)
|
|---|
| 1013 | ro_data%leo_id(1:4) = 'GOP1'
|
|---|
| 1014 | CASE (266)
|
|---|
| 1015 | ro_data%leo_id(1:4) = 'GOP2'
|
|---|
| 1016 | CASE (267)
|
|---|
| 1017 | ro_data%leo_id(1:4) = 'PLIA'
|
|---|
| 1018 | CASE (268)
|
|---|
| 1019 | ro_data%leo_id(1:4) = 'PLIB'
|
|---|
| 1020 | CASE (269)
|
|---|
| 1021 | ro_data%leo_id(1:4) = 'SP3U'
|
|---|
| 1022 | CASE (421)
|
|---|
| 1023 | ro_data%leo_id(1:4) = 'OSAT'
|
|---|
| 1024 | CASE (440)
|
|---|
| 1025 | ro_data%leo_id(1:4) = 'MGTP'
|
|---|
| 1026 | CASE (522)
|
|---|
| 1027 | ro_data%leo_id(1:4) = 'FY3C'
|
|---|
| 1028 | CASE (523)
|
|---|
| 1029 | ro_data%leo_id(1:4) = 'FY3D'
|
|---|
| 1030 | CASE (722)
|
|---|
| 1031 | ro_data%leo_id(1:4) = 'GRAA'
|
|---|
| 1032 | CASE (723)
|
|---|
| 1033 | ro_data%leo_id(1:4) = 'GRAB'
|
|---|
| 1034 | CASE (740, 741, 742, 743, 744, 745)
|
|---|
| 1035 | WRITE(ro_data%leo_id(1:4), '(A1,I3.3)') 'C', ival(1) - 739
|
|---|
| 1036 | CASE (750, 751, 752, 753, 754, 755)
|
|---|
| 1037 | WRITE(ro_data%leo_id(1:4), '(A3,I1.1)') 'C2E', ival(1) - 749
|
|---|
| 1038 | CASE (786)
|
|---|
| 1039 | ro_data%leo_id(1:4) = 'CNOF'
|
|---|
| 1040 | CASE (800)
|
|---|
| 1041 | ro_data%leo_id(1:4) = 'SUNS'
|
|---|
| 1042 | CASE (803)
|
|---|
| 1043 | ro_data%leo_id(1:4) = 'GRAC'
|
|---|
| 1044 | CASE (804)
|
|---|
| 1045 | ro_data%leo_id(1:4) = 'GRAD'
|
|---|
| 1046 | CASE (820)
|
|---|
| 1047 | ro_data%leo_id(1:4) = 'SACC'
|
|---|
| 1048 | CASE (825)
|
|---|
| 1049 | ro_data%leo_id(1:4) = 'KOM5'
|
|---|
| 1050 | END SELECT
|
|---|
| 1051 |
|
|---|
| 1052 | ! Software ID
|
|---|
| 1053 | WRITE ( sw_no, FMT="(F10.3)" ) ival(5) / 1000.D0
|
|---|
| 1054 | IF ( (ival(5) / 1000.D0) < 10.D0 ) THEN
|
|---|
| 1055 | ro_data%software_version = "V0" // ADJUSTL ( sw_no )
|
|---|
| 1056 | ELSE
|
|---|
| 1057 | ro_data%software_version = "V" // ADJUSTL ( sw_no )
|
|---|
| 1058 | END IF
|
|---|
| 1059 |
|
|---|
| 1060 | ! DTocc
|
|---|
| 1061 | ro_data%dtocc%year = ival(7)
|
|---|
| 1062 | ro_data%dtocc%month = ival(8)
|
|---|
| 1063 | ro_data%dtocc%day = ival(9)
|
|---|
| 1064 | ro_data%dtocc%hour = ival(10)
|
|---|
| 1065 | ro_data%dtocc%minute = ival(11)
|
|---|
| 1066 | ro_data%dtocc%second = INT(rval(12))
|
|---|
| 1067 | ro_data%dtocc%msec = NINT((rval(12) - ro_data%dtocc%second)*1000.D0)
|
|---|
| 1068 |
|
|---|
| 1069 | ! GNSS ID
|
|---|
| 1070 | SELECT CASE(ival(21))
|
|---|
| 1071 | CASE (401)
|
|---|
| 1072 | WRITE(ro_data%gns_id(1:4), '(A1,I3.3)') 'G', ival(22)
|
|---|
| 1073 | CASE (402)
|
|---|
| 1074 | WRITE(ro_data%gns_id(1:4), '(A1,I3.3)') 'R', ival(22)
|
|---|
| 1075 | CASE (403)
|
|---|
| 1076 | WRITE(ro_data%gns_id(1:4), '(A1,I3.3)') 'E', ival(22)
|
|---|
| 1077 | CASE (404)
|
|---|
| 1078 | WRITE(ro_data%gns_id(1:4), '(A1,I3.3)') 'C', ival(22)
|
|---|
| 1079 | END SELECT
|
|---|
| 1080 |
|
|---|
| 1081 | ! OCC ID
|
|---|
| 1082 | SELECT CASE(ival(3))
|
|---|
| 1083 | CASE (94)
|
|---|
| 1084 | ro_data%processing_centre = 'DMI (ROM SAF)'
|
|---|
| 1085 | CASE (78)
|
|---|
| 1086 | ro_data%processing_centre = 'GFZ Helmholtz Centre, Potsdam'
|
|---|
| 1087 | CASE (74)
|
|---|
| 1088 | ro_data%processing_centre = 'METO Met Office, Exeter'
|
|---|
| 1089 | CASE (60)
|
|---|
| 1090 | ro_data%processing_centre = 'UCAR Boulder'
|
|---|
| 1091 | CASE (160)
|
|---|
| 1092 | ro_data%processing_centre = 'NESDIS Washington'
|
|---|
| 1093 | CASE (254)
|
|---|
| 1094 | ro_data%processing_centre = 'EUMETSAT Darmstadt'
|
|---|
| 1095 | CASE (38)
|
|---|
| 1096 | ro_data%processing_centre = 'CMA Beijing'
|
|---|
| 1097 | CASE (28)
|
|---|
| 1098 | ro_data%processing_centre = 'ISRO New Delhi'
|
|---|
| 1099 | CASE (178)
|
|---|
| 1100 | ro_data%processing_centre = 'SPIRE Spire Global, Inc.'
|
|---|
| 1101 | CASE (179)
|
|---|
| 1102 | ro_data%processing_centre = 'GEOPTICS GeoOptics, Inc.'
|
|---|
| 1103 | CASE (180)
|
|---|
| 1104 | ro_data%processing_centre = 'PLANETIQ PlanetiQ'
|
|---|
| 1105 | END SELECT
|
|---|
| 1106 | WRITE(ro_data%occ_id(1:33), '(A3,I4.4,5(I2.2),A1,A4,A1,A4,A1,A4)') &
|
|---|
| 1107 | 'OC_', ival(7), ival(8), ival(9), ival(10), ival(11), INT(rval(12)), '_', &
|
|---|
| 1108 | ro_data%leo_id(1:4), '_', ro_data%gns_id(1:4), '_', ro_data%processing_centre(1:4)
|
|---|
| 1109 |
|
|---|
| 1110 | ! PCD
|
|---|
| 1111 | DO k=0, 15
|
|---|
| 1112 | IF (IBITS(ival(13), k, 1) == 1) THEN
|
|---|
| 1113 | ro_data%pcd = IBSET(ro_data%pcd, 15-k)
|
|---|
| 1114 | ELSE
|
|---|
| 1115 | ro_data%pcd = IBCLR(ro_data%pcd, 15-k)
|
|---|
| 1116 | ENDIF
|
|---|
| 1117 | ENDDO
|
|---|
| 1118 |
|
|---|
| 1119 | ! Overall quality
|
|---|
| 1120 | IF (ival(14) == -999) THEN
|
|---|
| 1121 | ro_data%overall_qual = -9.9999E7_dp
|
|---|
| 1122 | ELSE
|
|---|
| 1123 | ro_data%overall_qual = REAL(ival(14), KIND=KIND(1.D0))
|
|---|
| 1124 | ENDIF
|
|---|
| 1125 |
|
|---|
| 1126 | ! LEO ref POD
|
|---|
| 1127 | ro_data%georef%leo_pod%pos(1) = rval(15)
|
|---|
| 1128 | ro_data%georef%leo_pod%pos(2) = rval(16)
|
|---|
| 1129 | ro_data%georef%leo_pod%pos(3) = rval(17)
|
|---|
| 1130 | ro_data%georef%leo_pod%vel(1) = rval(18)
|
|---|
| 1131 | ro_data%georef%leo_pod%vel(2) = rval(19)
|
|---|
| 1132 | ro_data%georef%leo_pod%vel(3) = rval(20)
|
|---|
| 1133 |
|
|---|
| 1134 | ! GNSS ref POD
|
|---|
| 1135 | ro_data%georef%gns_pod%pos(1) = rval(23)
|
|---|
| 1136 | ro_data%georef%gns_pod%pos(2) = rval(24)
|
|---|
| 1137 | ro_data%georef%gns_pod%pos(3) = rval(25)
|
|---|
| 1138 | ro_data%georef%gns_pod%vel(1) = rval(26)
|
|---|
| 1139 | ro_data%georef%gns_pod%vel(2) = rval(27)
|
|---|
| 1140 | ro_data%georef%gns_pod%vel(3) = rval(28)
|
|---|
| 1141 |
|
|---|
| 1142 | ! Georef
|
|---|
| 1143 | ro_data%georef%time_offset = rval(29)
|
|---|
| 1144 | ro_data%georef%lat = rval(30)
|
|---|
| 1145 | ro_data%georef%lon = rval(31)
|
|---|
| 1146 | ro_data%georef%r_coc(1) = rval(32)
|
|---|
| 1147 | ro_data%georef%r_coc(2) = rval(33)
|
|---|
| 1148 | ro_data%georef%r_coc(3) = rval(34)
|
|---|
| 1149 | ro_data%georef%roc = rval(35)
|
|---|
| 1150 | ro_data%georef%azimuth = rval(36)
|
|---|
| 1151 | ro_data%georef%undulation = rval(37)
|
|---|
| 1152 |
|
|---|
| 1153 | ! Lev1b
|
|---|
| 1154 | n1b = ival(38)
|
|---|
| 1155 | index = 38
|
|---|
| 1156 | DO k=1,n1b
|
|---|
| 1157 | index = index + 1 ; ro_data%lev1b%lat_tp(k) = rval(index)
|
|---|
| 1158 | index = index + 1 ; ro_data%lev1b%lon_tp(k) = rval(index)
|
|---|
| 1159 | index = index + 1 ; ro_data%lev1b%azimuth_tp(k) = rval(index)
|
|---|
| 1160 | index = index + 1 ; nfq = ival(index)
|
|---|
| 1161 |
|
|---|
| 1162 | DO l=1,nfq
|
|---|
| 1163 |
|
|---|
| 1164 | index = index + 1 ; freq = rval(index)
|
|---|
| 1165 | index = index + 1 ; impact = rval(index)
|
|---|
| 1166 | index = index + 1 ; bangle = rval(index)
|
|---|
| 1167 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1168 | index = index + 1 ; sigma = rval(index)
|
|---|
| 1169 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1170 |
|
|---|
| 1171 | SELECT CASE(NINT(freq/1.0D6))
|
|---|
| 1172 | CASE (1500)
|
|---|
| 1173 | ro_data%lev1b%impact_L1(k) = impact
|
|---|
| 1174 | ro_data%lev1b%bangle_L1(k) = bangle
|
|---|
| 1175 | ro_data%lev1b%bangle_L1_sigma(k) = sigma
|
|---|
| 1176 | CASE (1200)
|
|---|
| 1177 | ro_data%lev1b%impact_L2(k) = impact
|
|---|
| 1178 | ro_data%lev1b%bangle_L2(k) = bangle
|
|---|
| 1179 | ro_data%lev1b%bangle_L2_sigma(k) = sigma
|
|---|
| 1180 | CASE (0)
|
|---|
| 1181 | ro_data%lev1b%impact(k) = impact
|
|---|
| 1182 | ro_data%lev1b%bangle(k) = bangle
|
|---|
| 1183 | ro_data%lev1b%bangle_sigma(k) = sigma
|
|---|
| 1184 | END SELECT
|
|---|
| 1185 |
|
|---|
| 1186 | ENDDO
|
|---|
| 1187 |
|
|---|
| 1188 | index = index + 1 ; dum = ival(index) ! Percent confidence
|
|---|
| 1189 | IF (dum == -999) THEN
|
|---|
| 1190 | ro_data%lev1b%bangle_qual(k) = -9.9999E7_dp
|
|---|
| 1191 | ELSE
|
|---|
| 1192 | ro_data%lev1b%bangle_qual(k) = REAL(dum, KIND=KIND(1.D0))
|
|---|
| 1193 | ENDIF
|
|---|
| 1194 |
|
|---|
| 1195 | ENDDO
|
|---|
| 1196 |
|
|---|
| 1197 | ! Lev2a
|
|---|
| 1198 | index = index + 1 ; n2a = ival(index)
|
|---|
| 1199 | DO k=1,n2a
|
|---|
| 1200 | index = index + 1 ; ro_data%lev2a%alt_refrac(k) = ival(index)
|
|---|
| 1201 | index = index + 1 ; ro_data%lev2a%refrac(k) = rval(index)
|
|---|
| 1202 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1203 | index = index + 1 ; ro_data%lev2a%refrac_sigma(k) = rval(index)
|
|---|
| 1204 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1205 | index = index + 1 ; dum = ival(index) ! Percent confidence
|
|---|
| 1206 | IF (dum == -999) THEN
|
|---|
| 1207 | ro_data%lev2a%refrac_qual(k) = -9.9999E7_dp
|
|---|
| 1208 | ELSE
|
|---|
| 1209 | ro_data%lev2a%refrac_qual(k) = REAL(dum, KIND=KIND(1.D0))
|
|---|
| 1210 | ENDIF
|
|---|
| 1211 | ! calculate geop_refrac, as it is not present in BUFR file
|
|---|
| 1212 | ro_data%lev2a%geop_refrac(k) = &
|
|---|
| 1213 | geometric2geopotential(ro_data%georef%lat, ro_data%lev2a%alt_refrac(k))
|
|---|
| 1214 | ENDDO
|
|---|
| 1215 |
|
|---|
| 1216 | ! Lev2b
|
|---|
| 1217 | index = index + 1 ; n2b = ival(index)
|
|---|
| 1218 | DO k=1,n2b
|
|---|
| 1219 | index = index + 1 ; ro_data%lev2b%geop(k) = ival(index)
|
|---|
| 1220 | index = index + 1 ; ro_data%lev2b%press(k) = rval(index)
|
|---|
| 1221 | IF ( ro_data%lev2b%press(k) > ropp_mdtv ) ro_data%lev2b%press(k) = &
|
|---|
| 1222 | ro_data%lev2b%press(k) / 100.0D0
|
|---|
| 1223 | index = index + 1 ; ro_data%lev2b%temp(k) = rval(index)
|
|---|
| 1224 | index = index + 1 ; ro_data%lev2b%shum(k) = rval(index)
|
|---|
| 1225 | IF ( ro_data%lev2b%shum(k) > ropp_mdtv ) ro_data%lev2b%shum(k) = &
|
|---|
| 1226 | ro_data%lev2b%shum(k) * 1000.0D0
|
|---|
| 1227 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1228 | index = index + 1 ; ro_data%lev2b%press_sigma(k) = rval(index)
|
|---|
| 1229 | IF ( ro_data%lev2b%press_sigma(k) > ropp_mdtv ) ro_data%lev2b%press_sigma(k) = &
|
|---|
| 1230 | ro_data%lev2b%press_sigma(k) / 100.0D0
|
|---|
| 1231 | index = index + 1 ; ro_data%lev2b%temp_sigma(k) = rval(index)
|
|---|
| 1232 | index = index + 1 ; ro_data%lev2b%shum_sigma(k) = rval(index)
|
|---|
| 1233 | IF ( ro_data%lev2b%shum_sigma(k) > ropp_mdtv ) ro_data%lev2b%shum_sigma(k) = &
|
|---|
| 1234 | ro_data%lev2b%shum_sigma(k) * 1000.0D0
|
|---|
| 1235 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1236 | index = index + 1 ; dum = ival(index) ! Percent confidence
|
|---|
| 1237 | IF (dum == -999) THEN
|
|---|
| 1238 | ro_data%lev2b%meteo_qual(k) = -9.9999E7_dp
|
|---|
| 1239 | ELSE
|
|---|
| 1240 | ro_data%lev2b%meteo_qual(k) = REAL(dum, KIND=KIND(1.D0))
|
|---|
| 1241 | ENDIF
|
|---|
| 1242 | ENDDO
|
|---|
| 1243 |
|
|---|
| 1244 | ! Lev2c
|
|---|
| 1245 | index = index + 1 ; dum = ival(index) ! Vertical significance
|
|---|
| 1246 | index = index + 1 ; ro_data%lev2c%geop_sfc = ival(index)
|
|---|
| 1247 | index = index + 1 ; ro_data%lev2c%press_sfc = rval(index)
|
|---|
| 1248 | IF ( ro_data%lev2c%press_sfc > ropp_mdtv ) ro_data%lev2c%press_sfc = &
|
|---|
| 1249 | ro_data%lev2c%press_sfc / 100.0D0
|
|---|
| 1250 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1251 | index = index + 1 ; ro_data%lev2c%press_sfc_sigma = rval(index)
|
|---|
| 1252 | IF ( ro_data%lev2c%press_sfc_sigma > ropp_mdtv ) ro_data%lev2c%press_sfc_sigma = &
|
|---|
| 1253 | ro_data%lev2c%press_sfc_sigma / 100.0D0
|
|---|
| 1254 | index = index + 1 ; dum = ival(index) ! First order stats
|
|---|
| 1255 | index = index + 1 ; ro_data%lev2c%press_sfc_qual = ival(index) ! Percent confidence
|
|---|
| 1256 |
|
|---|
| 1257 | END SUBROUTINE BUFR_sec4_to_ROPP
|
|---|
| 1258 |
|
|---|
| 1259 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 1260 |
|
|---|
| 1261 | SUBROUTINE BUFR_decode_sample(cdata, namvar, i1, i2, pad, size, quiet)
|
|---|
| 1262 |
|
|---|
| 1263 | CHARACTER(LEN=*), INTENT(IN) :: cdata, namvar
|
|---|
| 1264 | INTEGER, INTENT(IN) :: i1, i2
|
|---|
| 1265 | LOGICAL, OPTIONAL, INTENT(INOUT) :: pad
|
|---|
| 1266 | LOGICAL, OPTIONAL, INTENT(IN) :: quiet
|
|---|
| 1267 | INTEGER, OPTIONAL, INTENT(INOUT) :: size
|
|---|
| 1268 |
|
|---|
| 1269 | INTEGER :: i
|
|---|
| 1270 | CHARACTER(LEN=10) :: c_dum
|
|---|
| 1271 | INTEGER :: dum
|
|---|
| 1272 |
|
|---|
| 1273 | CHARACTER(LEN=5) :: fmt
|
|---|
| 1274 | CHARACTER(LEN=5) :: s_octet, s_val
|
|---|
| 1275 | CHARACTER(LEN=128) :: msg
|
|---|
| 1276 | LOGICAL :: local_quiet
|
|---|
| 1277 |
|
|---|
| 1278 | local_quiet = .FALSE.
|
|---|
| 1279 | IF ( PRESENT(quiet) ) local_quiet = quiet
|
|---|
| 1280 |
|
|---|
| 1281 | DO i=i1, i2
|
|---|
| 1282 | WRITE(c_dum(2*(i-i1)+1:2*(i-i1)+2), '(Z2)') ICHAR(cdata(i:i))
|
|---|
| 1283 | ENDDO
|
|---|
| 1284 |
|
|---|
| 1285 | IF (i2 - i1 >= 4) THEN
|
|---|
| 1286 | WRITE(fmt, '(A,I2,A)') '(Z', 2*(i2-i1+1), ')'
|
|---|
| 1287 | ELSE
|
|---|
| 1288 | WRITE(fmt, '(A,I1,A)') '(Z', 2*(i2-i1+1), ')'
|
|---|
| 1289 | ENDIF
|
|---|
| 1290 |
|
|---|
| 1291 | READ(c_dum, fmt) dum
|
|---|
| 1292 |
|
|---|
| 1293 | ! Extra diags, for debugging.
|
|---|
| 1294 | ! PRINT*, ' '
|
|---|
| 1295 | ! PRINT*, TRIM(ADJUSTL(namvar)) // ' = ', dum
|
|---|
| 1296 | ! DO i=i1, i2
|
|---|
| 1297 | ! PRINT*,'Byte ', i
|
|---|
| 1298 | ! CALL BUFR_bit_breakdown(cdata(i:i))
|
|---|
| 1299 | ! ENDDO
|
|---|
| 1300 |
|
|---|
| 1301 | IF ( .NOT. local_quiet ) THEN
|
|---|
| 1302 | WRITE(s_octet, '(I2,A1,I2)') i1, '-', i2
|
|---|
| 1303 | WRITE(s_val, '(I5)') dum
|
|---|
| 1304 | WRITE(msg, '(2X,A5,3X,A24,3X,A5)') s_octet, TRIM(namvar), s_val
|
|---|
| 1305 | IF ( s_octet(1:1) == ' ' ) THEN
|
|---|
| 1306 | CALL message(msg_noin, ' ' // ADJUSTL(msg))
|
|---|
| 1307 | ELSE
|
|---|
| 1308 | CALL message(msg_noin, ' ' // ADJUSTL(msg))
|
|---|
| 1309 | ENDIF
|
|---|
| 1310 | ENDIF
|
|---|
| 1311 |
|
|---|
| 1312 | IF ( PRESENT(pad) .AND. dum == 10 ) pad = .TRUE.
|
|---|
| 1313 |
|
|---|
| 1314 | IF ( PRESENT(size) ) size = dum
|
|---|
| 1315 |
|
|---|
| 1316 | END SUBROUTINE BUFR_decode_sample
|
|---|
| 1317 |
|
|---|
| 1318 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 1319 |
|
|---|
| 1320 | SUBROUTINE BUFR_bit_breakdown(cchar)
|
|---|
| 1321 |
|
|---|
| 1322 | CHARACTER(LEN=1) :: cchar
|
|---|
| 1323 |
|
|---|
| 1324 | CHARACTER(LEN=8) :: ctemp
|
|---|
| 1325 | ! CHARACTER(LEN=10) :: cdum
|
|---|
| 1326 | INTEGER :: m, j
|
|---|
| 1327 |
|
|---|
| 1328 | ! PRINT*,'cchar = ', cchar
|
|---|
| 1329 |
|
|---|
| 1330 | m = ICHAR(cchar)
|
|---|
| 1331 | ! WRITE(cdum, '(Z2)') cchar
|
|---|
| 1332 | ! READ(cdum, '(Z2)') m
|
|---|
| 1333 | ! PRINT*,'ichar(cchar) = ', m
|
|---|
| 1334 |
|
|---|
| 1335 | ctemp = '00000000'
|
|---|
| 1336 | DO j=0,7
|
|---|
| 1337 | IF (BTEST(m, j)) ctemp(j+1:j+1) = '1'
|
|---|
| 1338 | ENDDO
|
|---|
| 1339 |
|
|---|
| 1340 | PRINT*,'Bit breakdown: ', ctemp
|
|---|
| 1341 |
|
|---|
| 1342 | END SUBROUTINE BUFR_bit_breakdown
|
|---|
| 1343 |
|
|---|
| 1344 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 1345 |
|
|---|
| 1346 | FUNCTION ival(cstring) RESULT(ivalue)
|
|---|
| 1347 |
|
|---|
| 1348 | ! There must be a simpler way of doing this!
|
|---|
| 1349 |
|
|---|
| 1350 | CHARACTER(LEN=*) :: cstring
|
|---|
| 1351 | INTEGER :: ivalue
|
|---|
| 1352 |
|
|---|
| 1353 | INTEGER :: k, l, m
|
|---|
| 1354 |
|
|---|
| 1355 | ivalue = 0
|
|---|
| 1356 | m = 1
|
|---|
| 1357 | DO k=LEN(cstring),1,-1
|
|---|
| 1358 | READ(cstring(k:k), '(I1)') l
|
|---|
| 1359 | ivalue = ivalue + l*m
|
|---|
| 1360 | m = 2 * m
|
|---|
| 1361 | ENDDO
|
|---|
| 1362 |
|
|---|
| 1363 | END FUNCTION ival
|
|---|
| 1364 |
|
|---|
| 1365 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|---|
| 1366 |
|
|---|
| 1367 | END PROGRAM robufr2ropp
|
|---|
