Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

101 lines
3.1 KiB

2 years ago
C The author of this software is Eric Grosse.
C Permission to use, copy, modify, and distribute this software for any
C purpose without fee is hereby granted, provided that this entire notice
C is included in all copies of any software which is or includes a copy
C or modification of this software and in all copies of the supporting
C documentation for such software.
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
C This routine computes colors suitable for use in color level plots.
C Typically s=v=1 and h varies from 0 (red) to 1 (blue) in
C equally spaced steps. (h=.5 gives green; 1<h<1.5 gives magenta.)
C To convert for frame buffer, use R = floor(255.999*pow(*r,1/gamma)) etc.
C To get tables calibrated for other devices or to report complaints,
C contact ehg@research.att.com.
subroutine rainbow(h, s, v, r, g, b)
real h, s, v
real r, g, b
INTEGER i
REAL huettab(0:60)
DATA huettab /0.0000, 0.0062, 0.0130, 0.0202, 0.0280,
* 0.0365, 0.0457, 0.0559, 0.0671, 0.0796,
* 0.0936, 0.1095, 0.1275, 0.1482, 0.1806,
* 0.2113, 0.2393, 0.2652, 0.2892, 0.3119,
* 0.3333, 0.3556, 0.3815, 0.4129, 0.4526,
* 0.5060, 0.5296, 0.5501, 0.5679, 0.5834,
* 0.5970, 0.6088, 0.6191, 0.6281, 0.6361,
* 0.6430, 0.6490, 0.6544, 0.6590, 0.6631,
* 0.6667, 0.6713, 0.6763, 0.6815, 0.6873,
* 0.6937, 0.7009, 0.7092, 0.7190, 0.7308,
* 0.7452, 0.7631, 0.7856, 0.8142, 0.8621,
* 0.9029, 0.9344, 0.9580, 0.9755, 0.9889, 1.0000/
C computed from the FMC-1 color difference formula
C Barco monitor, max(r,g,b)=1, n=61 magenta, 2 Jan 1986
H = 60.0 * MOD(H / 1.5, 1.)
I = INT(H)
H = huettab(i) + (huettab(i+1) - huettab(i)) * (h - i)
CALL dhsv2rgb(h, s, v, r, g, b)
RETURN
END
SUBROUTINE dhsv2rgb(h, s, v, r, g, b)
C...hexcone model...
REAL h, s, v
REAL r, g, b
C...all variables in range [0,1[
C...here, h=.667 gives blue, h=0 or 1 gives red.
C...see Alvy Ray Smith, Color Gamut Transform Pairs, SIGGRAPH '78
INTEGER i
REAL f, m, n, k
h = 6 * mod(h, 1.)
i = int(h)
f = h - i
m = (1 - s)
n = (1 - s * f)
k = (1 - (s * (1 - f)))
if (i .eq. 0) then
r = 1
g = k
b = m
else if (i .eq. 1) then
r = n
g = 1
b = m
else if (i .eq. 2) then
r = m
g = 1
b = k
else if (i .eq. 3) then
r = m
g = n
b = 1
else if (i .eq. 4) then
r = k
g = m
b = 1
else if (i .eq. 5) then
r = 1
g = m
b = n
end if
f = max(r, g, b)
f = v / f
r = r * f
g = g * f
b = b * f
return
end