program plot c c --- i index (latitude) increases N to S, j index (longitude) increases W to E c c **** COADS data from 55N to 0 and 100W to 38E (example) parameter (idmh=56,jdmh=139) c common/cclats/clats(idmh) character util(idmh*jdmh+14)*2,util1(idmh*jdmh+14)*2 character preambl(5)*79,preamb1(5)*79 real plot1(jdmh,idmh),datain(idmh,jdmh) real mask(idmh,jdmh) dimension mon(12) common/conre1/ioffp,spval data ii,jj/idmh,jdmh/ data mon/'JAN.','FEB.','MAR.','APR.','MAY ','JUNE','JULY','AUG.', . 'SEP.','OCT.','NOV.','DEC.'/ c **** change header according to data file data hdr/'TAUX'/ c --- clong (clat) are W (N) longitude (latitude) limit of COADS data c --- cgridj, cgridi are resolution (deg) of data in long, lat direction ccc data clong/-97./,clat/79./,cgridj/1./,cgridi/1./ c data clong/-100./,clat/55./,cgridj/1./,cgridi/1./ c --- clats contains COADS data latitudes do 1 i=1,idmh 1 clats(i)=clat-cgridi*float(i-1) c call opngks call gsclip(0) ioffp=1 spval=-9. c c **** mask file open (unit=20,file='mask.1deg',status='old') read (20,100) preamb1,idim,jdim,length,(util1(l),l=1,length) call unpakk(mask,idmh,idmh,jdmh,util1,length) c c **** unit 10 is pakked 12-month file created by newtest.f iuni=10 c --- loop over 12 months do 500 imon=1,12 read (iuni,100) preambl,idum,jdum,length,(util(l),l=1,length) call unpakk(datain,idmh,idmh,jdmh,util,length) 100 format (5(a79/),3i6/(40a2)) c --- test prints do 201 i=1,29 201 print 202, i,(datain(i,j),j=1,26) 202 format(' i=',i3,' datain='/(1x,26f5.2)) do 301 i=1,2 301 print 302, i,(datain(i,j),j=1,10) 302 format(' i=',i3,' datain='/(1x,10e12.5)) c c --- insert a statement such as the following if plots are not desired for c --- every month if (imon.ne.1.and.imon.ne.7) go to 995 c --- plot COADS data call set(.05,.95,.05,.95,1.,float(jdmh),1.,float(idmh),1) call getset(xxa,xxb,yya,yyb,xa,xb,ya,yb,ltype) call mappos(xxa,xxb,yya,yyb) call maproj('CE',0.,0.,0.) call mapstc('OUTLINE','CO') call mapstl('DOT',.false.) xla1=clats(1) xlo1=clong xla2=clats(idmh) xlo2=clong+(jdmh-1)*cgridj call mapset('CORNERS',xla1,xlo1,xla2,xlo2) call mapsti('LA',0) call mapint call mapdrw call getset(xxa,xxb,yya,yyb,xa,xb,ya,yb,ltype) call set(xxa,xxb,yya,yyb,1.,float(jdmh),1.,float(idmh),1) c --- reverse data for plotting (so i is longitude and j is latitude) do 132 i=1,jdmh do 132 j=1,idmh plot1(i,j)=datain(idmh-j+1,i) if (mask(idmh-j+1,i).eq.0.) plot1(i,j)=spval 132 continue c --- test prints do 203 j=idmh,idmh-28,-1 203 print 204, j,(plot1(i,j),i=1,26) 204 format(' j=',i3,' plot1='/(1x,26f5.2)) do 303 j=idmh,idmh-1,-1 303 print 304, j,(plot1(i,j),i=1,10) 304 format(' j=',i3,' plot1='/(1x,10e12.5)) call conrec(plot1,jdmh,jdmh,idmh,0.,0.,.02,1,-1,-'125252'o) call pwrit(5.0,float(idmh)+2.,mon(imon),4,2,0,-1) call pwrit(float(jdmh/4),float(idmh)+2.,15h - COADS , . 15,2,0,-1) call pwrit(float(jdmh)/4.,float(idmh)+2.,hdr,4,2,0,-1) call perim(1,jdmh-1,1,idmh-1) call frame 995 continue 500 continue call clsgks end subroutine pakk(array,idim,ii,jj,compac,length) c c --- converts the contents of -array- into an ascii character string which c --- is stored in character*2 array -compac-. compac(1)...compac(7) contain c --- the base value, i.e., the minimum value encountered in -array-. c --- compac(8)...compac(14) contain a scale factor by which the individual c --- 6-bit integers encoded as ascii character pairs in compac(8),... c --- compac(length) must be multiplied before the base value is added c --- during an unpakking operation. base value and scale factor are encoded c --- in e14.7 format. c c --- the printable ascii characters used to encode the integers include c --- the numbers 0...9, upper- and lower-case letters a...z, a...z, plus c --- two additional characters '.' and '/' (total of 64). c c --- a packing operation fills (ii*jj+14) array elements in -compac- which c --- must be dimensioned accordingly in the calling program. the total c --- number of occupied array elements is returned in -length-. in calls to c --- unpack, -length- is treated as input variable. c real array(idim,1) character*2 char,compac(1),comp2(14) character*14 comp14(2) equivalence (comp2,comp14) data nbits/12/ base=1.e22 do 1 i=1,ii do 1 j=1,jj 1 base=min(base,array(i,j)) scal=0. do 2 i=1,ii do 2 j=1,jj 2 scal=max(scal,array(i,j)-base) scal=scal/float(2**nbits-1) i1=0 i2=0 length=14 do 3 i=1,ii do 3 j=1,jj if (scal.eq.0.) go to 7 numb=(array(i,j)-base)/scal+.5 i1=numb/64 i2=numb-64*i1 c c --- map 6-bit numbers onto character set consisting of numbers c --- 0...9, letters a...z, a...z, and the two characters '.' and '/'. c --- (if mapping into the character range 32...95 -- which includes the c --- characters !"#$%&'()*+,-./:;<=>?@[\]^_ -- is deemed safe, delete c --- the next 6 lines.) ccc if (i1.gt.37) i1=i1+6 ccc if (i1.gt.11) i1=i1+7 ccc i1=i1+14 ccc if (i2.gt.37) i2=i2+6 ccc if (i2.gt.11) i2=i2+7 ccc i2=i2+14 c 7 length=length+1 compac(length)(1:1)=char(i1+32) compac(length)(2:2)=char(i2+32) 100 format (a2) 3 continue write (comp14(1),101) base write (comp14(2),101) scal 101 format (1pe14.7) do 8 l=1,14 8 compac(l)=comp2(l) c return c c entry unpakk(array,idim,ii,jj,compac,length) c do 9 l=1,14 9 comp2(l)=compac(l) read (comp14(1),101) base read (comp14(2),101) scal lngth=14 do 4 i=1,ii do 4 j=1,jj lngth=lngth+1 i1=ichar(compac(lngth)(1:1)) i2=ichar(compac(lngth)(2:2)) c c --- 6-bit numbers are mapped onto character set consisting of numbers c --- 0...9, letters a...z, a...z, and the two characters '.' and '/'. c --- (if mapped into character range 32...95, delete next 6 lines) ccc if (i1.gt.96) i1=i1-6 ccc if (i1.gt.64) i1=i1-7 ccc i1=i1-14 ccc if (i2.gt.96) i2=i2-6 ccc if (i2.gt.64) i2=i2-7 ccc i2=i2-14 c 4 array(i,j)=scal*float(64*(i1-32)+(i2-32))+base if (lngth.ne.length) stop 'unpack' return end