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----------------------------------------------------------------------- c call gscr(1,255,1.,1.,1.) ! for ps.mono c do index = 2,numclr c r = rgb(1,index) c g = rgb(2,index) c b = rgb(3,index) c iclrs(index) = c + 2 + ifix(252.*(float(index)-2.)/(float(numclr)-1.)) c call gscr(1,iclrs(index),r,g,b) ! set color representation c end do c call gscr(1,0,0.,0.,0.) ! set to background color (black) call gscr(1,1,1.,1.,1.) ! set to forground color (white) do i=1,numclr iclrs(i) = i+1 call gscr(1,iclrs(i),rgb(1,i),rgb(2,i),rgb(3,i)) end do return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine fixrgb(nrgb,rgb,iclrs) c c Set up a fixed color table (color tables determined a priori, different c for different numbers of colors). c (set default background and foreground black and white respectively) c nrgb = desired number of colors c rgb = return rgb values of table c iclrs = return color indices (starting at 2) c dimension rgb(3,nrgb),iclrs(nrgb) dimension rgb12(3,12),rgb13(3,13),rgb14(3,14) c data rgb12/ + 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.75 , 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.68 / data rgb13/ + 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.68 / data rgb14/ + 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 / c c Set background and foreground colors c (black and white are indices 0 and 1 respectively): c call gscr(1,0,0.,0.,0.) call gscr(1,1,1.,1.,1.) c c See if we have color table with desired number of colors: c if (nrgb.eq.12) then do i=1,nrgb rgb(1,i) = rgb12(1,i) rgb(2,i) = rgb12(2,i) rgb(3,i) = rgb12(3,i) enddo elseif (nrgb.eq.13) then do i=1,nrgb rgb(1,i) = rgb13(1,i) rgb(2,i) = rgb13(2,i) rgb(3,i) = rgb13(3,i) enddo elseif (nrgb.eq.14) then do i=1,nrgb rgb(1,i) = rgb14(1,i) rgb(2,i) = rgb14(2,i) rgb(3,i) = rgb14(3,i) enddo else write(6,"('>>> fixrgb: do not have fixed color table for ', + 'nrgb=',i3)") nrgb nrgb = -1 return endif c c Enter color table for gks, also defining iclrs indices: c do i=1,nrgb iclrs(i) = i+1 call gscr(1,iclrs(i),rgb(1,i),rgb(2,i),rgb(3,i)) end do return end