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