c program tst parameter(kmx=25,jmx=36,imx=73) dimension iasf(13),viewport(4),censatv(2),gcmlat(jmx), + gcmlon(imx),plot(imx,jmx) character*2 ou data iasf/13*1/ data viewport/.05,.80,.13,.88/ data grid/15./, censatv/70.,90./, erdist/6.631/ data ou/'PS'/ c parameter(lrwrk=2000,liwrk=1000,liama=300000,lcra=10000) common/work/ rwrk(lrwrk),iwrk(liwrk),iama(liama),iiasf(13), + iaia(10),igia(10),xcra(lcra),ycra(lcra) c call opngks call gsclip(0) call gsasf(iasf) call gsfais(1) c do j=1,jmx gcmlat(j) = -87.5 + (j-1)*5. enddo do i=1,imx gcmlon(i) = -180. + (i-1)*5. enddo do j=1,jmx do i=1,imx plot(i,j) = float(j)*float(i) enddo enddo c call arinam(iama,liama) call mksatv(viewport,censatv,grid,erdist,ou) call cpgcm(plot,gcmlat,gcmlon) call mapgrd call maplot call frame c call clsgks stop end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine mksatv(viewport,censatv,grid,erdist,ou) dimension viewport(4),censatv(2) character*2 ou c call mapsti('EL',1) call mapstr('GR',grid) call mapstc('OU',ou) if (erdist.gt.0.) call mapstr("SA",erdist) call mappos(viewport(1),viewport(2),viewport(3),viewport(4)) call maproj('SV',censatv(1),censatv(2),0.) call mapset('MA',0.,0.,0.,0.) call mapint return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine cpgcm(plot,gcmlat,gcmlon) parameter(kmx=25,jmx=36,imx=73) dimension gcmlat(jmx),gcmlon(imx),plot(imx,jmx) data ncalls/0/ save ncalls c ncalls = ncalls+1 if (ncalls.eq.1) then call cpsetup(1.e36) call cpsetr('XC1',gcmlon(1)) call cpsetr('XCM',gcmlon(imx)) call cpsetr('YC1',gcmlat(1)) call cpsetr('YCN',gcmlat(jmx)) call cpseti('SET',0) call cpseti('ILP',0) call cpseti('MAP',1) endif write(6,"('cpgcm calling conclr')") call conclr(plot,imx,imx,jmx) return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine conclr(zz,idimx,nx,ny) dimension zz(idimx,ny) parameter(lrwrk=2000,liwrk=1000,liama=300000,lcra=10000) common/work/ rwrk(lrwrk),iwrk(liwrk),iama(liama),iiasf(13), + iaia(10),igia(10),xcra(lcra),ycra(lcra) c parameter(mxclrs=256) common/color/ nclrs,ixclr(mxclrs) external drawcl,colram c call cprect(zz,idimx,nx,ny,rwrk,lrwrk,iwrk,liwrk) call cppkcl(zz,rwrk,iwrk) call cpgeti('NCL -- number of contour levels',ncl) do i=1,ncl call cpseti('PAI',i) call cpgetr('CLV -- contour level',clev) call cpgeti('AIA - area identifier above',iiaia) call cpgeti('AIB - area identifier below',iiaib) write(6,"('conclr: ncl=',i2,' i=',i2,' clev=',e12.4, + ' aia aib=',2i4)") ncl,i,clev,iiaia,iiaib enddo nclrs = ncl+2 call mkrgb(nclrs,ixclr) c call arinam(iama,liama) call cpclam(zz,rwrk,iwrk,iama) call arscam(iama,xcra,ycra,lcra,iaia,igia,10,colram) call cplbam(zz,rwrk,iwrk,iama) call cplbdr(zz,rwrk,iwrk) call cpcldm(zz,rwrk,iwrk,iama,drawcl) c return end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine drawcl(xcs,ycs,ncs,iai,iag,nai) dimension xcs(*),ycs(*),iai(*),iag(*) idr=1 do i=1,nai if (iai(i).lt.0) idr=0 enddo if (idr.ne.0) call curved(xcs,ycs,ncs) return end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine colram(xcra,ycra,ncra,iaia,igia,naia) parameter(mxclrs=256) common/color/ nclrs,ixclr(mxclrs) dimension xcra(*),ycra(*),iaia(*),igia(*) c c Edge group 1=ocean, 2=continents, 3=contour levels, 4=vertical strips c c write(6,"('colram: nclrs=',i3,' ncra=',i3,' naia=',i3, c + ' ixclr=',/(12i5))") nclrs,ncra,naia,(ixclr(i),i=1,nclrs) c write(6,"('iaia=',/(12i5))") (iaia(i),i=1,naia) c write(6,"('igia=',/(12i5))") (igia(i),i=1,naia) ifll=1 do 100 i=1,naia 100 if (iaia(i).lt.0) ifll=0 if (ifll.ne.0) then ! fill the area ifll=0 do 105 i=1,naia 105 if (igia(i).eq.3) ifll=iaia(i) ! area id of a contour level if (ifll.gt.0.and.ifll.le.nclrs) then ! within the color tabl write(6,"('colram within clr table: ifll=',i3, + ' ixclr(ifll+1)=',i3)") ifll,ixclr(ifll+1) call gsfaci(ixclr(ifll+1)) call gfa(ncra-1,xcra,ycra) elseif (ifll.gt.nclrs) then call gsfaci(nclrs+1) call gfa(ncra-1,xcra,ycra) endif endif return end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine cpsetup(cpspval) c c Set various processor and conpack defaults c data chsize/.013/ c c cpcit = conpack contour interval table dimension cpcit(10),icplit(10) data cpcit /1.0, 1.5, 2.0, 2.5, 3.0, 4.0, 5.0, 6.0, 7.0, 7.5/ data icplit/ 2, 4, 3, 4, 3, 3, 4, 3, 3, 4/ c c All plotting characters to be 'high quality': c call pcseti('QU - quality flag',0) c c Tell conpack values for which it is allowed to make multiples c from for contour intervals: c do 50 i=1,10 call cpseti('PAI -- parameter array index',i) call cpsetr('CIT -- contour interval table',cpcit(i)) call cpseti('LIT -- label interval table',icplit(i)) 50 continue c c Set special value for conpack: c call cpsetr('SPV -- special value',cpspval) c c Turn on text extent computation, allowing calculation c of distance to top of string, bottom of string, etc: c call pcseti('TE - text extent computation flag',1) c c Contour line labels are positioned at regular intervals c along the line: c (This also makes conpack draw the labels, not dashchar, c so parameters like LLS are enabled) c Note that changing LLP from 1 to 3 triples the time c required to produce a plot) c call cpseti('LLP -- line label positioning',3) c c Line labels are to be written in the local direction of the c contour line: c call cpseti('LLO -- line label orientation',1) c c Contour line labels drawn by CPLBDR are not boxed (b/w): c call cpseti('LLB -- line label box flag',0) c c Do not use high/low label in conpack: c call cpsetc('HLT - high/low label test',' ') c c ILX and ILY will be x and y coords of the info label c position (set from the individual plotting routines). c This call says that ILX and ILY will specify c the center of the bottom of the label box: c call cpseti('ILP - informational label positioning flag',-3) c c Specify text of the info label: c call cpsetc('ILT - info label text', + 'MINIMUM $ZMN$, MAXIMUM $ZMX$, CONTOUR INTERVAL $CIU$') c c Set character size for contour line labels: c call cpsetr('LLS - line label size',chsize) return end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine mkrgb(numclr,iclrs) c----------------------------------------------------------------------- c This subroutine calculates the red-green-blue mixtures based on c equations in "Color Spaces for Computer Graphics" by Joblove and c Greenberg from "Communication of the Association for Computing c Machinery--Proceedings of SIGGRAPH, 1978". c On input -- c numclr ------- integer number of distinct colors for color bar c if = -14 use the special color bar for transparencies c if = 14 use the special color bar for slides c On output -- c The color table will be set up going from blues to pink. c----------------------------------------------------------------------- c parameter(maxclr=256) dimension iclrs(numclr) dimension rgb(3,maxclr),rgbp(3,maxclr),rgbt(3,16) data pi/3.141592654/ c RGB for 14 color bar (for slides) data ((rgb(i,j),i=1,3),j=1,10) / 1 0.0, 0.0, 0.0, 2 1.0, 1.0, 1.0, 3 0.0, 0.0, 0.9, 4 0., 0.1667, 1.0, 5 0.0, 0.5, 1.0, 6 0.0, 0.75, 1.0, 7 0.0, 0.5, 0.0, 8 0.0 , 0.80, 0.0, 9 0.33, 1.0, 0.0, 1 1.0, 1.0, 0.0/ data ((rgb(i,j),i=1,3),j=11,16) / 1 1.0, 0.60, 0.00, 2 1.0, 0.33, 0.00, 3 1.0, 0.0, 0.00, 4 1.0, 0.0, 0.70, 5 1.0, 0.0, 1.00, 6 1.0, 0.3, 1.00/ c RGB for color transparencies data ((rgbt(i,j),i=1,3),j=1,10) / 1 0.0, 0.0, 0.0, 2 1.0, 1.0, 1.0, 3 0.0, 0.0, 1.0, 4 0.334, 0.667, 1.0, 5 0.0, 1.0, 1.0, 6 0.667, 1.0, 1.0, 7 0.334, 1.0, 0.667, 8 0.0, 1.0, 0.0, 9 0.667, 1.0, 0.0, 1 1.0, 1.0, 0.0/ data ((rgbt(i,j),i=1,3),j=11,16) / 1 1.0, 0.667, 0.334, 2 1.0, 0.334, 0.00, 3 1.0, 0.0, 0.334, 4 0.667, 0.0, 0.667, 5 1.0, 0.0, 1.0, 6 1.0, 0.667, 1.0/ c----------------------------------------------------------------------- c check that the number of colors specified does not exceed the maximum. c----------------------------------------------------------------------- if (numclr.gt.maxclr-2) then write(6,"('>>> mkrgb warning: number of colors requested = ', + i4,' but max allowed = ',i4,' will return max only')") + numclr,maxclr numclr = maxclr end if c----------------------------------------------------------------------- c set fill area to solid c----------------------------------------------------------------------- call gsfais(1) c----------------------------------------------------------------------- c initialize some values c----------------------------------------------------------------------- one6th=1./6. two6th=2./6. thr6th=3./6. for6th=4./6. fiv6th=5./6. twn436=24./36. ! color offset c----------------------------------------------------------------------- c calculate the rgb prime values. c----------------------------------------------------------------------- hdif=(34./36.)/float(numclr) h=twn436+(numclr/12.)*hdif do i=1,numclr h=h-hdif if (h.lt.0.) h=1. if (h.le.one6th) then rgbp(1,i)=1. rgbp(2,i)=6.*h rgbp(3,i)=0. elseif (h.le.two6th) then rgbp(1,i)=2.-6.*h rgbp(2,i)=1. rgbp(3,i)=0. elseif (h.le.thr6th) then rgbp(1,i)=0. rgbp(2,i)=1. rgbp(3,i)=6.*h-2. elseif (h.le.for6th) then rgbp(1,i)=0. rgbp(2,i)=4.-6.*h rgbp(3,i)=1. elseif (h.le.fiv6th) then rgbp(1,i)=6.*h-4. rgbp(2,i)=0. rgbp(3,i)=1. else rgbp(1,i)=1. rgbp(2,i)=0. rgbp(3,i)=6.-6.*h end if end do c----------------------------------------------------------------------- c calculate the true rgb values using a sinusoidal interpolation c----------------------------------------------------------------------- do i=1,numclr do j=1,3 rgb(j,i)=( 1. + cos ( (1.-rgbp(j,i)) * pi) ) / 2. end do end do c----------------------------------------------------------------------- c set the GKS number of colors to numclr and set the GKS color bar c----------------------------------------------------------------------- call gscr(1,255,1.,1.,1.) ! for ps.mono do index = 2,numclr r = rgb(1,index) g = rgb(2,index) b = rgb(3,index) iclrs(index) = + 2 + ifix(252.*(float(index)-2.)/(float(numclr)-1.)) call gscr(1,iclrs(index),r,g,b) ! set color representation end do return end