* file: test.f - last change: 9/6/93 (c) 1993 Arlindo da Silva * * Reads UWM/COADS files and prints portion of it on the * screen. This program demonstrates routine UWREAD. * c **** this program stores a portion of the data at 1-deg. resolution c **** in arrays of dimension (idm,jdm) in the usual MICOM convention, c **** that is, i increases from N to S, and j increases from W to E parameter ( IDIM = 360, JDIM = 180, NDIM = IDIM * JDIM ) c **** see comments regarding lat/long in subr. putout c **** change these parameters - idm and jdm - accordingly parameter (idm=56,jdm=139) c real A(idim,jdim),b(idm,jdm) real mask(idm,jdm) character*80 label, fname character*2 util(idm*jdm+14) character preambl(5)*79,mon(12)*3 data mon/'jan','feb','mar','apr','may','jun','jul','aug', . 'sep','oct','nov','dec'/ *........................................................................... print * print *, ' << Printing UWM-COADS Files >>' print * c c c --------------------------------------------------------- c **** insert COADS file name here fname = 'fvcubed.nc$' print *, fname(1:78) preambl(1)=fname(1:78) *........................................................................ c iyear = 0 means climatology iyear = 0 c iyear = iyr1,iyr2 refers to specific years c ccc do 50 iyear = 45, 89 c c **** loop over 12 months for iyear=0 (climatology) do 50 imon = 1, 12 print *, 'month = ', imon print *, 'year = ', iyear print * preambl(2)=mon(imon) * Read Array * ---------- call UWREAD ( ier, A, idim, jdim, label, imon, iyear, fname ) if ( ier .ne. 0 ) then print *, 'Error on return from UWREAD: ier = ', ier call exit(1) end if ll = index ( label, '$' ) - 1 * Print portion of it on the screen * --------------------------------- call PUTOUT ( a, idim, jdim, b, idm, jdm, mask, label(1:ll) ) c c **** routines uwread and putout store data in array b(idm,jdm) c **** which is then written in pakked form on unit 10 c call pakk(b,idm,idm,jdm,util,length) write (10,100) preambl,idm,jdm,length,(util(l),l=1,length) 100 format (5(a79/),3i6/(40a2)) c c **** also write mask array on unit 20 (same for all 12 months) c **** mask array has zeros where land is, one otherwise c if (imon.eq.1) then call pakk(mask,idm,idm,jdm,util,length) write (20,100) preambl,idm,jdm,length,(util(l),l=1,length) close (unit=20) endif 50 continue close (unit=10) stop end *........................................................................ subroutine PUTOUT ( a, idim, jdim, b, idm, jdm, mask, string ) real a(idim,jdim),b(idm,jdm),mask(idm,jdm) character*(*) string * This subroutine prints a portion of the * input array, generally corresponding to the * North Atlantic. * * This routine is resolution dependent. c **** i for this routine is longitude, j is latitude data i1, i2, idel / 260, 398, 1 / ! 100W to 38E (example) data j1, j2, jdel / 145, 90, -1 / ! 55N to 0 (example) data iu / 10 / * Prints the array a * ------------------ write(6,*) write(6,*) string call PRARR ( a, idim, jdim, b,idm,jdm, mask, & i1, i2, idel, j1, j2, jdel, iu) *** read * return end *...................................................................... subroutine PRARR ( a, idim, jdim, b, idm, jdm, mask, & i1, i2, idel, j1, j2, jdel, iu) * This routine prints out an array. real a(idim,jdim),b(idm,jdm),mask(idm,jdm) character*8 ac(360) parameter ( ALAND = -1. E 10, AMISS = +1. E 10 ) data spval/-.03125/ jlat=0 do 20 j = j1, j2, jdel jlat=jlat+1 ilon=0 if (i2.le.idim) then do 10 i = i1, i2, idel ilon=ilon+1 c **** note first index of b is now latitude, second index is longitude b(jlat,ilon)=a(i,j) mask(jlat,ilon)=1. if (a(i,j).eq.AMISS.or.a(i,j).eq.ALAND) then b(jlat,ilon)=spval mask(jlat,ilon)=0. endif 10 continue endif if (i2.gt.idim) then do 11 i = i1, idim, idel ilon=ilon+1 b(jlat,ilon)=a(i,j) mask(jlat,ilon)=1. if (a(i,j).eq.AMISS.or.a(i,j).eq.ALAND) then b(jlat,ilon)=spval mask(jlat,ilon)=0. endif 11 continue do 12 i = 1, i2-idim, idel ilon=ilon+1 b(jlat,ilon)=a(i,j) mask(jlat,ilon)=1. if (a(i,j).eq.AMISS.or.a(i,j).eq.ALAND) then b(jlat,ilon)=spval mask(jlat,ilon)=0. endif 12 continue endif 20 continue c print 200, jlat,ilon,idm,jdm 200 format(' jlat,ilon=',2i5,' idm,jdm=',2i5) return end c subroutine pakk(array,idim,ii,jj,compac,length) 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