Page 1 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 tranhirs3.f 1 PROGRAM BUFR_TRANHIRS3 2 C$$$ MAIN PROGRAM DOCUMENTATION BLOCK 3 C 4 C MAIN PROGRAM: BUFR_TRANHIRS3 5 C PRGMMR: KEYSER ORG: NP22 DATE: 2012-10-23 6 C 7 C ABSTRACT: Read raw HIRS-3 or HIRS-4 1B format file, decode, write 8 C selected Tb observations to output BUFR file. 9 C 10 C PROGRAM HISTORY LOG: 11 C 1998-06-15 Treadon -- Original author 12 C 2000-09-06 Woollen -- Added second output in BUFR 13 C 2000-11-13 Keyser -- Added error handling when no output is 14 C created so that subsequent TRANJB's are skipped 15 C 2000-11-20 Treadon -- Changed to properly relabel NOAA-16 satellite 16 C id from 2 to 16 to be consistent with the convention followed 17 C in the global and regional analysis systems 18 C 2002-02-11 Woollen -- Modifications and corrections to output BUFR 19 C dataset: "SAID" (0-01-007) corrected to proper WMO Code Table 20 C value (was 14 for NOAA-14, etc.), "SIID" (0-02-019) repl. 21 C "SIDU" (0-02-021) which didn't seem to be correct, "HMSL" 22 C (0-07-002) corrected to proper units of meters (was being 23 C stored in km), "LSQL" (0-08-012) corrected to proper WMO Code 24 C Table value (0-land/1-sea) (was backwards), "TMBR" (0-12-163) 25 C corrected to proper units of K (was being stored as K + 26 C 273.15), channel 20 "TMBR" set to missing for HIRS-2 and HIRS-3 27 C types 28 C 2002-07-08 Keyser -- Accounts for NOAA-17 (converts NESDIS sat. 29 C no. from 6 to 17) 30 C 2002-10-23 Treadon -- Use lbyte instead of mbyte for unpacking 31 C counts 32 C 2004-01-23 Keyser -- Based on new namelist switch "compress", now 33 C has option to write compressed BUFR messages using WRITCP 34 C instead of WRITSB (removes the need for the downstream program 35 C BUFR_COMPRESS) 36 C 2005-04-26 Sager -- Modified to use new atovs1b hirx format: 37 C (1) Tests version type to invoke new format decoding 38 C (2) Looks at octet 35 bit 6 to see if any quality flags set 39 C (3) If so, tests channel quality flags octet 37-76 to locate 40 C bad channels 41 C 2005-04-29 Keyser -- Improved Docblocks and comments in code 42 C 2005-06-21 Keyser -- Modified to handle processing of NOAA-18 43 C HIRS-4 data, processing it into BUFR message type NC021028 (in 44 C addition to existing processing of NOAA-15, -16, -17 HIRS-3 45 C data into both BUFR message type NC021025 and IEEE), NOAA-18 46 C HIRS-4 does not write out into IEEE 47 C 2005-09-06 Keyser -- Corrected error in 2005-04-26 change, did 48 C not extract octet 35 bit 6 properly - this resulted in 49 C unilateral skipping of channel calibration quality flag tests 50 C (even if octet 35 bit 6 was set); for NOAA-18, no longer 51 C includes calibration quality bit in determining if scan 52 C line failed overall Q.C. - this flag is always set because N-18 53 C channel 1 HIRS is always bad - instead, falls through and lets 54 C code check calibration quality flags for individual channels 55 C 2006-04-21 Derber -- Modified to estimate solar and satellite 56 C azimuth (via new subroutine SATAZIMUTH), and to update time 57 C within a scan line Page 2 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 tranhirs3.f 58 C 2007-02-09 Keyser -- Modified to encode the following new 59 C information into output BUFR file: estimated solar azimuth 60 C (SOLAZI) and estimated satellite azimuth (BEARAZ) for each 61 C subset (retrieval) (note: this is not added to output IEEE file 62 C for HIRS-3); the "report" time in the BUFR and IEEE files now 63 C varies across a scan line as a result of 2006-04-21 change; 64 C modified subr. DATTIM to input real double precision second-of- 65 C day and output real double precision second-of-minute (both had 66 C been integer); array passed into subr. BUFR1B now contains spot 67 C hour-of-day, minute-of-hour and second-of-minute rather than 68 C only second-of-day (since the hour, minute and second are stored 69 C in BUFR, second now rounded to nearest whole second rather than 70 C truncated) (IEEE files still store second-of-day for HIRS-3); 71 C increased limit for i/o filename length from 80 characters to 72 C 500 characters; modified to write BUFR code table value 73 C 0-01-007, the BUFR value for satellite id, into word 1 of output 74 C "bdata" array, rather than the actual satellite number as before 75 C (this simplifies subroutine BUFR1B which then encodes this value 76 C directly into BUFR) (note: the actual satellite number is still 77 C written to the output IEEE file); now accounts for new METOP-1 78 C satellite (HIRS-4) 79 C 2007-04-12 Keyser -- Modified to correct METOP satellite number 80 C to METOP-2 with BUFR satellite id = 4 (was incorrectly set to 81 C METOP-1 with BUFR satellite id = 3) 82 C 2009-09-03 Krasowski -- Modified to handle processing of NOAA-19 83 C data 84 C 2009-09-03 Keyser -- Modified to no longer unilaterally toss a 85 C scan line if a calibration anomaly is detected in the 86 C calibration quality information (bit 28 in octets 29-32 set, 87 C this only means a potential for noise in the data), instead the 88 C results from this test are ignored and the "Scan Line Quality 89 C Flags" are tested to see if a scan contains marginal calibration 90 C in some of its IR channels (bit 6 in octet 35 set), if not then 91 C all channels pass, otherwise, code tests the calibration quality 92 C bits for each individual channel and if set for a particular 93 C channel, that channel is not processed {Note: This overall logic 94 C had previously been in place but only for NOAA-18, now it is in 95 C place for all satellites (for HIRS-3 or -4) assuming the format 96 C is the post-April 2005 version} 97 C 2012-10-23 Keyser -- Changes to run on WCOSS. Modified to handle 98 C processing of METOP-1 data. Removed IEEE output processing. 99 C 100 C USAGE: 101 C 102 C INPUT FILES: 103 C UNIT 05 - Standard input (namelist "input") 104 C UNIT 11 - Binary file containing raw 1B HIRS-3 or HIRS-4 data 105 C UNIT 12 - BUFR mnemonic table 106 C UNIT 41 - Binary file containing topography information 107 C used by function LANSEA 108 C 109 C ***NOTE*** 110 C Function LANSEA assumes this information is in 111 C a file named 'lowtopog.dat' which is local to 112 C the working directory. 113 C 114 C OUTPUT FILES: Page 3 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 tranhirs3.f 115 C UNIT 06 - Printout 116 C UNIT 52 - BUFR file containing HIRS-3 or HIRS-4 Tb data 117 C 118 C SUBPROGRAMS CALLED: 119 C UNIQUE: - HIRS CHARS DATTIM ICHARS LANSEA LBIT 120 C MBYTE LBYTE XFLOAT SATAZIMUTH BUFR1B 121 C SYSTEM: - SYSTEM GET_ENVIRONMENT_VARIABLE 122 C LIBRARY: 123 C W3NCO - W3TAGB W3TAGE ERREXIT W3FS26 W3MOVDAT W3DOXDAT 124 C BUFRLIB - OPENBF CLOSBF OPENMB WRITSB WRITCP UFBSEQ 125 C MESGBC 126 C 127 C 128 C EXIT STATES 129 C 0 = No errors detected 130 C 1 = Data type id decoded from header is not for HIRS-3 or HIRS-4 131 C 3 = Problem reading header record of 1b HIRS-3 or HIRS-4 file 132 C 6 = Unknown satellite id 133 C 7 = Unknown satellite instrument 134 C 135 C REMARKS: 136 C Switches read in Namelist INPUT: 137 C INFILE - Path to input 1B data file 138 C COMPRESS - BUFR compression switch (YES or NO) 139 C COEFILE - Path to input coefficient file 140 C PROCESS_Tb - Process brightness temps into BUFR files? 141 C (hardwired to YES - can only process Tb) 142 C PROCESS_Ta - Process antenna temps into BUFR files? 143 C (hardwired to NO - can only process Tb) 144 C 145 C#################################################################### 146 C NOTE: This program can only process Tb into a BUFR file. There 147 C is no Ta data for HIRS-3 or HIRS-4. Switches pertaining to 148 C the processing of Ta data are included because the parent 149 C script also executes BUFR_TRANAMSUA which can process BOTH 150 C Tb and Ta data into BUFR files. 151 C#################################################################### 152 C 153 C ATTRIBUTES: 154 C LANGUAGE: FORTRAN 90 155 C MACHINE: NCEP WCOSS 156 C 157 C$$$ 158 159 C Declare namelist variables and namelist 160 C --------------------------------------- 161 162 integer stdout 163 character*500 infile,coefile 164 character*8 compress,process_Tb,process_Ta 165 namelist /input/ infile,coefile,compress,process_Tb,process_Ta 166 167 common/switches/compress,process_Tb,process_Ta 168 169 C Set I/O unit numbers 170 C -------------------- 171 Page 4 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 tranhirs3.f 172 data lunam, stdout / 5, 6 / 173 data lunin / 11 / 174 175 call w3tagb('BUFR_TRANHIRS3',2012,0297,0068,'NP22') 176 177 print * 178 print *, 'WELCOME TO BUFR_TRANHIRS3 - Version 10/23/2012' 179 print * 180 181 C Get Namelist input 182 C ------------------ 183 184 read(lunam,input) 185 186 process_Tb = 'YES' ! process_Tb is hardwired to YES 187 process_Ta = 'NO' ! process_Ta is hardwired to NO 188 189 write(stdout,*)'namelist input below' 190 write(stdout,input) 191 192 C Read/decode/output data records scan by scan 193 C -------------------------------------------- 194 195 call hirs(lunin,infile) 196 197 call w3tage('BUFR_TRANHIRS3') 198 199 stop 200 end Page 5 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name MAIN__ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References BUFR_TRANHIRS3 Prog 1 COEFILE Local 163 CHAR 500 scalar 165 COMPRESS Scalar 164 CHAR 8 scalar COM 165 HIRS Subr 195 195 INFILE Local 163 CHAR 500 scalar 165,195 INPUT Local 165 scalar 184,190 LUNAM Local 172 I(4) 4 scalar 172,184 LUNIN Local 173 I(4) 4 scalar 173,195 PROCESS_TA Scalar 164 CHAR 8 scalar COM 165,187 PROCESS_TB Scalar 164 CHAR 8 scalar COM 165,186 STDOUT Local 162 I(4) 4 scalar 172,189,190 SWITCHES Common 167 24 W3TAGB Subr 175 175 W3TAGE Subr 197 197 Page 6 Source Listing BUFR_TRANHIRS3 2012-11-20 14:03 tranhirs3.f 201 202 SUBROUTINE HIRS(LUNIN,RAWHIRS) 203 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 204 C 205 C SUBPROGRAM: HIRS 206 C PRGMMR: KEYSER ORG: NP22 DATE: 2010-10-23 207 C 208 C ABSTRACT: Read raw HIRS-3 or HIRS-4 1B format file, decode, write 209 C selected Tb observations to output BUFR file. 210 C 211 C PROGRAM HISTORY LOG: 212 C 1998-06-15 Treadon -- Original author 213 C 2002-07-08 Keyser -- Accounts for NOAA-17 (converts NESDIS sat. 214 C no. from 6 to 17) 215 C 2005-06-21 Keyser -- Modified to handle processing of NOAA-18 216 C HIRS-4 data, processing it into BUFR message type NC021028 (in 217 C addition to existing processing of NOAA-15, -16, -17 HIRS-3 218 C data into both BUFR message type NC021025 and IEEE), NOAA-18 219 C HIRS-4 does not write out into IEEE 220 C 2006-04-21 Derber -- Modified to estimate solar and satellite 221 C azimuth (via new subroutine SATAZIMUTH), and to update time 222 C within a scan line 223 C 2006-07-20 Keyser -- Modified to encode the following new 224 C information into output BUFR file: estimated solar azimuth 225 C (SOLAZI) and estimated satellite azimuth (BEARAZ) for each 226 C subset (retrieval) (note: this is not added to output IEEE file 227 C for HIRS-3); the "report" time in the BUFR and IEEE files now 228 C varies across a scan line as a result of 2006-04-21 change; 229 C increased limit for i/o filename length from 80 characters to 230 C 500 characters 231 C 2009-09-03 Krasowski -- Modified to handle processing of NOAA-19 232 C data 233 C 2009-09-03 Keyser -- Modified to no longer unilaterally toss a 234 C scan line if a calibration anomaly is detected in the 235 C calibration quality information (bit 28 in octets 29-32 set, 236 C this only means a potential for noise in the data), instead the 237 C results from this test are ignored and the "Scan Line Quality 238 C Flags" are tested to see if a scan contains marginal calibration 239 C in some of its IR channels (bit 6 in octet 35 set), if not then 240 C all channels pass, otherwise, code tests the calibration quality 241 C bits for each individual channel and if set for a particular 242 C channel, that channel is not processed {Note: This overall logic 243 C had previously been in place but only for NOAA-18, now it is in 244 C place for all satellites (for HIRS-3 or -4) assuming the format 245 C is the post-April 2005 version} 246 C 2012-10-23 Keyser -- Removed IEEE output processing 247 C 248 C USAGE: CALL HIRS(LUNIN,RAWHIRS) 249 C INPUT ARGUMENT LIST: 250 C LUNIN - Unit connected to raw 1B HIRS-3 or HIRS-4 data file 251 C RAWHIRS - Name of raw 1B HIRS-3 or HIRS-4 data file 252 C 253 C INPUT FILES: 254 C UNIT 12 - BUFR mnemonic table 255 C UNIT 41 - Binary file containing topography information 256 C used by function LANSEA 257 C UNIT LUNIN - Binary file containing raw 1B HIRS-3 or HIRS-4 data Page 7 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 258 C 259 C ***NOTE*** 260 C Function LANSEA assumes this information is in 261 C a file named 'lowtopog.dat' which is local to 262 C the working directory. 263 C 264 C OUTPUT FILES: 265 C UNIT 06 - Printout 266 C UNIT 52 - BUFR file containing HIRS-3 or HIRS-4 Tb data 267 C 268 C REMARKS: 269 C 270 C ATTRIBUTES: 271 C LANGUAGE: FORTRAN 90 272 C MACHINE: NCEP WCOSS 273 C 274 C$$$ 275 276 C Include machine dependent parameters 277 C ------------------------------------ 278 279 include 'rfac.inc' 280 281 C Declare/set parameters: 282 C NBYTE1 = Total number of bytes (4608) in HIRS-3 or HIRS-4 data 283 C record 284 C NBYTE4 = Number of 4-byte words in NBYTE1 bytes (4608/4=1152) 285 C NSET = Number of topography datasets for function LANSEA3 286 C (not currently used) 287 C EPS = A "small" number 288 C MCH = Number of channels 289 C MPOS = Number of spots (positions) on a scan line 290 307 integer,parameter::real_32=selected_real_kind(6,37) 308 integer,parameter::real_64=selected_real_kind(15,307) 309 real(real_64) eps 310 parameter (nbyte1=4608,nbyte4=nbyte1/4) 311 parameter (nset=3) 312 parameter (eps=1.d-12) 313 parameter (mch=20) 314 parameter (mpos=56) 315 316 C Set parameters for structure of output data file 317 C ------------------------------------------------ 318 319 parameter (nreal=18,nperchan=1,ntot=nreal+nperchan*mch) 320 321 C Declare variables 322 C ----------------- 323 324 character*1 kbuf(nbyte1),kold 325 character*4 indat(nbyte4),jbuf(nbyte4) 326 character*40 mapfile(nset) 327 character*80 tankfile 328 character*500 rawhirs 329 330 integer stdout Page 8 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 331 integer(8) itime 332 integer newpos(mch),idt(2),ndt(5),idat(8),jdat(8) 333 integer ichan(mch),lndsea(mpos),ikeepb(mpos) 334 integer imx(nset),jmx(nset),ibadc(mch) 335 336 real(real_64) p1,p2,term1,term2,term3,ta0,b,c 337 real(real_64) scale,scale5,scale6,scale9,scale12 338 real(real_64) sctime,xsec,counts,rads,rad0 339 real(real_64) soza(mpos),saza(mpos),rlocaz(mpos),sazimuth(mpos) 340 real(real_64) slat(mpos),slon(mpos),aazimuth(mpos) 341 real(real_64) cwave(mch),cnst1(mch),cnst2(mch) 342 real(real_64) rad(mch,mpos),tb(mch,mpos),sfchgt(mpos) 343 real(real_64) c0(mch),c1(mch),c2(mch) 344 real(real_32) bdata(ntot),rinc(5),sctime1 345 real(real_64) badr(mch),badtb(mch),badc(mch) 346 347 logical lnew 348 349 C Declare equivalences 350 C -------------------- 351 352 equivalence (kbuf(1),jbuf(1)) 353 354 C Set information for different resolution map datasets 355 C ----------------------------------------------------- 356 357 data imx / 360, 720, 1440 / 358 data jmx / 181, 361, 721 / 359 data mapfile / 'mapdat_100.iee', 'mapdat_050.iee', 360 x 'mapdat_025.iee' / 361 362 C Lower/upper limits for gross temperature check on Tb 363 C ---------------------------------------------------- 364 365 data tlo,thi / 100., 400. / 366 367 C Constants for Planck equation 368 C ----------------------------- 369 370 data p1,p2 / 1.1910659d-5, 1.438833d0 / 371 372 C Order channel numbers as stored in data file 373 C -------------------------------------------- 374 375 data newpos/1,17,2,3,13,4,18,11,19,7,8,20,10,14,6,5,15,12,16,9/ 376 377 C Missing data flag 378 C ----------------- 379 380 data rmiss / -999. / 381 382 C Channel numbers 383 C --------------- 384 385 data ichan / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 386 x 12, 13, 14, 15, 16, 17, 18, 19, 20 / 387 Page 9 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 388 C Set I/O unit numbers (including standard output) 389 C ------------------------------------------------ 390 391 data stdout / 6/ 392 data lundx /12/ 393 data lubfrb /52/ 394 395 data kold /Z'01'/ 396 397 call get_environment_variable('TANKFILE',tankfile) 398 399 write(stdout,*)' ' 400 if(tankfile.ne.'b021/xx028') then 401 write(stdout,*)' BEGIN HIRS-3 1B DECODE' 402 else 403 write(stdout,*)' BEGIN HIRS-4 1B DECODE' 404 end if 405 406 C Initialize arrays 407 C ----------------- 408 409 badr = 0. 410 badtb = 0. 411 badc = 0. 412 nprint = 500 ! skip between data record diagnostic prints 413 414 C Write header record to standard output 415 C -------------------------------------- 416 417 write(stdout,*)' ' 418 write(stdout,*)'header information below' 419 write(stdout,*)'nreal,mch = ',nreal,mch 420 write(stdout,*)'ntot = ',ntot 421 write(stdout,*)'channel numbers below' 422 write(stdout,*) (ichan(i),i=1,mch) 423 write(stdout,*)' ' 424 ccccc if(tankfile.ne.'b021/xx028') then 425 ccccc write(99,*) nreal-4,mch,(ichan(i),i=1,mch) 426 ccccc else 427 ccccc write(99,*) nreal,mch,(ichan(i),i=1,mch) 428 ccccc end if 429 430 C Open output BUFR file 431 C --------------------- 432 433 ccccc call openbf(lubfrb,'OUT',lundx) 434 call openbf(lubfrb,'NODX',lundx) 435 436 C Open unit to raw 1B HIRS-3 or HIRS-4 data file - read header record, 437 C see if valid data type - if not, exit routine 438 C -------------------------------------------------------------------- 439 440 open(lunin,file=rawhirs,recl=nbyte1/rfac, 441 & access='direct',status='old') 442 nri = 1 443 read (lunin,rec=nri,err=1900) (kbuf(i),i=1,nbyte1) 444 Page 10 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 445 C Load header record into work array 446 C ---------------------------------- 447 448 do i = 1,nbyte4 449 indat(i) = jbuf(i) 450 end do 451 452 C Test for OLD vs. NEW NESDIS 1B format (NEW after 4/28/2005) 453 C ----------------------------------------------------------- 454 455 if (kbuf(6) .eq. kold ) then 456 lnew = .false. 457 print *, 'OLD NESDIS 1B Format' 458 else 459 lnew = .true. 460 print *, 'NEW NESDIS 1B Format' 461 end if 462 463 C Extract NOAA spacecraft identification code (72*8+1=577) 464 C and convert it into BUFR value (CODE TABLE 0-01-007) 465 C -------------------------------------------------------- 466 467 jsat = lbyte(577,16,indat) 468 if (jsat.eq.4) then ! NOAA-15 469 jsat0 = jsat 470 jsat = 206 471 write(stdout,*) '***WARNING: reset NOAA-15 satellite id ', 472 x 'from ',jsat0,' to ',jsat 473 elseif (jsat.eq.2) then ! NOAA-16 474 jsat0 = jsat 475 jsat = 207 476 write(stdout,*) '***WARNING: reset NOAA-16 satellite id ', 477 x 'from ',jsat0,' to ',jsat 478 elseif (jsat.eq.6) then ! NOAA-17 479 jsat0 = jsat 480 jsat = 208 481 write(stdout,*) '***WARNING: reset NOAA-17 satellite id ', 482 x 'from ',jsat0,' to ',jsat 483 elseif (jsat.eq.7) then ! NOAA-18 484 jsat0 = jsat 485 jsat = 209 486 write(stdout,*) '***WARNING: reset NOAA-18 satellite id ', 487 x 'from ',jsat0,' to ',jsat 488 elseif (jsat.eq.8) then ! NOAA-19 489 jsat0 = jsat 490 jsat = 223 491 write(stdout,*) '***WARNING: reset NOAA-19 satellite id ', 492 x 'from ',jsat0,' to ',jsat 493 else if(jsat.eq.12) then ! METOP-2 494 jsat0 = jsat 495 jsat = 4 496 write(stdout,*) '***WARNING: reset METOP-2 satellite id ', 497 x 'from ',jsat0,' to ',jsat 498 else if(jsat.eq.11) then ! METOP-1 499 jsat0 = jsat 500 jsat = 3 501 write(stdout,*) '***WARNING: reset METOP-1 satellite id ', Page 11 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 502 x 'from ',jsat0,' to ',jsat 503 else 504 write(stdout,*) '***ERROR*** unknown satellite id ',jsat 505 call w3tage('BUFR_TRANHIRS3') 506 call errexit(6) 507 endif 508 509 C Extract data type code (76*8+1=609) 510 C ----------------------------------- 511 512 jtype = lbyte(609,16,indat) 513 514 if (jtype.ne.5) then 515 write(stdout,*)'***ERROR*** Input data file does not contain', 516 x ' HIRS-3 or HIRS-4 data (type=5). data type = ',jtype 517 call w3tage('BUFR_TRANHIRS3') 518 call errexit(1) 519 endif 520 write(stdout,*) 'Data type and BUFR satellite id = ',jtype,jsat 521 522 C Extract number of data records in data set (128*1+1=1025) 523 C and number of scans (130*8+1=1041) 524 C --------------------------------------------------------- 525 526 nrecs = lbyte(1025,16,indat) 527 nscan = lbyte(1041,16,indat) 528 write(stdout,*)'nrecs,nscan=',nrecs,nscan 529 530 C Extract coefficients for radiance to temperature conversion 531 C ----------------------------------------------------------- 532 533 scale5 = 1.d-5 534 scale6 = 1.d-6 535 do j = 1,mch 536 scale = scale6 537 if (j.ge.13) scale = scale5 538 if (j.le.mch-1) then 539 jb = 521 + (j-1)*12 540 jb0 = jb 541 jb1 = jb0 + 4 542 jb2 = jb1 + 4 543 cwave(j) = xfloat(1,kbuf(jb0))*scale 544 cnst1(j) = xfloat(1,kbuf(jb1))*scale6 545 cnst2(j) = xfloat(1,kbuf(jb2))*scale6 546 ccccc write(stdout,*)'cwave = ',j,jb0,xfloat(1,kbuf(jb0)) 547 ccccc write(stdout,*)'cnst1 = ',j,jb1,xfloat(1,kbuf(jb1)) 548 ccccc write(stdout,*)'cnst2 = ',j,jb2,xfloat(1,kbuf(jb2)) 549 else 550 jb = 749 551 jb0 = jb 552 jb1 = jb0 + 2 553 cwave(j) = 0.0 554 cnst1(j) = xfloat(1,kbuf(jb0))*scale6 555 cnst2(j) = xfloat(1,kbuf(jb1))*scale6 556 ccccc write(stdout,*)'cwave = ',j,0.0 557 ccccc write(stdout,*)'cnst1 = ',j,jb0,xfloat(1,kbuf(jb0)) 558 ccccc write(stdout,*)'cnst2 = ',j,jb1,xfloat(1,kbuf(jb1)) Page 12 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 559 endif 560 end do 561 write(stdout,*)'chn 1 cwave,cnst1,cnst2=', 562 x cwave(1),cnst1(1),cnst2(1) 563 write(stdout,*)' ' 564 565 C Prepatory initializations prior to reading in satellite data 566 C ------------------------------------------------------------ 567 568 nopos = 0 569 nqcbad = 0 570 nqctim = 0 571 nqccal = 0 572 nqcloc = 0 573 nbadc = 0 574 nbadl = 0 575 nbadtb = 0 576 nbadr = 0 577 nrecb = 0 578 nrepb = 0 579 nskipc = 0 580 nskipq = 0 581 nskipm = 0 582 nskiptb = 0 583 nlandb = 0 584 nseab = 0 585 nlo = 0 586 587 1200 continue 588 589 C********************************************************************** 590 C MAIN LOOP OVER NUMBER OF SCANS 591 C********************************************************************** 592 593 nri = nri + 1 ! Increment record counter 594 595 C Read data record and load into local work array 596 C ----------------------------------------------- 597 598 read(lunin,rec=nri,err=1600) (kbuf(i),i=1,nbyte1) 599 600 do i = 1,nbyte4 601 indat(i) = jbuf(i) 602 end do 603 604 nlo = nlo + 1 ! Increment line counter 605 line = nlo 606 607 C Extract scan type (18*8+1=145) - if scan type is not 0 (earth view), 608 C skip this scan line 609 C Possible scan types are: 610 C 0 = earth view 611 C 1 = space view 612 C 2 = cold black body (BB) view 613 C 3 = main BB view 614 C -------------------------------------------------------------------- 615 Page 13 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 616 iscantyp = lbyte(145,16,indat) 617 if (iscantyp.ne.0) then 618 nskipm = nskipm + 1 619 nskipq = nskipq + 1 620 write(stdout,2000) nlo,iline,iscantyp,nskipq 621 2000 format('***WRONG MODE-SCAN : nlo=',i6,' iline=',i6, 622 x ' type=',i2,' nskipq=',i6) 623 goto 1200 624 endif 625 626 C Extract scan line number, start date/time, position, and type 627 C ------------------------------------------------------------- 628 629 iline = lbyte(1,16,indat) 630 iyear = lbyte(17,16,indat) ! (2*8+1=17) 631 iddd = lbyte(33,16,indat) ! (4*8+1=33) 632 itime = lbyte(65,32,indat) ! (8*8+1=65) 633 idt(1) = iddd ! day of the year 634 idt(2) = iyear ! 4-digit year 635 sctime = 1.d-3*itime ! second of the day 636 637 ccccc write(stdout,*) 'iline,date=',iline,iyear,iddd,itime,sctime,idt 638 639 C Convert scan start time from year, day-of-year and second-of-day 640 C to YYYY,MM,DD,HH,mm,ss 641 C ---------------------------------------------------------------- 642 643 call dattim(idt,sctime,ndt,xsec) 644 rinc = 0 645 idat = 0 646 idat(1:3) = ndt(1:3) 647 idat(5:6) = ndt(4:5) 648 idat(7) = xsec 649 idat(8) = mod(xsec*1000._8,1000._8) 650 651 C Extract quality bits - if all good (=0) continue, else skip this scan 652 C --------------------------------------------------------------------- 653 654 isum = 0 655 iqcbad = lbyte(225,1,indat) ! (8*28+1=225) 656 iqctim = lbyte(226,1,indat) ! (8*28+1+1=226) 657 iqccal = lbyte(228,1,indat) ! (8*28+1+3=228) 658 iqcloc = lbyte(229,1,indat) ! (8*28+1+4=229) 659 isum = iqcbad + iqctim + iqccal + iqcloc 660 661 C For NOAA-18, or all satellites if new NESDIS HIRS 1B format, do not 662 C include calibration quality bit in determining if scan line failed 663 C overall Q.C. (in NOAA-18 this flag is always set because channel 1 664 C HIRS is always bad, for any satellite in new format this flag being 665 C set only indicates a potential for noise in the data) - instead, 666 C fall through and let code check calibration quality flags for 667 C individual channels 668 C -------------------------------------------------------------------- 669 670 if (jsat.eq.209 .or. lnew) isum = iqcbad + iqctim + iqcloc 671 672 if (iqcbad.ne.0) nqcbad = nqcbad + 1 Page 14 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 673 if (iqctim.ne.0) nqctim = nqctim + 1 674 if (iqccal.ne.0) nqccal = nqccal + 1 675 if (iqcloc.ne.0) nqcloc = nqcloc + 1 676 if (isum.ne.0) then 677 nskipq = nskipq + 1 678 write(stdout,1000) nlo,iline,iqcbad,iqctim, 679 x iqccal,iqcloc,nskipq 680 1000 format('***FAIL QC-SCAN : nlo=',i6,' iline=',i6, 681 x ' bad=',i2,' time=',i2,' cali=',i2,' loc=',i2, 682 x ' nskipq=',i6) 683 goto 1200 684 endif 685 686 isum = 0 687 688 if (lnew) then 689 690 C If this is new format, check to see if octet 35, bit 6 (scan 691 c contains marginal calibration in some of the IR channels) is set 692 c ----------------------------------------------------------------- 693 694 io35b6 = lbyte(274,1,indat) ! (8*34+1+1=274) 695 ccc print *, 'io35b6 = ',io35b6 696 cppppp 697 if(io35b6.ne.0) print *, '~~~Octet 35, bit 6 is ON' 698 cppppp 699 if (io35b6 .ne. 0) then 700 C 701 C .. if this flag is set, must extract calibration quality bits (and 702 C test) for each channel (otherwise skip this and accept all 703 C channels) - each channel is in a 2-octet word beginning at 704 C octet 37, there are 20 channels 705 C ------------------------------------------------------------------ 706 707 do jj = 1,mch 708 j = newpos(jj) 709 ibadc(j) = 0 710 jb = (36 + (j-1)*2)*8+1 711 iqccal = lbyte(jb,16,indat) 712 if (iqccal .lt. 7) then 713 714 C .. if either space views (bit 1) or blackbody views (bit 2) failed 715 C NEDC test (or both) {bit(s) set}, but no other quality bits are 716 C set for a particular channel, then this channel passes 717 C calibration q.c. test (also true if all bits are not set) 718 C ----------------------------------------------------------------- 719 720 iqccal = 0 721 else 722 723 C .. this channel fails calibration q.c. test 724 C ------------------------------------------- 725 726 iqc5 = lbyte(jb+10,1,indat) 727 iqc4 = lbyte(jb+11,1,indat) 728 iqc3 = lbyte(jb+12,1,indat) 729 iqc2 = lbyte(jb+13,1,indat) Page 15 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 730 iqc1 = lbyte(jb+14,1,indat) 731 iqc0 = lbyte(jb+15,1,indat) 732 write(stdout,3005) nlo,iline,j,iqccal,iqc0,iqc1, 733 x iqc2,iqc3,iqc4,iqc5 734 3005 format('+++FAIL CAL-CHN: nlo=',i6,' iline=',i6, 735 x ' chn=',i3,' badcal=',i2,' bits 0-5=',6i2) 736 end if 737 ibadc(j) = iqccal 738 isum = isum + ibadc(j) 739 end do 740 if (isum.ne.0) then 741 nskipc = nskipc + 1 742 ccc write(stdout,1005) nlo,iline,(ibadc(j),j=1,mch) 743 1005 format('***FAIL CAL : nlo=',i6,' iline=',i6, 744 x ' badcal=',20(i2,1x)) 745 endif 746 endif 747 else 748 749 C If this is old format, always extract calibration quality bits for 750 C each channel (if any quality bit is set, this channel fails 751 C calibration q.c. test) 752 C ------------------------------------------------------------------ 753 754 do jj = 1,mch 755 j = newpos(jj) 756 ibadc(j) = 0 757 jb = (36 + (j-1)*2)*8+1 758 iqccal = lbyte(jb,16,indat) 759 if (iqccal .gt. 0) then 760 iqc5 = lbyte(jb+10,1,indat) 761 iqc4 = lbyte(jb+11,1,indat) 762 iqc3 = lbyte(jb+12,1,indat) 763 iqc2 = lbyte(jb+13,1,indat) 764 iqc1 = lbyte(jb+14,1,indat) 765 iqc0 = lbyte(jb+15,1,indat) 766 write(stdout,3005) nlo,iline,j,iqccal,iqc0,iqc1, 767 x iqc2,iqc3,iqc4,iqc5 768 end if 769 ibadc(j) = iqccal 770 isum = isum + ibadc(j) 771 end do 772 if (isum.ne.0) then 773 nskipc = nskipc + 1 774 ccc write(stdout,1005) nlo,iline,(ibadc(j),j=1,mch) 775 endif 776 endif 777 778 C Extract calibration coefficients 779 C -------------------------------- 780 781 scale12 = 1.d-12 782 scale9 = 1.d-9 783 scale6 = 1.d-6 784 do jj = 1,mch 785 j = newpos(jj) 786 jb2 = 157 + (jj-1)*12 Page 16 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 787 c2(j) = xfloat(1,kbuf(jb2))*scale12 788 jb1 = jb2 + 4 789 c1(j) = xfloat(1,kbuf(jb1))*scale9 790 jb0 = jb1 + 4 791 c0(j) = xfloat(1,kbuf(jb0))*scale6 792 ccccc write(stdout,*)'cali c0 = ',jj,j,jb0,xfloat(1,kbuf(jb0)),c0(j) 793 ccccc write(stdout,*)'cali c1 = ',jj,j,jb1,xfloat(1,kbuf(jb1)),c1(j) 794 ccccc write(stdout,*)'cali c2 = ',jj,j,jb2,xfloat(1,kbuf(jb2)),c2(j) 795 end do 796 797 C EXTRACT NAVIGATION DATA 798 C ----------------------- 799 C ----------------------- 800 801 C Extract spacecraft altitude (km) 802 C -------------------------------- 803 804 scale = 1.d-1 805 sathgt = lbyte(5297,16,indat)*scale ! (662*8+1=5297) 806 807 C Extract angular relationships 808 C ----------------------------- 809 810 scale = 1.d-2 811 do i = 1,mpos 812 jb0 = 664*8+1 + (i-1)*48 813 jb1 = jb0 + 16 814 jb2 = jb1 + 16 815 soza(i) = mbyte(jb0,16,indat)*scale 816 saza(i) = mbyte(jb1,16,indat)*scale 817 rlocaz(i) = mbyte(jb2,16,indat)*scale 818 ccccc write(stdout,*)'location = ',i,jb0,jb1,jb2,soza(i), 819 ccccc x saza(i),rlocaz(i) 820 end do 821 822 C Extract earth location data 823 C --------------------------- 824 825 scale = 1.d-4 826 do i = 1,mpos 827 jb0 = 1001 + (i-1)*8 828 slat(i) = xfloat(1,kbuf(jb0))*scale 829 jb1 = jb0 + 4 830 slon(i) = xfloat(1,kbuf(jb1))*scale 831 lndsea(i) = rmiss 832 sfchgt(i) = rmiss 833 ikeepb(i) = 0 834 ccccc write(stdout,*)'latlon = ',i,jb0,jb1,xfloat(1,kbuf(jb0)), 835 ccccc x xfloat(1,kbuf(jb1)),slat(i),slon(i) 836 if ( (abs(slat(i)).gt.90.) .or. 837 x (abs(slon(i)).gt.180.) ) then 838 ikeepb(i) = 0 839 nbadl = nbadl + 1 840 write(stdout,*)'bad (lat,lon) ',i,slat(i),slon(i) 841 elseif ( (abs(slat(i)).le.eps) .and. 842 x (abs(slon(i)).le.eps) ) then 843 ikeepb(i) = 0 Page 17 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 844 nopos = nopos + 1 845 else 846 ikeepb(i) = 1 847 848 C Set surface type information based on resolution option 849 C If iresol = 1, use 1.0 degree dataset 850 C iresol = 2, use 0.5 degree dataset 851 C iresol = 3, use 0.25 degree dataset 852 C ------------------------------------------------------- 853 854 ccccc call lansea3(xlat,xlon,imx(iresol),jmx(iresol), 855 ccccc x mapfile(iresol),rmask,water,elev,stdev) 856 ccccc lndsea(i) = rmask + 1.d-3 857 ccccc sfchgt(i) = elev 858 859 ils = lansea(slat(i),slon(i),ll) 860 if (ils.eq.2) then 861 lndsea(i) = 0 862 sfchgt(i) = 0.0 863 elseif (ils.eq.1) then 864 lndsea(i) = 1 865 sfchgt(i) = 1.*ll 866 else 867 lndsea(i) = rmiss 868 sfchgt(i) = rmiss 869 endif 870 endif 871 end do 872 873 C Extract HIRS-3 or HIRS-4 counts, then convert counts to radiances 874 C ----------------------------------------------------------------- 875 876 do i = 1,mpos 877 jb = (1460 + (i-1)*48)*8+1 878 do jj = 1,mch 879 j = newpos(jj) 880 jb0 = jb + (jj-1)*16 881 counts = lbyte(jb0,16,indat) 882 883 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 884 cfix 885 c 98071500: Tom K. notes that counts-4096 "fixes" problem with 886 c hirs-3 radiances. This problem began 98062800. 887 c 888 c 98092300: Tom K. says offset should be 4095, not 4096 889 counts = counts - 4095 890 cfix 891 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 892 893 rads = c0(j) + (c1(j)+c2(j)*counts)*counts 894 rad0 = rads 895 if (rads.lt.0.) then 896 nbadr = nbadr + 1 897 badr(j) = badr(j) + 1 898 rads = rmiss 899 endif 900 rad(j,i) = rads Page 18 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 901 ccccc write(stdout,*)'counts = ',i,jb,jj,jb0,counts,rad0,rads 902 end do 903 end do 904 905 C----------------------------------------------------------------------- 906 C Convert radiances to apparent temperature (Ta0), then convert 907 C apparent temperature (Ta0) to brightness temperature (Tb) 908 C QC all channels - if all channels are bad for a given spot, set 909 C flag to omit Tb data in final write 910 C Note: The HIRS-3 and HIRS-4 do not produce an intermediate antenna 911 C temperature (Ta) 912 C----------------------------------------------------------------------- 913 914 do i = 1,mpos 915 ibadtb = 0 916 do jj = 1,mch 917 j = newpos(jj) 918 rads = rad(j,i) 919 term1 = p2*cwave(j) 920 tb(j,i) = rmiss 921 if ( (rads.gt.eps) .and. (j.ne.mch) ) then 922 term2 = 1 + p1*cwave(j)**3/rads 923 if (term2.le.0) term2 = eps 924 term3 = dlog(term2) 925 ta0 = term1/term3 926 b = cnst1(j) 927 c = cnst2(j) 928 tb(j,i) = (ta0-b)/c 929 else 930 ta0 = 0. 931 tb(j,i) = rmiss 932 endif 933 934 C Apply gross check to Tb using limits TLO and THI set in data stmt 935 C ----------------------------------------------------------------- 936 937 if ( ((tb(j,i).lt.tlo) .or. 938 x (tb(j,i).gt.thi)) .and. 939 x (j.ne.mch) ) then 940 nbadtb = nbadtb + 1 941 badtb(j) = badtb(j) + 1 942 tb(j,i) = rmiss 943 endif 944 945 C If calibration quality flag for this channel is nonzero, we do not 946 C want to use this channel for Tb 947 C ------------------------------------------------------------------ 948 949 if (ibadc(j).ne.0) then 950 CC bug, wrong nbadc = nbadc + nbadc 951 nbadc = nbadc + 1 952 badc(j) = badc(j) + 1 953 tb(j,i) = rmiss 954 endif 955 956 C Count number of bad channels for current scan position 957 C ------------------------------------------------------ Page 19 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 958 959 if (tb(j,i).lt.0.) ibadtb = ibadtb + 1 960 961 end do 962 963 C If all Tb channels are bad for current scan position, set keep flag 964 C to zero (this tells the code below to not write Tb for this spot 965 C to the output files) 966 C ------------------------------------------------------------------- 967 968 if (ibadtb.eq.mch) then 969 nskiptb = nskiptb + 1 970 ikeepb(i) = 0 971 endif 972 973 end do 974 975 976 C ------------------------------------------------------------------- 977 C WRITE HIRS-3 OR HIRS-4 DATA FOR EACH SPOT POS. ON CURRENT SCAN LINE 978 C ------------------------------------------------------------------- 979 980 do i = 1,mpos 981 if (ikeepb(i).eq.1) then 982 983 C First, update scan start date time to reflect date time for spot 984 C ---------------------------------------------------------------- 985 986 rinc(4) = 0.023+(i-1)*.10 ! # of seconds to add to scan 987 ! start time for this spot 988 call w3movdat(rinc,idat,jdat) ! update date time 989 990 C Calculate updated day-of-year & second-of-day for use by satazimuth 991 C ------------------------------------------------------------------- 992 993 call w3doxdat(jdat,jdow,jdoy,jday) ! calc. updated DOY 994 sctime = jdat(5)*3600 +jdat(6)*60 +jdat(7) +jdat(8)/1000. 995 sctime1 = sctime 996 997 C Estimate satellite azimuth angle and solar azimuth angle 998 C -------------------------------------------------------- 999 1000 call satazimuth(jdat(1),jdoy,sctime,slat(i),slon(i), 1001 x rlocaz(i),aazimuth(i),sazimuth(i)) 1002 ccccc write(stdout,*)i,sctime,slat(i),slon(i),aazimuth(i), 1003 cccccx sazimuth(i),soza(i) 1004 1005 C Store output information for this spot 1006 C -------------------------------------- 1007 1008 bdata(1) = jsat ! satellite id 1009 bdata(2) = jtype ! data type indicator 1010 bdata(3) = jdat(1) ! 4-digit year 1011 bdata(4) = jdat(2) ! month 1012 bdata(5) = jdat(3) ! day 1013 bdata(6) = jdat(5) ! hour 1014 bdata(7) = jdat(6) ! minute Page 20 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 1015 bdata(8) = jdat(7) + jdat(8)/1000. ! second 1016 bdata(9) = lndsea(i) ! land/sea tag 1017 bdata(10)= i ! F-O-V (spot) number 1018 bdata(11)= slat(i) ! latitude 1019 bdata(12)= slon(i) ! longitude 1020 ccccc bdata(13)= rlocaz(i) 1021 bdata(13)= saza(i) ! sat. zenith angle 1022 bdata(14)= soza(i) ! solar zenith angle 1023 bdata(15)= sfchgt(i) ! surface height 1024 bdata(16)= sathgt ! satellite height 1025 bdata(17)= sazimuth(i) ! solar azimuth angle 1026 bdata(18)= aazimuth(i) ! sat. azimuth angle 1027 1028 if (lndsea(i).lt.0.5) nseab = nseab + 1 1029 if (lndsea(i).gt.0.5) nlandb = nlandb + 1 1030 do j = 1,mch 1031 bdata(18+j) = tb(j,i) ! brightness temp 1032 end do 1033 nrecb = nrecb + 1 1034 if(tankfile.ne.'b021/xx028') then 1035 call bufr1b(lubfrb,'NC021025',nreal,mch,bdata,nrepb) 1036 ccccc write(99,*) (bdata(j),j=1,5),sctime1, 1037 ccccc+ (bdata(j),j=9,nreal-2), 1038 ccccc+ (bdata(j),j=nreal+1,ntot,nperchan) 1039 else 1040 call bufr1b(lubfrb,'NC021028',nreal,mch,bdata,nrepb) 1041 endif 1042 endif 1043 end do 1044 1045 C Every NPRINT scan lines, print mpos-th record 1046 C --------------------------------------------- 1047 1048 if (mod(nlo,nprint).eq.0 .or. nlo.eq.1) then 1049 write(stdout,*)' ' 1050 write(stdout,*)' Tb data for line,rec=',nlo,nrecb 1051 write(stdout,*) (bdata(i),i=1,ntot) 1052 write(stdout,*)' ' 1053 endif 1054 1055 C********************************************************************** 1056 C DONE WITH THIS SCAN LINE, READ NEXT SCAN LINE 1057 C********************************************************************** 1058 1059 goto 1200 1060 ctest 1061 ccccc if (nlo.le.30) goto 1200 1062 ctest 1063 1064 1600 continue 1065 1066 C All scan lines have been read and processed, summarize 1067 C ------------------------------------------------------ 1068 1069 write(stdout,*)' ' 1070 write(stdout,*)'Done reading raw 1b file' 1071 write(stdout,*)' ' Page 21 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 1072 if(tankfile.ne.'b021/xx028') then 1073 write(stdout,*)'HIRS-3 INGEST STATS:' 1074 else 1075 write(stdout,*)'HIRS-4 INGEST STATS:' 1076 end if 1077 write(stdout,*)' # of records actually read = ', 1078 $ nlo 1079 write(stdout,*)' # of records in file as read in header = ', 1080 $ nrecs 1081 write(stdout,*)' # of "good" scans in file as read in header = ', 1082 $ nscan 1083 write(stdout,*)' # of scans flagged for non-use (skip) = ', 1084 $ nqcbad 1085 write(stdout,*)' # of scans failing time qc (skip) = ', 1086 $ nqctim 1087 write(stdout,*)' # of scans failing location qc (skip) = ', 1088 $ nqcloc 1089 write(stdout,*)' # of scans with bad scan type mode (skip) = ', 1090 $ nskipm 1091 if (jsat.eq.209 .or. lnew) then 1092 write(stdout,*)' # of scans with calibration qc noise = ', 1093 $ nqccal 1094 else 1095 write(stdout,*)' # of scans with calibration qc noise (skip) = ', 1096 $ nqccal 1097 end if 1098 write(stdout,*)' TOTAL # of scans skipped = ', 1099 $ nskipq 1100 write(stdout,*)' TOTAL # of channels failing calibration qc = ', 1101 $ nskipc 1102 write(stdout,*)' TOTAL # of scan positions with bad lat,lon = ', 1103 $ nbadl 1104 write(stdout,*)' TOTAL # of scan positions with zero lat,lon = ', 1105 $ nopos 1106 write(stdout,*)' TOTAL # of channels with bad radiances = ', 1107 $ nbadr 1108 write(stdout,*)' TOTAL # of channels with bad calibration = ', 1109 $ nbadc 1110 write(stdout,*)' TOTAL # of scan positions with bad Tb value = ', 1111 $ nskiptb 1112 write(stdout,*)' TOTAL # of channels with bad Tb value = ', 1113 $ nbadtb 1114 write(stdout,*)' # of Tb reports passed into BUFR encoder = ', 1115 $ nrecb 1116 write(stdout,*)' -- # of land Tb reports = ', 1117 $ nlandb 1118 write(stdout,*)' -- # of sea Tb reports = ', 1119 $ nseab 1120 write(stdout,*)' # of Tb BUFR reports (subsets) written = ', 1121 $ nrepb 1122 1123 write(stdout,*)' ' 1124 write(stdout,*)'bad radiance,temperature,calibration counts per ', 1125 $ 'channel' 1126 write(stdout,1020) 1127 1020 format(t1,'channel',t10,' bad rad',t20,' bad Tb',t30, 1128 $ ' bad calib.') Page 22 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 1129 sumr = 0. 1130 sumtb = 0. 1131 sumc = 0. 1132 do jj = 1,mch 1133 j = newpos(jj) 1134 write(stdout,1030) j,nint(badr(j)),nint(badtb(j)),nint(badc(j)) 1135 1030 format(t1,i2,t10,I6,t20,I6,t30,I6) 1136 sumr = sumr + badr(j) 1137 sumtb = sumtb + badtb(j) 1138 sumc = sumc + badc(j) 1139 end do 1140 write(stdout,*)'nbadr,nbadtb,nbadc=',sumr,sumtb,sumc 1141 1142 write(stdout,*)' ' 1143 if(tankfile.ne.'b021/xx028') then 1144 write(stdout,*)' HIRS-3 1B DECODE COMPLETED' 1145 else 1146 write(stdout,*)' HIRS-4 1B DECODE COMPLETED' 1147 end if 1148 write(stdout,*)' ' 1149 1150 C Close UNITs 1151 C ----------- 1152 1153 close(lunin) 1154 call closbf(lubfrb) 1155 1156 call system('echo YES > Tb') 1157 if(nrecb.eq.0) then 1158 write(stdout,1003) 1159 1003 format(/' NO Tb RECORDS WRITTEN -- DISABLING ALL SUBSEQUENT ', 1160 . 'Tb PROCESSING.'/) 1161 call system('echo NO > Tb') 1162 else 1163 call mesgbc(lubfrb,msgt,icomp) 1164 if(icomp.eq.1) then 1165 print'(/"OUTPUT Tb BUFR FILE MESSAGES '// 1166 . 'C O M P R E S S E D"/"FIRST MESSAGE TYPE FOUND IS",I5/)', 1167 . msgt 1168 elseif(icomp.eq.0) then 1169 print'(/"OUTPUT Tb BUFR FILE MESSAGES '// 1170 . 'U N C O M P R E S S E D"/"FIRST MESSAGE TYPE FOUND IS",'// 1171 . 'I5/)', msgt 1172 elseif(icomp.eq.-1) then 1173 print'(//"ERROR READING OUTPUT Tb BUFR FILE - MESSAGE '// 1174 . 'COMPRESSION UNKNOWN"/)' 1175 elseif(icomp.eq.-3) then 1176 print'(/"OUTPUT Tb BUFR FILE DOES NOT EXIST"/)' 1177 elseif(icomp.eq.-2) then 1178 print'(/"OUTPUT Tb BUFR FILE HAS NO DATA MESSAGES"/'// 1179 . '"FIRST MESSAGE TYPE FOUND IS",I5/)', msgt 1180 endif 1181 endif 1182 1183 close(lubfrb) 1184 1185 return Page 23 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 1186 1187 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1188 C ERRORS 1189 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1190 1191 C Error reading 1B file header record 1192 C ----------------------------------- 1193 1194 1900 continue 1195 write(stdout,*)' *** error reading hdr record of file ',rawhirs 1196 close(lunin) 1197 call closbf(lubfrb) 1198 call w3tage('BUFR_TRANHIRS3') 1199 call errexit(3) 1200 1201 end ENTRY POINTS Name hirs_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1000 Label 664 662 1003 Label 1143 1142 1005 Label 727 1020 Label 1111 1110 1030 Label 1119 1118 1200 Label 571 607,667,1043 1600 Label 1048 582 1900 Label 1178 427 2000 Label 605 604 3005 Label 718 716,750 AAZIMUTH Local 324 R(8) 8 1 56 985,1010 ABS Func 820 scalar 820,821,825,826 B Local 320 R(8) 8 scalar 910,912 BADC Local 329 R(8) 8 1 20 395,936,1118,1122 BADR Local 329 R(8) 8 1 20 393,881,1118,1120 BADTB Local 329 R(8) 8 1 20 394,925,1118,1121 BDATA Local 328 R(4) 4 1 38 992,993,994,995,996,997,998,999,10 00,1001,1002,1003,1005,1006,1007,1 008,1009,1010,1015,1019,1024,1035 BUFR1B Subr 1019 1019,1024 C Local 320 R(8) 8 scalar 911,912 C0 Local 327 R(8) 8 1 20 775,877 C1 Local 327 R(8) 8 1 20 773,877 C2 Local 327 R(8) 8 1 20 771,877 CLOSBF Subr 1138 1138,1181 CNST1 Local 325 R(8) 8 1 20 528,538,546,910 CNST2 Local 325 R(8) 8 1 20 529,539,546,911 COUNTS Local 322 R(8) 8 scalar 865,873,877 Page 24 Source Listing HIRS 2012-11-20 14:03 Symbol Table tranhirs3.f Name Object Declared Type Bytes Dimen Elements Attributes References CWAVE Local 325 R(8) 8 1 20 527,537,546,903,906 DATTIM Subr 627 627 DLOG Func 908 scalar 908 EPS Param 293 R(8) 8 scalar 825,826,905,907 ERREXIT Subr 490 490,502,1183 GET_ENVIRONMENT_VARIABLE Intrin 381 381 HIRS Subr 202 I Local 406 I(4) 4 scalar 406,427,432,433,582,584,585,795,79 6,799,800,801,810,811,812,814,815, 816,817,820,821,822,824,825,826,82 7,830,843,845,846,848,849,851,852, 860,861,884,898,902,904,912,915,92 1,922,926,937,943,954,964,965,970, 984,985,1000,1001,1002,1003,1005,1 006,1007,1009,1010,1012,1013,1015, 1035 IBADC Local 318 I(4) 4 1 20 693,721,722,740,753,754,933 IBADTB Local 899 I(4) 4 scalar 899,943,952 ICHAN Local 317 I(4) 4 1 20 369,406 ICOMP Local 1147 I(4) 4 scalar 1147,1148,1152,1156,1159,1161 IDAT Local 316 I(4) 4 1 8 629,630,631,632,633,972 IDDD Local 615 I(4) 4 scalar 615,617 IDT Local 316 I(4) 4 1 2 617,618,627 IKEEPB Local 317 I(4) 4 1 56 817,822,827,830,954,965 ILINE Local 604 I(4) 4 scalar 604,613,662,716,750 ILS Local 843 I(4) 4 scalar 843,844,847 IMX Local 318 I(4) 4 1 3 341 INDAT Local 309 CHAR 4 1 1152 433,451,496,510,511,585,600,613,61 4,615,616,639,640,641,642,678,695, 710,711,712,713,714,715,742,744,74 5,746,747,748,749,789,799,800,801, 865 IO35B6 Local 678 I(4) 4 scalar 678,681,683 IQC0 Local 715 I(4) 4 scalar 715,716,749,750 IQC1 Local 714 I(4) 4 scalar 714,716,748,750 IQC2 Local 713 I(4) 4 scalar 713,717,747,751 IQC3 Local 712 I(4) 4 scalar 712,717,746,751 IQC4 Local 711 I(4) 4 scalar 711,717,745,751 IQC5 Local 710 I(4) 4 scalar 710,717,744,751 IQCBAD Local 639 I(4) 4 scalar 639,643,654,656,662 IQCCAL Local 641 I(4) 4 scalar 641,643,658,663,695,696,704,716,72 1,742,743,750,753 IQCLOC Local 642 I(4) 4 scalar 642,643,654,659,663 IQCTIM Local 640 I(4) 4 scalar 640,643,654,657,662 ISCANTYP Local 600 I(4) 4 scalar 600,601,604 ISUM Local 638 I(4) 4 scalar 638,643,654,660,670,722,724,754,75 6 ITIME Local 315 I(8) 8 scalar 616,619 IYEAR Local 614 I(4) 4 scalar 614,618 J Local 519 I(4) 4 scalar 519,521,522,523,527,528,529,537,53 8,539,692,693,694,716,721,722,739, 740,741,750,753,754,769,771,773,77 5,863,877,881,884,901,902,903,904, 905,906,910,911,912,915,921,922,92 3,925,926,933,936,937,943,1014,101 Page 25 Source Listing HIRS 2012-11-20 14:03 Symbol Table tranhirs3.f Name Object Declared Type Bytes Dimen Elements Attributes References 5,1117,1118,1120,1121,1122 JB Local 523 I(4) 4 scalar 523,524,534,535,694,695,710,711,71 2,713,714,715,741,742,744,745,746, 747,748,749,861,864 JB0 Local 524 I(4) 4 scalar 524,525,527,535,536,538,774,775,79 6,797,799,811,812,813,864,865 JB1 Local 525 I(4) 4 scalar 525,526,528,536,539,772,773,774,79 7,798,800,813,814 JB2 Local 526 I(4) 4 scalar 526,529,770,771,772,798,801 JBUF Local 309 CHAR 4 1 1152 433,585 JDAT Local 316 I(4) 4 1 8 972,977,978,984,994,995,996,997,99 8,999 JDAY Local 977 I(4) 4 scalar 977 JDOW Local 977 I(4) 4 scalar 977 JDOY Local 977 I(4) 4 scalar 977,984 JJ Local 691 I(4) 4 scalar 691,692,738,739,768,769,770,862,86 3,864,900,901,1116,1117 JMX Local 318 I(4) 4 1 3 342 JSAT Local 451 I(4) 4 scalar 451,452,453,454,456,457,458,459,46 1,462,463,464,466,467,468,469,471, 472,473,474,476,477,478,479,481,48 2,483,484,486,488,504,654,992,1075 JSAT0 Local 453 I(4) 4 scalar 453,456,458,461,463,466,468,471,47 3,476,478,481,483,486 JTYPE Local 496 I(4) 4 scalar 496,498,500,504,993 KBUF Local 308 CHAR 1 1 4608 427,439,527,528,529,538,539,582,77 1,773,775,812,814 KOLD Local 308 CHAR 1 scalar 379,439 LANSEA Func 843 I(4) 4 scalar 843 LBYTE Func 451 I(4) 4 scalar 451,496,510,511,600,613,614,615,61 6,639,640,641,642,678,695,710,711, 712,713,714,715,742,744,745,746,74 7,748,749,789,865 LINE Local 589 I(4) 4 scalar 589 LL Local 843 I(4) 4 scalar 843,849 LNDSEA Local 317 I(4) 4 1 56 815,845,848,851,1000,1012,1013 LNEW Local 331 L(4) 4 scalar 440,443,654,672,1075 LUBFRB Local 377 I(4) 4 scalar 377,418,1019,1024,1138,1147,1167,1 181 LUNDX Local 376 I(4) 4 scalar 376,418 LUNIN Dummy 202 I(4) 4 scalar ARG,INOUT 424,427,582,1137,1180 MAPFILE Local 310 CHAR 40 1 3 343 MBYTE Func 799 I(4) 4 scalar 799,800,801 MCH Param 297 I(4) 4 scalar 303,316,317,318,325,326,327,329,40 3,406,519,522,691,738,768,862,900, 905,923,952,1014,1019,1024,1116 MESGBC Subr 1147 1147 MOD Func 633 scalar 633,1032 MPOS Param 298 I(4) 4 scalar 317,323,324,326,795,810,860,898,96 4 MSGT Local 1147 I(4) 4 scalar 1147,1151,1155,1163 NBADC Local 557 I(4) 4 scalar 557,935,1093 NBADL Local 558 I(4) 4 scalar 558,823,1087 NBADR Local 560 I(4) 4 scalar 560,880,1091 NBADTB Local 559 I(4) 4 scalar 559,924,1097 Page 26 Source Listing HIRS 2012-11-20 14:03 Symbol Table tranhirs3.f Name Object Declared Type Bytes Dimen Elements Attributes References NBYTE1 Param 294 I(4) 4 scalar 294,308,424,427,582 NBYTE4 Param 294 I(4) 4 scalar 309,432,584 NDT Local 316 I(4) 4 1 5 627,630,631 NEWPOS Local 316 I(4) 4 1 20 359,692,739,769,863,901,1117 NINT Func 1118 scalar 1118 NLANDB Local 567 I(4) 4 scalar 567,1013,1101 NLO Local 569 I(4) 4 scalar 569,588,589,604,662,716,750,1032,1 034,1062 NOPOS Local 552 I(4) 4 scalar 552,828,1089 NPERCHAN Param 303 I(4) 4 scalar 303 NPRINT Local 396 I(4) 4 scalar 396,1032 NQCBAD Local 553 I(4) 4 scalar 553,656,1068 NQCCAL Local 555 I(4) 4 scalar 555,658,1077,1080 NQCLOC Local 556 I(4) 4 scalar 556,659,1072 NQCTIM Local 554 I(4) 4 scalar 554,657,1070 NREAL Param 303 I(4) 4 scalar 303,403,1019,1024 NRECB Local 561 I(4) 4 scalar 561,1017,1034,1099,1141 NRECS Local 510 I(4) 4 scalar 510,512,1064 NREPB Local 562 I(4) 4 scalar 562,1019,1024,1105 NRI Local 426 I(4) 4 scalar 426,427,577,582 NSCAN Local 511 I(4) 4 scalar 511,512,1066 NSEAB Local 568 I(4) 4 scalar 568,1012,1103 NSET Param 295 I(4) 4 scalar 310,318 NSKIPC Local 563 I(4) 4 scalar 563,725,757,1085 NSKIPM Local 565 I(4) 4 scalar 565,602,1074 NSKIPQ Local 564 I(4) 4 scalar 564,603,604,661,663,1083 NSKIPTB Local 566 I(4) 4 scalar 566,953,1095 NTOT Param 303 I(4) 4 scalar 328,404,1035 OPENBF Subr 418 418 P1 Local 320 R(8) 8 scalar 354,906 P2 Local 320 R(8) 8 scalar 354,903 RAD Local 326 R(8) 8 2 1120 884,902 RAD0 Local 322 R(8) 8 scalar 878 RADS Local 322 R(8) 8 scalar 877,878,879,882,884,902,905,906 RAWHIRS Dummy 202 CHAR 500 scalar ARG,INOUT 424,1179 REAL_32 Param 291 I(4) 4 scalar 328 REAL_64 Param 292 I(4) 4 scalar 293,320,321,322,323,324,325,326,32 7,329 RFAC Param 15 I(4) 4 scalar 424 RINC Local 328 R(4) 4 1 5 628,970,972 RLOCAZ Local 323 R(8) 8 1 56 801,985 RMISS Local 364 R(4) 4 scalar 364,815,816,851,852,882,904,915,92 6,937 SATAZIMUTH Subr 984 984 SATHGT Local 789 R(4) 4 scalar 789,1008 SAZA Local 323 R(8) 8 1 56 800,1005 SAZIMUTH Local 323 R(8) 8 1 56 985,1009 SCALE Local 321 R(8) 8 scalar 520,521,527,788,789,794,799,800,80 1,809,812,814 SCALE12 Local 321 R(8) 8 scalar 765,771 SCALE5 Local 321 R(8) 8 scalar 517,521 SCALE6 Local 321 R(8) 8 scalar 518,520,528,529,538,539,767,775 SCALE9 Local 321 R(8) 8 scalar 766,773 SCTIME Local 322 R(8) 8 scalar 619,627,978,979,984 SCTIME1 Local 328 R(4) 4 scalar 979 Page 27 Source Listing HIRS 2012-11-20 14:03 Symbol Table tranhirs3.f Name Object Declared Type Bytes Dimen Elements Attributes References SELECTED_REAL_KIND Func 291 scalar 291,292 SFCHGT Local 326 R(8) 8 1 56 816,846,849,852,1007 SLAT Local 324 R(8) 8 1 56 812,820,824,825,843,984,1002 SLON Local 324 R(8) 8 1 56 814,821,824,826,843,984,1003 SOZA Local 323 R(8) 8 1 56 799,1006 STDOUT Local 314 I(4) 4 scalar 375,383,385,387,401,402,403,404,40 5,406,407,455,460,465,470,475,480, 485,488,499,504,512,545,547,604,66 2,716,750,824,1033,1034,1035,1036, 1053,1054,1055,1057,1059,1061,1063 ,1065,1067,1069,1071,1073,1076,107 9,1082,1084,1086,1088,1090,1092,10 94,1096,1098,1100,1102,1104,1107,1 108,1110,1118,1124,1126,1128,1130, 1132,1142,1179 SUMC Local 1115 R(4) 4 scalar 1115,1122,1124 SUMR Local 1113 R(4) 4 scalar 1113,1120,1124 SUMTB Local 1114 R(4) 4 scalar 1114,1121,1124 SYSTEM Subr 1140 1140,1145 TA0 Local 320 R(8) 8 scalar 909,912,914 TANKFILE Local 311 CHAR 80 scalar 381,384,1018,1056,1127 TB Local 326 R(8) 8 2 1120 904,912,915,921,922,926,937,943,10 15 TERM1 Local 320 R(8) 8 scalar 903,909 TERM2 Local 320 R(8) 8 scalar 906,907,908 TERM3 Local 320 R(8) 8 scalar 908,909 THI Local 349 R(4) 4 scalar 349,922 TLO Local 349 R(4) 4 scalar 349,921 W3DOXDAT Subr 977 977 W3MOVDAT Subr 972 972 W3TAGE Subr 489 489,501,1182 XFLOAT Func 527 R(4) 4 scalar 527,528,529,538,539,771,773,775,81 2,814 XSEC Local 322 R(8) 8 scalar 627,632,633 Page 28 Source Listing HIRS 2012-11-20 14:03 tranhirs3.f 1202 1203 SUBROUTINE CHARS(IWORD,LEN,CWORD) 1204 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1205 C 1206 C SUBPROGRAM: CHARS 1207 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-06 1208 C 1209 C ABSTRACT: Turns integer into character string of specified length, 1210 C starting at low-order byte of integer. 1211 C 1212 C PROGRAM HISTORY LOG: 1213 C 1997-11-06 Katz -- Original author 1214 C 1215 C USAGE: CALL CHARS(IWORD,LEN,CWORD) 1216 C INPUT ARGUMENT LIST: 1217 C IWORD - INTEGER argument 1218 C LEN - INTEGER argument holding number of low-order bytes 1219 C of first argument to convert into character 1220 C 1221 C OUTPUT ARGUMENT LIST: 1222 C CWORD - CHARACTER argument 1223 C 1224 C REMARKS: 1225 C 1226 C ATTRIBUTES: 1227 C LANGUAGE: FORTRAN 90 1228 C MACHINE: NCEP WCOSS 1229 C 1230 C$$$ 1231 character*1 cword(len) 1232 integer iword 1233 do ic = len , 1 , -1 1234 ibeg = (len - ic) * 8 1235 ichr = ibits(iword,ibeg,8) 1236 cword(ic) = char(ichr) 1237 enddo 1238 return 1239 end Page 29 Source Listing CHARS 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name chars_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References CHAR Func 1220 scalar 1220 CHARS Subr 1187 CWORD Dummy 1187 CHAR 1 1 0 ARG,INOUT 1220 IBEG Local 1218 I(4) 4 scalar 1218,1219 IBITS Func 1219 scalar 1219 IC Local 1217 I(4) 4 scalar 1217,1218,1220 ICHR Local 1219 I(4) 4 scalar 1219,1220 IWORD Dummy 1187 I(4) 4 scalar ARG,INOUT 1219 LEN Dummy 1187 I(4) 4 scalar ARG,INOUT 1215,1217,1218 Page 30 Source Listing CHARS 2012-11-20 14:03 tranhirs3.f 1240 1241 SUBROUTINE DATTIM(IDT,SCTIME,NDT,XSEC) 1242 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1243 C 1244 C SUBPROGRAM: DATTIM 1245 C PRGMMR: KEYSER ORG: NP22 DATE: 2006-07-20 1246 C 1247 C ABSTRACT: Converts year, day-of-year, and second-of-day into year, 1248 C month-of-year, day-of-month, hour-of-day, minute-of-hour, and 1249 C second-of-minute. 1250 C 1251 C PROGRAM HISTORY LOG: 1252 C 1997-11-06 Katz -- Original author 1253 C 2006-07-20 Keyser -- Modified to input real double precision 1254 C second-of-day and output real double precision second-of-minute 1255 C (both had been integer) 1256 C 1257 C USAGE: CALL DATTIM(IDT,SCTIME,NDT,XSEC) 1258 C INPUT ARGUMENT LIST: 1259 C IDT - INTEGER array argument containing two members: 1260 C day-of-year and year. 1261 C SCTIME - REAL*8 argument containing second-of-day. 1262 C 1263 C OUTPUT ARGUMENT LIST: 1264 C NDT - INTEGER array argument containing five members: 1265 C year, month-of-year, day-of-month, hour-of-day, 1266 C and minute-of-hour. 1267 C XSEC - REAL*8 argument containing second-of-minute. 1268 C 1269 C REMARKS: 1270 C NONE 1271 C 1272 C ATTRIBUTES: 1273 C LANGUAGE: FORTRAN 90 1274 C MACHINE: NCEP WCOSS 1275 C 1276 C$$$ 1277 1278 integer,parameter::real_64=selected_real_kind(15,307) 1279 1280 integer idt(2),ndt(5) 1281 integer iday,ihr,imin,imon,isec,iyr,jday,jsec 1282 real(real_64) sctime,xsec 1283 1284 external w3fs26 1285 1286 intrinsic mod 1287 1288 JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4 1289 & -3 * ((IYR + 4899) / 100) / 4 + IDYR 1290 1291 jday = idt(1) 1292 iyr = idt(2) 1293 1294 C If year is two digits, convert to 4 digits 1295 C ------------------------------------------ 1296 Page 31 Source Listing DATTIM 2012-11-20 14:03 tranhirs3.f 1297 if (iyr.ge.0.and.iyr.le.99) then 1298 if (iyr.lt.21) then 1299 kyr = iyr + 2000 1300 else 1301 kyr = iyr + 1900 1302 endif 1303 else 1304 kyr = iyr 1305 endif 1306 1307 C Compute julian day number as number days after 4713 bc 1308 C ------------------------------------------------------ 1309 1310 idy = jday 1311 jdn = julian(kyr,idy) 1312 1313 call w3fs26(jdn,iyear,jmo,jda,idaywk,idayyr) 1314 1315 imon = jmo 1316 iday = jda 1317 jsec = sctime 1318 ihr = sctime/3600 1319 imin = mod(sctime,3600._8)/60 1320 xsec = sctime - 3600*ihr - 60*imin 1321 ndt(1) = iyr 1322 ndt(2) = imon 1323 ndt(3) = iday 1324 ndt(4) = ihr 1325 ndt(5) = imin 1326 return 1327 end Page 32 Source Listing DATTIM 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name dattim_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DATTIM Subr 1225 IDAY Local 1265 I(4) 4 scalar 1300,1307 IDAYWK Local 1297 I(4) 4 scalar 1297 IDAYYR Local 1297 I(4) 4 scalar 1297 IDT Dummy 1225 I(4) 4 1 2 ARG,INOUT 1275,1276 IDY Local 1294 I(4) 4 scalar 1294,1295 IHR Local 1265 I(4) 4 scalar 1302,1304,1308 IMIN Local 1265 I(4) 4 scalar 1303,1304,1309 IMON Local 1265 I(4) 4 scalar 1299,1306 ISEC Local 1265 I(4) 4 scalar IYEAR Local 1297 I(4) 4 scalar 1297 IYR Local 1265 I(4) 4 scalar 1276,1281,1282,1283,1285,1288,1305 JDA Local 1297 I(4) 4 scalar 1297,1300 JDAY Local 1265 I(4) 4 scalar 1275,1294 JDN Local 1295 I(4) 4 scalar 1295,1297 JMO Local 1297 I(4) 4 scalar 1297,1299 JSEC Local 1265 I(4) 4 scalar 1301 JULIAN Local 1272 I(4) 4 scalar 1295 KYR Local 1283 I(4) 4 scalar 1283,1285,1288,1295 MOD Func 1270 scalar 1303 NDT Dummy 1225 I(4) 4 1 5 ARG,INOUT 1305,1306,1307,1308,1309 REAL_64 Param 1262 I(4) 4 scalar 1266 SCTIME Dummy 1225 R(8) 8 scalar ARG,INOUT 1301,1302,1303,1304 SELECTED_REAL_KIND Func 1262 scalar 1262 W3FS26 Subr 1268 1297 XSEC Dummy 1225 R(8) 8 scalar ARG,INOUT 1304 Page 33 Source Listing DATTIM 2012-11-20 14:03 tranhirs3.f 1328 1329 INTEGER FUNCTION ICHARS(CWORD,LEN) 1330 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1331 C 1332 C SUBPROGRAM: ICHARS 1333 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-05 1334 C 1335 C ABSTRACT: Turns character string of specified length into integer. 1336 C 1337 C PROGRAM HISTORY LOG: 1338 C 1997-11-05 Katz -- Original author 1339 C 1340 C USAGE: ICHARS(CWORD,LEN) 1341 C INPUT ARGUMENT LIST: 1342 C CWORD - CHARACTER*1 array argument 1343 C LEN - INTEGER argument holding length of cword 1344 C 1345 C REMARKS: 1346 C NONE 1347 C 1348 C ATTRIBUTES: 1349 C LANGUAGE: FORTRAN 90 1350 C MACHINE: NCEP WCOSS 1351 C 1352 C$$$ 1353 1354 character*1 cword(len) 1355 lchars = 0 1356 do ic = len , 1 , -1 1357 ibeg = (len - ic) * 8 1358 icmove = mova2i(cword(ic)) 1359 call mvbits(icmove,0,8,lchars,ibeg) 1360 enddo 1361 ichars = lchars 1362 return 1363 end Page 34 Source Listing ICHARS 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name ichars_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References CWORD Dummy 1313 CHAR 1 1 0 ARG,INOUT 1342 IBEG Local 1341 I(4) 4 scalar 1341,1343 IC Local 1340 I(4) 4 scalar 1340,1341,1342 ICHARS Func 1313 I(4) 4 scalar 1345 ICHARS@0 Local 1313 I(4) 4 scalar ICMOVE Local 1342 I(4) 4 scalar 1342,1343 LCHARS Local 1339 I(4) 4 scalar 1339,1343,1345 LEN Dummy 1313 I(4) 4 scalar ARG,INOUT 1338,1340,1341 MOVA2I Func 1342 I(4) 4 scalar 1342 MVBITS Intrin 1343 1343 Page 35 Source Listing ICHARS 2012-11-20 14:03 tranhirs3.f 1364 cfpp$ expand(ichars,lbit) 1365 1366 INTEGER FUNCTION LANSEA(RLAT,RLON,LEVEL) 1367 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1368 C 1369 C SUBPROGRAM: LANSEA 1370 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-05 1371 C 1372 C ABSTRACT: Calculates topography, land/sea status from latitude and 1373 C longitude. 1374 C 1375 C PROGRAM HISTORY LOG: 1376 C 1997-11-05 Katz -- Original author 1377 C 1378 C USAGE: LANSEA(RLAT,RLON,LEVEL) 1379 C INPUT ARGUMENT LIST: 1380 C RLAT - INTEGER argument containing scaled latitude 1381 C RLON - INTEGER argument containing scaled longitude 1382 C 1383 C OUTPUT ARGUMENT LIST: 1384 C LEVEL - INTEGER argument containing scaled topography 1385 C 1386 C INPUT FILES: 1387 C UNIT 41 - Binary low-resolution topography file 1388 C 1389 C REMARKS: 1390 C NONE 1391 C 1392 C ATTRIBUTES: 1393 C LANGUAGE: FORTRAN 90 1394 C MACHINE: NCEP WCOSS 1395 C 1396 C$$$ 1397 1398 include 'rfac.inc' 1399 1416 integer,parameter::real_64=selected_real_kind(15,307) 1417 integer ilat,ilon,level 1418 real(real_64) rlat,rlon 1419 real slat,slon,xlon 1420 integer iopn,iu,lan,last,lat,lenr,lon 1421 character*12 name 1422 character*4 iflag(12),kelev(192) 1423 character*2 ielev(360) 1424 1425 integer lbit,ichars 1426 1427 external lbit,ichars 1428 1429 intrinsic float,max0 1430 1431 equivalence (iflag(1),kelev(1)), (ielev(1),kelev(13)) 1432 1433 data name/'lowtopog.dat'/,iu/41/,lenr/768/,last/0/,iopn/0/ 1434 1435 save iopn,kelev,last 1436 Page 36 Source Listing LANSEA 2012-11-20 14:03 tranhirs3.f 1437 if (iopn.eq.0) then 1438 open (iu,recl=lenr/rfac, 1439 & file=name,access='direct',status='old') 1440 iopn = 1 1441 endif 1442 lan = 0 1443 level = 0 1444 slat = rlat 1445 slon = rlon 1446 lat = slat + 1. 1447 if (slat.lt.0.) lat = slat 1448 lat = max0(lat,-87) 1449 lat = 91 - lat 1450 if (lat.eq.last) go to 100 1451 read (iu,rec=lat) kelev 1452 last = lat 1453 100 xlon = slon 1454 if (xlon.lt.0.) xlon = xlon + 360. 1455 lon = xlon 1456 if (lon.eq.360) lon = 0 1457 lon = lon + 1 1458 lan = lbit(lon,iflag) 1459 if (lan.ne.0) then 1460 ltemp = ichars(ielev(lon),2) 1461 if (btest(ltemp,15)) then 1462 ltemp = ior(ltemp,-65536) 1463 endif 1464 level = ltemp 1465 endif 1466 lansea = 2 - lan 1467 return 1468 end Page 37 Source Listing LANSEA 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name lansea_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 1421 1418 BTEST Func 1429 scalar 1429 FLOAT Func 1397 scalar ICHARS Func 1393 I(4) 4 scalar 1428 IELEV Local 1391 CHAR 2 1 360 1428 IFLAG Local 1390 CHAR 4 1 12 1426 ILAT Local 1385 I(4) 4 scalar ILON Local 1385 I(4) 4 scalar IOPN Local 1388 I(4) 4 scalar 1401,1405,1408 IOR Func 1430 scalar 1430 IU Local 1388 I(4) 4 scalar 1401,1406,1419 KELEV Local 1390 CHAR 4 1 192 1419 LAN Local 1388 I(4) 4 scalar 1410,1426,1427,1434 LANSEA Func 1350 I(4) 4 scalar 1434 LANSEA@0 Local 1350 I(4) 4 scalar LAST Local 1388 I(4) 4 scalar 1401,1418,1420 LAT Local 1388 I(4) 4 scalar 1414,1415,1416,1417,1418,1419,1420 LBIT Func 1393 I(4) 4 scalar 1426 LENR Local 1388 I(4) 4 scalar 1401,1406 LEVEL Dummy 1350 I(4) 4 scalar ARG,INOUT 1411,1432 LON Local 1388 I(4) 4 scalar 1423,1424,1425,1426,1428 LTEMP Local 1428 I(4) 4 scalar 1428,1429,1430,1432 MAX0 Func 1397 scalar 1416 NAME Local 1389 CHAR 12 scalar 1401,1407 REAL_64 Param 1384 I(4) 4 scalar 1386 RFAC Param 15 I(4) 4 scalar 1406 RLAT Dummy 1350 R(8) 8 scalar ARG,INOUT 1412 RLON Dummy 1350 R(8) 8 scalar ARG,INOUT 1413 SELECTED_REAL_KIND Func 1384 scalar 1384 SLAT Local 1387 R(4) 4 scalar 1412,1414,1415 SLON Local 1387 R(4) 4 scalar 1413,1421 XLON Local 1387 R(4) 4 scalar 1421,1422,1423 Page 38 Source Listing LANSEA 2012-11-20 14:03 tranhirs3.f 1469 cfpp$ expand(ichars) 1470 1471 INTEGER FUNCTION LBIT(J,ARRAY) 1472 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1473 C 1474 C SUBPROGRAM: LBIT 1475 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-05 1476 C 1477 C ABSTRACT: Extracts j'th bit from array of CHARACTER*4. 1478 C 1479 C PROGRAM HISTORY LOG: 1480 C 1997-11-05 Katz -- Original author 1481 C 1482 C USAGE: LBIT(J,ARRAY) 1483 C INPUT ARGUMENT LIST: 1484 C J - INTEGER argument 1485 C ARRAY - CHARACTER*4 array argument 1486 C 1487 C REMARKS: 1488 C NONE 1489 C 1490 C ATTRIBUTES: 1491 C LANGUAGE: FORTRAN 90 1492 C MACHINE: NCEP WCOSS 1493 C 1494 C$$$ 1495 1496 integer j 1497 character*4 array(*) 1498 integer ibit,jout,jw,jword,nbit 1499 1500 integer ichars 1501 external ichars 1502 1503 intrinsic btest 1504 1505 jw = (j-1)/32 1506 nbit = j - jw*32 1507 jword = ichars(array(jw+1),4) 1508 ibit = 32 - nbit 1509 jout = 0 1510 if (btest(jword,ibit)) jout = 1 1511 lbit = jout 1512 return 1513 end Page 39 Source Listing LBIT 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name lbit_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ARRAY Dummy 1439 CHAR 4 1 0 ARG,INOUT 1475 BTEST Func 1471 scalar 1478 IBIT Local 1466 I(4) 4 scalar 1476,1478 ICHARS Func 1468 I(4) 4 scalar 1475 J Dummy 1439 I(4) 4 scalar ARG,INOUT 1473,1474 JOUT Local 1466 I(4) 4 scalar 1477,1478,1479 JW Local 1466 I(4) 4 scalar 1473,1474,1475 JWORD Local 1466 I(4) 4 scalar 1475,1478 LBIT Func 1439 I(4) 4 scalar 1479 LBIT@0 Local 1439 I(4) 4 scalar NBIT Local 1466 I(4) 4 scalar 1474,1476 Page 40 Source Listing LBIT 2012-11-20 14:03 tranhirs3.f 1514 cfpp$ expand(ichars) 1515 1516 INTEGER FUNCTION MBYTE(J,LENGTH,JARRAY) 1517 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1518 C 1519 C SUBPROGRAM: MBYTE 1520 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-05 1521 C 1522 C ABSTRACT: Extracts bit string from array of CHARACTER*4 and 1523 C converts it to INTEGER. Entry point MBYTE propagates sign bit 1524 C in result; entry point LBYTE does not. 1525 C 1526 C PROGRAM HISTORY LOG: 1527 C 1997-11-05 Katz -- Original author 1528 C 1529 C USAGE: MBYTE(J,LENGTH,JARRAY) 1530 C INPUT ARGUMENT LIST: 1531 C J - INTEGER argument containing starting bit 1532 C LENGTH - integer argument containing number of bits 1533 C (maximum value 32) 1534 C JARRAY - CHARACTER*4 array argument 1535 C 1536 C OUTPUT FILES: 1537 C UNIT 06 - printout 1538 C 1539 C REMARKS: 1540 C NONE 1541 C 1542 C ATTRIBUTES: 1543 C LANGUAGE: FORTRAN 90 1544 C MACHINE: NCEP WCOSS 1545 C 1546 C$$$ 1547 1548 integer j,length 1549 character*4 jarray(*) 1550 integer inleft,jbit,kompl,mflag,n,nlj,nrj, 1551 + nsh,nword 1552 integer(8) item,jleft,jrite,mask 1553 integer(8) kounts(33) 1554 1555 integer ichars 1556 external ichars 1557 1558 intrinsic iand,ior,mod 1559 1560 integer lbyte 1561 1562 data kounts/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192, 1563 + 16384,32768,65536,131072,262144,524288,1048576,2097152, 1564 + 4194304,8388608,16777216,33554432,67108864,134217728, 1565 + 268435456,536870912,1073741824,2147483648_8,0/ 1566 1567 C ENTRY MBYTE 1568 C ----------- 1569 1570 mflag = 1 Page 41 Source Listing MBYTE 2012-11-20 14:03 tranhirs3.f 1571 110 nword = (j-1)/32 + 1 1572 if (length.lt.1 .or. length.gt.32) write (*,fmt=120) length 1573 120 format (' improper byte length in mbyte or lbyte',i10) 1574 nlj = mod(j-1,32) 1575 nrj = 32 - length - nlj 1576 if (nrj.lt.0) go to 150 1577 item = ichars(jarray(nword),4) 1578 kompl = 33 - length - nlj 1579 mask = -kounts(kompl) 1580 item = iand(item,mask) 1581 item = item/kounts(nrj+1) 1582 mask = kounts(length+1) - 1 1583 item = iand(item,mask) 1584 130 if (mflag.eq.0) go to 140 1585 1586 c ... means logical byte 1587 1588 mbyte = item 1589 jbit = iand(kounts(length),item) 1590 if (jbit.eq.0) return 1591 1592 c ... need sign extension 1593 1594 mask = -mask - 1 1595 item = ior(item,mask) 1596 mbyte = item 1597 return 1598 1599 C ENTRY LBYTE 1600 C ----------- 1601 1602 entry lbyte(j,length,jarray) 1603 1604 mflag = 0 1605 go to 110 1606 1607 140 lbyte = item 1608 return 1609 1610 c ... byte spans two words 1611 1612 150 inleft = length + nrj 1613 mask = kounts(inleft+1) - 1 1614 jleft = ichars(jarray(nword),4) 1615 jleft = iand(jleft,mask) 1616 nsh = 1 - nrj 1617 jleft = jleft*kounts(nsh) 1618 n = 1 - nrj 1619 jrite = ichars(jarray(nword+1),4) 1620 kompl = 33 + nrj 1621 mask = -kounts(kompl) 1622 jrite = iand(jrite,mask) 1623 jrite = jrite/kounts(nrj+33) 1624 mask = kounts(n) - 1 1625 jrite = iand(jrite,mask) 1626 item = ior(jrite,jleft) 1627 mask = kounts(length+1) - 1 Page 42 Source Listing MBYTE 2012-11-20 14:03 tranhirs3.f 1628 go to 130 1629 end ENTRY POINTS Name Name lbyte_ mbyte_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 110 Label 1539 1573 120 Label 1541 1540 130 Label 1552 1596 140 Label 1575 1552 150 Label 1580 1544 IAND Func 1526 scalar 1548,1551,1557,1583,1590,1593 ICHARS Func 1523 I(4) 4 scalar 1545,1582,1587 INLEFT Local 1518 I(4) 4 scalar 1580,1581 IOR Func 1526 scalar 1563,1594 ITEM Local 1520 I(8) 8 scalar 1545,1548,1549,1551,1556,1557,1563 ,1564,1575,1594 J Dummy 1484 I(4) 4 scalar ARG,INOUT 1539,1542 JARRAY Dummy 1484 CHAR 4 1 0 ARG,INOUT 1545,1582,1587 JBIT Local 1518 I(4) 4 scalar 1557,1558 JLEFT Local 1520 I(8) 8 scalar 1582,1583,1585,1594 JRITE Local 1520 I(8) 8 scalar 1587,1590,1591,1593,1594 KOMPL Local 1518 I(4) 4 scalar 1546,1547,1588,1589 KOUNTS Local 1521 I(8) 8 1 33 1530,1547,1549,1550,1557,1581,1585 ,1589,1591,1592,1595 LBYTE Func 1528 I(4) 4 scalar 1575 LENGTH Dummy 1484 I(4) 4 scalar ARG,INOUT 1540,1543,1546,1550,1557,1580,1595 MASK Local 1520 I(8) 8 scalar 1547,1548,1550,1551,1562,1563,1581 ,1583,1589,1590,1592,1593,1595 MBYTE Func 1484 I(4) 4 scalar 1556,1564 MBYTE@0 Local 1484 I(4) 4 scalar MFLAG Local 1518 I(4) 4 scalar 1538,1552,1572 MOD Func 1526 scalar 1542 N Local 1518 I(4) 4 scalar 1586,1592 NLJ Local 1518 I(4) 4 scalar 1542,1543,1546 NRJ Local 1518 I(4) 4 scalar 1543,1544,1549,1580,1584,1586,1588 ,1591 NSH Local 1519 I(4) 4 scalar 1584,1585 NWORD Local 1519 I(4) 4 scalar 1539,1545,1582,1587 Page 43 Source Listing MBYTE 2012-11-20 14:03 tranhirs3.f 1630 cfpp$ expand(ichars) 1631 1632 REAL FUNCTION XFLOAT(JB,IARRAY) 1633 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1634 C 1635 C SUBPROGRAM: XFLOAT 1636 C PRGMMR: BERT KATZ ORG: NP20 DATE: 1997-11-05 1637 C 1638 C ABSTRACT: Takes two consecutive elements of CHARACTER*2 array and 1639 C forms a floating point number from them. 1640 C 1641 C PROGRAM HISTORY LOG: 1642 C 1997-11-05 Katz -- Original author 1643 C 1644 C USAGE: XFLOAT(JB,IARRAY) 1645 C INPUT ARGUMENT LIST: 1646 C JB - INTEGER argument containing array location 1647 C IARRAY - CHARACTER*2 array argument 1648 C 1649 C REMARKS: 1650 C NONE 1651 C 1652 C ATTRIBUTES: 1653 C LANGUAGE: FORTRAN 90 1654 C MACHINE: NCEP WCOSS 1655 C 1656 C$$$ 1657 1658 integer jb 1659 integer*8 mask 1660 data mask/x'ffffffff00000000'/ 1661 ccccc character*2 iarray(2) 1662 character*2 iarray(2000) 1663 character*4 conv 1664 real xf 1665 integer j 1666 integer*8 jj 1667 integer in(2) 1668 1669 integer ichars 1670 external ichars 1671 1672 intrinsic btest,ior 1673 1674 j = jb 1675 conv(1:2) = iarray(j) 1676 conv(3:4) = iarray(j+1) 1677 jj = ichars(conv,4) 1678 if (btest(jj,31_8)) then 1679 jj = ior(jj,mask) 1680 endif 1681 xf = jj 1682 xfloat = xf 1683 return 1684 end Page 44 Source Listing XFLOAT 2012-11-20 14:03 Entry Points tranhirs3.f ENTRY POINTS Name xfloat_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References BTEST Func 1640 scalar 1646 CONV Local 1631 CHAR 4 scalar 1643,1644,1645 IARRAY Dummy 1600 CHAR 2 1 2000 ARG,INOUT 1643,1644 ICHARS Func 1637 I(4) 4 scalar 1645 IN Local 1635 I(4) 4 1 2 IOR Func 1640 scalar 1647 J Local 1633 I(4) 4 scalar 1642,1643,1644 JB Dummy 1600 I(4) 4 scalar ARG,INOUT 1642 JJ Local 1634 I(8) 8 scalar 1645,1646,1647,1649 MASK Local 1627 I(8) 8 scalar 1628,1647 XF Local 1632 R(4) 4 scalar 1649,1650 XFLOAT Func 1600 R(4) 4 scalar 1650 XFLOAT@0 Local 1600 R(4) 4 scalar Page 45 Source Listing XFLOAT 2012-11-20 14:03 tranhirs3.f 1685 1686 SUBROUTINE SATAZIMUTH(IYEAR,IDAY,STIME,SLAT,SLON,RAZIMUTH, 1687 + AAZIMUTH,SAZIMUTH) 1688 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 1689 C 1690 C SUBPROGRAM: SATAZIMUTH 1691 C PRGMMR: DERBER ORG: NP2 DATE: 2006-04-06 1692 C 1693 C ABSTRACT: Calculates satellite azimuth angle and solar azimuth angle 1694 C given the relative azimuth angle and the date/time. 1695 C 1696 C PROGRAM HISTORY LOG: 1697 C 2006-04-06 Derber - Original author 1698 C 1699 C USAGE: CALL SATAZIMUTH(IYEAR,IDAY,STIME,RAZIMUTH,SLAT,SLON, 1700 C AAZIMUTH,SAZIMUTH) 1701 C INPUT ARGUMENT LIST: 1702 C IYEAR - Year 1703 C IDAY - Day of year 1704 C STIME - Time of day (seconds) 1705 C SLAT - Latitude (degrees N) 1706 C SLON - Longitude (degrees, + E, - W) 1707 C RAZIMUTH - Relative azimuth angle (degrees true) 1708 C 1709 C OUTPUT ARGUMENT LIST: 1710 C AAZIMUTH - Satellite azimuth angle (degrees true, 0-360) 1711 C SAZIMUTH - Solar azimuth angle (degrees true, 0-360) 1712 C 1713 C REMARKS: 1714 C NONE 1715 C 1716 C ATTRIBUTES: 1717 C LANGUAGE: FORTRAN 90 1718 C MACHINE: NCEP WCOSS 1719 C 1720 C$$$ 1721 1722 integer,parameter::real_64=selected_real_kind(15,307) 1723 real(real_64) slon,slat,tcen,omega,gmeananomsun,sec,y 1724 real(real_64) razimuth,aazimuth,deg2rad,rad2deg 1725 real(real_64) sinm,sin2m,sin3m,suneqofcenter,geommeanlongsun 1726 real(real_64) suntruelon,sunapparentlong,meanobliquity 1727 real(real_64) obliquitycorrection,decl,ayr 1728 real(real_64) byr,sin210,sin410,cos210,eccearthorbit 1729 real(real_64) eqtime,tst,sazimuth,sozanew,stime 1730 integer iday 1731 1732 external w3fs26 1733 1734 ajday(byr,jday) = floor(365.25*(byr+4716.)) - 1735 + floor(byr/100.)+ 1736 + floor(float(floor(byr/100.))/4.)-2452639.5+float(jday) 1737 deg2rad = acos(-1.)/180. 1738 rad2deg = 1./deg2rad 1739 1740 ayr = float(iyear-1) 1741 Page 46 Source Listing SATAZIMUTH 2012-11-20 14:03 tranhirs3.f 1742 C Calculate relative time to 2000.0 (in centuries) 1743 C ------------------------------------------------ 1744 1745 tcen = (ajday(ayr,iday)+stime/86400.)/36525.0 1746 omega=(125.04-1934.136*tcen)*deg2rad 1747 gmeananomsun=(357.52911+tcen*(35999.05029- 1748 + 0.0001537*tcen))*deg2rad 1749 sinm=sin(gmeananomsun) 1750 sin2m=sin(2.0*gmeananomsun) 1751 sin3m=sin(3.0*gmeananomsun) 1752 suneqofcenter=(sinm*(1.914602- 1753 + tcen*(0.004817+0.000014*tcen))+sin2m*(0.019993- 1754 + 0.000101*tcen)+sin3m*0.000289)*deg2rad 1755 geommeanlongsun=280.46646+tcen*(36000.76983+0.0003032*tcen) 1756 if(geommeanlongsun > 360.0) geommeanlongsun=geommeanlongsun-360. 1757 if(geommeanlongsun < 0.0) geommeanlongsun=geommeanlongsun+360. 1758 geommeanlongsun=deg2rad*geommeanlongsun 1759 suntruelon=geommeanlongsun+suneqofcenter 1760 sunapparentlong=suntruelon-(0.00569-0.00478*sin(omega))*deg2rad 1761 sec=21.448-tcen*(46.8150+tcen*(0.00059-tcen*0.001813)) 1762 meanobliquity=23.0+(26.0+(sec/60.))/60. 1763 obliquitycorrection= (meanobliquity + 0.00256*cos(omega))*deg2rad 1764 decl = asin(sin(obliquitycorrection)*sin(sunapparentlong)) 1765 ccccc solarrightascension = atan2(cos(obliquitycorrection)* 1766 ccccc+ sin(sunapparentlong),cos(sunapparentlong)) 1767 y = tan(obliquitycorrection/2.0) 1768 y = y*y 1769 sin210=sin(2.0*geommeanlongsun) 1770 sin410=sin(4.0*geommeanlongsun) 1771 cos210=cos(2.0*geommeanlongsun) 1772 eccearthorbit=0.016708634-tcen*(0.000042037+ 1773 + 0.0000001287*tcen) 1774 eqtime=(y*sin210 1775 + -2.0*eccearthorbit*sinm 1776 + +4.0*eccearthorbit*y*sinm*cos210 1777 + -0.5*y*y*sin410 1778 + -1.25*eccearthorbit*eccearthorbit*sin2m)*4.0*rad2deg 1779 1780 tst=eqtime+4.*slon+stime/60. 1781 ha=(tst/4.0)-180. 1782 if(ha > 180.)ha=ha-360. 1783 if(ha < -180.)ha=360.+ha 1784 sozanew=acos(sin(deg2rad*slat)*sin(decl)+cos(deg2rad*slat)* 1785 + cos(decl)*cos(deg2rad*ha)) 1786 sazimuth = acos((sin(decl)-sin(deg2rad*slat)*cos(sozanew))/ 1787 + (cos(deg2rad*slat)*sin(sozanew)))*rad2deg 1788 if(ha > 0.)sazimuth=-sazimuth 1789 ccccc if(sazimuth > 180.)sazimuth=sazimuth-360. 1790 ccccc if(sazimuth < -180.)sazimuth=360.+sazimuth 1791 1792 aazimuth= razimuth+sazimuth 1793 if(aazimuth > 180.)aazimuth=aazimuth-360. 1794 if(aazimuth < -180.)aazimuth=360.+aazimuth 1795 1796 C Correct aziumuth angles to be 0-360 degrees true (for BUFR) 1797 C ----------------------------------------------------------- 1798 Page 47 Source Listing SATAZIMUTH 2012-11-20 14:03 tranhirs3.f 1799 if(aazimuth < 0.)aazimuth=360.+aazimuth 1800 if(sazimuth < 0.)sazimuth=360.+sazimuth 1801 1802 return 1803 end ENTRY POINTS Name satazimuth_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References AAZIMUTH Dummy 1655 R(8) 8 scalar ARG,INOUT 1760,1761,1762,1767 ACOS Func 1705 scalar 1705,1752,1754 AJDAY Local 1702 R(4) 4 scalar 1713 ASIN Func 1732 scalar 1732 AYR Local 1695 R(8) 8 scalar 1708,1713 BYR Local 1696 R(8) 8 scalar COS Func 1731 scalar 1731,1739,1752,1753,1754,1755 COS210 Local 1696 R(8) 8 scalar 1739,1744 DECL Local 1695 R(8) 8 scalar 1732,1752,1753,1754 DEG2RAD Local 1692 R(8) 8 scalar 1705,1706,1714,1716,1722,1726,1728 ,1731,1752,1753,1754,1755 ECCEARTHORBIT Local 1696 R(8) 8 scalar 1740,1743,1744,1746 EQTIME Local 1697 R(8) 8 scalar 1742,1748 FLOAT Func 1704 scalar 1704,1708 FLOOR Func 1702 scalar 1702,1703,1704 GEOMMEANLONGSUN Local 1693 R(8) 8 scalar 1723,1724,1725,1726,1727,1737,1738 ,1739 GMEANANOMSUN Local 1691 R(8) 8 scalar 1715,1717,1718,1719 HA Local 1749 R(4) 4 scalar 1749,1750,1751,1753,1756 IDAY Dummy 1654 I(4) 4 scalar ARG,INOUT 1713 IYEAR Dummy 1654 I(4) 4 scalar ARG,INOUT 1708 MEANOBLIQUITY Local 1694 R(8) 8 scalar 1730,1731 OBLIQUITYCORRECTION Local 1695 R(8) 8 scalar 1731,1732,1735 OMEGA Local 1691 R(8) 8 scalar 1714,1728,1731 RAD2DEG Local 1692 R(8) 8 scalar 1706,1746,1755 RAZIMUTH Dummy 1654 R(8) 8 scalar ARG,INOUT 1760 REAL_64 Param 1690 I(4) 4 scalar 1691,1692,1693,1694,1695,1696,1697 SATAZIMUTH Subr 1654 SAZIMUTH Dummy 1655 R(8) 8 scalar ARG,INOUT 1754,1756,1760,1768 SEC Local 1691 R(8) 8 scalar 1729,1730 SELECTED_REAL_KIND Func 1690 scalar 1690 SIN Func 1717 scalar 1717,1718,1719,1728,1732,1737,1738 ,1752,1754,1755 SIN210 Local 1696 R(8) 8 scalar 1737,1742 SIN2M Local 1693 R(8) 8 scalar 1718,1721,1746 SIN3M Local 1693 R(8) 8 scalar 1719,1722 SIN410 Local 1696 R(8) 8 scalar 1738,1745 SINM Local 1693 R(8) 8 scalar 1717,1720,1743,1744 SLAT Dummy 1654 R(8) 8 scalar ARG,INOUT 1752,1754,1755 Page 48 Source Listing SATAZIMUTH 2012-11-20 14:03 Symbol Table tranhirs3.f Name Object Declared Type Bytes Dimen Elements Attributes References SLON Dummy 1654 R(8) 8 scalar ARG,INOUT 1748 SOZANEW Local 1697 R(8) 8 scalar 1752,1754,1755 STIME Dummy 1654 R(8) 8 scalar ARG,INOUT 1713,1748 SUNAPPARENTLONG Local 1694 R(8) 8 scalar 1728,1732 SUNEQOFCENTER Local 1693 R(8) 8 scalar 1720,1727 SUNTRUELON Local 1694 R(8) 8 scalar 1727,1728 TAN Func 1735 scalar 1735 TCEN Local 1691 R(8) 8 scalar 1713,1714,1715,1716,1721,1722,1723 ,1729,1740,1741 TST Local 1697 R(8) 8 scalar 1748,1749 W3FS26 Subr 1700 scalar Y Local 1691 R(8) 8 scalar 1735,1736,1742,1744,1745 Page 49 Source Listing SATAZIMUTH 2012-11-20 14:03 Subprograms/Common Blocks tranhirs3.f SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References BUFR_TRANHIRS3 Prog 1 CHARS Subr 1187 DATTIM Subr 1225 HIRS Subr 202 ICHARS Func 1313 I(4) 4 scalar 1345 LANSEA Func 1350 I(4) 4 scalar 1434 LBIT Func 1439 I(4) 4 scalar 1479 MBYTE Func 1484 I(4) 4 scalar 1556,1564 SATAZIMUTH Subr 1654 SWITCHES Common 167 24 XFLOAT Func 1600 R(4) 4 scalar 1650 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 byterecl -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__ Page 50 Source Listing SATAZIMUTH 2012-11-20 14:03 tranhirs3.f -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 -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model nofast -fp_model strict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -fp_modbits nofp_contract -fp_modbits nono_fp_contract -fp_modbits nofenv_access -fp_modbits nono_fenv_access -fp_modbits nocx_limited_range -fp_modbits nono_cx_limited_range -fp_modbits noprec_div -fp_modbits nono_prec_div -fp_modbits noprec_sqrt -fp_modbits nono_prec_sqrt -fp_modbits noftz -fp_modbits no_ftz -fp_modbits nointrin_limited_range -fp_modbits nono_intrin_limited_range -fp_modbits notrunc_compares -fp_modbits nono_trunc_compares -fp_modbits noieee_nan_compares -fp_modbits nono_ieee_nan_compares -fp_modbits nohonor_f32_conversion -fp_modbits nono_honor_f32_conversion -fp_modbits nohonor_f64_conversion -fp_modbits nono_honor_f64_conversion -fp_modbits nono_x87_copy -fp_modbits nono_no_x87_copy -fp_modbits noexception_semantics -fp_modbits nono_exception_semantics -fp_modbits noprecise_libm_functions -fp_modbits nono_precise_libm_functions -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 32 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 : tranhirs3.lst -o filename : none Page 51 Source Listing SATAZIMUTH 2012-11-20 14:03 tranhirs3.f COMPILER: Intel(R) Fortran 12.1-2100