Page 1 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 1 C$$$ MAIN PROGRAM DOCUMENTATION BLOCK 2 C 3 C MAIN PROGRAM: BUFR_TRANSATW 4 C PRGMMR: Y. LING ORG: NP22 DATE: 2012-11-16 5 C 6 C ABSTRACT: READS IN SATELLITE WIND REPORTS IN WMO BUFR FORMAT, 7 C REFORMATS AND PACKS INTO A BUFR FILE WHICH CAN BE DATABASED BY 8 C TRANJB. THIS CURRENTY APPLIES TO MESSAGE TYPES NC005010-014, 9 C NC005019, NC005050-051, NC005071-071 AND NC005080. 10 C 11 C PROGRAM HISTORY LOG: 12 C 2000-05-08 X. SU - ORIGINAL AUTHOR 13 C 2000-09-05 D. KEYSER - REDUCED AMOUNT OF STDOUT PRINT; HARDWIRE THE 14 C RECURSIVE FILTER FLAG (RFFL) AS MISSING FOR PICTURE TRIPLET WINDS 15 C IN TYPE 005, SUBTYPE 013 16 C 2001-03-30 D. KEYSER - NOW CHECKS YYYYMMDDHH OF EACH REPORT TO SEE 17 C IF A NEW OUTPUT MESSAGE SHOULD BE OPENED WITH THIS DATE, ENSURES 18 C THAT OUTPUT FILE BUFR MESSAGES CONTAIN ONLY REPORTS WITH SAME 19 C YYYYMMDDHH AS MESSAGE (THIS IS A REDUNDANT CHECK FOR UNCOMPRESSED 20 C FILES SINCE SUBSEQUENT BUFR_TRANJB PROGRAM ALSO DOES THIS, BUT 21 C THIS CHECK DOESN'T COST ANY TIME AND IT WILL BE IMPORTANT IF 22 C THESE FILES ARE EVER COMPRESSED); ADDED ERROR HANDLING WHEN NO 23 C OUTPUT IS CREATED SO THAT SUBSEQUENT TRANJB'S ARE SKIPPED; 24 C STREAMLINED CODE; TURNED OFF EXTRANEOUS PRINTOUT 25 C 2004-09-02 D. KEYSER -- MODIFIED TO PROCESS TERRA AND AQUA MODIS 26 C WINDS WHICH HAVE SATELLITE ID VALUES OF 783 AND 784, RESP. 27 C (FORMER GET "T" IN FIRST CHARACTER OF STNID, LATTER GET "U") 28 C 2005-03-14 D. KEYSER -- MODIFIED TO ENCODE TERRA AND AQUA MODIS 29 C WINDS IN THE SAME BUFR FORMAT STRUCTURE AS THE GOES GTS WINDS - 30 C THIS PROVIDES MORE QUALITY INFORMATION 31 C 2006-02-02 D. KEYSER - REPLACED CALL TO BUFRLIB ROUTINE IREADIBM 32 C WITH CALL TO BUFRLIB ROUTINE IREADMG (IREADIBM OBSOLETE WITH 33 C 1/31/2006 VERSION OF BUFRLIB) 34 C 2006-02-02 S. BENDER - MODIFIED TO PROCESS GOES 3.9 um WINDS (ENCODE 35 C IN THE SAME BUFR FORMAT STRUCTURE AS THE GOES GTS AND MODIS 36 C WINDS) 37 C 2010-04-07 G. KRASOWSKI - MODIFIED TO PROCESS NOAA-15 THROUGH -19 38 C AND METOP-2 AVHRR WINDS WHICH HAVE SATELLITE ID VALUES OF 206- 39 C 209, 223 and 004, RESP. 40 C 2011-11-22 D. KEYSER MODIFIED TO RECOGNIZE ALL CURRENT AND FUTURE 41 C SATELLITES WHICH COULD PRODUCE SATELLITE-DERIVED WINDS (EVEN 42 C THOSE TYPES NOT NORMALLY PROCESSED BY THIS PROGRAM); MODIFIED TO 43 C RECOGNIZE INPUT "FOREIGN" BUFR TABLE WHICH NOW INCLUDES A FOURTH 44 C REPLICATION OF QUALITY INFO ("PCCF") CONTAINING "EXPECTED ERROR" 45 C (EE) (OR AT LEAST IS SET UP TO HOLD THIS IF IT IS AVAILABLE IN 46 C THE INCOMING RAW FILES) (IN ADDITION TO RFF, QI WITH FORECAST AND 47 C QI W/O FORECAST), AND TO POSSIBLY ENCODE THIS INTO AN OUTPUT BUFR 48 C TABLE WITH A NEW FOURTH REPLICATION OF QUALITY INFO ("PCCF") FOR 49 C MODIS WINDS IN NC005070 AND NC005071; MODIFIED TO NOW POSSIBLY 50 C ENCODE ALL FOUR QUALITY INDICATORS ("PCCF") INTO OUTPUT BUFR 51 C TABLE GOES MESSAGE TYPES NC005010, NC005011, NC005012 AND 52 C NC005014 (THESE THEN LOOK LIKE THE MODIS WIND MESSAGES, 53 C STRUCTURE-WISE - ALL ARE IN QUASI-NESDIS VERSION 10 BUFR WINDS 54 C FORMAT) - IMPORTANT: THIS CODE WILL ALSO WORK WITH: 55 C 1) MESSAGE TYPES WHOSE "FOREIGN" BUFR TABLE DOES NOT INCLUDE 56 C A PLACE HOLDER FOR EE (I.E., IT HAS ONLY THREE 57 C REPLICATIONS OF QUALITY INFO) AND WHOSE OUTPUT BUFR TABLE Page 2 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 58 C ALSO DOES NOT INCLUDE A PLACE HOLDER FOR EE (E.G., MODIS 59 C IR & WVI WITH ONLY RFF, QI W/ FCST & QI W/O FCST, AND 60 C GOES IR, WVI, VIZ & WVS WITH ONLY RFF - THE GOES OUPUT 61 C BUFR SUBSETS NOT BEING IN VERSION 10 FORMAT) 62 C 2) MESSAGE TYPES WHOSE "FOREIGN" BUFR TABLE DOES HAVE EE (OR 63 C AT LEAST IS SET UP TO HOLD THIS IF IT IS AVAILABLE) (I.E, 64 C IT HAS FOUR REPLICATIONS OF QUALITY INFO) BUT WHOSE 65 C OUTPUT BUFR TABLE DOES NOT INCLUDE A PLACE HOLDER FOR EE 66 C (E.G., MODIS IR & WVI WITH ONLY RFF, QI W/ FCST & QI W/O 67 C FCST, AND GOES IR, WVI, VIZ & WVS WITH ONLY RFF - THE 68 C GOES OUTPUT BUFR SUBSETS NOT BEING IN VERSION 10 FORMAT) 69 C 3) MESSAGE TYPES WHOSE "FOREIGN" BUFR TABLE DOES NOT HAVE 70 C INCLUDE A PLACE HOLDER FOR EE (I.E., IT HAS ONLY THREE 71 C REPLICATIONS OF QUALITY INFO) BUT WHOSE OUTPUT BUFR TABLE 72 C DOES INCLUDE A PLACE HOLDER FOR EE (E.G., AVHRR IR FROM 73 C UW/CIMSS) (EE WILL BE MISSING IN OUTPUT) 74 C {what I am trying to say here is that this code will work with 75 C input and output BUFR tables as they appeared through November 76 C 2011; it will also work with input BUFR tables that include a 77 C placeholder for EE (but with no EE in raw data) and output BUFR 78 C tables as they appeared through November 2011; and it will work 79 C with input BUFR tables modified to add EE for one or more (or 80 C all types) but output BUFR tables not yet modified to handle EE 81 C for any types; and it will work with input BUFR tables not yet 82 C modified to handle EE for some (or all) types but output BUFR 83 C tables modified to add EE for the same types (EE missing in 84 C output here); and finally it will work for input and output 85 C BUFR tables both modified to add EE, where the GOES message 86 C types are also modified to be BUFR V10 format (looking like the 87 C MODIS and AVHRR winds structure-wise) 88 C 2012-01-03 D. KEYSER CORRECTED LOGIC TO PROPERLY IDENTIFY CASE 89 C WHEN INPUT FILE HAS 4 PCCF REPLICATIONS BUT THE 4'TH (EE) IS NOT 90 C POPULATED (BEFORE, EE COULD SOMETIMES BE ENCODED AS 0 RATHER THAN 91 C AS MISSING IN AN OUTPUT FILE ALSO WITH 4 PCCF REPLICATIONS) 92 C 2012-11-16 Y. Ling/D. Keyser Changes to run on WCOSS (e.g., 93 C replaced all real declarations with real(8) for types in ufbxxx 94 C calls). 95 C 96 C USAGE: 97 C INPUT FILES: 98 C UNIT 05 - STANDARD INPUT. W3TRNARG PARSES ARGUMENTS FROM 99 C - STANDARD INPUT. 100 C UNIT 11 - WMO BUFR FILE. 101 C UNIT 19 - FOREIGN BUFR TABLE FILE CONTAINING BUFR TABLES A, 102 C - B, AND D (FOR UNIT 11). 103 C UNIT 20 - BUFR TABLE FILE CONTAINING BUFR TABLES A, B, AND 104 C D (FOR UNIT 51). 105 C 106 C OUTPUT FILES: 107 C UNIT 06 - PRINTOUT 108 C UNIT 51 - POINTS TO THE OUTPUT BUFR FILE. TRANJB WILL PLACE 109 C THE BUFR MESSAGES INTO THE PROPER TANKS. 110 C 111 C SUBPROGRAMS CALLED: 112 C UNIQUE - SCAN_BUFRTABLE 113 C LIBRARY: 114 C SYSTEM - INQUIRE Page 3 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 115 C W3NCO - W3TRNARG W3TAGB W3TAGE ERREXIT 116 C BUFRLIB - OPENBF CLOSBF OPENMB UFBINT UFBREP WRITSB 117 C - IREADMG IREADSB DATELEN UPFTBV IBFMS DIGIT 118 C 119 C EXIT STATES: 120 C COND = 0 - SUCCESSFUL RUN 121 C = 1 - UNABLE TO PARSE INPUT ARGUMENTS IN W3TRNARG 122 C = 44 - ERROR SCANNING OUTPUT BUFR TABLE 123 C = 253 - NO REPORTS WRITTEN OUT 124 C 125 C ATTRIBUTES: 126 C LANGUAGE: FORTRAN 90 127 C MACHINE: NCEP WCOSS 128 C 129 C$$$ 130 131 PROGRAM BUFR_TRANSATW 132 133 REAL(8),DIMENSION(1) :: TCMD,SWQM,RSTNID,SWDL,CORN,TPHR 134 REAL(8),DIMENSION(2) :: XLALO 135 REAL(8),DIMENSION(3) :: YMDAY 136 REAL(8),DIMENSION(4) :: GNAPIN,TSIGOUT 137 REAL(8),DIMENSION(5) :: GCLONG,HOUROUT 138 REAL(8),DIMENSION(6) :: RCPDAT 139 REAL(8),DIMENSION(8) :: PCCFOUT,GNAPOUT 140 REAL(8),DIMENSION(9) :: OGCEOUT 141 REAL(8),DIMENSION(10) :: HOURIN,TSIGIN,TMDBST 142 REAL(8),DIMENSION(11) :: PRLC,HAMD 143 REAL(8),DIMENSION(12) :: SATINFO 144 REAL(8),DIMENSION(40) :: PCCFIN 145 REAL(8),DIMENSION(2,5) :: WINDSQ,TMISCOUT 146 REAL(8),DIMENSION(2,9) :: TMISCIN 147 148 INTEGER,DIMENSION(7) :: ISWDL 149 INTEGER,DIMENSION(8) :: IDAT 150 INTEGER,DIMENSION(31):: IBIT 151 152 LOGICAL V10_BUFR 153 154 CHARACTER*1 STNID1(784),STNID6(7),CDUMMY 155 CHARACTER*8 SUBSET,TLFLAG,STNID,SUBFGN 156 CHARACTER*80 APPCHR,SUBDIR,TANKID 157 CHARACTER*128 FILENAME 158 159 EQUIVALENCE (STNID,RSTNID) 160 161 DATA LUNIN /11/ 162 DATA LINDX /19/ 163 DATA LUNDX /20/ 164 DATA LUNOT /51/ 165 DATA BMISS /10E10/ 166 DATA MINJAP /150/ 167 DATA MAXJAP /152/ 168 169 DATA IDATE_prev/-99/,LDATE_prev/-99/ 170 171 C First character of report id Page 4 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 172 C ---------------------------- 173 174 DATA STNID1 ! unique characters still available: 'J','S' 175 176 C ** METOP ** 177 C ---- spare(1-2) 3 4 5 178 $/ 2*'?','H','E','I' 179 180 C ---- spare(6-49) 181 $, 44* '?' 182 183 C ** Meteosat ** 184 C ---- 50 51 52 53 54 55 56 57 58 59 sp(60-69) 70 sp(71-98) 99 185 $,'Z','W','X','Y','Z','W','X','Y','Z','W',10* '?', 'Z',28* '?', 'X' 186 187 C ---- spare(100-149) 188 $, 50* '?' 189 190 C ** GMS/MTSAT ** 191 C ---- 150 151 152 sp(153-170) 171 172 173 174 175 176 sp(177-198) 199 192 $,'R','O','P', 18* '?', 'Q','R','O','P','Q','R', 22* '?', 'Q' 193 194 C ** NOAA ** 195 C ---- spare(200-205) 206 207 208 209 spare(210-222) 223 196 $, 6* '?', 'F','L','M','N', 13* '?', 'G' 197 198 C ---- spare(224-249) 199 $, 26* '?' 200 201 C ** GOES ** 202 C ---- 250 251 252 253 254 255 256 257 258 259 203 $,'D','A','B','C','D','A','B','C','D','A' 204 205 206 C ---- spare(260-439) 207 $, 180* '?' 208 209 C ** Kalpana ** 210 C ---- 440 211 $,'K' 212 213 C ---- spare(441-469) 214 $, 29* '?' 215 216 C ** Insat ** 217 C ---- 470 spare(471-498) 499 218 $,'V', 28* '?', 'V' 219 220 C ---- spare(500-782) 221 $, 283* '?' 222 223 C ** Terra ** 224 C ---- 783 225 $,'T' 226 227 C ** Aqua ** 228 C ---- 784 Page 5 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 229 $,'U' / 230 231 232 C Sixth character of report id, deep-layer switch 233 C -> Type: IR VIS WV-CT PTRIP WV-DL WV-? 234 DATA STNID6 / 'I', 'Z', 'W', 'P', 'W', '?', 'W' / 235 DATA ISWDL / 2 , 2 , 2 , 99999, 1 , 99999, 99999 / 236 237 C----------------------------------------------------------------------- 238 239 CALL W3TAGB('BUFR_TRANSATW',2012,0321,0073,'NP22') 240 241 PRINT *, ' ' 242 PRINT *, ' ==> Welcome to BUFR_TRANSATW -- Version 11/16/2012' 243 PRINT *, ' ' 244 245 CALL W3TRNARG(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR, 246 . TLFLAG,JDATE,KDATE,IERR) 247 ccccc print *, 'LSUBDR=',LSUBDR 248 ccccc print *, 'LTNKID=',LTNKID 249 ccccc print *, 'SUBDIR=',SUBDIR(LSUBDR-2:LSUBDR) 250 ccccc print *, 'TANKID=',TANKID(LTNKID-2:LTNKID) 251 IF(IERR.NE.0) THEN 252 WRITE(6,'('' UNABLE TO PARSE ARGS TO TRANSLATION ROUTINE - '', 253 . '' RETURN CODE = '',I5)') IERR 254 CALL W3TAGE('BUFR_TRANSATW') 255 CALL ERREXIT(IERR) 256 ENDIF 257 SUBSET = 'NC'//SUBDIR(LSUBDR-2:LSUBDR)//TANKID(LTNKID-2:LTNKID) 258 ccccc print *, 'SUBSET=',SUBSET 259 C----------------------------------------------------------------------- 260 261 C Determine how many replications of quality information are specified 262 C in the output BUFR table for this message type (subset) - this 263 C will determine if the output BUFR table is in quasi-Version 10 BUFR 264 C winds format for this message type AND, if it is in Version 10, how 265 C many pieces of quality information are present for this message 266 C type (or at least how many place holders for quality information 267 C are present for this message type) 268 C NOTE: All subsets are INPUT in true NESDIS Version 10 BUFR WINDS 269 C format (although the number of replications of quality 270 C information for this message type in the INPUT BUFR table is 271 C not yet known) 272 C -------------------------------------------------------------------- 273 274 call scan_bufrtable(lundx,subset,ireps) 275 IF(ireps.eq.0) then 276 print'(" This message type (",A,") is NOT specified in quasi-", 277 . "Version 10 BUFR winds format in output BUFR table")', SUBSET 278 print * 279 V10_BUFR = .FALSE. 280 ELSE 281 print'(" This message type (",A,") IS specified in quasi-", 282 . "Version 10 BUFR winds format in output BUFR table")', SUBSET 283 print'(" -- number of pieces of quality information in output", 284 . " BUFR table = ",I0)',ireps 285 print * Page 6 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 286 V10_BUFR = .TRUE. 287 ENDIF 288 289 IRD = 0 290 IWT = 0 291 KTSKPT=0 292 293 CALL DATELEN(10) 294 295 C OPEN AND READ THRU THE INPUT BUFR FILE 296 C -------------------------------------- 297 298 CALL OPENBF(LUNIN,'IN',LINDX) 299 ccccc CALL OPENBF(LUNOT,'OUT',LUNDX) 300 CALL OPENBF(LUNOT,'NODX',LUNDX) 301 302 INQUIRE(LINDX,NAME=FILENAME) 303 PRINT'(" Table used to read input files: ",A)', FILENAME 304 305 INQUIRE(LUNDX,NAME=FILENAME) 306 PRINT'(" Table used to write output files: ",A)', FILENAME 307 308 C ------------------------------------------------------------------- 309 310 C READ THROUGH THE MESSAGES/SUBSETS IN THE FILE 311 C --------------------------------------------- 312 313 DO WHILE(IREADMG(LUNIN,SUBFGN,IDATE).EQ.0) 314 ccccc print *,' IDATE ',idate 315 ccccc print *,' SUBFGN IS ',SUBFGN 316 IF(IDATE.NE.IDATE_prev) then 317 print *, ' ' 318 print *, 'OPENING INPUT MESSAGE WITH NEW DATE ',IDATE, 319 . ' (SUBSET ',SUBFGN,')' 320 print *, ' ' 321 ENDIF 322 IDATE_prev = IDATE 323 DO WHILE(IREADSB(LUNIN).EQ.0) 324 325 C READ THE INTERNAL DATE AND CHECK FOR REALISM 326 C -------------------------------------------- 327 328 CALL UFBINT(LUNIN,YMDAY,3,1,IRET,'YEAR MNTH DAYS') 329 CALL UFBREP(LUNIN,HOURIN,1,10,IRET,'HOUR') 330 CALL UFBREP(LUNIN,TMISCIN,2,9,IRET,'MINU SECO') 331 IYR = NINT(YMDAY(1)) 332 MON = NINT(YMDAY(2)) 333 IDAY = NINT(YMDAY(3)) 334 IHR = NINT(HOURIN(1)) 335 MIN = NINT(TMISCIN(1,1)) 336 ISEC = NINT(TMISCIN(2,1)) 337 IRD = IRD+1 338 339 IF(IYR .LT.0 .OR. 340 . MON .LT.1 .OR. MON .GT.12 .OR. 341 . IDAY.LT.1 .OR. IDAY.GT.31 .OR. 342 . IHR .LT.0 .OR. IHR .GT.24 .OR. Page 7 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 343 . MIN .LT.0 .OR. MIN .GT.60 .OR. 344 . ISEC.LT.0 .OR. ISEC.GT.60) THEN 345 PRINT '(" BAD DATE:",I4,5I2.2," SUBSET:",A8)', 346 . IYR,MON,IDAY,IHR,MIN,ISEC,SUBFGN 347 KTSKPT=KTSKPT+1 348 ELSE 349 CALL UFBINT(LUNIN,SATINFO,12,1,IRET, 350 . 'SAID SCLF SSNX SSNY SWCM SIDP SCCF CCST LSQL SAZA SCBW OFGI') 351 CALL UFBINT(LUNIN,XLALO,2,1,IRET,'CLATH CLONH') 352 CALL UFBREP(LUNIN,WINDSQ,2,5,IRET,'WDIR WSPD') 353 CALL UFBINT(LUNIN,TCMD,1,1,IRET,'TCMD') 354 CALL UFBREP(LUNIN,GCLONG,1,5,IRET,'GCLONG') 355 CALL UFBREP(LUNIN,PRLC,1,11,IRET,'PRLC') 356 CALL UFBREP(LUNIN,HAMD,1,11,IRET,'HAMD') 357 CALL UFBREP(LUNIN,TMDBST,1,10,IRET,'TMDBST') 358 359 C iret_PCCF will either be 30 or 40: 30 if EE quality indicator is 360 C NOT in this message type in input BUFR data from NESDIS (i.e., 361 C only 3 replications of quality information), 40 if EE quality 362 C indicator IS in this message type in input BUFR data from NESDIS 363 C (i.e., 4 replications of quality information) (Note: the presence 364 C of the EE quality indicator does not necessarily mean it is filled 365 C with EE value here - that depends on if EE is present in the raw 366 C files being read in) 367 C -------------------------------------------------------------------- 368 369 CALL UFBREP(LUNIN,PCCFIN,1,40,iret_PCCF,'PCCF') 370 371 IF(IRD .EQ. 1) THEN 372 if(iret_PCCF.eq.40) then 373 print'(" This message type contains 4 ", 374 . "replications of quality information -- RFF, QI ", 375 . "w/ fcst, QI w/o fcst, EE --"/" in input ", 376 . """foreign"" BUFR table (in Version 10 winds ", 377 . "format)")' 378 else if(iret_PCCF.eq.30) then 379 print'(" This message type contains 3 ", 380 . "replications of quality information -- RFF, QI ", 381 . "w/ fcst, QI w/o fcst --"/" in input ""foreign""", 382 . " BUFR table (in Version 10 winds format)")' 383 else 384 print'(" This message type contains ",I0, 385 . " replications of quality information in input ", 386 . """foreign"" BUFR table"/" (in Version 10 winds ", 387 . "format)")', iret_PCCF/10 388 endif 389 print * 390 ENDIF 391 392 CALL UFBREP(LUNIN,TSIGIN,1,10,IRET,'TSIG') 393 CALL UFBREP(LUNIN,GNAPIN,1,4,IRET,'GNAP') 394 CALL UFBINT(LUNIN,TPHR,1,1,IRET,'TPHR') 395 396 IF(IRD .LE. 3) THEN ! Turn on extraneous print for 397 ! first 3 reports in file 398 ccccc IF(IRD .LE. 0) THEN ! Turn off all extraneous print 399 Page 8 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 400 C Print bit switched on rather than flag table decimal value for SIDP 401 C ------------------------------------------------------------------- 402 403 satinfo6 = bmiss 404 if(ibfms(satinfo(6)).eq.0) then 405 call upftbv(lunin,'SIDP',satinfo(6),31,ibit,nib) 406 if(nib.gt.0) satinfo6 = ibit(1) 407 endif 408 409 satinfo11 = satinfo(11) 410 if(ibfms(satinfo(11)).ne.0) satinfo11 = 10e17 411 412 C Assuming the input file has a 4'th (EE) replication, we'll assume 413 C PCCF, GNAP and GCLONG are all missing in the input file's EE 414 C replication if either: 415 C 1) the output BUFR table is either not Version 10 or contains 416 C only 3 replications of quality information (this affects the 417 C below printout only); or 418 C 2) Upon reading in GNAP in the EE replication from the input 419 C file, it is not equal to 4 (this affects the below printout 420 C and forces the values for PCCF, GNAP and GCLONG in the 4'th 421 C (EE) replication of quality information to be enocoded as 422 C missing 423 C -------------------------------------------------------------------- 424 425 if(ireps.LT.4.or.gnapin(4).ne.4) then 426 gclong(5) = bmiss 427 pccfin(31:40) = bmiss 428 gnapin(4) = bmiss 429 IF(IRD.EQ.1.and.ireps.eq.4.and.iret_PCCF.eq.40) THEN 430 print'(" Input BUFR file does not contain EE ", 431 . "quality information even though its BUFR ", 432 . "table contains place holders for it - encode", 433 . " PCCF,"/" GNAP and GCLONG as missing in the ", 434 . "4th (EE) replication of quality information ", 435 . "in the output BUFR file")' 436 print * 437 endif 438 endif 439 440 write(6, 441 . '(''SAID SCLF SSNX SSNY SWCM SIDP SCCF CCST '', 442 . '' LSQL SAZA SCBW OFGI''/ 443 . 2(f4.0,1x),f7.0,2x,f7.0,2x,f3.0,2x,f4.0,1pe12.5,0pf6.1,3x, 444 . f3.0,2x,f6.1,2x,f17.0,2x,f6.0)') 445 . (satinfo(ii),ii=1,5),satinfo6,(satinfo(ii),ii=7,10), 446 . satinfo11,satinfo(12) 447 write(6,'('' latitude, longitude :'',f7.2,1x,f7.2)') 448 . xlalo 449 write(6,'(''FINAL wind direction speed:'',2(f9.1,1x))') 450 . (windsq(i,1),i=1,2) 451 write(6,'(''GUESS wind direction speed:'',2(f9.1,1x))') 452 . (windsq(i,2),i=1,2) 453 write(6,'(''ORIGNL wind direction speed:'',2(f9.1,1x))') 454 . (windsq(i,3),i=1,2) 455 write(6,'(''IMG1-2 wind direction speed:'',2(f9.1,1x))') 456 . (windsq(i,4),i=1,2) Page 9 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 457 write(6,'(''IMG2-3 wind direction speed:'',2(f9.1,1x))') 458 . (windsq(i,5),i=1,2) 459 ccccc write(6,'(''wind direction speed:'',4f10.1)') 460 ccccc. ((windsq(i,j),i=1,2),j=1,5) 461 write(6,'(''Gen. Center. (overall, generating appl.'', 462 . '' 1-4):'',5(f9.1,1x))') gclong 463 write(6,'(''Tracer Corr.:'',f10.1)') tcmd 464 write(6,'(''Pressure (FNL, WINDOW CHN, HISTOGRAM, '', 465 . ''H2O INTERCEPT, CO2 SLICING, ORIG, LAST 5 '', 466 . ''MISSING):''/5x,11(f9.1,1x))') prlc 467 write(6,'(''Hgt. assign. method (FNL, WINDOW CHN, '', 468 . ''HISTOGRAM, H2O INTERCEPT, CO2 SLICING, ORIG, '', 469 . ''LAST 5 MISSING):''/5x,11(f7.0,1x))') hamd 470 write(6,'(''dry bulb temp (WINDOW CHN, HISTOGRAM, '', 471 . '' H2O INTERCEPT, CO2 SLICING, ORIG, LAST 5 '', 472 . ''MISSING):''/5x,10(f7.1,1x))') tmdbst 473 write(6,'(''Year Month Day.:'',3f8.0)') ymday 474 write(6,'(''hour (OBS, GUESS, ORIG, IMG1-2, IMG2-3)'', 475 . '':'',5(f7.1,1x))') hourin((/1,3,5,7,9/)) 476 write(6,'(''minute second (OBS, GUESS, ORIG, '', 477 . ''IMG1-2,IMG2-3):''/5x,2(f7.1,1x),''|'',2(f7.1,1x), 478 . ''|'',2(f7.1,1x),''|'',2(f7.1,1x),''|'',2(f7.1,1x))') 479 . tmiscin((/1,2/),(/1,2,4,6,8/)) 480 write(6,'(''WDIR QI w/o forecast:'',f7.1)') pccfin(1) 481 write(6,'(''WDIR recursive filter:'',f6.1)') 482 . pccfin(11) 483 write(6,'(''WDIR QI w/ forecast:'',f7.1)') pccfin(21) 484 write(6,'(''WDIR expected error:'',f8.1)') pccfin(31) 485 write(6,'(''WSPD QI w/o forecast:'',f7.1)') pccfin(2) 486 write(6,'(''WSPD recursive filter:'',f6.1)') 487 . pccfin(12) 488 write(6,'(''WSPD QI w/ forecast:'',f7.1)') pccfin(22) 489 write(6,'(''WSPD expected error:'',f8.1)') pccfin(32) 490 write(6,'(''time significance (GUESS, ORIG, IMG1-2,'', 491 . '' IMG2-3):'',4f8.1/)') tsigin((/3,5,7,9/)) 492 write(6,'(''gen. application:'',4f8.0/)') gnapin 493 write(6,'(''time per. or displ.:'',f8.0/)') tphr 494 END IF 495 496 HOUROUT(1:5)=HOURIN(1:9:2) 497 498 TMISCOUT(1:2,1)=TMISCIN(1:2,1) 499 TMISCOUT(1:2,2:5)=TMISCIN(1:2,2:8:2) 500 501 TSIGOUT(1:4)=TSIGIN(3:9:2) 502 503 IF(ireps.EQ.4) THEN 504 505 C Come here if space for EE is allocated in this output message type 506 C ------------------------------------------------------------------ 507 508 IF(iret_PCCF.EQ.40) THEN 509 510 C .... come here if space for EE is allocated in this input message 511 C type - if EE is present it will be transferred to this 512 C output message type 513 C ------------------------------------------------------------ Page 10 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 514 515 PCCFOUT(1:4)=PCCFIN(1:31:10) 516 PCCFOUT(5:8)=PCCFIN(2:32:10) 517 518 GNAPOUT(1:4)=GNAPIN(1:4) 519 GNAPOUT(5:8)=GNAPIN(1:4) 520 521 OGCEOUT(1:5)=GCLONG(1:5) 522 OGCEOUT(6:9)=GCLONG(2:5) 523 524 ELSE IF(iret_PCCF.EQ.30) THEN 525 526 C .... come here if EE is NOT in this input message type - it will 527 C be set to missing in this output message type 528 C ----------------------------------------------------------- 529 530 PCCFOUT(1:3)=PCCFIN(1:21:10) 531 PCCFOUT(4) =BMISS 532 PCCFOUT(5:7)=PCCFIN(2:22:10) 533 PCCFOUT(8) =BMISS 534 535 GNAPOUT(1:3)=GNAPIN(1:3) 536 GNAPOUT(4) =BMISS 537 GNAPOUT(5:7)=GNAPIN(1:3) 538 GNAPOUT(8) =BMISS 539 540 OGCEOUT(1:4)=GCLONG(1:4) 541 OGCEOUT(5) =BMISS 542 OGCEOUT(6:8)=GCLONG(2:4) 543 OGCEOUT(9) =BMISS 544 545 END IF 546 547 ELSE IF(ireps.EQ.3) THEN 548 549 C Come here if space for EE NOT allocated in this output message type 550 C ------------------------------------------------------------------- 551 552 IF(iret_PCCF.EQ.40 .or. iret_PCCF.EQ.30) THEN 553 554 C .... come here if space for EE either IS or is NOT allocated in 555 C this input message type - in the case of the former it will 556 C NOT be transferred to this output message type 557 C ----------------------------------------------------------- 558 559 PCCFOUT(1:3)=PCCFIN(1:21:10) 560 PCCFOUT(4:6)=PCCFIN(2:22:10) 561 562 GNAPOUT(1:3)=GNAPIN(1:3) 563 GNAPOUT(4:6)=GNAPIN(1:3) 564 565 OGCEOUT(1:4)=GCLONG(1:4) 566 OGCEOUT(5:7)=GCLONG(2:4) 567 568 END IF 569 570 END IF Page 11 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 571 572 SWQM=2 573 574 STNID = '????????' 575 576 577 C IN FIRST POSITION OF ID: SATELLITE ID 578 C GOES SATELLITE NO. 251, 255, 259 --- GETS CHARACTER 'A' 579 C GOES SATELLITE NO. 252, 256 --- GETS CHARACTER 'B' 580 C GOES SATELLITE NO. 253, 257 --- GETS CHARACTER 'C' 581 C GOES SATELLITE NO. 250, 254, 258 --- GETS CHARACTER 'D' 582 C METEOSAT SATELLITE NO. 52, 56, 99 --- GETS CHARACTER 'X' 583 C METEOSAT SATELLITE NO. 53, 57 --- GETS CHARACTER 'Y' 584 C METEOSAT SATELLITE NO. 50, 54, 58, 70 --- GETS CHARACTER 'Z' 585 C METEOSAT SATELLITE NO. 51, 55, 59 --- GETS CHARACTER 'W' 586 C GMS SATELLITE NO. 152 --- GETS CHARACTER 'P' 587 C GMS SATELLITE NO. 150 --- GETS CHARACTER 'R' 588 C GMS SATELLITE NO. 151 --- GETS CHARACTER 'O' 589 C MTSAT SATELLITE NO. 171, 175, 199 --- GETS CHARACTER 'Q' 590 C MTSAT SATELLITE NO. 172, 176 --- GETS CHARACTER 'R' 591 C MTSAT SATELLITE NO. 173 --- GETS CHARACTER 'O' 592 C MTSAT SATELLITE NO. 174 --- GETS CHARACTER 'P' 593 C KALPANA SATELLITE NO. 440 --- GETS CHARACTER 'K' 594 C INSAT SATELLITE NO. 470, 499 --- GETS CHARACTER 'V' 595 C TERRA SATELLITE NO. 783 --- GETS CHARACTER 'T' 596 C AQUA SATELLITE NO. 784 --- GETS CHARACTER 'U' 597 C METOP SATELLITE NO. 3 --- GETS CHARACTER 'H' 598 C METOP SATELLITE NO. 4 --- GETS CHARACTER 'E' 599 C METOP SATELLITE NO. 5 --- GETS CHARACTER 'I' 600 C NOAA SATELLITE NO. 206 --- GETS CHARACTER 'F' 601 C NOAA SATELLITE NO. 207 --- GETS CHARACTER 'L' 602 C NOAA SATELLITE NO. 208 --- GETS CHARACTER 'M' 603 C NOAA SATELLITE NO. 209 --- GETS CHARACTER 'N' 604 C NOAA SATELLITE NO. 223 --- GETS CHARACTER 'G' 605 606 ISATID1=NINT(SATINFO(1)) 607 608 IF(ISATID1.GT.0 .AND. ISATID1.LT.785) THEN 609 IF(STNID1(ISATID1).NE.'?') STNID(1:1)=STNID1(ISATID1) 610 END IF 611 IF(STNID(1:1).EQ.'?') THEN 612 PRINT *,'Satellite ID ',ISATID1,' is missing or not ', 613 . 'valid value, skip' 614 KTSKPT=KTSKPT+1 615 IERR=2 616 CYCLE 617 END IF 618 C 619 C IN SIXTH POSITION OF ID: READ SATELLITE DERIVED WIND COMPUTATION 620 C METHOD TO GET INFORMATION ABOUT WHICH WIND IN THE SUBSET 621 C WATER VAPOR CHANNEL (IMAGER AND SOUNDER)....GETS CHARACTER 'W', 622 C INFRARED CHANNEL............................GETS CHARACTER 'I' 623 C VISIBLE CHANNEL.............................GETS CHARACTER 'Z' 624 C SPECTRAL CHANNELS OR PICTURE TRIPLET........GETS CHARACTER 'P' 625 C 626 627 C SATELLITE DERIVED WIND METHOD AS READ IN - ISATID5: Page 12 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 628 C 1 - IR 629 C 2 - VISIBLE 630 C 3 - WATER VAPOR (IMAGER AND SOUNDER) - CLOUD TOP 631 C 4 - COMBNATION OF SPECTRAL CHANNELS OR PICTURE TRIPLET 632 C 5 - WATER VAPOR (IMAGER AND SOUNDER) - CLEAR AIR (DEEP LAYER) 633 C 6 - RESERVED FOR OZONE 634 C 7 - WATER VAPOR (IMAGER AND SOUNDER) - CLOUD TOP OR CLEAR AIR 635 C UNKNOWN 636 637 ISATID5=NINT(SATINFO(5)) 638 639 SWDL=BMISS 640 IF((ISATID5.GT.0. AND. ISATID5.LT.8) .AND. ISATID5.NE.6) 641 . THEN 642 STNID(6:6)=STNID6(ISATID5) 643 IF(ISWDL(ISATID5).LT.3) THEN 644 SWDL=ISWDL(ISATID5) 645 ELSE 646 PRINT'(" The value of satellite derived wind ", 647 . "method",F5.1," is missing or not a valid ", 648 . "value")', SWDL 649 KTSKPT=KTSKPT+1 650 IERR=2 651 CYCLE 652 END IF 653 ELSE 654 PRINT'(" The value of satellite derived wind method ", 655 . F5.1," is missing or not a valid value")', SWDL 656 KTSKPT=KTSKPT+1 657 IERR=2 658 CYCLE 659 END IF 660 661 C CHECK REPORT DATE (YYYYMMDDHH) TO SEE IF A NEW OUTPUT MESSAGE 662 C SHOULD BE OPENED (TRANJB TAKES CARE OF THIS FOR UNCOMPRESSED 663 C FILES, BUT IT DOESN'T HURT TO HAVE REDUNDANCY BUILT IN HERE) 664 C ------------------------------------------------------------- 665 666 LDATE = IYR*1000000+MON*10000+IDAY*100+IHR 667 ccccc print *,' LDATE ',ldate 668 ccccc print *,' SUBSET IS ',SUBSET 669 IF(LDATE.NE.LDATE_prev) then 670 print *, ' ' 671 print *, 'OPENING OUTPUT MESSAGE WITH NEW DATE ', 672 . LDATE,' (SUBSET ',SUBSET,')' 673 print *, ' ' 674 ENDIF 675 LDATE_prev = LDATE 676 CALL OPENMB(LUNOT,SUBSET,LDATE) 677 678 C WRITE A SUBSET 679 C -------------- 680 681 IF(.NOT.V10_BUFR) THEN 682 C ... OUTPUT that is NOT in quasi-NESDIS Version 10 BUFR winds format 683 C in bufrtab.005 comes here (all INPUT is in true NESDIS Version 684 C 10 BUFR WINDS format) Page 13 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 685 CALL UFBINT(LUNOT,SATINFO,10,1,IRET, 686 . 'SAID SCLF SSNX SSNY SWCM SIDP SCCF CCST LSQL SAZA') 687 GCLONG=160.0 ! orig. center is hardwired to NESDIS 688 CALL UFBINT(LUNOT,GCLONG,1,1,IRET,'GCLONG') 689 CALL UFBREP(LUNOT,TMDBST,1,5,IRET,'TMDBST') 690 CALL UFBREP(LUNOT,PRLC,1,6,IRET,'PRLC') 691 CALL UFBREP(LUNOT,HAMD,1,6,IRET,'HAMD') 692 IF(ISATID5.EQ.4) PCCFIN(11) = BMISS ! ptriplet RFFL 693 ! set to missing 694 CALL UFBINT(LUNOT,PCCFIN(11),1,1,IRET,'RFFL') 695 CALL UFBINT(LUNOT,SWDL,1,1,IRET,'SWDL') 696 ELSE 697 C ... OUTPUT that is in quasi-NESDIS Version 10 BUFR winds format in 698 C bufrtab.005 comes here (all INPUT is in true NESDIS Version 10 699 C BUFR WINDS format) 700 RCPDAT=BMISS 701 RCPDAT(1) = 0. 702 CALL W3UTCDAT(IDAT) 703 RCPDAT(2:4) = REAL(IDAT(1:3)) 704 RCPDAT(5:6) = REAL(IDAT(5:6)) 705 CORN = 0. 706 CALL UFBINT(LUNOT,SATINFO,12,1,IRET, 707 . 'SAID SCLF SSNX SSNY SWCM SIDP SCCF CCST LSQL SAZA SCBW OFGI') 708 CALL UFBREP(LUNOT,OGCEOUT,1,(2*ireps)+1,IRET,'OGCE') 709 CALL UFBREP(LUNOT,TMDBST,1,10,IRET,'TMDBST') 710 CALL UFBREP(LUNOT,PRLC,1,11,IRET,'PRLC') 711 CALL UFBREP(LUNOT,HAMD,1,11,IRET,'HAMD') 712 CALL UFBREP(LUNOT,PCCFOUT,1,2*ireps,IRET,'PCCF') 713 CALL UFBREP(LUNOT,GNAPOUT,1,2*ireps,IRET,'GNAP') 714 CALL UFBINT(LUNOT,RCPDAT,6,1,IRET, 715 . 'RCTS RCYR RCMO RCDY RCHR RCMI') 716 CALL UFBINT(LUNOT,CORN,1,1,IRET,'CORN') 717 CALL UFBINT(LUNOT,TPHR,1,1,IRET,'TPHR') 718 END IF 719 CALL UFBINT(LUNOT,XLALO,2,1,IRET,'CLAT CLON') 720 CALL UFBREP(LUNOT,WINDSQ,2,5,IRET,'WDIR WSPD') 721 CALL UFBINT(LUNOT,SWQM,1,1,IRET,'SWQM') 722 CALL UFBINT(LUNOT,RSTNID,1,1,IRET,'RPID') 723 CALL UFBINT(LUNOT,TCMD,1,1,IRET,'TCMD') 724 CALL UFBINT(LUNOT,YMDAY,3,1,IRET,'YEAR MNTH DAYS') 725 CALL UFBREP(LUNOT,HOUROUT,1,5,IRET,'HOUR') 726 CALL UFBREP(LUNOT,TMISCOUT,2,5,IRET,'MINU SECO') 727 CALL UFBREP(LUNOT,TSIGOUT,1,4,IRET,'TSIG') 728 729 CALL WRITSB(LUNOT) 730 731 IWT=IWT+1 732 733 END IF 734 ENDDO 735 ENDDO 736 737 C WHEN FINISHED MAKE SURE ALL BUFFERS ARE FLUSHED THEN EXIT 738 C --------------------------------------------------------- 739 740 CALL CLOSBF(LUNIN) 741 CALL CLOSBF(LUNOT) Page 14 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 742 PRINT*,'*** PROCESSING ENDED NORMALLY ***' 743 PRINT*,'*** READ :',IRD 744 PRINT*,'*** WROT :',IWT 745 PRINT*,'*** SKIP :',KTSKPT 746 PRINT*,'*** PROCESSING ENDED NORMALLY ***' 747 IF(IWT.EQ.0) THEN 748 WRITE(6,2003) 749 2003 FORMAT(' NO REPORTS PROCESSED -- DISABLING ALL SUBSEQUENT ', 750 . 'PROCESSING.') 751 CALL W3TAGE('BUFR_TRANSATW') 752 CALL ERREXIT(253) 753 ENDIF 754 CALL W3TAGE('BUFR_TRANSATW') 755 756 STOP 757 END ENTRY POINTS Name MAIN__ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 2003 Label 749 748 APPCHR Local 156 CHAR 80 scalar 245 BMISS Local 165 R(8) 8 scalar 165,403,426,427,428,531,533,536,53 8,541,543,639,692,700 BUFR_TRANSATW Prog 131 CDUMMY Local 154 CHAR 1 scalar CLOSBF Subr 740 740,741 CORN Local 133 R(8) 8 1 1 705,716 DATELEN Subr 293 293 ERREXIT Subr 255 255,752 FILENAME Local 157 CHAR 128 scalar 302,303,305,306 GCLONG Local 137 R(8) 8 1 5 354,426,462,521,522,540,542,565,56 6,687,688 GNAPIN Local 136 R(8) 8 1 4 393,425,428,492,518,519,535,537,56 2,563 GNAPOUT Local 139 R(8) 8 1 8 518,519,535,536,537,538,562,563,71 3 HAMD Local 142 R(8) 8 1 11 356,469,691,711 HOURIN Local 141 R(8) 8 1 10 329,334,475,496 HOUROUT Local 137 R(8) 8 1 5 496,725 I Local 450 I(4) 4 scalar 450,452,454,456,458 IBFMS Func 404 I(4) 4 scalar 404,410 IBIT Local 150 I(4) 4 1 31 405,406 IDAT Local 149 I(4) 4 1 8 702,703,704 IDATE Local 313 I(4) 4 scalar 313,316,318,322 IDATE_PREV Local 169 I(4) 4 scalar 169,316,322 IDAY Local 333 I(4) 4 scalar 333,341,346,666 IERR Local 246 I(4) 4 scalar 246,251,253,255,615,650,657 Page 15 Source Listing BUFR_TRANSATW 2012-11-20 14:07 Symbol Table transatw.f Name Object Declared Type Bytes Dimen Elements Attributes References IHR Local 334 I(4) 4 scalar 334,342,346,666 II Local 445 I(4) 4 scalar 445 IRD Local 289 I(4) 4 scalar 289,337,371,396,429,743 IREADMG Func 313 I(4) 4 scalar 313 IREADSB Func 323 I(4) 4 scalar 323 IREPS Local 274 I(4) 4 scalar 274,275,284,425,429,503,547,708,71 2,713 IRET Local 328 I(4) 4 scalar 328,329,330,349,351,352,353,354,35 5,356,357,392,393,394,685,688,689, 690,691,694,695,706,708,709,710,71 1,712,713,714,716,717,719,720,721, 722,723,724,725,726,727 IRET_PCCF Local 369 I(4) 4 scalar 369,372,378,387,429,508,524,552 ISATID1 Local 606 I(4) 4 scalar 606,608,609,612 ISATID5 Local 637 I(4) 4 scalar 637,640,642,643,644,692 ISEC Local 336 I(4) 4 scalar 336,344,346 ISWDL Local 148 I(4) 4 1 7 235,643,644 IWT Local 290 I(4) 4 scalar 290,731,744,747 IYR Local 331 I(4) 4 scalar 331,339,346,666 JDATE Local 246 I(4) 4 scalar 246 KDATE Local 246 I(4) 4 scalar 246 KTSKPT Local 291 I(4) 4 scalar 291,347,614,649,656,745 LAPCHR Local 245 I(4) 4 scalar 245 LDATE Local 666 I(4) 4 scalar 666,669,672,675,676 LDATE_PREV Local 169 I(4) 4 scalar 169,669,675 LINDX Local 162 I(4) 4 scalar 162,298,302 LSUBDR Local 245 I(4) 4 scalar 245,257 LTNKID Local 245 I(4) 4 scalar 245,257 LUNDX Local 163 I(4) 4 scalar 163,274,300,305 LUNIN Local 161 I(4) 4 scalar 161,298,313,323,328,329,330,349,35 1,352,353,354,355,356,357,369,392, 393,394,405,740 LUNOT Local 164 I(4) 4 scalar 164,300,676,685,688,689,690,691,69 4,695,706,708,709,710,711,712,713, 714,716,717,719,720,721,722,723,72 4,725,726,727,729,741 MAXJAP Local 167 I(4) 4 scalar 167 MIN Local 335 I(4) 4 scalar 335,343,346 MINJAP Local 166 I(4) 4 scalar 166 MON Local 332 I(4) 4 scalar 332,340,346,666 NIB Local 405 I(4) 4 scalar 405,406 NINT Func 331 scalar 331,332,333,334,335,336,606,637 OGCEOUT Local 140 R(8) 8 1 9 521,522,540,541,542,543,565,566,70 8 OPENBF Subr 298 298,300 OPENMB Subr 676 676 PCCFIN Local 144 R(8) 8 1 40 369,427,480,482,483,484,485,487,48 8,489,515,516,530,532,559,560,692, 694 PCCFOUT Local 139 R(8) 8 1 8 515,516,530,531,532,533,559,560,71 2 PRLC Local 142 R(8) 8 1 11 355,466,690,710 RCPDAT Local 138 R(8) 8 1 6 700,701,703,704,714 REAL Func 703 scalar 703,704 RSTNID Local 133 R(8) 8 1 1 722 Page 16 Source Listing BUFR_TRANSATW 2012-11-20 14:07 Symbol Table transatw.f Name Object Declared Type Bytes Dimen Elements Attributes References SATINFO Local 143 R(8) 8 1 12 349,404,405,409,410,445,446,606,63 7,685,706 SATINFO11 Local 409 R(8) 8 scalar 409,410,446 SATINFO6 Local 403 R(8) 8 scalar 403,406,445 SCAN_BUFRTABLE Subr 274 274 STNID Local 155 CHAR 8 scalar 574,609,611,642 STNID1 Local 154 CHAR 1 1 784 174,609 STNID6 Local 154 CHAR 1 1 7 234,642 SUBDIR Local 156 CHAR 80 scalar 245,257 SUBFGN Local 155 CHAR 8 scalar 313,319,346 SUBSET Local 155 CHAR 8 scalar 257,274,277,282,672,676 SWDL Local 133 R(8) 8 1 1 639,644,648,655,695 SWQM Local 133 R(8) 8 1 1 572,721 TANKID Local 156 CHAR 80 scalar 245,257 TCMD Local 133 R(8) 8 1 1 353,463,723 TLFLAG Local 155 CHAR 8 scalar 246 TMDBST Local 141 R(8) 8 1 10 357,472,689,709 TMISCIN Local 146 R(8) 8 2 18 330,335,336,479,498,499 TMISCOUT Local 145 R(8) 8 2 10 498,499,726 TPHR Local 133 R(8) 8 1 1 394,493,717 TSIGIN Local 141 R(8) 8 1 10 392,491,501 TSIGOUT Local 136 R(8) 8 1 4 501,727 UFBINT Subr 328 328,349,351,353,394,685,688,694,69 5,706,714,716,717,719,721,722,723, 724 UFBREP Subr 329 329,330,352,354,355,356,357,369,39 2,393,689,690,691,708,709,710,711, 712,713,720,725,726,727 UPFTBV Subr 405 405 V10_BUFR Local 152 L(4) 4 scalar 279,286,681 W3TAGB Subr 239 239 W3TAGE Subr 254 254,751,754 W3TRNARG Subr 245 245 W3UTCDAT Subr 702 702 WINDSQ Local 145 R(8) 8 2 10 352,450,452,454,456,458,720 WRITSB Subr 729 729 XLALO Local 134 R(8) 8 1 2 351,448,719 YMDAY Local 135 R(8) 8 1 3 328,331,332,333,473,724 Page 17 Source Listing BUFR_TRANSATW 2012-11-20 14:07 transatw.f 758 759 C###################################################################### 760 C###################################################################### 761 C###################################################################### 762 763 C Read through the output BUFR table in "iunit". 764 C Find all lines that define the mnemonics in "subset". 765 C Search each line looking for mnemonic "GQCPRMS" (including quotes). 766 C Determine how many standard replicatons are defined for "GQCPRMS". 767 C Return this to calling program as "ireps" 768 C A value of zero for "ireps" is the default and means that "GQCPRMS" 769 C was not found. 770 771 subroutine scan_bufrtable(iunit,subset,ireps) 772 773 character*1 creps 774 character*8 subset 775 character*80 card 776 logical digit 777 778 imatch = 0 779 ireps = 0 780 781 do i = 1,10000 782 read(iunit,'(A80)',end=88,err=99) card 783 cc write(6,44) card 784 44 format(1x,'CARD "',A,'"') 785 if(card(1:10).eq.'| '//subset) then 786 imatch = imatch + 1 787 if(imatch.gt.1) then 788 cc write(6,44) card 789 do istart = 14,69 790 if(card(istart:istart+8).eq.'"GQCPRMS"') then 791 creps = card(istart+9:istart+9) 792 if(digit(creps)) read(creps,'(i1)') ireps 793 return 794 end if 795 end do 796 end if 797 end if 798 end do 799 800 99 continue 801 802 WRITE(6,'('' ERROR SCANNING OUTPUT BUFR TABLE'')') 803 CALL W3TAGE('BUFR_TRANSATW') 804 CALL ERREXIT(44) 805 806 88 continue 807 808 return 809 end Page 18 Source Listing SCAN_BUFRTABLE 2012-11-20 14:07 Entry Points transatw.f ENTRY POINTS Name scan_bufrtable_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 44 Label 784 88 Label 806 782 99 Label 800 782 CARD Local 775 CHAR 80 scalar 782,785,790,791 CREPS Local 773 CHAR 1 scalar 791,792 DIGIT Func 776 L(4) 4 scalar 792 ERREXIT Subr 804 804 I Local 781 I(4) 4 scalar 781 IMATCH Local 778 I(4) 4 scalar 778,786,787 IREPS Dummy 771 I(4) 4 scalar ARG,INOUT 779,792 ISTART Local 789 I(4) 4 scalar 789,790,791 IUNIT Dummy 771 I(4) 4 scalar ARG,INOUT 782 SCAN_BUFRTABLE Subr 771 SUBSET Dummy 771 CHAR 8 scalar ARG,INOUT 785 W3TAGE Subr 803 803 Page 19 Source Listing SCAN_BUFRTABLE 2012-11-20 14:07 transatw.f 810 Page 20 Source Listing SCAN_BUFRTABLE 2012-11-20 14:07 Subprograms/Common Blocks transatw.f SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References BUFR_TRANSATW Prog 131 SCAN_BUFRTABLE Subr 771 COMPILER OPTIONS BEING USED -align nocommons -align nodcommons -align noqcommons -align records -align nosequence -align norec1byte -align norec2byte -align norec4byte -align norec8byte -align norec16byte -altparam -assume accuracy_sensitive -assume nobscc -assume nobuffered_io -assume nobyterecl -assume nocc_omp -assume nocstring -assume nodummy_aliases -assume nofpe_summary -assume noieee_fpe_flags -assume nominus0 -assume noold_boz -assume old_unit_star -assume noold_ldout_format -assume noold_logical_ldio -assume old_maxminloc -assume old_xor -assume protect_constants -assume noprotect_parens -assume split_common -assume source_include -assume nostd_intent_in -assume nostd_mod_proc_name -assume norealloc_lhs -assume underscore -assume no2underscores no -auto -auto_scalar no -bintext -ccdefault default -check noargs -check noarg_temp_created -check nobounds -check noformat -check nooutput_conversion -check nooverflow -check nopointers -check power -check noshape -check nounderflow -check nouninitialized -coarray-num-procs 0 no -coarray-config-file -convert big_endian -cross_reference -D __INTEL_COMPILER=1210 -D __unix__ -D __unix -D __linux__ -D __linux -D __gnu_linux__ -D unix -D linux -D __ELF__ -D __x86_64 -D __x86_64__ -D _MT -D __INTEL_COMPILER_BUILD_DATE=20120612 -D __i686 -D __i686__ -D __pentiumpro -D __pentiumpro__ -D __pentium4 -D __pentium4__ -D __tune_pentium4__ -D __SSE2__ -D __SSE__ -D __MMX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals -fixed no -fpconstant Page 21 Source Listing SCAN_BUFRTABLE 2012-11-20 14:07 transatw.f -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -O2 no -pad_source -real_size 64 no -recursive -reentrancy none no -sharable_localsaves -vec=simd -show noinclude -show map -show options no -syntax_only no -threadcom no -U no -vms -w noall -w nonone -w alignments -w noargument_checking -w nodeclarations -w general -w noignore_bounds -w noignore_loc -w nointerfaces -w notruncated_source -w uncalled -w uninitialized -w nounused -w usage -includepath : /gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/,.f,./.f,/usrx/local/intel/composerxe/mkl/include/.f, /usrx/local/intel/composerxe/tbb/include/.f,/gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/.f, /gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/.f,/usr/local/include/.f,/usr/lib/gcc/x86_64-redhat-linux/4.4.6/include/.f, /usr/include/.f,/usr/include/.f -list filename : transatw.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100