aboutsummaryrefslogtreecommitdiff
path: root/plotlib/plt_color.f
diff options
context:
space:
mode:
Diffstat (limited to 'plotlib/plt_color.f')
-rw-r--r--plotlib/plt_color.f623
1 files changed, 623 insertions, 0 deletions
diff --git a/plotlib/plt_color.f b/plotlib/plt_color.f
new file mode 100644
index 0000000..3646ab2
--- /dev/null
+++ b/plotlib/plt_color.f
@@ -0,0 +1,623 @@
+C***********************************************************************
+C Module: plt_color.f
+C
+C Copyright (C) 1996 Harold Youngren, Mark Drela
+C
+C This library is free software; you can redistribute it and/or
+C modify it under the terms of the GNU Library General Public
+C License as published by the Free Software Foundation; either
+C version 2 of the License, or (at your option) any later version.
+C
+C This library is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+C Library General Public License for more details.
+C
+C You should have received a copy of the GNU Library General Public
+C License along with this library; if not, write to the Free
+C Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C
+C Report problems to: guppy@maine.com
+C or drela@mit.edu
+C***********************************************************************
+C
+C***********************************************************************
+C --- Xplot11 color plotting routines
+C
+C Version 4.46 11/28/01
+C
+C Note: These routines implement the interface to setup, select and
+C query colors in the XPLOT11 plot package.
+C***********************************************************************
+C
+C The default colormap defines these colors and associated color indices
+C (before the user defines any more)...
+C BLACK = 1
+C WHITE = 2
+C YELLOW = 3
+C ORANGE = 4
+C RED = 5
+C GREEN = 6
+C CYAN = 7
+C BLUE = 8
+C MAGENTA = 9
+C VIOLET = 10
+
+
+ subroutine NEWCOLOR(icol)
+C...Sets color by composite color index
+C color is set by the map index (for +icol)
+C or spectrum index (for -icol)
+C Color map indices run from 0 -> N_COLORS
+C Color spectrum indices run from -1 -> -N_SPECTRUM
+C
+C (see colormap subroutines below for setting colormap colors)
+C
+ include 'pltlib.inc'
+c
+ if(icol.GT.0) then
+ if(icol.GT.N_COLOR) then
+ write(*,*) 'NEWCOLOR: color index out of bounds: ',
+ & icol,N_COLOR
+ return
+ endif
+ icindex = icol
+ else
+ if(-icol.GT.N_SPECTRUM) then
+ write(*,*) 'NEWCOLOR: spectrum index out of bounds: ',
+ & -icol,N_SPECTRUM
+ return
+ endif
+ icindex = IFIRST_SPECTRUM - icol - 1
+ endif
+c
+C...Skip if this is the current color
+ if(icindex.EQ.I_CLR) return
+c
+C...Install color command into display primitives list
+ I_CLR = icindex
+ call putprim(ColorCommand,I_CLR,0.,0.)
+c
+ return
+ end
+
+
+ subroutine GETCOLOR(icol)
+C...Returns current foreground color composite index
+C if icol>0 the index is the color table index (non-spectrum colors)
+C if icol<0 the index is -(color spectrum index)
+C
+ include 'pltlib.inc'
+ if(I_CLR.ge.IFIRST_SPECTRUM .and.
+ & I_CLR.le.IFIRST_SPECTRUM+N_SPECTRUM-1) then
+ icol = IFIRST_SPECTRUM - I_CLR - 1
+ else
+ icol = I_CLR
+ endif
+ return
+ end
+
+
+ subroutine GETCOLORINDEX(icindex)
+C...Returns color table index (not spectrum color index)
+C of current foreground color table index (icindex runs from 0 -> N_COLOR)
+C
+ include 'pltlib.inc'
+ icindex = I_CLR
+ return
+ end
+
+
+ subroutine NEWCOLORNAME(colorname)
+C...Sets color for plotting by named string
+C (to circumvent knowing the color table index)
+C Valid color names (either upper or lower case) are found by
+C running the X11 command: showrgb
+C
+ character colorname*(*), colorin*22
+ include 'pltlib.inc'
+c
+C...Convert input color to uppercase
+ colorin = colorname
+ call convrt2uc(colorin)
+c
+C...Search for color name in current colortable
+ do ic = 1, N_COLOR
+c write(*,*) 'colorbyname table ic=',ic,' ',colorin,' ',
+c & COLOR_NAME(ic),' ci ',G_COLOR_CINDEX(ic)
+ if(colorin.eq.COLOR_NAME(ic)) then
+ call NEWCOLOR(ic)
+ return
+ endif
+ end do
+c
+C...Add new color to colortable
+C...Get RGB components for named color
+ call gw_cname2rgb(colorname,ired,igreen,iblue)
+c write(*,*) 'cname->rgb ',colorname, ired,igreen,iblue
+c
+ if (ired.ge.0) then
+ N = N_COLOR + 1
+ if(N.gt.Ncolors_max) then
+ write(*,*)
+ & 'NEWCOLORNAME: Colortable overflow. New color ignored.'
+ return
+ endif
+ G_COLOR_CINDEX(N) = -1
+ COLOR_RGB(N) = iblue + 256*(igreen + 256*ired)
+ COLOR_NAME(N) = colorin
+ N_COLOR = N
+ call NEWCOLOR(N)
+ else
+ write(*,*)
+ & 'NEWCOLORNAME: Color not found ',colorname
+ endif
+c
+ return
+ end
+
+
+ subroutine NEWCOLORRGB(ired,igreen,iblue)
+C...Sets color for plotting by R,G,B components
+C (to circumvent knowing the color table index)
+C Valid color components for red,green,blue run from 0-255
+C
+ include 'pltlib.inc'
+c
+C...Search for r,g,b color in current colortable
+ do ic = 1, N_COLOR
+ irgb = iblue + 256*(igreen + 256*ired)
+c write(*,*) 'NEWCOLORRGB table ic=',ic,' ',irgb,' ',
+c & COLOR_RGB(ic),
+c & COLOR_NAME(ic),' ci ',G_COLOR_CINDEX(ic)
+ if(irgb.eq.COLOR_RGB(ic)) then
+ call NEWCOLOR(ic)
+ return
+ endif
+ end do
+c
+ N = N_COLOR + 1
+ if(N.gt.Ncolors_max) then
+ write(*,*)
+ & 'NEWCOLORRGB: Colortable overflow. New color ignored.'
+ return
+ endif
+ G_COLOR_CINDEX(N) = -1
+ COLOR_RGB(N) = iblue + 256*(igreen + 256*ired)
+ COLOR_NAME(N) = 'RGBCOLOR'
+ N_COLOR = N
+ call NEWCOLOR(N)
+ return
+ end
+
+
+
+ subroutine GETCOLORRGB(icol,ired,igrn,iblu,colorname)
+C...Gets color information for color designated by index icol
+C if icol<=0, color -icol in Spectrum is queried
+C Returns ired - red color component (0-255) (-1 if no color)
+C igrn - green color component (0-255) (-1 if no color)
+C iblu - blue color component (0-255) (-1 if no color)
+C colorname - name of current color (lowercase)
+C
+ include 'pltlib.inc'
+ character*(*) colorname
+C
+C...First assume color "icol" does not exist
+ ired = -1
+ igrn = -1
+ iblu = -1
+ colorname = ' '
+c
+ if(icol.GT.0) then
+ ic = icol
+ else
+ if(-icol.GT.N_SPECTRUM) then
+ write(*,*) 'GETCOLORRGB: spectrum index out of bounds: ',
+ & -icol,N_SPECTRUM
+ return
+ endif
+ ic = IFIRST_SPECTRUM - icol - 1
+ endif
+c
+ if(ic.GT.N_COLOR) then
+ write(*,*) 'GETCOLORRGB: color index out of bounds: ',
+ & ic,N_COLOR
+ return
+ endif
+c
+ irgb = COLOR_RGB(ic)
+ irg = irgb/256
+ ired = irg/256
+ igrn = irg - 256*ired
+ iblu = irgb - 256*irg
+ colorname = COLOR_NAME(ic)
+c
+ return
+ end
+
+
+ subroutine convrt2uc(input)
+C...Convert string to uppercase
+C Note that the string must be writeable (a variable, not a constant)
+c
+ character*(*) input
+ character*26 lcase, ucase
+ data lcase /'abcdefghijklmnopqrstuvwxyz'/
+ data ucase /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+c
+ n = len(input)
+ do i=1, n
+ k = index(lcase, input(i:i))
+ if(k.gt.0) input(i:i) = ucase(k:k)
+ end do
+c
+ return
+ end
+
+
+ subroutine GETNUMCOLOR(ncol)
+C...Gets current number of defined colors
+C
+ include 'pltlib.inc'
+ ncol = N_COLOR
+ return
+ end
+
+
+ subroutine GETNUMSPECTRUM(nspec)
+C...Gets current number of defined colors in Spectrum
+C
+ include 'pltlib.inc'
+ nspec = N_SPECTRUM
+ return
+ end
+
+
+ subroutine COLORMAPDEFAULT
+C
+C...Creates default colormap palette containing a small number of basic
+C colors defined in DATA statement below. The first two colors
+C are used as the default foreground and background.
+C
+C The default colormap contains these defined colors
+C BLACK = 1
+C WHITE = 2
+C YELLOW = 3
+C ORANGE = 4
+C RED = 5
+C GREEN = 6
+C CYAN = 7
+C BLUE = 8
+C MAGENTA = 9
+C VIOLET = 10
+C
+C These colors are then accessible by a normal NEWCOLOR(icol) call:
+C icol = 1 .. NCMAP
+C
+C Also installs the RGB components of these colors and these color
+C names in the color table. The colorindex is set to -1 to indicate
+C that the color has not yet been mapped to the screen color hardware
+C (this step happens the first time the color is actually used).
+C
+ include 'pltlib.inc'
+c
+ PARAMETER (NCMAP=10)
+C
+ INTEGER DEFCMAPRGB1(3,NCMAP), DEFCMAPRGB0(3,NCMAP)
+ CHARACTER*10 DEFCMAPNAMES(NCMAP)
+c
+ SAVE ifirst
+ DATA ifirst / 0 /
+c
+c DATA ((DEFCMAPRGB(L,I),L=1,3),I=1,NCMAP)
+c & / 0, 0, 0, ! black
+c & 255, 255, 255, ! white
+c & 255, 0, 0, ! red
+c & 255, 165, 0, ! orange
+c & 255, 255, 0, ! yellow
+c & 0, 255, 0, ! green
+c & 0, 255, 255, ! cyan
+c & 0, 0, 255, ! blue
+c & 148, 0, 211 / ! violet
+c & 255, 0, 255, ! magenta
+C
+C---- hues for reverse-video (black background), use full saturation
+ DATA ((DEFCMAPRGB1(L,I),L=1,3),I=1,NCMAP)
+ & / 0, 0, 0, ! black
+ & 255, 255, 255, ! white
+ & 255, 0, 0, ! red
+ & 255, 165, 0, ! orange
+ & 255, 255, 0, ! yellow
+ & 0, 255, 0, ! green
+ & 0, 255, 255, ! cyan
+ & 30, 140, 255, ! blue
+ & 205, 55, 255, ! violet
+ & 255, 0, 255 / ! magenta
+C
+C---- hues for regular-video (white background), use partial saturation
+ DATA ((DEFCMAPRGB0(L,I),L=1,3),I=1,NCMAP)
+ & / 0, 0, 0, ! black
+ & 255, 255, 255, ! white
+ & 255, 0, 0, ! red
+ & 255, 165, 0, ! orange
+ & 220, 220, 0, ! yellow
+ & 0, 225, 0, ! green
+ & 0, 210, 210, ! cyan
+ & 30, 140, 255, ! blue
+ & 205, 55, 255, ! violet
+ & 255, 0, 255 / ! magenta
+C
+ DATA DEFCMAPNAMES
+ & / 'BLACK ',
+ & 'WHITE ',
+ & 'RED ',
+ & 'ORANGE ',
+ & 'YELLOW ',
+ & 'GREEN ',
+ & 'CYAN ',
+ & 'BLUE ',
+ & 'VIOLET ',
+ & 'MAGENTA ' /
+C
+c
+C---Initialize the colormap indices for first call
+ if(ifirst.EQ.0) then
+ N_COLOR = 0
+ N_SPECTRUM = 0
+ IFIRST_SPECTRUM = 0
+ ifirst = 1
+ endif
+C
+C--- Skip installing new default map if there already are NCMAP colors
+ if(N_COLOR.EQ.NCMAP) return
+C
+C--- Flush current colormap if any, to free up space for new map
+ if(N_COLOR.GT.0) call gw_newcmap
+c
+C--- Fill in the colormap with with the default colors and set colorindex
+C to -1 to indicate that the color is still unallocated by hardware
+ IF(LGW_REVVIDEO) THEN
+ do n = 1, NCMAP
+ ired = DEFCMAPRGB1(1,n)
+ igrn = DEFCMAPRGB1(2,n)
+ iblu = DEFCMAPRGB1(3,n)
+ COLOR_RGB(n) = iblu + 256*(igrn + 256*ired)
+ COLOR_NAME(n) = DEFCMAPNAMES(n)
+ G_COLOR_CINDEX(n) = -1
+ end do
+ ELSE
+ do n = 1, NCMAP
+ ired = DEFCMAPRGB0(1,n)
+ igrn = DEFCMAPRGB0(2,n)
+ iblu = DEFCMAPRGB0(3,n)
+ COLOR_RGB(n) = iblu + 256*(igrn + 256*ired)
+ COLOR_NAME(n) = DEFCMAPNAMES(n)
+ G_COLOR_CINDEX(n) = -1
+ end do
+ ENDIF
+C
+ N_COLOR = NCMAP
+c write(*,*) 'COLORMAPDEFAULT: NCOLOR ',N_COLOR
+C
+ return
+ end
+
+
+ subroutine COLORSPECTRUMHUES(ncols,HUESTR)
+ character*(*) HUESTR
+C
+C...Sets up a color "Spectrum" table that gives a continuous
+C blend between a small number of base colors specified in the
+C character string HUESTR, which can be "RYGCBM" or any subset thereof.
+C
+C The RGB components associated with each specified color are set in
+C the DATA statement below. These colors are appended to any existing
+C colormap data, typically set up by COLORMAPDEFAULT.
+C
+C These Spectrum colors are then accessible by NEWCOLOR(-icol)
+C -icol = 1 .. ncols
+C
+C NOTE: The maximum number of colors available to the Spectrum is LESS
+C than the screen depth would indicate. Some of the X colormap
+C is used by other X window applications, typically this will be
+C around 30-40 colormap entries. So, for an 8 bit depth, this
+C leaves around 220 or so available for use, only 210 or so after
+C the Palette colors (typ. 10) are assigned. Less are available
+C if other applications are using the X colormap.
+C
+ include 'pltlib.inc'
+c
+C
+C...RGB components of the Spectrum-defining base colors
+C COLWIDTH controls the relative extent of that defining color
+C
+ parameter (NRGB = 7)
+ dimension irgbhue(3,NRGB), huewidth(NRGB)
+C
+ DIMENSION IRGBTABLE(3,NRGB)
+ DIMENSION COLORWIDTH(NRGB)
+ CHARACTER*(NRGB) COLORCHARS
+c
+ DATA COLORCHARS / 'MBCGYOR' /
+ DATA ( (IRGBTABLE(L,I),L=1,3),COLORWIDTH(I), I=1, NRGB )
+ & / 240, 0, 240, 1.5, ! Magenta
+ & 32, 32, 255, 1.0, ! Blue
+ & 0, 240, 240, 1.0, ! Cyan
+ & 32, 255, 32, 1.0, ! Green
+ & 240, 240, 0, 1.0, ! Yellow
+ & 255, 160, 0, 1.0, ! Orange
+ & 255, 32, 32, 1.5 / ! Red
+C Red Green Blue
+C
+ call convrt2uc(HUESTR)
+ nhuemax = len(HUESTR)
+c
+ nhue = 0
+ do k=1, nhuemax
+ i = index( COLORCHARS , HUESTR(k:k) )
+ if(i.ne.0) then
+ nhue = nhue + 1
+ irgbhue(1,nhue) = IRGBTABLE(1,i)
+ irgbhue(2,nhue) = IRGBTABLE(2,i)
+ irgbhue(3,nhue) = IRGBTABLE(3,i)
+ huewidth(nhue) = COLORWIDTH(i)
+ endif
+ enddo
+c
+ CALL COLORSPECTRUMTRP(ncols,nhue,irgbhue,huewidth)
+C
+ return
+ end
+
+
+
+ subroutine COLORSPECTRUMTRP(ncols,NBASE,IRGBBASE,COLWIDTH)
+C...Interpolates a color "Spectrum" table of 1..ncols colors that are
+C a continuous blend between a small number of defined base colors.
+C The blending between the base colors is controlled by the color
+C "width" COLWIDTH.
+C
+C Input:
+C ncols number desired interpolated colors in spectrum
+C NBASE number base colors defined in IRGBBASE
+C IRGBBASE array(3,*) of integer RGB components for the base colors
+C COLWIDTH color pseudo "width" to use for interpolation
+C
+C Overwrites the definition of any existing Spectrum.
+C
+C
+ DIMENSION IRGBBASE(3,NBASE)
+ DIMENSION COLWIDTH(NBASE)
+C
+ include 'pltlib.inc'
+C
+ DIMENSION COLAXIS(NColors_max), IRGBTBL(3,NColors_max)
+c
+ if(NBASE.GT.NColors_max)
+ & STOP 'COLORSPECTRUM: Local IRGBBASE array overflow.'
+C
+C
+C---Don't allow less than 2 spectrum colors defined by interpolation table
+ if(ncols.LT.2) return
+c
+C--- Check to make sure we have enough room in the color table
+ if(N_COLOR+ncols+1 .gt. Ncolors_max) then
+ write(*,*) 'COLORSPECTRUMTRP: Too many colors specified.'
+ return
+ endif
+C
+ COLAXIS(1) = 0.
+ do ibase=2, NBASE
+ COLAXIS(ibase) = COLAXIS(ibase-1)
+ & + 0.5*(COLWIDTH(ibase-1)+COLWIDTH(ibase))
+ if(COLAXIS(ibase) .LE. COLAXIS(ibase-1))
+ & STOP 'COLORSPECTRUM: Non-monotonic color axis. Check COLWIDTH.'
+ enddo
+C
+C--- Now fill in the rgb table for the Spectrum colors,
+C interpolating colors between the entries in the passed-in color table
+ ibase = 1
+ do i = 1, ncols
+ xcol = COLAXIS(NBASE) * float(i-1)/float(ncols-1)
+c
+ 5 xnorm = (xcol -COLAXIS(ibase))
+ & / (COLAXIS(ibase+1)-COLAXIS(ibase))
+c
+ if(xnorm.GT.1.0 .AND. ibase.LT.NBASE) then
+ ibase = ibase + 1
+ go to 5
+ endif
+c
+ w0 = COLWIDTH(ibase )
+ w1 = COLWIDTH(ibase+1)
+ frac = w1*xnorm / (w0 + (w1-w0)*xnorm)
+C
+ red0 = float(IRGBBASE(1,ibase) )
+ grn0 = float(IRGBBASE(2,ibase) )
+ blu0 = float(IRGBBASE(3,ibase) )
+ red1 = float(IRGBBASE(1,ibase+1))
+ grn1 = float(IRGBBASE(2,ibase+1))
+ blu1 = float(IRGBBASE(3,ibase+1))
+c
+ IRGBTBL(1,i) = ifix( (red0 + frac*(red1-red0)) + 0.5 )
+ IRGBTBL(2,i) = ifix( (grn0 + frac*(grn1-grn0)) + 0.5 )
+ IRGBTBL(3,i) = ifix( (blu0 + frac*(blu1-blu0)) + 0.5 )
+ end do
+ call COLORSPECTRUMRGB(ncols,IRGBTBL)
+c
+ return
+ end
+
+
+ subroutine COLORSPECTRUMRGB(NRGB,IRGB)
+C...Sets up a color "Spectrum" table for NRGB colors that are
+C defined by r,g,b values (0-255) in the IRGB array.
+C
+C Input:
+C NRGB number r,g,b colors defined in IRGB
+C IRGB array(3,*) of integer RGB components for the colors
+C
+C Overwrites any existing Spectrum.
+C
+ DIMENSION IRGB(3,NRGB)
+C
+ include 'pltlib.inc'
+C
+ if(N_COLOR.LE.0 .OR. N_COLOR.GT.10) then
+ CALL COLORMAPDEFAULT
+ endif
+C
+C--- Check to make sure we have enough room in the color table
+ if(N_COLOR+NRGB .gt. Ncolors_max) then
+ write(*,*) 'COLORSPECTRUMRGB: Too many colors specified.'
+ return
+ endif
+C
+C--- starting index of Spectrum in colormap arrays
+ IFIRST_SPECTRUM = N_COLOR + 1
+C
+C--- Now fill in the Spectrum colors from the passed-in color table
+ do i = 1, NRGB
+ ired = IRGB(1,i)
+ igrn = IRGB(2,i)
+ iblu = IRGB(3,i)
+C
+ IC = IFIRST_SPECTRUM + i - 1
+c
+ COLOR_RGB(IC) = iblu + 256*(igrn + 256*ired)
+ COLOR_NAME(IC) = 'SPECTRUM'
+ G_COLOR_CINDEX(IC) = -1
+ end do
+c
+ N_SPECTRUM = NRGB
+ N_COLOR = IC
+c write(*,*) 'COLORSPECTRUMRGB: NCOLOR,NSPECTRUM ',N_COLOR,N_SPECTRUM
+c
+ return
+ end
+
+
+
+ subroutine LWR2UPR(INPUT)
+ CHARACTER*(*) INPUT
+C
+ CHARACTER*26 LCASE, UCASE
+ DATA LCASE / 'abcdefghijklmnopqrstuvwxyz' /
+ DATA UCASE / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
+C
+ N = LEN(INPUT)
+C
+ do I=1, N
+ K = INDEX( LCASE , INPUT(I:I) )
+ IF(K.GT.0) INPUT(I:I) = UCASE(K:K)
+ end do
+C
+ return
+ end
+
+
+
+
+
+