#batch. read compressed td14 format xxxxxx # # QSUB -lT 55 -q ded_1 -l mpp_p=5 -eo -J m cd $TMPDIR cat << "ENDCAT" >! tsrc.f program td14rd c c*********************************************************************** c this code dumps a condensed td14 data file - for data through 1983 c*********************************************************************** c C common jeof,nbuf(1006),iced(200),idle(24,44) common ideck(1),ista,iyear,imonth,iday,lat,lon,ielev,itmzn,nobs c nbuf(1)=0 c c to skip file(s) if desired c call skipfile(1,1,lst) c 2 continue c*** read record (one day) and unpack ID information call rsfca if (jeof .ne. 0) go to 200 numeof=0 nrec=nrec+1 c*** c*** select records here according to ID parameters returned, c*** i.e. ista,iyear,imonth,iday,lat,lon,ielev,itmzn,nobs c*** c 20 continue c*** print ID information write(*,10001) ideck,ista,iyear,imonth,iday,lat,lon,ielev,itmzn, *nobs 10001 format ('1deck ',i4,' station ',i5,' year ',i4, 1 ' month ',i2,' day ',i2,' lat. ',i5,' long. ',i5, 2 ' elev. ',i5,' time zonee ',i2,' nobs ',i2) 1111 continue c c*** unpack hourly parameters call usfca c c*** print first 22 hourly parameters c c 1 HOUR 12 RELATIVE HUMIDITY INDICATOR c 2 CEILING HEIGHT INDICATOR 13 RELATIVE HUMIDITY c 3 CEILING HEIGHT 14 SEA LEVEL PRESSURE c 4 HORIZ. VISIBILITY INDICATOR 15 STATION PRESSURE c 5 HORIZ. VISIBILITY 16 SKY CONDITION INDICATOR c 6 WIND DIRECTION FLAG 17 SKY CONDITION 1ST c 7 WIND DIRECTION 18 SKY CONDITION 2ND c 8 WIND SPEED 19 SKY CONDITION 3RD c 9 DRY BULB TEMPERATURE 20 SKY CONDITION 4TH c 10 WET BULB TEMPERATURE 21 TOTAL SKY COVER c 11 DEW POINT TEMPERATURE 22 TOTAL OPAQUE SKY COVER c write(*,20002) 20002 format('0numbered variables in data section of format document',/, *' 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 *18 19 20 21 22',/, *' -- -- ---- -- ---- - --- --- --- --- --- -- --- ----- ---- - -- *-- -- -- -- --') write(*,10002) ((idle(n,m),m=1,22),n=1,nobs) 10002 format(1x,i2,i3,i5,i3,i5,i2,5i4,i3,i4,i6,i5,i2,6i3) c c*** repeat print of hour , print parameters 23 to 44 c 23 LOWEST CLOUD AMOUNT 34 FOURTH CLOUD AMOUNT c 24 LOWEST CLOUD TYPE 35 FOURTH CLOUD TYPE c 25 LOWEST CLOUD BASE HGT. 36 FOURTH CLOUD BASE HGT. c 26 SECOND CLOUD AMOUNT 37 OCCURRENCE OF THUNDERSTORMS, ETC. c 27 SECOND CLOUD TYPE 38 OCCURRENCE OF RAIN, ETC. c 28 SECOND CLOUD BASE HGT. 39 OCCURRENCE OF RAIN SQUALLS, ETC. c 29 SUM 1ST TWO CLOUD LAYER AMOUNTS 40 OCCURRENCE OF SNOW PELLETS, ETC. c 30 THIRD CLOUD AMOUNT 41 OCCURRENCE OF SNOW SHOWERS, ETC. c 31 THIRD CLOUD TYPE 42 OCCURRENCE OF SLEET, ETC. c 32 THIRD CLOUD BASE HGT. 43 OCCURRENCE OF FOG, ETC. c 33 SUM 1ST THREE CLOUD LAYER AMOUNTS 44 OCCURRENCE OF SMOKE, ETC. c write(*,20003) 20003 format('0variable 1 (hour) repeats,numbered variables continue',/, *' 1 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 *40 41 42 43 44',/, *' -- ---- -- ---- -- -- ---- -- -- -- ---- -- -- -- ---- -- -- -- *-- -- -- -- --') write(*,10003) (idle(n,1),(idle(n,m),m=23,44),n=1,nobs) 10003 format(1x,i2,i5,i3,i5,2i3,i5,3i3,i5,3i3,i5,8i3) go to 2 200 continue write(*,201) (nbuf(i),i=2,4) 201 format('0lrecs/precs/wds',3i10) do 202 i=2,6 202 nbuf(i) = 0 nrec=0 numeof=numeof+1 if(numeof.lt.2) go to 2 end subroutine rsfca C common jeof,nbuf(1006),iced(200),idle(24,44) common ideck(1),ista,iyear,imonth,iday,lat,lon,ielev,itmzn,nobs dimension lcon(10) data lcon/7,17,8,4,6,15,16,14,5,5/ 2 call rptin(1, nbuf, iced, miced, 1, 200, jeof) if (jeof .ne. 0) return noff=19 do 1 i=1,10 call gbyte(iced,ideck(i),noff,lcon(i)) noff=noff+lcon(i) 1 continue c c yes, there are of few records with zero observations if(nobs.lt.1.or.nobs.gt.24) go to 2 c if(ideck(1).le.99) ideck(1) = ideck(1)+1400 if(iyear.le.253) iyear = iyear+1800 if(lat.le.18000) lat=lat-9000 if(ielev.le.10000) ielev=ielev-1000 nobs = min0(nobs,24) return end subroutine usfca C common jeof,nbuf(1006),iced(200),idle(24,44) common ideck(1),ista,iyear,imonth,iday,lat,lon,ielev,itmzn,nobs nskip = 128 c c*** unpack 44 parameters call gbytes(iced, idle( 1,1), nskip+ 0, 5,251,nobs) # 1 call gbytes(iced, idle( 1,2), nskip+ 5, 3,253,nobs) # 2 call gbytes(iced, idle( 1,3), nskip+ 8, 10,246,nobs) # 3 call gbytes(iced, idle( 1,4), nskip+ 18, 4,252,nobs) # 4 call gbytes(iced, idle( 1,5), nskip+ 22, 10,246,nobs) # 5 call gbytes(iced, idle( 1,6), nskip+ 32, 2,254,nobs) # 6 call gbytes(iced, idle( 1,7), nskip+ 34, 9,247,nobs) # 7 call gbytes(iced, idle( 1,8), nskip+ 43, 8,248,nobs) # 8 call gbytes(iced, idle( 1,9), nskip+ 51, 9,247,nobs) # 9 call gbytes(iced, idle(1,10), nskip+ 60, 9,247,nobs) # 10 call gbytes(iced, idle(1,11), nskip+ 69, 9,247,nobs) # 11 call gbytes(iced, idle(1,12), nskip+ 78, 2,254,nobs) # 12 call gbytes(iced, idle(1,13), nskip+ 80, 7,249,nobs) # 13 call gbytes(iced, idle(1,14), nskip+ 87, 11,245,nobs) # 14 do 1013 i=1,nobs if(idle(i,14).le.1999) idle(i,14)=idle(i,14)+9000 1013 continue call gbytes(iced, idle(1,15), nskip+ 98, 12,244,nobs) # 15 call gbytes(iced, idle(1,16), nskip+110, 2,254,nobs) # 16 call gbytes(iced, idle(1,17), nskip+112, 4,252,nobs) # 17 call gbytes(iced, idle(1,18), nskip+116, 4,252,nobs) # 18 call gbytes(iced, idle(1,19), nskip+120, 4,252,nobs) # 19 call gbytes(iced, idle(1,20), nskip+124, 4,252,nobs) # 20 call gbytes(iced, idle(1,21), nskip+128, 4,252,nobs) # 21 call gbytes(iced, idle(1,22), nskip+132, 4,252,nobs) # 22 call gbytes(iced, idle(1,23), nskip+136, 4,252,nobs) # 23 call gbytes(iced, idle(1,24), nskip+140, 5,251,nobs) # 24 call gbytes(iced, idle(1,25), nskip+145, 10,246,nobs) # 25 call gbytes(iced, idle(1,26), nskip+155, 4,252,nobs) # 26 call gbytes(iced, idle(1,27), nskip+159, 5,251,nobs) # 27 call gbytes(iced, idle(1,28), nskip+164, 10,246,nobs) # 28 call gbytes(iced, idle(1,29), nskip+174, 4,252,nobs) # 29 call gbytes(iced, idle(1,30), nskip+178, 4,252,nobs) # 30 call gbytes(iced, idle(1,31), nskip+182, 5,251,nobs) # 31 call gbytes(iced, idle(1,32), nskip+187, 10,246,nobs) # 32 call gbytes(iced, idle(1,33), nskip+197, 4,252,nobs) # 33 call gbytes(iced, idle(1,34), nskip+201, 4,252,nobs) # 34 call gbytes(iced, idle(1,35), nskip+205, 5,251,nobs) # 35 call gbytes(iced, idle(1,36), nskip+210, 10,246,nobs) # 36 call gbytes(iced, idle(1,37), nskip+220, 4,252,nobs) # 37 call gbytes(iced, idle(1,38), nskip+224, 4,252,nobs) # 38 call gbytes(iced, idle(1,39), nskip+228, 4,252,nobs) # 39 call gbytes(iced, idle(1,40), nskip+232, 4,252,nobs) # 40 call gbytes(iced, idle(1,41), nskip+236, 4,252,nobs) # 41 call gbytes(iced, idle(1,42), nskip+240, 4,252,nobs) # 42 call gbytes(iced, idle(1,43), nskip+244, 4,252,nobs) # 43 call gbytes(iced, idle(1,44), nskip+248, 4,252,nobs) # 44 return end subroutine skipfile(lun,numf,lst) save nf=0 10 continue call rdtape(lun,1,0,idum,1) call iowait(lun,lst,lwds) if(lst.eq.0) go to 10 if(lst.ne.2) go to 20 print 15,lun 15 format(' read error on unit',i2) go to 10 20 continue lst=1 nf=nf+1 if(nf.lt.numf) go to 10 return end "ENDCAT" /wp/dss/bin/cf77 tsrc.f msread fort.1 /DSS/xxxxxx ls -la fort.1 a.out