c c------------------------------------------------------------------ c Begin file /home/sting/foster/plt/defclrs.f c------------------------------------------------------------------ c subroutine defclrs(idemo) C C Define color table containing nclrs colors, not including black/white C (black and white indices are always 0 and 1, respectively) C ixclr(nclrs) = Color indices for each color: 2 -> nclrs+1 C include 'cpwrk.h' include 'color.h' c parameter (igi=4) character*2 chix character*16 chrgb data iblack/0/, iwhite/1/, iclrtxt/90/ c c 14-color table: c c data rgbv / c + 0.20 , 0.10 , 0.30 , c + 0.30 , 0.10 , 0.50 , c + 0.30 , 0.00 , 0.85 , c + 0.00 , 0.00 , 1.00 , c + 0.00 , 0.50 , 1.00 , c + 0.00 , 1.00 , 1.00 , c + 0.00 , 1.00 , 0.60 , c + 0.00 , 1.00 , 0.00 , c + 0.75 , 1.00 , 0.00 , c + 1.00 , 1.00 , 0.00 , c + 1.00 , 0.75 , 0.00 , c + 1.00 , 0.38 , 0.38 , c + 1.00 , 0.00 , 0.38 , c + 1.00 , 0.00 , 0.00 , 6*0./ data rgbv / + 0.30 , 0.00 , 0.85 , + 0.00 , 0.00 , 1.00 , + 0.00 , 0.65 , 1.00 , + 0.00 , 1.00 , 1.00 , + 0.00 , 1.00 , 0.60 , + 0.75 , 1.00 , 0.00 , + 1.00 , 1.00 , 0.00 , + 1.00 , 0.82 , 0. , + 1.00 , 0.70 , 0.00 , + 1.00 , 0.50 , 0.00 , + 1.00 , 0.38 , 0.38 , + 1.00 , 0.00 , 0.00 , + 1.00 , 0.00 , 0.55 , + 1.00 , 0.00 , 0.68 , 6*0./ c c 13-color table: c c data rgbv / c + 0.30 , 0.00 , 0.85 , c + 0.00 , 0.00 , 1.00 , c + 0.00 , 0.65 , 1.00 , c + 0.00 , 1.00 , 1.00 , c + 0.00 , 1.00 , 0.60 , c + 0.75 , 1.00 , 0.00 , c + 1.00 , 1.00 , 0.00 , c + 1.00 , 0.82 , 0. , c + 1.00 , 0.70 , 0.00 , c + 1.00 , 0.50 , 0.00 , c + 1.00 , 0.38 , 0.38 , c + 1.00 , 0.00 , 0.00 , c + 1.00 , 0.00 , 0.68 , 9*0./ c c 12-color table: c c data rgbv / c + 0.30 , 0.00 , 0.85 , c + 0.00 , 0.00 , 1.00 , c + 0.00 , 0.65 , 1.00 , c + 0.00 , 1.00 , 1.00 , c + 0.00 , 1.00 , 0.60 , c + 0.75 , 1.00 , 0.00 , c + 1.00 , 1.00 , 0.00 , c + 1.00 , 0.75 , 0.00 , c + 1.00 , 0.50 , 0.00 , c + 1.00 , 0.38 , 0.38 , c + 1.00 , 0.00 , 0.00 , c + 1.00 , 0.00 , 0.68 , 12*0./ external clrdemo C iidemo = idemo c if (nclrs.ne.14) then c write(6,"(' >>> defclrs: currently set up for 14 colors only', c + ' (plus black and white) -- changing nclrs from ',i3, c + ' to ',i2)") nclrs,mxclrs-2 c nclrs = mxclrs-2 c endif C C Define black and white color indices: call gscr(1,0,0.,0.,0.) call gscr(1,1,1.,1.,1.) c c Define index 90 to be a text color for movies (yellow-green): call gscr(1,iclrtxt,.75,.75,0.) C C Define color indices 2 -> nclrs+1 do 100 i=1,nclrs ixclr(i) = i+1 call gscr(1,ixclr(i),rgbv(1,i),rgbv(2,i),rgbv(3,i)) 100 continue c c ired will be last color in the table: ired = nclrs C C Make a frame showing the color table: if (iidemo.eq.1) then call getset(pl,pr,pb,pt,ul,ur,ub,utt,lty) call set(0.,1.,0.,1.,0.,1.,0.,1.,1) C C Draw perimeter around plotter frame: call gsplci(iwhite) call line(0.,0.,1.,0.) call line(1.,0.,1.,1.) call line(1.,1.,0.,1.) call line(0.,1.,0.,0.) call arinam(iama,liama) ycra(1) = 0. ycra(2) = 1. do 200 i=1,nclrs-1 rnclrs = float(nclrs) xcra(1) = float(i)/rnclrs xcra(2) = xcra(1) call aredam(iama,xcra,ycra,2,igi,i+1,i+2) 200 continue call arpram(iama,0,0,0) call arscam(iama,xcra,ycra,lcra,iaia,iaga,10,clrdemo) C C Write color index numbers on each color: C call gsplci(iblack) ypos = 0.1 do 300 i=1,nclrs xpos = 0.5*(float(i)/rnclrs+float(i-1)/rnclrs) write(chix,"(i2)") i+1 call plchhq(xpos,ypos,chix,.02,0.,0.) write(chrgb,"(f4.2,', ',f4.2,', ',f4.2)") rgbv(1,i), + rgbv(2,i),rgbv(3,i) call plchhq(xpos,.5,chrgb,.02,90.,0.) 300 continue call gsplci(iwhite) C call frame call set(pl,pr,pb,pt,ul,ur,ub,utt,lty) endif return end CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC subroutine clrdemo(xcs,ycs,ncs,iai,iag,nai) c include 'color.h' c parameter(igi=4) dimension xcs(*),ycs(*),iai(*),iag(*) ifl=1 do 100 i=1,nai 100 if (iai(i).lt.0) ifl=0 if (ifl.gt.0) then ifl = 0 do 105 i=1,nai if (iag(i).eq.igi) ifl = iai(i) c write(6,"(' clrdemo 105: i=',i2,' iag iai=',2i3,' ifl=',i2)") c + i,iag(i),iai(i),ifl 105 continue if (ifl.gt.0.and.ifl.le.nclrs+1) then call gsfaci(ifl) call gfa(ncs-1,xcs,ycs) Endif endif return end