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