# # QSUB -eo -q reg -lT 55 -s /bin/csh cd $TMPDIR cat << "ENDCAT" >! tsrc.f program wmsc c*** driver for access routine to world monthly station surface climatology c c*** common blocks a, b, c needed in routines calling rdwmsc and upwmsc common/a/nout,nst,nbuf(1006),month(42),npar(13,19) common/b/nwmo,nyear,lat,lon,ielev,name(4),miss,num common/c/iform,isourc,nship,lsourc,nmo,nsix,nine,nht(6,4) c dimension label(5,19) data label/40hsea level pressure indicator #1 , * 40hsea level pressure (tenths of mb) , * 40hsea level pressure indicator #2 , * 40hstation pressure (tenths of mb) , * 40hheight (meters) , * 40htemperature (tenths of degrees c) , * 40hprecipitation (tenths of mm) , * 40htemperature departure (tenths, deg-c) , * 40hmoisture indicator (0=rh, 1=vp) , * 40hmoisture (% or tenths of mb) , * 40hmoisture departure (% or tenths of mb) , * 40hdays with precipitation .ge. 1 mm , * 40hprecipitation departure (mm) , * 40hquintile , * 40hnumber of observation per month , * 40hsunshine duration (hours) , * 40hsunshine % of average (whole percent) , * 40hsea temperature (tenths of degrees c) , * 40hsea temperature departure (tenths,deg-c)/ c*** set nout = logical unit number on volume or assign card nout=1 c 10 continue c*** read logical record and unpack id parameters call rdwmsc if(nst.eq.1.or.nst.eq.3) go to 100 nrec=nrec+1 if(nst.eq.0) go to 15 c 11 continue c*** handle parity error c 15 continue c*** select records here c if(nwmo .ne. 616410) go to 10 c 20 continue c*** unpack standard parameters. if additional parameters are not wanted c*** set miss=0 before call to upwmsc call upwmsc c 25 continue c*** process record c n=7 if(miss.ne.0.and.nyear.gt.1960) n=19 print 50,nrec,iform,isourc,nship,lsourc,nwmo,nyear,nmo,lat,lon, *ielev,name,nsix,nine,miss 50 format(1h0,i6,4i3,6i7,3x,3a8,a6,i7,i10,i2) print 51, ((npar(i,j),i=1,13),(label(k,j),k=1,5),j=1,n) 51 format(1x,13i7,1x,5a8) if(miss.eq.0.or.nyear.gt.1960) go to 10 print 52,(nht(i,1),i=1,num) 52 format(1x,6i10) c go to 10 c 100 continue c*** end of file = 1, end of tape = 3 c end subroutine rdwmsc c c*** access routine for world monthly station surface climatology c*** parameters are unpacked in the order they appear in the tables of the c*** format writeup c common/a/nout,nst,nbuf(1006),month(42),npar(13,19) common/b/nwmo,nyear,lat,lon,ielev,name(4),miss,num common/c/iform,isourc,nship,lsourc,nmo,nsix,nine,nht(6,4) dimension ic(30) data name(4)/8h / c c*** read logical record 6000 call rptin(nout,nbuf,month,nwds,1 ,42,nst) if(nst.ne.0) return c c*** unpack identification - see table 1 call gbyte(month,iform,16,6) call gbyte(month,isourc,22,2) call gbyte(month,nship,24,1) call gbyte(month,lsourc,25,2) call gbyte(month,nwmo,27,21) call gbyte(month,nyear,48,12) call gbyte(month,nmo,60,4) call gbyte(month,lat,64,11) call gbyte(month,lon,75,12) call gbyte(month,ielev,87,14) call gbytes(month,ic,101,6,0,30) call dpcasc(ic,ic,30) call sbytes(name,ic,0,8,0,30) call gbyte(month,nsix,281,20) call gbyte(month,nine,301,30) call gbyte(month,miss,331,1) lat=lat-1000 lon=lon-2000 ielev=ielev-1000 return c c c*** entry upwmsc c*** c c*** unpack standard parameters - see table 2 call gbytes(month,npar(1,1),332,1,74,13) call gbytes(month,npar(1,2),333,15,60,13) call gbytes(month,npar(1,3),348,2,73,13) call gbytes(month,npar(1,4),350,15,60,13) call gbytes(month,npar(1,5),365,13,62,13) call gbytes(month,npar(1,6),378,11,64,13) call gbytes(month,npar(1,7),389,18,57,13) c*** remove bias from unpacked parameters do 6001 i=1,13 npar(i, 6)=npar(i, 6)-1000 6001 continue c c*** check for additional parameters if(miss.eq.0) return jyear=nyear-(nyear/1000)*1000+1000 if(jyear.gt.1960) go to 6100 c c*** unpack additional parameters - see table 3 call gbyte(month,num,1307,1) num=6+18*num call gbytes(month,nht,1308,17,0,num) c*** remove bias from unpacked parameters do 6200 i=1,num 6200 nht(i,1)=nht(i,1)-10000 return c 6100 continue c*** unpack additional parameters - see table 3a call gbytes(month,npar(1, 8),1307,11, 92,13) call gbytes(month,npar(1, 9),1318, 1,102,13) call gbytes(month,npar(1,10),1319,11, 92,13) call gbytes(month,npar(1,11),1330,11, 92,13) call gbytes(month,npar(1,12),1341, 6, 97,13) call gbytes(month,npar(1,13),1347,12, 91,13) call gbytes(month,npar(1,14),1359, 3,100,13) call gbytes(month,npar(1,15),1362, 6, 97,13) call gbytes(month,npar(1,16),1368,10, 93,13) call gbytes(month,npar(1,17),1378,10, 93,13) call gbytes(month,npar(1,18),1388,11, 92,13) call gbytes(month,npar(1,19),1399,11, 92,13) c*** remove bias from unpacked parameters do 7000 i=1,13 npar(i, 8)=npar(i, 8)-1000 ibias=100 if(npar(i,9).eq.1) ibias=1000 npar(i,11)=npar(i,11)-ibias npar(i,13)=npar(i,13)-2000 npar(i,18)=npar(i,18)-1000 npar(i,19)=npar(i,19)-1000 7000 continue return end subroutine dpcasc(in,iout,num) dimension in(1),iout(1),ic(64) data ic/ 72b,101b,102b,103b,104b,105b,106b,107b, * 110b,111b,112b,113b,114b,115b,116b,117b, * 120b,121b,122b,123b,124b,125b,126b,127b, * 130b,131b,132b, 60b, 61b, 62b, 63b, 64b, * 65b, 66b, 67b, 70b, 71b, 53b, 55b, 52b, * 57b, 50b, 51b, 44b, 75b, 40b, 54b, 56b, * 43b,133b,135b, 45b, 42b,137b, 41b, 46b, * 47b, 77b, 74b, 76b,100b,134b,136b, 73b/ do 100 i=1,num n=in(i)+1 iout(i)=ic(n) 100 continue return end "ENDCAT" cft77 -e h tsrc.f segldr tsrc.o -L /lib,/usr/lib,/usr/local/lib -l ncarm,ncaro,net msread indata /DSS/K0848K assign -a indata fort.1 ja pshell a.out ja -cst