| 1 | ! $Id: convertcodes.f90 5560 2018-08-07 08:03:52Z idculv $
|
|---|
| 2 |
|
|---|
| 3 | SUBROUTINE ConvertCodes ( ROdata, & ! (inout)
|
|---|
| 4 | Gclass, & ! (inout)
|
|---|
| 5 | Gcode, & ! (inout)
|
|---|
| 6 | Lcode, & ! (inout)
|
|---|
| 7 | Icode, & ! (inout)
|
|---|
| 8 | Ocode, & ! (inout)
|
|---|
| 9 | Scode, & ! (inout)
|
|---|
| 10 | Ccode, & ! (inout)
|
|---|
| 11 | Bcode, & ! (inout)
|
|---|
| 12 | ind ) ! (in)
|
|---|
| 13 |
|
|---|
| 14 | !****s* ropp2bufr/ConvertCodes *
|
|---|
| 15 | !
|
|---|
| 16 | ! NAME
|
|---|
| 17 | ! ConvertCodes
|
|---|
| 18 | !
|
|---|
| 19 | ! SYNOPSIS
|
|---|
| 20 | ! Convert header codes between ROPP and BUFR
|
|---|
| 21 | !
|
|---|
| 22 | ! USE ropp_io_types
|
|---|
| 23 | ! TYPE (roprof) rodata
|
|---|
| 24 | ! INTEGER :: gclass,gcode,lcode,icode,ocode,scode,bcode,ind
|
|---|
| 25 | ! CHARACTER (LEN=4) :: ccode
|
|---|
| 26 | ! ind = 1 ! to convert ROPP-->BUFR, ind = -1 for BUFR-->ROPP
|
|---|
| 27 | ! CALL convertcodes(rodata,&
|
|---|
| 28 | ! gclass,gcode,lcode,icode,ocode,scode,ccode,bcode,&
|
|---|
| 29 | ! ind)
|
|---|
| 30 | !
|
|---|
| 31 | ! INPUTS
|
|---|
| 32 | ! ROdata dtyp RO data structure [ind>0]
|
|---|
| 33 | ! Gclass int GNSS code (Satellite Class) [ind<=0]
|
|---|
| 34 | ! Gcode int GNSS PRN (Platform Tx ID) [ind<=0]
|
|---|
| 35 | ! Lcode int LEO code (Satellite ID) [ind<=0]
|
|---|
| 36 | ! Icode int Instrument code (Instrument ID) [ind<=0]
|
|---|
| 37 | ! Ocode int Originating (processing) Centre code [ind<=0]
|
|---|
| 38 | ! Scode int Originating Sub-centre code [ind<=0]
|
|---|
| 39 | ! Ccode chr Originating (GTS) centre ICAO code [ind<=0]
|
|---|
| 40 | ! Bcode int Background generating centre code [ind<=0]
|
|---|
| 41 | ! ind int ROPP-->BUFR if >0, else BUFR-->ROPP
|
|---|
| 42 | !
|
|---|
| 43 | ! OUTPUTS
|
|---|
| 44 | ! ROdata dtyp RO data structure [ind<=0]
|
|---|
| 45 | ! Gclass int GNSS code (Satellite Class) [ind>0]
|
|---|
| 46 | ! Gcode int GNSS PRN (Platform Tx ID) [ind>0]
|
|---|
| 47 | ! Lcode int LEO code (Satellite ID) [ind>0]
|
|---|
| 48 | ! Icode int Instrument code (Instrument ID) [ind>0]
|
|---|
| 49 | ! Ocode int Originating (processing) Centre code [ind>0]
|
|---|
| 50 | ! Scode int Originating Sub-centre code [ind>0]
|
|---|
| 51 | ! Ccode chr Originating (GTS) centre ICAO code [ind>0]
|
|---|
| 52 | ! Bcode int Background generating centre code [ind>0]
|
|---|
| 53 | !
|
|---|
| 54 | ! MODULES
|
|---|
| 55 | ! messages - ROPP message library
|
|---|
| 56 | ! ropp_utils - ROPP utilities
|
|---|
| 57 | ! ropp_io - ROPP file I/O support
|
|---|
| 58 | !
|
|---|
| 59 | ! CALLS
|
|---|
| 60 | ! GETENV
|
|---|
| 61 | ! Get_IO_Unit
|
|---|
| 62 | ! message
|
|---|
| 63 | ! message_get_routine
|
|---|
| 64 | ! message_set_routine
|
|---|
| 65 | !
|
|---|
| 66 | ! CALLED BY
|
|---|
| 67 | ! ConvertBUFRtoROPP
|
|---|
| 68 | ! ConvertROPPtoBUFR
|
|---|
| 69 | !
|
|---|
| 70 | ! FILES
|
|---|
| 71 | ! roppbufrcodes.nl - in path BUFR_TABLES, BUFR_LIBRARY or PWD
|
|---|
| 72 | !
|
|---|
| 73 | ! ENVIRONMENT
|
|---|
| 74 | ! BUFR_LIBRARY - when using MetDB BUFR library
|
|---|
| 75 | ! BUFR_TABLES - when using ECMWF BUFR library
|
|---|
| 76 | !
|
|---|
| 77 | ! DESCRIPTION
|
|---|
| 78 | ! Converts from character-based codes (as defined for ROPP) to numeric codes
|
|---|
| 79 | ! suitable for BUFR encoding, if ind>0, else vice-versa.
|
|---|
| 80 | ! The code conversion is driven by a set of look-up tables, which are read
|
|---|
| 81 | ! from a NAMELIST file 'roppbufrcodes.nl' which is expected in the directory
|
|---|
| 82 | ! path defined by at least one of the environment variables BUFR_TABLES
|
|---|
| 83 | ! (ECMWF), BUFR_LIBRARY (MetDB) or PWD (searched in that order).
|
|---|
| 84 | ! If this file cannot be found or opened, a warning is issued and an in-built
|
|---|
| 85 | ! default set of tables is used instead.
|
|---|
| 86 | !
|
|---|
| 87 | ! REFERENCES
|
|---|
| 88 | ! 1. Manual on Codes: International Codes, Part B & Part C.
|
|---|
| 89 | ! WMO-No. 306, World Meteorological Organisation, Geneva.
|
|---|
| 90 | ! http://www.wmo.int/pages/prog/www/WMOCodes/WMO306_vI2/VolumeI.2.html
|
|---|
| 91 | ! 2. Location Indicators. ICAO Document 7910/138
|
|---|
| 92 | ! ISBN 978-92-9231-677-8, Ed.138, December 2010.
|
|---|
| 93 | !
|
|---|
| 94 | ! AUTHOR
|
|---|
| 95 | ! Met Office, Exeter, UK.
|
|---|
| 96 | ! Any comments on this software should be given via the ROM SAF
|
|---|
| 97 | ! Helpdesk at http://www.romsaf.org
|
|---|
| 98 | !
|
|---|
| 99 | ! COPYRIGHT
|
|---|
| 100 | ! (c) EUMETSAT. All rights reserved.
|
|---|
| 101 | ! For further details please refer to the file COPYRIGHT
|
|---|
| 102 | ! which you should have received as part of this distribution.
|
|---|
| 103 | !
|
|---|
| 104 | !****
|
|---|
| 105 |
|
|---|
| 106 | ! Modules
|
|---|
| 107 |
|
|---|
| 108 | USE messages
|
|---|
| 109 | USE ropp_utils, ONLY: Get_IO_Unit
|
|---|
| 110 | USE ropp_io_types
|
|---|
| 111 |
|
|---|
| 112 | IMPLICIT NONE
|
|---|
| 113 |
|
|---|
| 114 | ! Fixed values
|
|---|
| 115 |
|
|---|
| 116 | INTEGER, PARAMETER :: NVIND = 2147483647 ! Missing data flag value
|
|---|
| 117 |
|
|---|
| 118 | ! NB: no. of elements given in NAMELIST file parameters must not
|
|---|
| 119 | ! exceed these values - increase values below if necessary.
|
|---|
| 120 |
|
|---|
| 121 | INTEGER, PARAMETER :: ntx = 6 ! Max. no. of GNSS Tx types
|
|---|
| 122 | INTEGER, PARAMETER :: nrx = 42 ! Max. no. of LEO Rx types
|
|---|
| 123 | INTEGER, PARAMETER :: noc = 11 ! Max. no. of orig. centre types
|
|---|
| 124 | INTEGER, PARAMETER :: nbg = 11 ! Max. no. of b/g centre types
|
|---|
| 125 |
|
|---|
| 126 | INTEGER, PARAMETER :: nep = 3 ! No. of environment paths
|
|---|
| 127 | CHARACTER (LEN=*), PARAMETER :: NLenv(nep) = (/"BUFR_TABLES ", & ! N/L paths
|
|---|
| 128 | "BUFR_LIBRARY", &
|
|---|
| 129 | "PWD " /)
|
|---|
| 130 | CHARACTER (LEN=*), PARAMETER :: NLdsn = "roppbufrcodes.nl" ! N/L file name
|
|---|
| 131 |
|
|---|
| 132 | ! Argument list parameters
|
|---|
| 133 |
|
|---|
| 134 | TYPE ( ROprof ), INTENT(INOUT) :: Rodata ! ROPP data structure
|
|---|
| 135 | INTEGER, INTENT(INOUT) :: Gclass ! GNSS class value
|
|---|
| 136 | INTEGER, INTENT(INOUT) :: Gcode ! GNSS PRN
|
|---|
| 137 | INTEGER, INTENT(INOUT) :: Lcode ! LEO code value
|
|---|
| 138 | INTEGER, INTENT(INOUT) :: Icode ! Instrument code value
|
|---|
| 139 | INTEGER, INTENT(INOUT) :: Ocode ! Origin. centre code value
|
|---|
| 140 | INTEGER, INTENT(INOUT) :: Scode ! Sub-centre code value
|
|---|
| 141 | CHARACTER (LEN=*), INTENT(INOUT) :: Ccode ! ICAO code
|
|---|
| 142 | INTEGER, INTENT(INOUT) :: Bcode ! B/G generator code value
|
|---|
| 143 | INTEGER, INTENT(IN) :: ind ! RO->code if >1 else code->RO
|
|---|
| 144 |
|
|---|
| 145 | ! Define arrays for chararacter (ROPP) & numeric (BUFR code) lists.
|
|---|
| 146 | ! Set some defaults in case the NAMELISTs can't be read. NAMELIST
|
|---|
| 147 | ! values will overwrite these defaults. Include some dummy spares so
|
|---|
| 148 | ! that extra ones can be defined in the NAMELIST _without_ having to
|
|---|
| 149 | ! change the array sizes (up to the max. values) and rebuilding
|
|---|
| 150 | ! the program.
|
|---|
| 151 |
|
|---|
| 152 | ! Satellite Classification (GNSS Tx constellation) (Code Table 002020)
|
|---|
| 153 |
|
|---|
| 154 | CHARACTER (LEN=1), DIMENSION(ntx) :: GNSlist = &
|
|---|
| 155 | (/ "U", "G", "R", "E", "C", "U" /)
|
|---|
| 156 | INTEGER, DIMENSION(ntx) :: GNScode = &
|
|---|
| 157 | (/ NVIND, 401, 402, 403, 404, NVIND /)
|
|---|
| 158 |
|
|---|
| 159 | ! Satellite Identifier (LEO Rx mission) (Code Table 001007 or CCT C-5)
|
|---|
| 160 | ! and associated Instrument Type (Code Table 002019 or CCT C-8)
|
|---|
| 161 | ! NB: instrument code 104 (Tri-G) for COSMIC-2 and GRACE-FO is provisional
|
|---|
| 162 |
|
|---|
| 163 | CHARACTER (LEN=4), DIMENSION(nrx) :: LEOlist = &
|
|---|
| 164 | (/ "UNKN", "OERS", "CHMP", "SUNS", "SACC", &
|
|---|
| 165 | "GRAA", "GRAB", "GRAC", "GRAD", &
|
|---|
| 166 | "C001", "C002", "C003", &
|
|---|
| 167 | "C004", "C005", "C006", &
|
|---|
| 168 | "META", "METB", "METC", "TSRX", &
|
|---|
| 169 | "TDMX", "PAZE", "OSAT", "CNOF", &
|
|---|
| 170 | "MGTP", "FY3C", "FY3D", "KOM5", &
|
|---|
| 171 | "C2E1", "C2E2", "C2E3", &
|
|---|
| 172 | "C2E4", "C2E5", "C2E6", &
|
|---|
| 173 | "C2P1", "C2P2", "C2P3", &
|
|---|
| 174 | "C2P4", "C2P5", "C2P6", &
|
|---|
| 175 | "UNKN", "UNKN", "UNKN" /)
|
|---|
| 176 | INTEGER, DIMENSION(nrx) :: LEOcode = &
|
|---|
| 177 | (/ NVIND, 040, 041, 800, 820, &
|
|---|
| 178 | 722, 723, 803, 804, &
|
|---|
| 179 | 740, 741, 742, &
|
|---|
| 180 | 743, 744, 745, &
|
|---|
| 181 | 004, 003, 005, 042, &
|
|---|
| 182 | 043, 044, 421, 786, &
|
|---|
| 183 | 440, 522, 523, 825, &
|
|---|
| 184 | 750, 751, 752, &
|
|---|
| 185 | 753, 754, 755, &
|
|---|
| 186 | 724, 725, 726, &
|
|---|
| 187 | 727, 728, 729, &
|
|---|
| 188 | NVIND, NVIND, NVIND /)
|
|---|
| 189 | INTEGER, DIMENSION(nrx) :: Inscode = &
|
|---|
| 190 | (/ NVIND, 102, 102, 102, 102, &
|
|---|
| 191 | 102, 102, 104, 104, &
|
|---|
| 192 | 102, 102, 102, &
|
|---|
| 193 | 102, 102, 102, &
|
|---|
| 194 | 202, 202, 202, 103, &
|
|---|
| 195 | 103, 103, 287, 102, &
|
|---|
| 196 | 287, 958, 958, 103, &
|
|---|
| 197 | 104, 104, 104, &
|
|---|
| 198 | 104, 104, 104, &
|
|---|
| 199 | 104, 104, 104, &
|
|---|
| 200 | 104, 104, 104, &
|
|---|
| 201 | NVIND, NVIND, NVIND /)
|
|---|
| 202 |
|
|---|
| 203 | ! List of (BUFR) Originating Centre IDs & their BUFR codes
|
|---|
| 204 | ! (Code Table 001033, CCT C-1, or 001035, CCT C-11)
|
|---|
| 205 | ! The (Processing) Sub-centre code should be valid for the
|
|---|
| 206 | ! associated Originating Centre code (for which Sub-Centre is 0).
|
|---|
| 207 | ! (Code Table 001034, CCT C-12)
|
|---|
| 208 | ! plus associated ICAO Location Indicator codes (for GTS routing headers)
|
|---|
| 209 | ! (ICAO Document 7910: Location Indicators)
|
|---|
| 210 | ! NB: Origin code 'CMA' for FY-3C/D is provisional
|
|---|
| 211 | ! NB: Origin code 'ISRO' for Megha-Tropiques is provisional
|
|---|
| 212 | !
|
|---|
| 213 | CHARACTER (LEN=8), DIMENSION(noc) :: ORGlist = &
|
|---|
| 214 | (/ "UNKNOWN ", "DMI ", "GFZ ", &
|
|---|
| 215 | "METO ", "UCAR ", &
|
|---|
| 216 | "NESDIS ", "EUMETSAT", &
|
|---|
| 217 | "CMA ", "ISRO ", &
|
|---|
| 218 | "UNKNOWN ", "UNKNOWN " /)
|
|---|
| 219 | INTEGER, DIMENSION(noc) :: ORGcode = &
|
|---|
| 220 | (/ NVIND, 094, 078, &
|
|---|
| 221 | 074, 060, &
|
|---|
| 222 | 160, 254, &
|
|---|
| 223 | 038, 028, &
|
|---|
| 224 | NVIND, NVIND /)
|
|---|
| 225 | INTEGER, DIMENSION(noc) :: Subcode = &
|
|---|
| 226 | (/ NVIND, 000, 173, &
|
|---|
| 227 | 000, 000, &
|
|---|
| 228 | 000, 000, &
|
|---|
| 229 | 000, 000, &
|
|---|
| 230 | 000, 000 /)
|
|---|
| 231 | CHARACTER (LEN=35), DIMENSION(noc) :: ORGname = &
|
|---|
| 232 | (/ " ", &
|
|---|
| 233 | "(ROM SAF) ", &
|
|---|
| 234 | "Helmholtz Centre, Potsdam ", &
|
|---|
| 235 | "Met Office, Exeter ", &
|
|---|
| 236 | "Boulder ", &
|
|---|
| 237 | "Washington ", &
|
|---|
| 238 | "Darmstadt ", &
|
|---|
| 239 | "Beijing ", &
|
|---|
| 240 | "New Delhi ", &
|
|---|
| 241 | " ", &
|
|---|
| 242 | " " /)
|
|---|
| 243 | CHARACTER (LEN=4), DIMENSION(noc) :: ICAOcode = &
|
|---|
| 244 | (/ "ZZZZ", "EKMI", "EDZW", &
|
|---|
| 245 | "EGRR", "KWBC", &
|
|---|
| 246 | "KNES", "EUMS", &
|
|---|
| 247 | "BAWX", "DEMS", &
|
|---|
| 248 | "ZZZZ", "ZZZZ" /)
|
|---|
| 249 |
|
|---|
| 250 | ! Orginating Centre (background profile)
|
|---|
| 251 | ! (Code Table 001033, CCT C-1, or 001035, CCT C-11)
|
|---|
| 252 |
|
|---|
| 253 | CHARACTER (LEN=8), DIMENSION(nbg) :: BGDlist = &
|
|---|
| 254 | (/ "UNKNOWN ", "ECMWF ", "DMI ", &
|
|---|
| 255 | "METO ", "NCEP ", &
|
|---|
| 256 | "CMA ", "ISRO ", &
|
|---|
| 257 | "NONE ", "UNKNOWN ", &
|
|---|
| 258 | "UNKNOWN ", "UNKNOWN " /)
|
|---|
| 259 | INTEGER, DIMENSION(nbg) :: BGDcode = &
|
|---|
| 260 | (/ NVIND, 98, 94, &
|
|---|
| 261 | 74, 7, &
|
|---|
| 262 | 38, 28, &
|
|---|
| 263 | NVIND, NVIND, &
|
|---|
| 264 | NVIND, NVIND /)
|
|---|
| 265 |
|
|---|
| 266 | ! Local variables
|
|---|
| 267 |
|
|---|
| 268 | CHARACTER (LEN=235) :: dir = " " ! Translated BUFR directory (path)
|
|---|
| 269 | CHARACTER (LEN=255) :: FileSpec ! Full sequence file name
|
|---|
| 270 | CHARACTER (LEN=50) :: routine ! Saved routine name
|
|---|
| 271 | INTEGER :: NLunit ! NAMELIST file unit no.
|
|---|
| 272 | INTEGER :: i, j, l ! loop counter/indices
|
|---|
| 273 | INTEGER :: ierr ! I/O error
|
|---|
| 274 | LOGICAL :: exists ! File exists flag
|
|---|
| 275 | LOGICAL :: first = .TRUE. ! First call flag
|
|---|
| 276 |
|
|---|
| 277 | ! Namelist parameters
|
|---|
| 278 |
|
|---|
| 279 | NAMELIST /GNScodes/ GNSlist, GNScode
|
|---|
| 280 | NAMELIST /LEOcodes/ LEOlist, LEOcode, Inscode
|
|---|
| 281 | NAMELIST /ORGcodes/ ORGlist, ORGcode, Subcode, ORGname, ICAOcode
|
|---|
| 282 | NAMELIST /BGDcodes/ BGDlist, BGDcode
|
|---|
| 283 |
|
|---|
| 284 | SAVE first
|
|---|
| 285 |
|
|---|
| 286 | CALL message_get_routine ( routine )
|
|---|
| 287 | CALL message_set_routine ( "ConvertCodes" )
|
|---|
| 288 |
|
|---|
| 289 | !---------------------------------------------------
|
|---|
| 290 | ! 1. Find & open codes NAMELIST file, read lists
|
|---|
| 291 | !---------------------------------------------------
|
|---|
| 292 |
|
|---|
| 293 | IF ( first ) THEN
|
|---|
| 294 | NLunit = Get_IO_Unit()
|
|---|
| 295 | DO i = 1, nep
|
|---|
| 296 | CALL GETENV ( TRIM(NLenv(i)), dir )
|
|---|
| 297 | l = LEN_TRIM(dir)
|
|---|
| 298 | IF ( l > 0 .AND. TRIM(dir) /= TRIM(NLenv(i)) ) THEN
|
|---|
| 299 | IF ( dir(l:l) /= "/" ) dir(l+1:l+1) = "/"
|
|---|
| 300 | FileSpec = ADJUSTL(TRIM(dir)//NLdsn)
|
|---|
| 301 | INQUIRE ( FILE=FileSpec, EXIST=exists )
|
|---|
| 302 | IF ( exists ) EXIT
|
|---|
| 303 | END IF
|
|---|
| 304 | END DO
|
|---|
| 305 |
|
|---|
| 306 | IF ( exists ) THEN
|
|---|
| 307 | OPEN ( UNIT=NLunit, FILE=FileSpec, ACTION="READ", IOSTAT=ierr )
|
|---|
| 308 | IF ( ierr == 0 ) THEN
|
|---|
| 309 | READ ( UNIT=NLunit, NML=GNScodes, IOSTAT=ierr )
|
|---|
| 310 | IF ( ierr /= 0 ) &
|
|---|
| 311 | CALL message ( msg_warn, "Error loading NAMELIST GNScodes" )
|
|---|
| 312 | READ ( UNIT=NLunit, NML=LEOcodes, IOSTAT=ierr )
|
|---|
| 313 | IF ( ierr /= 0 ) &
|
|---|
| 314 | CALL message ( msg_warn, "Error loading NAMELIST LEOcodes" )
|
|---|
| 315 | READ ( UNIT=NLunit, NML=ORGcodes, IOSTAT=ierr )
|
|---|
| 316 | IF ( ierr /= 0 ) &
|
|---|
| 317 | CALL message ( msg_warn, "Error loading NAMELIST ORGcodes" )
|
|---|
| 318 | READ ( UNIT=NLunit, NML=BGDcodes, IOSTAT=ierr )
|
|---|
| 319 | IF ( ierr /= 0 ) &
|
|---|
| 320 | CALL message ( msg_warn, "Error loading NAMELIST BGDcodes" )
|
|---|
| 321 | CLOSE ( UNIT=NLunit )
|
|---|
| 322 | IF ( ierr == 0 ) THEN
|
|---|
| 323 | CALL message ( msg_diag, "Loaded "//TRIM(FileSpec) )
|
|---|
| 324 | ELSE
|
|---|
| 325 | CALL message ( msg_warn, "Error loading ROPP-BUFR codes "// &
|
|---|
| 326 | "NAMELIST file" )
|
|---|
| 327 | CALL message ( msg_cont, " ("//TRIM(FileSpec)//")" )
|
|---|
| 328 | CALL message ( msg_cont, " Using default look-up tables for items "// &
|
|---|
| 329 | " not loaded" )
|
|---|
| 330 | END IF
|
|---|
| 331 | ELSE
|
|---|
| 332 | CALL message ( msg_warn, "ROPP-BUFR codes NAMELIST file"// &
|
|---|
| 333 | " could not be opened." )
|
|---|
| 334 | CALL message ( msg_cont, " ("//TRIM(FileSpec)//")" )
|
|---|
| 335 | CALL message ( msg_cont, " Using default look-up tables" )
|
|---|
| 336 | END IF
|
|---|
| 337 | ELSE
|
|---|
| 338 | CALL message ( msg_warn, "ROPP-BUFR codes NAMELIST file "// &
|
|---|
| 339 | TRIM(NLdsn)//" could not be found." )
|
|---|
| 340 | CALL message ( msg_cont, " Using default look-up tables" )
|
|---|
| 341 | END IF
|
|---|
| 342 |
|
|---|
| 343 | first = .FALSE.
|
|---|
| 344 | END IF
|
|---|
| 345 |
|
|---|
| 346 | !---------------------------------------------------
|
|---|
| 347 | ! 2. Look up numeric (BUFR) code from character (ROPP)
|
|---|
| 348 | !---------------------------------------------------
|
|---|
| 349 |
|
|---|
| 350 | IF ( ind >= 1 ) THEN
|
|---|
| 351 |
|
|---|
| 352 | ! Defaults
|
|---|
| 353 |
|
|---|
| 354 | Lcode = NVIND
|
|---|
| 355 | Icode = NVIND
|
|---|
| 356 | Gclass = NVIND
|
|---|
| 357 | Gcode = NVIND
|
|---|
| 358 | Ocode = NVIND
|
|---|
| 359 | Scode = NVIND
|
|---|
| 360 | Ccode = "ZZZZ"
|
|---|
| 361 | Bcode = NVIND
|
|---|
| 362 |
|
|---|
| 363 | ! LEO Rx ID code (satellite & hence instrument)
|
|---|
| 364 |
|
|---|
| 365 | i = nrx
|
|---|
| 366 | DO
|
|---|
| 367 | IF (i .EQ. 0) EXIT
|
|---|
| 368 | IF (LEOlist(i) .EQ. ROdata%LEO_id) EXIT
|
|---|
| 369 | i = i - 1
|
|---|
| 370 | END DO
|
|---|
| 371 |
|
|---|
| 372 | IF ( i > 0 ) THEN
|
|---|
| 373 | Lcode = LEOcode(i)
|
|---|
| 374 | Icode = Inscode(i)
|
|---|
| 375 | END IF
|
|---|
| 376 |
|
|---|
| 377 | ! GNSS Tx ID code (satellite class) & separate PRN
|
|---|
| 378 |
|
|---|
| 379 | i = ntx
|
|---|
| 380 | DO
|
|---|
| 381 | IF (i .EQ. 0) EXIT
|
|---|
| 382 | IF (GNSlist(i) .EQ. ROdata%GNS_id(1:1)) EXIT
|
|---|
| 383 | i = i - 1
|
|---|
| 384 | END DO
|
|---|
| 385 |
|
|---|
| 386 | IF ( i > 0 ) Gclass = GNScode(i)
|
|---|
| 387 | READ ( ROdata%GNS_id(2:4), FMT=*, IOSTAT=ierr ) Gcode
|
|---|
| 388 | IF ( ierr /= 0 .OR. &
|
|---|
| 389 | Gcode < 0 .OR. &
|
|---|
| 390 | Gcode > 32 ) Gcode = NVIND
|
|---|
| 391 |
|
|---|
| 392 | ! Originating (encoding) centre code and associated
|
|---|
| 393 | ! sub-centre (processing) & ICAO (GTS node) codes
|
|---|
| 394 |
|
|---|
| 395 | i = noc
|
|---|
| 396 | DO
|
|---|
| 397 | IF (i .EQ. 0) EXIT
|
|---|
| 398 | IF (ORGlist(i)(1:3) .EQ. ROdata%Processing_Centre(1:3)) EXIT
|
|---|
| 399 | i = i - 1
|
|---|
| 400 | END DO
|
|---|
| 401 |
|
|---|
| 402 | Ocode = ORGcode(i)
|
|---|
| 403 | Scode = SUBcode(i)
|
|---|
| 404 | Ccode = ICAOcode(i)
|
|---|
| 405 |
|
|---|
| 406 | ! Look up background generator centre code
|
|---|
| 407 |
|
|---|
| 408 | i = nbg
|
|---|
| 409 | DO
|
|---|
| 410 | IF (i .EQ. 0) EXIT
|
|---|
| 411 | IF (BGDlist(i)(1:3) .EQ. ROdata%BG%Source(1:3)) EXIT
|
|---|
| 412 | i = i - 1
|
|---|
| 413 | END DO
|
|---|
| 414 |
|
|---|
| 415 | Bcode = BGDcode(i)
|
|---|
| 416 |
|
|---|
| 417 | !---------------------------------------------------
|
|---|
| 418 | ! 3. Look up character (ROPP) code from numeric (BUFR)
|
|---|
| 419 | !---------------------------------------------------
|
|---|
| 420 |
|
|---|
| 421 | ELSE
|
|---|
| 422 |
|
|---|
| 423 | ! Defaults
|
|---|
| 424 |
|
|---|
| 425 | ROdata%LEO_id = "UNKN"
|
|---|
| 426 | ROdata%GNS_id = "U999"
|
|---|
| 427 | ROdata%Processing_Centre = "UNKNOWN"
|
|---|
| 428 | ROdata%BG%Source = "UNKNOWN"
|
|---|
| 429 |
|
|---|
| 430 | ! LEO Rx ID code (Satellite)
|
|---|
| 431 |
|
|---|
| 432 | i = nrx
|
|---|
| 433 | DO
|
|---|
| 434 | IF (i .EQ. 0) EXIT
|
|---|
| 435 | IF (Lcode .EQ. LEOcode(i)) EXIT
|
|---|
| 436 | i = i - 1
|
|---|
| 437 | END DO
|
|---|
| 438 |
|
|---|
| 439 | IF ( i > 0 ) ROdata%LEO_id = LEOlist(i)
|
|---|
| 440 |
|
|---|
| 441 | ! GNSS Tx ID code (from satellite class) & add PRN
|
|---|
| 442 |
|
|---|
| 443 | i = ntx
|
|---|
| 444 | DO
|
|---|
| 445 | IF (i .EQ. 0) EXIT
|
|---|
| 446 | IF (Gclass .EQ. GNScode(i)) EXIT
|
|---|
| 447 | i = i - 1
|
|---|
| 448 | END DO
|
|---|
| 449 |
|
|---|
| 450 | IF ( i > 0 ) ROdata%GNS_id(1:1) = GNSlist(i)
|
|---|
| 451 | IF ( Gcode < 0 .OR. Gcode > 999 ) Gcode = 999
|
|---|
| 452 | WRITE ( ROdata%GNS_id(2:4), &
|
|---|
| 453 | FMT="(I3.3)", &
|
|---|
| 454 | IOSTAT=ierr ) Gcode
|
|---|
| 455 |
|
|---|
| 456 | ! Originating (RO processing) centre code
|
|---|
| 457 |
|
|---|
| 458 | i = noc
|
|---|
| 459 | DO
|
|---|
| 460 | IF (i .EQ. 0) EXIT
|
|---|
| 461 | IF (Ocode .EQ. ORGcode(i)) EXIT
|
|---|
| 462 | i = i - 1
|
|---|
| 463 | END DO
|
|---|
| 464 |
|
|---|
| 465 | IF ( i > 0 ) THEN
|
|---|
| 466 | j = MAX ( LEN_TRIM ( ORGlist(i) ), 4 )
|
|---|
| 467 | ROdata%Processing_Centre = ORGlist(i)(1:j) &
|
|---|
| 468 | // " " // ORGname(i)
|
|---|
| 469 | Ccode = ICAOcode(i)
|
|---|
| 470 | END IF
|
|---|
| 471 |
|
|---|
| 472 | ! Background generating centre code
|
|---|
| 473 |
|
|---|
| 474 | i = nbg
|
|---|
| 475 | DO
|
|---|
| 476 | IF (i .EQ. 0) EXIT
|
|---|
| 477 | IF (Bcode .EQ. BGDcode(i)) EXIT
|
|---|
| 478 | i = i - 1
|
|---|
| 479 | END DO
|
|---|
| 480 |
|
|---|
| 481 | IF ( i > 0 ) ROdata%BG%Source = BGDlist(i)
|
|---|
| 482 |
|
|---|
| 483 | ENDIF
|
|---|
| 484 |
|
|---|
| 485 | CALL message_set_routine ( routine )
|
|---|
| 486 |
|
|---|
| 487 | END SUBROUTINE ConvertCodes
|
|---|
