subroutine angle_to_rgb ( angle, r, g, b ) !*****************************************************************************80 ! !! ANGLE_TO_RGB returns a color on the perimeter of the color hexagon. ! ! Modified: ! ! 13 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) ANGLE, the angle in the color hexagon. ! The sextants are defined by the following points: ! 0 degrees, 1, 0, 0, red; ! 60 degrees, 1, 1, 0, yellow; ! 120 degrees, 0, 1, 0, green; ! 180 degrees, 0, 1, 1, cyan; ! 240 degrees, 0, 0, 1, blue; ! 300 degrees, 1, 0, 1, magenta. ! ! Output, real ( kind = 8 ) R, G, B, RGB specifications for the color ! that lies at the given angle, on the perimeter of the color hexagon. One ! value will be 1, and one value will be 0. ! implicit none real ( kind = 8 ) angle real ( kind = 8 ) angle2 real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ), parameter :: degrees_to_radians = & 3.141592653589793D+00 / 180.0D+00 real ( kind = 8 ) r angle = mod ( angle, 360.0D+00 ) if ( angle < 0.0D+00 ) then angle = angle + 360.0D+00 end if if ( angle <= 60.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * angle / 4.0D+00 r = 1.0D+00 g = tan ( angle2 ) b = 0.0D+00 else if ( angle <= 120.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * angle / 4.0D+00 r = cos ( angle2 ) / sin ( angle2 ) g = 1.0D+00 b = 0.0D+00 else if ( angle <= 180.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 120.0D+00 ) / 4.0D+00 r = 0.0D+00 g = 1.0D+00 b = tan ( angle2 ) else if ( angle <= 240.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 120.0D+00 ) / 4.0D+00 r = 0.0D+00 g = cos ( angle2 ) / sin ( angle2 ) b = 1.0D+00 else if ( angle <= 300.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 240.0D+00 ) / 4.0D+00 r = tan ( angle2 ) g = 0.0D+00 b = 1.0D+00 else if ( angle <= 360.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 240.0D+00 ) / 4.0D+00 r = 1.0D+00 g = 0.0D+00 b = cos ( angle2 ) / sin ( angle2 ) end if return end function atan4 ( y, x ) !*****************************************************************************80 ! !! ATAN4 computes the inverse tangent of the ratio Y / X. ! ! Discussion: ! ! ATAN4 returns an angle whose tangent is ( Y / X ), a job which ! the built in functions ATAN and ATAN2 already do. ! ! However: ! ! * ATAN4 always returns a positive angle, between 0 and 2 PI, ! while ATAN and ATAN2 return angles in the interval [-PI/2,+PI/2] ! and [-PI,+PI] respectively; ! ! * ATAN4 accounts for the signs of X and Y, (as does ATAN2). The ATAN ! function by contrast always returns an angle in the first or fourth ! quadrants. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) Y, X, two quantities which represent the ! tangent of an angle. If Y is not zero, then the tangent is (Y/X). ! ! Output, real ( kind = 8 ) ATAN4, an angle between 0 and 2 * PI, whose ! tangent is (Y/X), and which lies in the appropriate quadrant so that ! the signs of its cosine and sine match those of X and Y. ! implicit none real ( kind = 8 ) abs_x real ( kind = 8 ) abs_y real ( kind = 8 ) atan4 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) theta real ( kind = 8 ) theta_0 real ( kind = 8 ) x real ( kind = 8 ) y ! ! Special cases: ! if ( x == 0.0D+00 ) then if ( 0.0D+00 < y ) then theta = pi / 2.0D+00 else if ( y < 0.0D+00 ) then theta = 3.0D+00 * pi / 2.0D+00 else if ( y == 0.0D+00 ) then theta = 0.0D+00 end if else if ( y == 0.0D+00 ) then if ( 0.0D+00 < x ) then theta = 0.0D+00 else if ( x < 0.0D+00 ) then theta = pi end if ! ! We assume that ATAN2 is correct when both arguments are positive. ! else abs_y = abs ( y ) abs_x = abs ( x ) theta_0 = atan2 ( abs_y, abs_x ) if ( 0.0D+00 < x .and. 0.0D+00 < y ) then theta = theta_0 else if ( x < 0.0D+00 .and. 0.0D+00 < y ) then theta = pi - theta_0 else if ( x < 0.0D+00 .and. y < 0.0D+00 ) then theta = pi + theta_0 else if ( 0.0D+00 < x .and. y < 0.0D+00 ) then theta = 2.0D+00 * pi - theta_0 end if end if atan4 = theta return end subroutine ch_cap ( c ) !*****************************************************************************80 ! !! CH_CAP capitalizes a single character. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none character c integer itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine chart_xyz_cap ( xcap, ycap, zcap, color ) !*****************************************************************************80 ! !! CHART_XYZ_CAP returns the CIE XYZ values of a 24 box color chart. ! ! Diagram: ! ! The chart may be drawn as a set of 4 rows of 6 squares of color: ! ! 1 2 3 4 5 6 ! 7 8 9 10 11 12 ! 13 14 15 16 17 18 ! 19 20 21 22 23 24 ! ! Modified: ! ! 04 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Roy Hall, ! Illumination and Color in Computer Generated Imagery, ! Springer Verlag, 1988. ! ! Calvin McCamy, H Marcus and J G Davidson, ! A Color Rendition Chart, ! Journal of Applied Photographic Engineering, ! Volume 11, number 3, pages 95-99. ! ! Parameters: ! ! Output, real ( kind = 8 ) XCAP(24), YCAP(24), ZCAP(24), the CIE XYZ ! color coordinates of the color squares. ! ! Output, character ( len = * ) COLOR(24), the names of the colors. ! The names are up to 14 characters in length. ! implicit none character ( len = * ) color(24) real ( kind = 8 ) xcap(24) real ( kind = 8 ) ycap(24) real ( kind = 8 ) zcap(24) color(1) = 'dark skin' xcap(1) = 0.092D+00 ycap(1) = 0.081D+00 zcap(1) = 0.058D+00 color(2) = 'light skin' xcap(2) = 0.411D+00 ycap(2) = 0.376D+00 zcap(2) = 0.303D+00 color(3) = 'blue sky' xcap(3) = 0.183D+00 ycap(3) = 0.186D+00 zcap(3) = 0.373D+00 color(4) = 'foliage' xcap(4) = 0.094D+00 ycap(4) = 0.117D+00 zcap(4) = 0.067D+00 color(5) = 'blue flower' xcap(5) = 0.269D+00 ycap(5) = 0.244D+00 zcap(5) = 0.503D+00 color(6) = 'bluish green' xcap(6) = 0.350D+00 ycap(6) = 0.460D+00 zcap(6) = 0.531D+00 color(7) = 'orange' xcap(7) = 0.386D+00 ycap(7) = 0.311D+00 zcap(7) = 0.066D+00 color(8) = 'purplish blue' xcap(8) = 0.123D+00 ycap(8) = 0.102D+00 zcap(8) = 0.359D+00 color(9) = 'moderate red' xcap(9) = 0.284D+00 ycap(9) = 0.192D+00 zcap(9) = 0.151D+00 color(10) = 'purple' xcap(10) = 0.059D+00 ycap(10) = 0.040D+00 zcap(10) = 0.102D+00 color(11) = 'yellow green' xcap(11) = 0.368D+00 ycap(11) = 0.474D+00 zcap(11) = 0.127D+00 color(12) = 'orange yellow' xcap(12) = 0.497D+00 ycap(12) = 0.460D+00 zcap(12) = 0.094D+00 color(13) = 'blue' xcap(13) = 0.050D+00 ycap(13) = 0.035D+00 zcap(13) = 0.183D+00 color(14) = 'green' xcap(14) = 0.149D+00 ycap(14) = 0.234D+00 zcap(14) = 0.106D+00 color(15) = 'red' xcap(15) = 0.176D+00 ycap(15) = 0.102D+00 zcap(15) = 0.048D+00 color(16) = 'yellow' xcap(16) = 0.614D+00 ycap(16) = 0.644D+00 zcap(16) = 0.112D+00 color(17) = 'magenta' xcap(17) = 0.300D+00 ycap(17) = 0.192D+00 zcap(17) = 0.332D+00 color(18) = 'cyan' xcap(18) = 0.149D+00 ycap(18) = 0.192D+00 zcap(18) = 0.421D+00 color(19) = 'white' xcap(19) = 0.981D+00 ycap(19) = 1.000D+00 zcap(19) = 1.184D+00 color(20) = 'neutral 8' xcap(20) = 0.632D+00 ycap(20) = 0.644D+00 zcap(20) = 0.763D+00 color(21) = 'neutral 6.5' xcap(21) = 0.374D+00 ycap(21) = 0.381D+00 zcap(21) = 0.451D+00 color(22) = 'neutral 5' xcap(22) = 0.189D+00 ycap(22) = 0.192D+00 zcap(22) = 0.227D+00 color(23) = 'neutral 3.5' xcap(23) = 0.067D+00 ycap(23) = 0.068D+00 zcap(23) = 0.080D+00 color(24) = 'black' xcap(24) = 0.000D+00 ycap(24) = 0.000D+00 zcap(24) = 0.000D+00 return end subroutine cmy_check ( c, m, y ) !*****************************************************************************80 ! !! CMY_CHECK corrects out-of-range CMY color coordinates. ! ! Definition: ! ! The CMY color system describes a color based on the amounts of the ! base colors cyan, magenta, and yellow. Thus, a particular color ! has three coordinates, (C,M,Y). Each coordinate must be between ! 0 and 1. ! ! Examples: ! ! Black (1,1,1) ! Blue (1,1,0) ! Cyan (1,0,0) ! Green (1,0,1) ! Magenta (0,1,0) ! Red (0,1,1) ! White (0,0,0) ! Yellow (0,0,1) ! ! Modified: ! ! 25 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) C, M, Y, the CMY color coordinates ! to be checked. Any value less than 0 is increased to zero. ! Any value greater than 1 is decreased to 1. ! implicit none real ( kind = 8 ) c real ( kind = 8 ) m real ( kind = 8 ) y c = max ( c, 0.0D+00 ) c = min ( c, 1.0D+00 ) m = max ( m, 0.0D+00 ) m = min ( m, 1.0D+00 ) y = max ( y, 0.0D+00 ) y = min ( y, 1.0D+00 ) return end subroutine cmy_to_cmyk ( c, m, y, c2, m2, y2, k2 ) !*****************************************************************************80 ! !! CMY_TO_CMYK converts CMY to CMYK color coordinates. ! ! Definition: ! ! The CMY color system describes a color based on the amounts of the ! base colors cyan, magenta, and yellow. Thus, a particular color ! has three coordinates, (C,M,Y). Each coordinate must be between ! 0 and 1. Black is (1,1,1) and white is (0,0,0). ! ! The CMYK color system describes a color based on the amounts of the ! base colors cyan, magenta, yellow, and black. The CMYK system is ! based on the CMY system, except that equal amounts of C, M, and Y ! are replaced by the single color K. Thus, a particular color ! has four coordinates, (C,M,Y,K). Each coordinate must be between ! 0 and 1, and it must also be true that C+K, M+K and Y+K are ! each no greater than 1. ! ! Formula: ! ! K2 = min ( C, M, Y ) ! C2 = C - K2 ! M2 = M - K2 ! Y2 = Y - K2 ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) C, M, Y, the CMY color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) C2, M2, Y2, K2, the corresponding CMYK ! color coordinates. ! implicit none real ( kind = 8 ) c real ( kind = 8 ) c2 real ( kind = 8 ) k2 real ( kind = 8 ) m real ( kind = 8 ) m2 real ( kind = 8 ) y real ( kind = 8 ) y2 k2 = min ( c, m, y ) c2 = c - k2 m2 = m - k2 y2 = y - k2 return end subroutine cmy_to_rgb ( c, m, y, r, g, b ) !*****************************************************************************80 ! !! CMY_TO_RGB converts CMY to RGB color coordinates. ! ! Definition: ! ! The CMY color system describes a color based on the amounts of the ! base colors cyan, magenta, and yellow. Thus, a particular color ! has three coordinates, (C,M,Y). Each coordinate must be between ! 0 and 1. Black is (1,1,1) and white is (0,0,0). ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Formula: ! ! R = 1.0D+00 - C ! G = 1.0D+00 - M ! B = 1.0D+00 - Y ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) C, M, Y, the CMY color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) g real ( kind = 8 ) m real ( kind = 8 ) r real ( kind = 8 ) y r = 1.0D+00 - c g = 1.0D+00 - m b = 1.0D+00 - y return end subroutine cmyk_check ( c, m, y, k ) !*****************************************************************************80 ! !! CMYK_CHECK corrects out-of-range CMYK color coordinates. ! ! Definition: ! ! The CMYK color system describes a color based on the amounts of the ! base colors cyan, magenta, yellow, and black. The CMYK system is ! based on the CMY system, except that equal amounts of C, M, and Y ! are replaced by the single color K. Thus, a particular color ! has four coordinates, (C,M,Y,K). Each coordinate must be between ! 0 and 1, and it must also be true that C+K, M+K and Y+K are ! each no greater than 1. ! ! Examples: ! ! Black (0,0,0,1) ! Blue (1,1,0,0) ! Cyan (1,0,0,0) ! Green (1,0,1,0) ! Magenta (0,1,0,0) ! Red (0,1,1,0) ! White (0,0,0,0) ! Yellow (0,0,1,0) ! ! Modified: ! ! 26 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) C, M, Y, K, the CMYK color coordinates ! to be checked. ! Any value less than 0 is increased to zero. ! Any value greater than 1 is decreased to 1. ! Then, if any of C+K, M+K or Y+K is greater than 1, C, M or Y is reduced ! accordingly. ! implicit none real ( kind = 8 ) c real ( kind = 8 ) k real ( kind = 8 ) m real ( kind = 8 ) y ! ! 1: Enforce the simple rule that C, M, Y and K must lie between 0 and 1. ! c = max ( c, 0.0D+00 ) c = min ( c, 1.0D+00 ) m = max ( m, 0.0D+00 ) m = min ( m, 1.0D+00 ) y = max ( y, 0.0D+00 ) y = min ( y, 1.0D+00 ) k = max ( k, 0.0D+00 ) k = min ( k, 1.0D+00 ) ! ! 2: Enforce C+K, M+K, Y+K each no greater than 1. ! c = min ( c, 1.0D+00 - k ) m = min ( m, 1.0D+00 - k ) y = min ( y, 1.0D+00 - k ) return end subroutine cmyk_to_cmy ( c, m, y, k, c2, m2, y2 ) !*****************************************************************************80 ! !! CMYK_TO_CMY converts CMYK to CMY color coordinates. ! ! Definition: ! ! The CMYK color system describes a color based on the amounts of the ! base colors cyan, magenta, yellow, and black. The CMYK system is ! based on the CMY system, except that equal amounts of C, M, and Y ! are replaced by the single color K. Thus, a particular color ! has four coordinates, (C,M,Y,K). Each coordinate must be between ! 0 and 1, and it must also be true that C+K, M+K and Y+K are ! each no greater than 1. ! ! The CMY color system describes a color based on the amounts of the ! base colors cyan, magenta, and yellow. Thus, a particular color ! has three coordinates, (C,M,Y). Each coordinate must be between ! 0 and 1. Black is (1,1,1) and white is (0,0,0). ! ! Formula: ! ! C2 = C + K ! M2 = M + K ! Y2 = Y + K ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) C, M, Y, K, the CMYK color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) C2, M2, Y2, the corresponding CMY color ! coordinates. ! implicit none real ( kind = 8 ) c real ( kind = 8 ) c2 real ( kind = 8 ) k real ( kind = 8 ) m real ( kind = 8 ) m2 real ( kind = 8 ) y real ( kind = 8 ) y2 c2 = c + k m2 = m + k y2 = y + k return end subroutine cmyk_to_rgb ( c, m, y, k, r, g, b ) !*****************************************************************************80 ! !! CMYK_TO_RGB converts CMYK to RGB color coordinates. ! ! Definition: ! ! The CMYK color system describes a color based on the amounts of the ! base colors cyan, magenta, yellow, and black. The CMYK system is ! based on the CMY system, except that equal amounts of C, M, and Y ! are replaced by the single color K. Thus, a particular color ! has four coordinates, (C,M,Y,K). Each coordinate must be between ! 0 and 1, and it must also be true that C+K, M+K and Y+K are ! each no greater than 1. ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) C, M, Y, K, the CMYK color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) g real ( kind = 8 ) k real ( kind = 8 ) m real ( kind = 8 ) r real ( kind = 8 ) y r = 1.0D+00 - ( c + k ) g = 1.0D+00 - ( m + k ) b = 1.0D+00 - ( y + k ) return end subroutine get_seed ( iseed ) !*****************************************************************************80 ! !! GET_SEED returns a seed for the random number generator. ! ! Discussion: ! ! The seed depends on the current time, and ought to be (slightly) ! different every millisecond. Once the seed is obtained, a random ! number generator should be called a few times to further process ! the seed. ! ! Modified: ! ! 23 March 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ISEED, a pseudorandom seed value. ! implicit none integer iseed double precision temp character ( len = 10 ) time character ( len = 8 ) today integer values(8) character ( len = 5 ) zone call date_and_time ( today, time, zone, values ) temp = 0.0D+00 temp = temp + dble ( values(2) - 1 ) / 11.0D+00 temp = temp + dble ( values(3) - 1 ) / 30.0D+00 temp = temp + dble ( values(5) ) / 23.0D+00 temp = temp + dble ( values(6) ) / 59.0D+00 temp = temp + dble ( values(7) ) / 59.0D+00 temp = temp + dble ( values(8) ) / 999.0D+00 temp = temp / 6.0D+00 if ( temp <= 0.0D+00 ) then temp = 1.0D+00 / 3.0D+00 else if ( 1.0D+00 <= temp ) then temp = 2.0D+00 / 3.0D+00 end if iseed = int ( dble ( huge ( iseed ) ) * temp ) ! ! Never use a seed of 0 or maximum integer. ! if ( iseed == 0 ) then iseed = 1 end if if ( iseed == huge ( iseed ) ) then iseed = huge ( iseed ) - 1 end if return end subroutine get_unit ( iunit ) !*****************************************************************************80 ! !! GET_UNIT returns a free FORTRAN unit number. ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5, 6 and 9, which ! are commonly reserved for console I/O). ! ! Otherwise, IUNIT is an integer between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! ! Modified: ! ! 18 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT, the free unit number. ! implicit none integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do return end subroutine grayscale_luv ( n, l, u, v ) !*****************************************************************************80 ! !! GRAYSCALE_LUV returns a grayscale in the CIE LUV system. ! ! Discussion: ! ! Only the L (lightness) coordinate does anything interesting. ! The U and V coordinates will all be 0. ! ! Modified: ! ! 05 August 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of levels in the gray scale. ! ! Output, real ( kind = 8 ) L(N), U(N), V(N), the CIE LUV color coordinates ! of the gray scale. ! implicit none integer n integer i real ( kind = 8 ) l(n) real ( kind = 8 ), parameter :: l_hi = 100.0D+00 real ( kind = 8 ), parameter :: l_lo = 0.0D+00 real ( kind = 8 ) u(n) real ( kind = 8 ) v(n) if ( n < 1 ) then return end if if ( n == 1 ) then l(1) = ( l_lo + l_hi ) / 2.0D+00 else do i = 1, n l(i) = ( real ( n - i, kind = 8 ) * l_lo & + real ( i - 1, kind = 8 ) * l_hi ) & / real ( n - 1, kind = 8 ) end do end if u(1:n) = 0.0D+00 v(1:n) = 0.0D+00 return end subroutine grayscale_rgb ( n, r, g, b ) !*****************************************************************************80 ! !! GRAYSCALE_RGB returns a grayscale in the RGB system. ! ! Discussion: ! ! All we do here is make a linear gray scale, and then run it ! through the gamma correction. I have no evidence that this ! is the right thing to do. My hope is that the grays will ! seem more equally spaced. ! ! Modified: ! ! 05 August 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of levels in the gray scale. ! ! Output, real ( kind = 8 ) R(N), G(N), B(N), the RGB color coordinates ! of the gray scale. ! implicit none integer n real ( kind = 8 ) b(n) real ( kind = 8 ) g(n) integer i real ( kind = 8 ) r(n) real ( kind = 8 ) v real ( kind = 8 ), parameter :: v_hi = 1.0D+00 real ( kind = 8 ), parameter :: v_lo = 0.0D+00 real ( kind = 8 ) v_prime if ( n < 1 ) then return end if if ( n == 1 ) then v = ( v_lo + v_hi ) / 2.0D+00 call lin_to_nonlin ( v, v_prime ) r(1) = v_prime else do i = 1, n v = ( real ( n - i, kind = 8 ) * v_lo & + real ( i - 1, kind = 8 ) * v_hi ) & / real ( n - 1, kind = 8 ) call lin_to_nonlin ( v, v_prime ) r(i) = v_prime end do end if g(1:n) = r(1:n) b(1:n) = r(1:n) return end subroutine hls_check ( h, l, s ) !*****************************************************************************80 ! !! HLS_CHECK corrects out-of-range HLS color coordinates. ! ! Definition: ! ! The HLS color system describes a color based on the qualities of ! hue, lightness, and saturation. A particular color has three ! coordinates, (H,L,S). The L and S coordinates must be between ! 0 and 1, while the H coordinate must be between 0 and 360, and ! is interpreted as an angle. ! ! The HLS color space is usually thought of as a double hexcone. ! If the L coordinate is vertical, then the color space is a single ! black point at L = 0, expands to a colorful hexagon ! at L = 0.5, and contracts again to a white point at L = 1. ! The colorful hexagon as the colors Red, Yellow, Green, Cyan, Blue, ! and Magenta at its vertices. ! The saturation coordinate varies from 0.0D+00 at the center of the ! hexagon to 1.0D+00 at the boundary. The corresponding color varies ! from gray at S = 0 to the full color on the boundary at S = 1. ! ! If the (H,S) plane is thought of as a circle, then S is the relative ! distance from the central vertical L axis to the boundary of the hexcone. ! Thus, even as the cone contracts to a point, S can always vary ! from 0 to 1. In particular, the white point can have coordinates ! ( H, 1.0, S ) where H is any value in [ 0, 360.0D+00 ) and S is ! any value in [ 0.0, 1.0D+00 ]. ! ! Note: ! ! Some versions of the HLS model assign Blue to have HLS coordinates ! ( 0.0, 0.5, 1.0D+00 ) instead of Red, rotating all the colors ahead ! 120 degrees. ! ! Some versions define L as equal to the average of R, G and B, rather ! than the average of the maximum and minimum of R, G and B. ! ! Examples: ! ! Given RED = ( 0.0, 0.5, 1.0D+00 ) then: ! ! Black ( 0.0, 0.0, 0.0D+00 ) ! Blue ( 240.0, 0.5, 1.0D+00 ) ! Cyan ( 180.0, 0.5, 1.0D+00 ) ! Green ( 120.0, 0.5, 1.0D+00 ) ! Magenta ( 300.0, 0.5, 1.0D+00 ) ! Red ( 0.0, 0.5, 1.0D+00 ) ! White ( 0.0, 1.0, 0.0D+00 ) ! Yellow ( 60.0, 0.5, 1.0D+00 ) ! ! Modified: ! ! 25 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) H, L, S, the HLS color coordinates to ! be checked. If H is outside the range [0, 360), it is brought back in ! range using a MOD operation. ! Values of L or S less than 0 are set to 0, greater than 1 are set ! to 1. ! implicit none real ( kind = 8 ) r8_modp real ( kind = 8 ) h real ( kind = 8 ) l real ( kind = 8 ) s h = r8_modp ( h, 360.0D+00 ) l = max ( l, 0.0D+00 ) l = min ( l, 1.0D+00 ) s = max ( s, 0.0D+00 ) s = min ( s, 1.0D+00 ) return end subroutine hls_to_rgb ( h, l, s, r, g, b ) !*****************************************************************************80 ! !! HLS_TO_RGB converts HLS to RGB color coordinates. ! ! Definition: ! ! The HLS color system describes a color based on the qualities of ! hue, lightness, and saturation. A particular color has three ! coordinates, (H,L,S). The L and S coordinates must be between ! 0 and 1, while the H coordinate must be between 0 and 360, and ! is interpreted as an angle. ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) H, L, S, the HLS color coordinates to ! be converted. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ) h real ( kind = 8 ) hls_value real ( kind = 8 ) l real ( kind = 8 ) m1 real ( kind = 8 ) m2 real ( kind = 8 ) r real ( kind = 8 ) s if ( l <= 0.5D+00 ) then m2 = l + l * s else m2 = l + s - l * s end if m1 = 2.0D+00 * l - m2 if ( s == 0.0D+00 ) then r = l g = l b = l else r = hls_value ( m1, m2, h + 120.0D+00 ) g = hls_value ( m1, m2, h ) b = hls_value ( m1, m2, h - 120.0D+00 ) end if return end function hls_value ( n1, n2, h ) !*****************************************************************************80 ! !! HLS_VALUE is a utility function used by HLS_TO_RGB. ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) N1, N2, H. ! ! Output, real ( kind = 8 ) HLS_VALUE. ! implicit none real ( kind = 8 ) r8_modp real ( kind = 8 ) h real ( kind = 8 ) hls_value real ( kind = 8 ) hue real ( kind = 8 ) n1 real ( kind = 8 ) n2 ! ! Make sure HUE lies between 0 and 360. ! hue = r8_modp ( h, 360.0D+00 ) if ( hue < 60.0D+00 ) then hls_value = n1 + ( n2 - n1 ) * hue / 60.0D+00 else if ( hue < 180.0D+00 ) then hls_value = n2 else if ( hue < 240.0D+00 ) then hls_value = n1 + ( n2 - n1 ) * ( 240.0D+00 - hue ) / 60.0D+00 else hls_value = n1 end if return end subroutine hsi_to_rgb ( h, s, i, r, g, b ) !*****************************************************************************80 ! !! HSI_TO_RGB converts HSI to RGB color coordinates. ! ! Definition: ! ! The HSI color system uses coordinates of ! Hue, an angle between 0 and 360, (0=R, 120=G, 240=B) ! Saturation, between 0 and 1, and ! Intensity, between 0 and 1. ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Modified: ! ! 05 August 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) H, S, I, the HSI color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) r8_modp real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ) h real ( kind = 8 ) h2 real ( kind = 8 ) i real ( kind = 8 ) r real ( kind = 8 ) s ! ! Ensure the H2 lies between 0 and 360. ! h2 = r8_modp ( h, 360.0D+00 ) ! ! Now turn H2 into a fraction of a full rotation, between 0 and 1. ! h2 = h2 / 360.0D+00 if ( 3.0D+00 * h2 < 1.0D+00 ) then h2 = 2.0D+00 * pi * h2 b = ( 1.0D+00 - s ) / 3.0D+00 r = 1.0D+00 + s * cos ( h2 ) / cos ( pi / 3.0D+00 - h2 ) r = r / 3.0D+00 g = 1.0D+00 - b - r else if ( 3.0D+00 * h2 < 2.0D+00 ) then h2 = 2.0D+00 * pi * ( h2 - 1.0D+00 / 3.0D+00 ) r = ( 1.0D+00 - s ) / 3 g = 1.0D+00 + s * cos ( h2 ) / cos ( pi / 3.0D+00 - h2 ) g = g / 3.0D+00 b = 1.0D+00 - r - g else h2 = 2.0D+00 * pi * ( h2 - 2.0D+00 / 3.0D+00 ) g = ( 1.0D+00 - s ) / 3.0D+00 b = 1.0D+00 + s * cos ( h2 ) / cos ( pi / 3.0D+00 - h2 ) b = b / 3.0D+00 r = 1.0D+00 - g - b end if r = r * i * 3.0D+00 g = g * i * 3.0D+00 b = b * i * 3.0D+00 return end subroutine hsv_check ( h, s, v ) !*****************************************************************************80 ! !! HSV_CHECK corrects out-of-range HSV color coordinates. ! ! Definition: ! ! The HSV color system describes a color based on the three qualities ! of hue, saturation, and value. A given color will be represented ! by three numbers, (H,S,V). H, the value of hue, is an angle ! between 0 and 360 degrees, with 0 representing red. S is the ! saturation, and is between 0 and 1. Finally, V is the "value", ! a measure of brightness, which goes from 0 for black, increasing ! to a maximum of 1 for the brightest colors. The HSV color system ! is sometimes also called HSB, where the B stands for brightness. ! ! Examples: ! ! Black ( 0.000 0.000 0.000 ) ! Blue ( 240.000 1.000 1.000 ) ! Cyan ( 180.000 1.000 1.000 ) ! Green ( 120.000 1.000 1.000 ) ! Magenta ( 300.000 1.000 1.000 ) ! Red ( 0.000 1.000 1.000 ) ! White ( 0.000 0.000 1.000 ) ! Yellow ( 60.000 1.000 1.000 ) ! ! Modified: ! ! 30 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) H, S, V, the HSV color coordinates to ! be checked. ! implicit none real ( kind = 8 ) r8_modp real ( kind = 8 ) h real ( kind = 8 ) s real ( kind = 8 ) v h = r8_modp ( h, 360.0D+00 ) s = max ( s, 0.0D+00 ) s = min ( s, 1.0D+00 ) v = max ( v, 0.0D+00 ) v = min ( v, 1.0D+00 ) return end subroutine hsv_to_rgb ( h, s, v, r, g, b ) !*****************************************************************************80 ! !! HSV_TO_RGB converts HSV to RGB color coordinates. ! ! Definition: ! ! The HSV color system describes a color based on the three qualities ! of hue, saturation, and value. A given color will be represented ! by three numbers, (H,S,V). H, the value of hue, is an angle ! between 0 and 360 degrees, with 0 representing red. S is the ! saturation, and is between 0 and 1. Finally, V is the "value", ! a measure of brightness, which goes from 0 for black, increasing ! to a maximum of 1 for the brightest colors. The HSV color system ! is sometimes also called HSB, where the B stands for brightness. ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) H, S, V, the HSV color coordinates to ! be converted. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) r8_modp real ( kind = 8 ) f real ( kind = 8 ) g real ( kind = 8 ) h real ( kind = 8 ) hue integer i real ( kind = 8 ) p real ( kind = 8 ) q real ( kind = 8 ) r real ( kind = 8 ) s real ( kind = 8 ) t real ( kind = 8 ) v if ( s == 0.0D+00 ) then r = v g = v b = v else ! ! Make sure HUE lies between 0 and 360.0D+00 ! hue = r8_modp ( h, 360.0D+00 ) hue = hue / 60.0D+00 i = int ( hue ) f = hue - real ( i, kind = 8 ) p = v * ( 1.0D+00 - s ) q = v * ( 1.0D+00 - s * f ) t = v * ( 1.0D+00 - s + s * f ) if ( i == 0 ) then r = v g = t b = p else if ( i == 1 ) then r = q g = v b = p else if ( i == 2 ) then r = p g = v b = t else if ( i == 3 ) then r = p g = q b = v else if ( i == 4 ) then r = t g = p b = v else if ( i == 5 ) then r = v g = p b = q end if end if return end subroutine hvc_check ( h, v, c ) !*****************************************************************************80 ! !! HVC_CHECK corrects out-of-range HVC color coordinates. ! ! Definition: ! ! The HVC color system, developed by Tektronix, describes a color ! based on the three qualities of hue, value, and chroma. A given ! color will be represented by three numbers, (H,V,C). H, the value ! of hue, is an angle between 0 and 360 degrees, with 0 representing ! red. V, the "value", is between 0 and 100. C, the "chroma", is ! between 0 and 100. ! ! Modified: ! ! 03 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) H, V, C, the HVC color coordinates ! to be checked. ! implicit none real ( kind = 8 ) c real ( kind = 8 ) r8_modp real ( kind = 8 ) h real ( kind = 8 ) v h = r8_modp ( h, 360.0D+00 ) v = max ( v, 0.0D+00 ) v = min ( v, 100.0D+00 ) c = max ( c, 0.0D+00 ) c = min ( c, 100.0D+00 ) return end function i4_log_2 ( i ) !*****************************************************************************80 ! !! I4_LOG_2 returns the integer part of the logarithm base 2 of |I|. ! ! Example: ! ! I I4_LOG_2 ! ! 0 -1 ! 1, 0 ! 2, 1 ! 3, 1 ! 4, 2 ! 5, 2 ! 6, 2 ! 7, 2 ! 8, 3 ! 9, 3 ! 10, 3 ! 127, 6 ! 128, 7 ! 129, 7 ! ! Modified: ! ! 13 January 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the number whose logarithm base 2 is desired. ! ! Output, integer I4_LOG_2, the integer part of the logarithm base 2 of ! the absolute value of I. ! For positive I4_LOG_2(I), it should be true that ! 2**I4_LOG_2(X) <= |I| < 2**(I4_LOG_2(I)+1). ! The special case of I4_LOG_2(0) returns -HUGE(). ! implicit none integer i4_log_2 integer i integer i_abs if ( i == 0 ) then i4_log_2 = - huge ( i4_log_2 ) else i4_log_2 = 0 i_abs = abs ( i ) do while ( 2 <= i_abs ) i_abs = i_abs / 2 i4_log_2 = i4_log_2 + 1 end do end if return end subroutine i4_to_angle ( i, angle ) !*****************************************************************************80 ! !! I4_TO_ANGLE maps integers to points on a circle. ! ! Discussion: ! ! The angles are intended to be used to select colors on a color ! hexagon whose 6 vertices are red, yellow, green, cyan, blue, ! magenta. ! ! Example: ! ! I X ANGLE ! ! 0 0/3 0 ! 1 1/3 120 ! 2 2/3 240 ! ! 3 1/6 60 ! 4 3/6 180 ! 5 5/6 300 ! ! 6 1/12 30 ! 7 3/12 90 ! 8 5/12 150 ! 9 7/12 210 ! 10 9/12 270 ! 11 11/12 330 ! ! 12 1/24 15 ! 13 3/24 45 ! 14 5/24 75 ! etc ! ! Modified: ! ! 14 January 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the desired color. ! ! Output, real ( kind = 8 ) ANGLE, an angle, measured in degrees, ! between 0 and 360. ! implicit none real ( kind = 8 ) angle integer i integer i4_log_2 integer i1 integer i2 integer i3 integer i4 if ( 0 <= abs ( i ) .and. abs ( i ) <= 2 ) then angle = 120.0D+00 * real ( abs ( i ), kind = 8 ) else i1 = i4_log_2 ( abs ( i ) / 3 ) i2 = abs ( i ) + 1 - 3 * 2**i1 i3 = 2 * ( i2 - 1 ) + 1 i4 = 3 * 2**( i1 + 1 ) angle = 360.0D+00 * real ( i3, kind = 8 ) / real ( i4, kind = 8 ) end if return end function i4_uniform ( a, b, seed ) !*****************************************************************************80 ! !! I4_UNIFORM returns a scaled pseudorandom I4. ! ! Discussion: ! ! An I4 is an integer ( kind = 4 ) value. ! ! The pseudorandom number will be scaled to be uniformly distributed ! between A and B. ! ! Modified: ! ! 12 November 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley Interscience, page 95, 1998. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Parameters: ! ! Input, integer ( kind = 4 ) A, B, the limits of the interval. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, integer ( kind = 4 ) I4_UNIFORM, a number between A and B. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) i4_uniform integer ( kind = 4 ) k real ( kind = 4 ) r integer ( kind = 4 ) seed integer ( kind = 4 ) value if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4_UNIFORM - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r = real ( seed, kind = 4 ) * 4.656612875E-10 ! ! Scale R to lie between A-0.5 and B+0.5. ! r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) & + r * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 ) ! ! Use rounding to convert R to an integer between A and B. ! value = nint ( r, kind = 4 ) value = max ( value, min ( a, b ) ) value = min ( value, max ( a, b ) ) i4_uniform = value return end subroutine interp ( ndat, x, xdat, y, ydat ) !*****************************************************************************80 ! !! INTERP does simple linear interpolation in a table. ! ! Discussion: ! ! The XDAT values are assumed to be sorted in ascending order. ! ! Input values of X less than XDAT(1) are assigned a Y value of YDAT(1). ! Values of X above XDAT(NDAT) are handled similarly. ! ! Modified: ! ! 06 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NDAT, the number of data items. ! ! Input, real ( kind = 8 ) X, the value of the independent variable. ! ! Input, real ( kind = 8 ) XDAT(NDAT), the tabulated X values, which should ! be in ascending order. ! ! Output, real ( kind = 8 ) Y, the interpolated Y value. ! ! Input, real ( kind = 8 ) YDAT(NDAT), the tabulated Y values. ! implicit none integer ndat integer i integer j real ( kind = 8 ) x real ( kind = 8 ) xdat(ndat) real ( kind = 8 ) y real ( kind = 8 ) ydat(ndat) if ( x <= xdat(1) ) then y = ydat(1) else if ( xdat(ndat) <= x ) then y = ydat(ndat) else do i = 1, ndat-1 if ( xdat(i) <= x .and. x <= xdat(i+1) ) then j = i exit end if end do y = ( ( xdat(j+1) - x ) * ydat(j) & + ( x - xdat(j) ) * ydat(j+1) ) & / ( xdat(j+1) - xdat(j) ) end if return end subroutine lab_check ( lstar, astar, bstar ) !*****************************************************************************80 ! !! LAB_CHECK corrects out-of-range CIE LAB color coordinates. ! ! Definition: ! ! The CIE LAB system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of ! light, but adjusted to account for human perception. ! 0 <= L* <= 100. ! a* is the amount of red chrominance, with negative values ! indicating green. -500 <= a* <= 500. ! b* is the amount of yellow chrominance, with negative values ! indicating blue. -200 <= b* <= 200. ! The CIE LAB model is more suitable than the CIE LUV model ! for situations involving reflected light. ! ! Modified: ! ! 07 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) LSTAR, ASTAR, BSTAR, the CIE LAB ! color coordinates to be checked. ! implicit none real ( kind = 8 ) astar real ( kind = 8 ) bstar real ( kind = 8 ) lstar lstar = max ( lstar, 0.0D+00 ) lstar = min ( lstar, 100.0D+00 ) astar = max ( astar, -500.0D+00 ) astar = min ( astar, 500.0D+00 ) bstar = max ( bstar, -200.0D+00 ) bstar = min ( bstar, 200.0D+00 ) return end subroutine lab_prop ( lstar, astar, bstar, chroma, hue, luminance ) !*****************************************************************************80 ! !! LAB_PROP returns certain properties of a CIE LAB color. ! ! Definition: ! ! The CIE LAB system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of ! light, but adjusted to account for human perception. ! 0 <= L* <= 100. ! a* is the amount of red chrominance, with negative values ! indicating green. -500 <= a* <= 500. ! b* is the amount of yellow chrominance, with negative values ! indicating blue. -200 <= b* <= 200. ! The CIE LAB model is more suitable than the CIE LUV model ! for situations involving reflected light. ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) LSTAR, ASTAR, BSTAR, the CIE LAB coordinates ! of the color. ! ! Output, real ( kind = 8 ) CHROMA, HUE, LUMINANCE, the chroma, hue, ! and relative luminance. HUE is returned as an angle, in degrees. ! implicit none real ( kind = 8 ) astar real ( kind = 8 ) bstar real ( kind = 8 ) chroma real ( kind = 8 ) hue real ( kind = 8 ) lstar real ( kind = 8 ) luminance real ( kind = 8 ) radians_to_degrees chroma = sqrt ( astar**2 + bstar**2 ) hue = atan2 ( bstar, astar ) hue = radians_to_degrees ( hue ) if ( lstar <= 0.0D+00 ) then luminance = 0.0D+00 else if ( lstar <= 903.3D+00 * 0.008856D+00 ) then luminance = lstar / 903.3D+00 else if ( lstar <= 100.0D+00 ) then luminance = ( ( lstar + 16.0D+00 ) / 116.0D+00 )**3 else luminance = 1.0D+00 end if return end subroutine lab_to_xyz_cap ( lstar, astar, bstar, xcap, ycap, zcap, xcapn, & ycapn, zcapn ) !*****************************************************************************80 ! !! LAB_TO_XYZ_CAP converts CIE LAB to CIE XYZ color coordinates. ! ! Definition: ! ! The CIE LAB system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of ! light, but adjusted to account for human perception. ! 0 <= L* <= 100. ! a* is the amount of red chrominance, with negative values ! indicating green. -500 <= a* <= 500. ! b* is the amount of yellow chrominance, with negative values ! indicating blue. -200 <= b* <= 200. ! The CIE LAB model is more suitable than the CIE LUV model ! for situations involving reflected light. ! ! The CIE XYZ color system describes a color in terms of its components ! of X, Y and Z primaries. In ordinary circumstances, all three of ! these components must be nonnegative. ! ! Modified: ! ! 09 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Giorgianni and Thomas Madden, ! Digital Color Management, Encoding Solutions, ! Addison Wesley, 1998. ! ! Parameters: ! ! Input, real ( kind = 8 ) LSTAR, ASTAR, BSTAR, the CIE LAB color ! coordinates. ! ! Output, real ( kind = 8 ) XCAP, YCAP, ZCAP, the CIE XYZ color coordinates. ! ! Input, real ( kind = 8 ) XCAPN, YCAPN, ZCAPN, the CIE XYZ color ! coordinates of white. ! implicit none real ( kind = 8 ) astar real ( kind = 8 ) bstar real ( kind = 8 ) fx real ( kind = 8 ) fy real ( kind = 8 ) fz real ( kind = 8 ) lstar real ( kind = 8 ) r8_cubert real ( kind = 8 ) xcap real ( kind = 8 ) xcapn real ( kind = 8 ) ycap real ( kind = 8 ) ycapn real ( kind = 8 ) zcap real ( kind = 8 ) zcapn if ( lstar <= 0.0D+00 ) then ycap = 0.0D+00 else if ( lstar <= 8.0D+00 ) then ycap = lstar * ycapn / 903.3D+00 else if ( lstar <= 100.0D+00 ) then ycap = ycapn * ( ( lstar + 16.0D+00 ) / 116.0D+00 )**3 else ycap = ycapn end if if ( ycap <= 0.00856D+00 * ycapn ) then fy = 7.787D+00 * ycap / ycapn + 16.0D+00 / 116.0D+00 else fy = r8_cubert ( ycap / ycapn ) end if fx = fy + ( astar / 500.0D+00 ) if ( fx**3 <= 0.008856D+00 ) then xcap = xcapn * ( fx - 16.0D+00 / 116.0D+00 ) / 7.787D+00 else xcap = xcapn * fx**3 end if fz = fy - ( bstar / 200.0D+00 ) if ( fz**3 <= 0.008856D+00 ) then zcap = zcapn * ( fz - 16.0D+00 / 116.0D+00 ) / 7.787D+00 else zcap = zcapn * fz**3 end if return end subroutine lcc_to_rgbprime ( luma, chroma1, chroma2, yr, yg, yb, rprime, & gprime, bprime ) !*****************************************************************************80 ! !! LCC_TO_RGBPRIME converts LCC to R'G'B' color coordinates. ! ! Definition: ! ! The LCC color coordinate system records a color as three components, ! Luma, Chroma1 and Chroma2. The LCC color coordinates are used ! in an intermediate calculation of the PhotoYCC color coordinates. ! Luma is scaled luminance, Chroma1 is (B'-Luma) and Chroma2 is (R'-Luma). ! ! The R'G'B' color system is a nonlinear video signal measurement. ! Each coordinate must be between 0 and 1. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) LUMA, CHROMA1, CHROMA2, the LCC color coordinates. ! ! Input, real ( kind = 8 ) YR, YG, YB, the coefficients of the R, G and B ! primaries in the luminance function. ! ! Output, real ( kind = 8 ) RPRIME, GPRIME, BPRIME, the R'G'B' color ! coordinates. ! implicit none real ( kind = 8 ) chroma1 real ( kind = 8 ) chroma2 real ( kind = 8 ) bprime real ( kind = 8 ) gprime real ( kind = 8 ) luma real ( kind = 8 ) rprime real ( kind = 8 ) yb real ( kind = 8 ) yg real ( kind = 8 ) yprime real ( kind = 8 ) yr yprime = luma rprime = yprime + chroma2 bprime = yprime + chroma1 gprime = ( luma - yr * rprime - yb * bprime ) / yg return end subroutine lcc_to_ycbcr ( luma, chroma1, chroma2, yprime, cb, cr ) !*****************************************************************************80 ! !! LCC_TO_YCBCR converts LCC to Y'CbCr color coordinates. ! ! Definition: ! ! The LCC color coordinate system records a color as three components, ! Luma, Chroma1 and Chroma2. The LCC color coordinates are used ! in an intermediate calculation of the PhotoYCC color coordinates. ! Luma is scaled luminance, Chroma1 is (B'-Luma) and Chroma2 is (R'-Luma). ! ! The Y'CbCr color system is used in digital television signals. ! The Y' component measures luma, an approximation to the luminance ! or amount of light. Y' is the only component displayed on black ! and white televisions. The Cb and Cr components contain measures ! of the blue and red components of the color. Y' should be between ! 0 and 1, with reference black at 16/255 and reference white at 235/255, ! while Cb and Cr should be between -0.5 and 0.5. ! ! Modified: ! ! 04 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! C Wayne Brown and Barry Shepherd, ! Graphics File Formats, ! Manning Publications, 1995. ! ! Parameters: ! ! Input, real ( kind = 8 ) LUMA, CHROMA1, CHROMA2, the LCC color coordinates. ! ! Output, real ( kind = 8 ) YPRIME, CB, CR, the Y'CbCr color coordinates. ! implicit none real ( kind = 8 ) cb real ( kind = 8 ) chroma1 real ( kind = 8 ) chroma2 real ( kind = 8 ) cr real ( kind = 8 ) luma real ( kind = 8 ) yprime yprime = ( 219.0D+00 * luma + 16.0D+00 ) / 255.0D+00 cb = ( 224.0D+00 * 0.564D+00 * chroma1 + 128.0D+00 ) / 255.0D+00 cr = ( 224.0D+00 * 0.713D+00 * chroma2 + 128.0D+00 ) / 255.0D+00 return end subroutine lcc_to_ycc ( luma, chroma1, chroma2, yprime, c1, c2 ) !*****************************************************************************80 ! !! LCC_TO_YCC converts LCC to PhotoYCC color coordinates. ! ! Definition: ! ! The LCC color coordinate system records a color as three components, ! Luma, Chroma1 and Chroma2. The LCC color coordinates are used ! in an intermediate calculation of the PhotoYCC color coordinates. ! Luma is scaled luminance, Chroma1 is (B'-Luma) and Chroma2 is (R'-Luma). ! ! The Kodak PhotoYCC Color Interchange Space was developed for the ! Photo CD System. The Y' coordinate is a measure of luminance, ! while C1 and C2 measure color difference chrominance. ! ! Modified: ! ! 17 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Giorgianni and Thomas Madden, ! Digital Color Management, Encoding Solutions, ! Addison Wesley, 1998. ! ! Parameters: ! ! Input, real ( kind = 8 ) LUMA, CHROMA1, CHROMA2, the LCC color coordinates. ! ! Output, real ( kind = 8 ) YPRIME, C1, C2, the PhotoYCC color coordinates. ! implicit none real ( kind = 8 ) c1 real ( kind = 8 ) c2 real ( kind = 8 ) chroma1 real ( kind = 8 ) chroma2 real ( kind = 8 ) luma real ( kind = 8 ) yprime yprime = 255.0D+00 * luma / 1.402D+00 c1 = 111.40D+00 * chroma1 + 156.0D+00 c2 = 135.64D+00 * chroma2 + 137.0D+00 return end subroutine lin_to_nonlin ( r, rprime ) !*****************************************************************************80 ! !! LIN_TO_NONLIN converts a linear light intensity to nonlinear video signal. ! ! Definition: ! ! This process is also known as gamma correction. ! ! Modified: ! ! 19 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, the linear light intensity. ! ! Output, real ( kind = 8 ) RPRIME, the nonlinear video signal. ! implicit none real ( kind = 8 ) r real ( kind = 8 ) rprime if ( r < -0.018D+00 ) then rprime = 0.099D+00 - 1.099D+00 * ( abs ( r ) )**0.45D+00 else if ( abs ( r ) <= 0.018D+00 ) then rprime = 4.5D+00 * r else rprime = -0.099D+00 + 1.099D+00 * r**0.45D+00 end if return end subroutine luv_check ( lstar, ustar, vstar ) !*****************************************************************************80 ! !! LUV_CHECK corrects out-of-range CIE LUV color coordinates. ! ! Definition: ! ! The CIE LUV system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of light, ! but adjusted for human perception. 0 <= L* <= 100. ! u* is the amount of red chrominance, with negative values ! indicating green. ! v* is the amount of yellow chrominance, with negative values ! indicating blue. ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) LSTAR, USTAR, VSTAR, the CIE LUV ! color coordinates to be checked. ! implicit none real ( kind = 8 ) lstar real ( kind = 8 ) ustar real ( kind = 8 ) vstar lstar = max ( lstar, 0.0D+00 ) lstar = min ( lstar, 100.0D+00 ) return end subroutine luv_prop ( lstar, ustar, vstar, chroma, hue, luminance, sat ) !*****************************************************************************80 ! !! LUV_PROP returns certain properties of a CIE LUV color. ! ! Discussion: ! ! The CIE LUV system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of light, ! but adjusted for human perception. 0 <= L* <= 100. ! u* is the amount of red chrominance, with negative values ! indicating green. ! v* is the amount of yellow chrominance, with negative values ! indicating blue. ! ! Modified: ! ! 11 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) LSTAR, USTAR, VSTAR, the CIE LUV coordinates ! of the color. ! ! Output, real ( kind = 8 ) CHROMA, HUE, LUMINANCE, SAT, the chroma, ! hue, relative luminance, and saturation. HUE is returned as an ! angle in degrees. ! implicit none real ( kind = 8 ) chroma real ( kind = 8 ) hue real ( kind = 8 ) lstar real ( kind = 8 ) luminance real ( kind = 8 ) radians_to_degrees real ( kind = 8 ) sat real ( kind = 8 ) ustar real ( kind = 8 ) vstar chroma = sqrt ( ustar**2 + vstar**2 ) hue = atan2 ( vstar, ustar ) hue = radians_to_degrees ( hue ) if ( lstar == 0.0D+00 ) then sat = 0.0D+00 else sat = chroma / lstar end if if ( lstar <= 0.0D+00 ) then luminance = 0.0D+00 else if ( lstar <= 903.3D+00 * 0.008856D+00 ) then luminance = lstar / 903.3D+00 else if ( lstar <= 100.0D+00 ) then luminance = ( ( lstar + 16.0D+00 ) / 116.0D+00 )**3 else luminance = 1.0D+00 end if return end subroutine luv_to_xyz_cap ( lstar, ustar, vstar, xcap, ycap, zcap, xcapn, & ycapn, zcapn ) !*****************************************************************************80 ! !! LUV_TO_XYZ_CAP converts CIE LUV to CIE XYZ color coordinates. ! ! Definition: ! ! The CIE LUV system describes a color based on three qualities: ! L* is CIE lightness, similar to luminance, the amount of light, ! but adjusted for human perception. 0 <= L* <= 100. ! u* is the amount of red chrominance, with negative values ! indicating green. ! v* is the amount of yellow chrominance, with negative values ! indicating blue. ! ! The CIE XYZ color system describes a color in terms of its components ! of X, Y and Z primaries. In ordinary circumstances, all three of ! these components must be nonnegative. ! ! Modified: ! ! 12 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) LSTAR, USTAR, VSTAR, the CIE LUV color ! coordinates. ! ! Output, real ( kind = 8 ) XCAP, YCAP, ZCAP, the CIE XYZ color coordinates. ! ! Input, real ( kind = 8 ) XCAPN, YCAPN, ZCAPN, the CIE XYZ color ! coordinates of white. ! implicit none real ( kind = 8 ) lstar real ( kind = 8 ) ustar real ( kind = 8 ) uprime real ( kind = 8 ) unprime real ( kind = 8 ) vstar real ( kind = 8 ) vprime real ( kind = 8 ) vnprime real ( kind = 8 ) wnprime real ( kind = 8 ) xcap real ( kind = 8 ) xcapn real ( kind = 8 ) ycap real ( kind = 8 ) ycapn real ( kind = 8 ) zcap real ( kind = 8 ) zcapn if ( lstar <= 0.0D+00 ) then xcap = 0.0D+00 ycap = 0.0D+00 zcap = 0.0D+00 else ! ! Compute CIE luminance from L* and YCAPN. ! if ( lstar <= 0.0D+00 ) then ycap = 0.0D+00 else if ( lstar <= 903.3D+00 * 0.008856D+00 ) then ycap = lstar * ycapn / 903.3D+00 else if ( lstar <= 100.0D+00 ) then ycap = ycapn * ( ( lstar + 16.0D+00 ) / 116.0D+00 )**3 else ycap = ycapn end if ! ! Compute (un',vn') from (XCAPN,YCAPN,ZCAPN). ! call xyz_cap_to_uvwprime ( xcapn, ycapn, zcapn, unprime, vnprime, wnprime ) ! ! Compute (u',v') from (un',vn') and (l*,u*,v*). ! uprime = unprime + ustar / ( 13.0D+00 * lstar ) vprime = vnprime + vstar / ( 13.0D+00 * lstar ) ! ! Now compute XCAP and ZCAP from (u',v') and YCAP. ! call uvprimey_to_xyz_cap ( uprime, vprime, xcap, ycap, zcap ) end if return end subroutine name_test ( itest, name ) !*****************************************************************************80 ! !! NAME_TEST supplies color names for tests. ! ! Modified: ! ! 12 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITEST, the index of the test. ! ! Output, character ( len = * ) NAME, the name of a color to be tested. ! The longest name is 11 characters. If ITEST is out of the range ! of data, then NAME is returned as ' '. ! implicit none integer itest character ( len = * ) name if ( itest == 1 ) then name = 'Red' else if ( itest == 2 ) then name = 'Green' else if ( itest == 3 ) then name = 'Blue' else if ( itest == 4 ) then name = 'Cyan' else if ( itest == 5 ) then name = 'Magenta' else if ( itest == 6 ) then name = 'Yellow' else if ( itest == 7 ) then name = 'White' else if ( itest == 8 ) then name = 'Black' else if ( itest == 9 ) then name = 'Pink' else if ( itest == 10 ) then name = 'Aquamarine' else if ( itest == 11 ) then name = 'Tan' else if ( itest == 12 ) then name = 'YellowGreen' else if ( itest == 13 ) then name = 'Maroon' else if ( itest == 14 ) then name = 'Salmon' else if ( itest == 15 ) then name = 'Mauve' else name = ' ' end if return end subroutine name_to_primaries ( name, rx, ry, gx, gy, bx, by, wx, wy ) !*****************************************************************************80 ! !! NAME_TO_PRIMARIES returns CIE xy chromaticities of television primaries. ! ! Modified: ! ! 30 April 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! David Martindale and Alan Paeth, ! Television Color Encoding and Hot Broadcast Colors, ! Graphics Gems II, edited by James Arvo, ! Academic Press, 1991, pages 147-158. ! ! Parameters: ! ! Input, character ( len = * ) NAME, the name of a television system: ! 'CIE', the CIE primaries; ! 'EBU', ! 'HDTV', ! 'NTSC', National Television Systems Committee; ! 'SMPTE', Society of Motion Picture and Television Engineers. ! ! Output, real ( kind = 8 ) RX, RY, the xy chromaticities of the R primary. ! ! Output, real ( kind = 8 ) GX, GY, the xy chromaticities of the G primary. ! ! Output, real ( kind = 8 ) BX, BY, the xy chromaticities of the B primary. ! ! Output, real ( kind = 8 ) WX, WY, the xy chromaticities of the ! reference white. ! implicit none real ( kind = 8 ) bx real ( kind = 8 ) by real ( kind = 8 ) gx real ( kind = 8 ) gy character ( len = * ) name character ( len = 30 ) name_copy real ( kind = 8 ) rx real ( kind = 8 ) ry logical s_eqi real ( kind = 8 ) wx real ( kind = 8 ) wy ! ! Make a temporary copy of NAME. ! name_copy = adjustl ( name ) ! ! Remove blanks and underlines. ! call s_c_delete ( name_copy, ' ' ) call s_c_delete ( name_copy, '_' ) if ( s_eqi ( name_copy, 'CIE' ) ) then rx = 0.73467D+00 ry = 0.26533D+00 gx = 0.27376D+00 gy = 0.71741D+00 bx = 0.16658D+00 by = 0.00886D+00 wx = 1.0D+00 / 3.0D+00 wy = 1.0D+00 / 3.0D+00 else if ( s_eqi ( name_copy, 'EBU' ) ) then rx = 0.64D+00 ry = 0.33D+00 gx = 0.29D+00 gy = 0.60D+00 bx = 0.15D+00 by = 0.06D+00 wx = 0.3127D+00 wy = 0.3291D+00 else if ( s_eqi ( name_copy, 'HDTV' ) ) then rx = 0.670D+00 ry = 0.330D+00 gx = 0.210D+00 gy = 0.710D+00 bx = 0.150D+00 by = 0.060D+00 wx = 0.3127D+00 wy = 0.3291D+00 else if ( s_eqi ( name_copy, 'NTSC' ) ) then rx = 0.67D+00 ry = 0.33D+00 gx = 0.21D+00 gy = 0.71D+00 bx = 0.14D+00 by = 0.08D+00 wx = 0.3101D+00 wy = 0.3162D+00 else if ( s_eqi ( name_copy, 'SMPTE' ) ) then rx = 0.630D+00 ry = 0.340D+00 gx = 0.310D+00 gy = 0.595D+00 bx = 0.155D+00 by = 0.070D+00 wx = 0.3127D+00 wy = 0.3291D+00 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAME_TO_PRIMARIES - Fatal error!' write ( *, '(a)' ) ' Unrecognized name: "' // trim ( name ) // '"' stop end if return end subroutine name_to_rgb ( name, r, g, b ) !*****************************************************************************80 ! !! NAME_TO_RGB converts a string to RGB colors. ! ! Discussion: ! ! The names and information are read from the file "COLORS.TXT", a ! modified version of the X Windows color data file "RGB.TXT". ! ! Modified: ! ! 10 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) NAME, the name of a color. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB coordinates. ! However, these will be returned as ( -1.0, -1.0, -1.0D+00 ) if the ! color name was not recognized. ! implicit none real ( kind = 8 ) b character ( len = 20 ) :: color_file = 'colors.txt' real ( kind = 8 ) g integer ib integer ig integer ios integer ir integer iunit character ( len = * ) name character ( len = 30 ) name_copy character ( len = 30 ) name_color real ( kind = 8 ) r logical s_eqi ! ! Make a temporary copy of the NAME. ! Remove blanks and underlines. ! name_copy = adjustl ( name ) call s_c_delete ( name_copy, ' ' ) call s_c_delete ( name_copy, '_' ) call get_unit ( iunit ) open ( unit = iunit, file = color_file, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAME_TO_RGB - Fatal error!' write ( *, '(a)' ) ' Could not open the color name file:' write ( *, '(a)' ) trim ( color_file ) stop end if do read ( iunit, '(i3,2x,i3,2x,i3,2x,a)', iostat = ios ) ir, ig, ib, name_color if ( ios /= 0 ) then r = - 1.0D+00 g = - 1.0D+00 b = - 1.0D+00 exit end if name_color = adjustl ( name_color ) call s_c_delete ( name_color, ' ' ) call s_c_delete ( name_color, '_' ) if ( s_eqi ( name_copy, name_color ) ) then r = real ( ir, kind = 8 ) / 255.0D+00 g = real ( ig, kind = 8 ) / 255.0D+00 b = real ( ib, kind = 8 ) / 255.0D+00 exit end if end do close ( unit = iunit ) return end subroutine name_to_xyz ( name, x, y, z ) !*****************************************************************************80 ! !! NAME_TO_XYZ converts a color or illuminant name to CIE xyz color coordinates. ! ! Discussion: ! ! Thanks to Harald Anlauf of the Technical University of Darmstadt, ! for pointing out a programming error which meant that NAME was not ! an input-only variable. (30 April 2002) ! ! Definition: ! ! In the CIE color system, the exact chromaticities of several ! standard illuminants were defined. These were generally chosen to ! correspond to common lighting situations. ! ! Modified: ! ! 30 April 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) NAME, the name of a color. Before considering ! the name, the routine removes all blanks and underscores, and ! capitalizes the name. Legal names include: ! ! 'A', the CIE illuminant A, light from a tungsten lamp, at 500 watts; ! 'B', the CIE illuminant B, direct sunlight, at 500 watts; ! 'C', the CIE illuminant C, average sunlight, at 500 watts; ! This is used as the reference white for NTSC color encoding. ! 'D50' or 'D5000', the CIE illuminant used in graphics printing, ! bright tunsten illumination; ! 'D55' or 'D5500', a CIE illuminant that approximates a cloudy bright day; ! 'D65' or 'D6500', the CIE illuminant that approximates daylight; ! This is used as the reference white for SMPTE, PAL/EBU, and HDTV ! color encoding. ! 'E', the CIE illuminant E, normalized reference source. ! ! Output, real ( kind = 8 ) X, Y, Z, the corresponding CIE xyz color ! coordinates, or (0,0,0) if the name is not recognized. ! implicit none character ( len = * ) name character ( len = 20 ) name_copy logical s_eqi real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z ! ! Make a temporary copy of NAME. ! name_copy = adjustl ( name ) ! ! Remove blanks and underlines. ! call s_c_delete ( name_copy, ' ' ) call s_c_delete ( name_copy, '_' ) ! ! Compare the input name to the recognized list. ! if ( s_eqi ( name_copy, 'A' ) ) then x = 0.448D+00 y = 0.407D+00 z = 0.145D+00 else if ( s_eqi ( name_copy, 'B' ) ) then x = 0.349D+00 y = 0.352D+00 z = 0.299D+00 else if ( s_eqi ( name_copy, 'C' ) ) then x = 0.3101D+00 y = 0.3162D+00 z = 0.3737D+00 else if ( s_eqi ( name_copy, 'D50' ) .or. & s_eqi ( name_copy, 'D5000' ) ) then x = 96.42D+00 / ( 96.42D+00 + 100.00D+00 + 82.49D+00 ) y = 100.00D+00 / ( 96.42D+00 + 100.00D+00 + 82.49D+00 ) z = 82.49D+00 / ( 95.42D+00 + 100.00D+00 + 82.49D+00 ) else if ( s_eqi ( name_copy, 'D55' ) .or. & s_eqi ( name_copy, 'D5500' ) ) then x = 0.3324D+00 y = 0.3474D+00 z = 0.3202D+00 else if ( s_eqi ( name_copy, 'D65' ) .or. & s_eqi ( name_copy, 'D6500' ) ) then x = 95.05D+00 / ( 95.05D+00 + 100.00D+00 + 108.91D+00 ) y = 100.00D+00 / ( 95.05D+00 + 100.00D+00 + 108.91D+00 ) z = 108.91D+00 / ( 95.05D+00 + 100.00D+00 + 108.91D+00 ) else if ( s_eqi ( name_copy, 'E' ) ) then x = 100.0D+00 / 300.0D+00 y = 100.0D+00 / 300.0D+00 z = 100.0D+00 / 300.0D+00 else x = 0.0D+00 y = 0.0D+00 z = 0.0D+00 end if return end subroutine ncs_check ( c1, c2, n, c, s ) !*****************************************************************************80 ! !! NCS_CHECK corrects out-of-range NCS color coordinates. ! ! Definition: ! ! The NCS or "natural color system" describes a color based on: ! * C1 and C2, two elementary colors from the sequence RYGB or ! C2 = blank for a pure elementary color, or ! C1 = N, C2 = blank for a neutral color); ! * N, the percentage of C2; ! * C, the colorfulness or strength, as a percentage; ! * S, the blackness as a percentage. ! ! The scant documentation I have seen claims that the percentages are ! always less than 100. I don't see why, and for now I'll let them ! lie between 0 and 100. The NCS designation for a color has the form ! "CCSS C1NC2". ! ! Examples: ! ! C1 C2 N C S Designation ! -- -- -- --- --- ----------- ! Black ( N * 0 0 100 ) 0099 N ! Blue ( B * 0 100 0 ) 9900 B ! Cyan ( G B 50 100 0 ) 9900 G50B ! Green ( G * 0 100 0 ) 9900 G ! Magenta ( B R 50 100 0 ) 9900 B50R ! Orange ( R Y 50 100 0 ) 9900 R50Y ! Red ( R * 0 100 0 ) 9900 R ! White ( N * 0 0 0 ) 0000 N ! Yellow ( Y * 0 100 0 ) 9900 Y ! ! Modified: ! ! 20 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Olof Kylander and Karin Kylander, ! GIMP: The Official Manual, ! Coriolis Open Press, 1999. ! ! Parameters: ! ! Input/output, character C1, C2, integer N, C, S, the NCS color ! coordinates to be checked. If the color information is very ! bad, it is replaced by the designation for black. ! implicit none integer c character c1 character c2 integer n integer s ! ! Replace C1 by its capitalized value. ! call ch_cap ( c1 ) ! ! We're expecting only the values R, Y, G, B, and possibly N (for neutral). ! if ( c1 == 'R' .or. c1 == 'Y' .or. c1 == 'G' .or. c1 == 'B' ) then else if ( c1 == 'N' .and. c2 == ' ' .and. c == 0 ) then else c1 = 'N' c2 = ' ' n = 0 c = 0 s = 100 return end if ! ! Replace C2 by its capitalized value. ! C2 may be blank, but then N should be 0. ! call ch_cap ( c2 ) ! ! We're expecting only the values R, Y, G, B and blank. ! if ( c2 == 'R' .or. c2 == 'Y' .or. c2 == 'G' .or. c2 == 'B' ) then else if ( c2 == ' ' .and. n == 0 ) then else c1 = 'N' c2 = ' ' n = 0 c = 0 s = 100 return end if ! ! If necessary, swap the colors so they have a preferred order. ! if ( c1 == 'Y' .and. c2 == 'R' ) then c1 = 'R' c2 = 'Y' n = 100 - n else if ( c1 == 'G' .and. c2 == 'Y' ) then c1 = 'Y' c2 = 'G' n = 100 - n else if ( c1 == 'B' .and. c2 == 'G' ) then c1 = 'G' c2 = 'B' n = 100 - n else if ( c1 == 'R' .and. c2 == 'B' ) then c1 = 'B' c2 = 'R' n = 100 - n end if ! ! Only certain pairs of colors are allowed. ! if ( c2 == 'R' .and. c1 == 'Y' ) then else if ( c2 == 'Y' .and. c1 == 'G' ) then else if ( c2 == 'G' .and. c1 == 'B' ) then else if ( c2 == 'B' .and. c1 == 'R' ) then else if ( c2 == ' ' .and. c1 == 'N' ) then else c1 = 'N' c2 = ' ' n = 0 c = 0 s = 100 end if ! ! Only certain values of N are allowed. ! if ( n == 0 ) then c2 = ' ' else if ( n == 100 ) then c1 = c2 c2 = ' ' else if ( n < 0 ) then n = 0 else if ( 100 < n ) then n = 100 else end if ! ! Only certain values of C are allowed. ! Here, we will "repair" such values. ! if ( c < 0 ) then c = 0 else if ( 100 < c ) then c = 100 else end if ! ! Only certain values of S are allowed. ! Here, we will "repair" such values. ! if ( s < 0 ) then s = 0 else if ( 100 < s ) then s = 100 else end if ! ! C + S must be no more than 100. ! if ( 100 < c + s ) then c1 = 'N' c2 = ' ' n = 0 c = 0 s = 100 return end if return end subroutine ncs_to_rgb ( c1, c2, n, c, s, r, g, b ) !*****************************************************************************80 ! !! NCS_TO_RGB converts NCS to RGB color coordinates. ! ! Discussion: ! ! It has been difficult to find two descriptions of NCS that agree. ! It has been impossible to find a description of the mathematical ! details of NCS. ! On top of that, I seem to have mixed up a few things, including ! the ordering of the colors. For now, I will be content that ! this routine embodies the "flavor" of NCS, and does a reasonable ! job of inverting RGB_TO_NCS, modulo the loss of information ! because of real to integer percentage truncation. ! I'll come back and fix this one day. ! ! Definition: ! ! The NCS or "natural color system" describes a color based on: ! * C1 and C2, two elementary colors from the sequence RYGB or ! C2 = blank for a pure elementary color, or ! C1 = N, C2 = blank for a neutral color); ! * N, the percentage of C2; ! * C, the colorfulness or strength, as a percentage; ! * S, the blackness as a percentage. ! ! The scant documentation I have seen claims that the percentages are ! always less than 100. I don't see why, and for now I'll let them ! lie between 0 and 100. The NCS designation for a color has the form ! "CCSS C1NC2". ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Modified: ! ! 20 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Olof Kylander and Karin Kylander, ! GIMP: The Official Manual, ! Coriolis Open Press, 1999. ! ! Parameters: ! ! Input, character C1, C2, integer N, C, S, the NCS color coordinates. ! ! Output, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! implicit none real ( kind = 8 ) b integer c character c1 character c2 real ( kind = 8 ) color(3) real ( kind = 8 ) color1(3) real ( kind = 8 ) color2(3) real ( kind = 8 ) color3(3) real ( kind = 8 ) g integer n real ( kind = 8 ) r integer s integer w ! ! Determine the colors that bracket the given color. ! if ( c1 == 'R' ) then color1(1:3) = (/ 1.0D+00, 0.0D+00, 0.0D+00 /) color2(1:3) = (/ 1.0D+00, 1.0D+00, 0.0D+00 /) else if ( c1 == 'Y' ) then color1(1:3) = (/ 1.0D+00, 1.0D+00, 0.0D+00 /) color2(1:3) = (/ 0.0D+00, 1.0D+00, 0.0D+00 /) else if ( c1 == 'G' ) then color1(1:3) = (/ 0.0D+00, 1.0D+00, 0.0D+00 /) color2(1:3) = (/ 0.0D+00, 0.0D+00, 1.0D+00 /) else if ( c1 == 'B' ) then color1(1:3) = (/ 0.0D+00, 0.0D+00, 1.0D+00 /) color2(1:3) = (/ 1.0D+00, 0.0D+00, 0.0D+00 /) end if ! ! Apply the value of N. ! This is trickier than it looks! ! if ( c1 == 'R' ) then if ( n < 50 ) then color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( 100 - n, kind = 8 ) else color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( n, kind = 8 ) end if else if ( c1 == 'Y' ) then if ( n < 50 ) then color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( 100 - n, kind = 8 ) else color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( n, kind = 8 ) end if else if ( c1 == 'G' ) then if ( n < 50 ) then color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( 100 - n, kind = 8 ) else color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( n, kind = 8 ) end if else if ( c1 == 'B' ) then if ( n < 50 ) then color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( 100 - n, kind = 8 ) else color3(1:3) = ( real ( 100 - n, kind = 8 ) * color1(1:3) & + real ( n, kind = 8 ) * color2(1:3) ) & / real ( n, kind = 8 ) end if end if ! ! The color can now be computed as the triangular sum of white, ! black, and the color from the color circle. ! w = 100 - c - s color(1:3) = ( & real ( c, kind = 8 ) * color3(1:3) & + real ( s, kind = 8 ) * (/ 0.0D+00, 0.0D+00, 0.0D+00 /) & + real ( w, kind = 8 ) * (/ 1.0D+00, 1.0D+00, 1.0D+00 /) ) / 100.0D+00 r = color(1) g = color(2) b = color(3) return end subroutine nm_to_rgbcie ( w, r, g, b ) !*****************************************************************************80 ! !! NM_TO_RGBCIE converts a pure light wavelength to CIE RGB color coordinates. ! ! Discussion: ! ! The "RGB" used here is not the "RGB" referred to in RGB monitors. Instead, ! it refers to three specific monochromatic light sources: ! ! R: red light at 700.0 nanometers; ! G: green light at 546.1 nanometers; ! B: blue light at 435.8 nanometers. ! ! The relative intensities of these lights are adjusted so that ! ! 1 R + 1 G + 1 B = white. ! ! For a light emission with given spectral power distribution SPD(W), ! the values tabulated here can be used to produce integrated RGB ! tristimulus values: ! ! rval = integral ( 380 <= w <= 760 ) spd(w) * rbar(w) d w; ! ! gval = integral ( 380 <= w <= 760 ) spd(w) * gbar(w) d w; ! ! bval = integral ( 380 <= w <= 760 ) spd(w) * bbar(w) d w. ! ! Modified: ! ! 12 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) W, the wavelength of the monochromatic light whose ! RGB color coordinatesare desired. W must lie between ! 380 and 760. ! ! Output, real ( kind = 8 ) R, G, B, the CIE RGB color coordinates for ! the monochromatic light of the given wavelength. ! implicit none integer, parameter :: ndat = 39 real ( kind = 8 ) b real ( kind = 8 ), save, dimension ( ndat ) :: bdat = (/ & 0.00117D+00, 0.00359D+00, 0.01214D+00, 0.03707D+00, 0.11541D+00, & 0.24769D+00, 0.31228D+00, 0.31670D+00, 0.39821D+00, 0.22991D+00, & 0.14494D+00, 0.08257D+00, 0.04776D+00, 0.02698D+00, 0.01221D+00, & 0.00549D+00, 0.00146D+00, -0.00058D+00, 0.00130D+00, -0.00135D+00, & -0.00108D+00, -0.00079D+00, -0.00049D+00, -0.00030D+00, -0.00015D+00, & -0.00008D+00, -0.00003D+00, -0.00001D+00, 0.00000D+00, 0.00000D+00, & 0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00, & 0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00 /) real ( kind = 8 ) g real ( kind = 8 ), save, dimension ( ndat ) :: gdat = (/ & -0.00001D+00, -0.00004D+00, -0.00014D+00, -0.00041D+00, -0.00110D+00, & -0.00119D+00, 0.00149D+00, 0.00678D+00, 0.01485D+00, 0.02538D+00, & 0.03914D+00, 0.05689D+00, 0.08536D+00, 0.12860D+00, 0.17468D+00, & 0.20317D+00, 0.21466D+00, 0.21178D+00, 0.19702D+00, 0.17087D+00, & 0.13610D+00, 0.09754D+00, 0.06246D+00, 0.03557D+00, 0.01828D+00, & 0.00833D+00, 0.00334D+00, 0.00116D+00, 0.00037D+00, 0.00011D+00, & 0.00003D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00, & 0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00 /) real ( kind = 8 ) r real ( kind = 8 ), save, dimension ( ndat ) :: rdat = (/ & 0.00003D+00, 0.00010D+00, 0.00030D+00, 0.00084D+00, 0.00211D+00, & 0.00218D+00, -0.00261D+00, -0.01213D+00, -0.02608D+00, -0.03933D+00, & -0.04939D+00, -0.05814D+00, -0.07173D+00, -0.08901D+00, -0.09264D+00, & -0.07101D+00, -0.03152D+00, 0.02279D+00, 0.09060D+00, 0.16768D+00, & 0.24526D+00, 0.30928D+00, 0.34429D+00, 0.33971D+00, 0.29708D+00, & 0.22677D+00, 0.15968D+00, 0.10167D+00, 0.05932D+00, 0.03149D+00, & 0.01687D+00, 0.00819D+00, 0.00410D+00, 0.00210D+00, 0.00105D+00, & 0.00052D+00, 0.00025D+00, 0.00012D+00, 0.00006D+00 /) real ( kind = 8 ) w real ( kind = 8 ), save, dimension ( ndat ) :: wdat = (/ & 380.0D+00, 390.0D+00, 400.0D+00, 410.0D+00, 420.0D+00, & 430.0D+00, 440.0D+00, 450.0D+00, 460.0D+00, 470.0D+00, & 480.0D+00, 490.0D+00, 500.0D+00, 510.0D+00, 520.0D+00, & 530.0D+00, 540.0D+00, 550.0D+00, 560.0D+00, 570.0D+00, & 580.0D+00, 590.0D+00, 600.0D+00, 610.0D+00, 620.0D+00, & 630.0D+00, 640.0D+00, 650.0D+00, 660.0D+00, 670.0D+00, & 680.0D+00, 690.0D+00, 700.0D+00, 710.0D+00, 720.0D+00, & 730.0D+00, 740.0D+00, 750.0D+00, 760.0D+00 /) if ( wdat(1) <= w .and. w <= wdat(ndat) ) then call interp ( ndat, w, wdat, r, rdat ) call interp ( ndat, w, wdat, g, gdat ) call interp ( ndat, w, wdat, b, bdat ) else r = 0.0D+00 g = 0.0D+00 b = 0.0D+00 end if return end subroutine nm_to_xyz ( w, x, y, z ) !*****************************************************************************80 ! !! NM_TO_XYZ converts a pure light wavelength to CIE xyz color coordinates. ! ! Discussion: ! ! The CIE xyz color coordinates are derived from the CIE X, Y, Z color ! coordinates by the relationship: ! ! x = X / ( X + Y + Z ) ! y = Y / ( X + Y + Z ) ! z = Z / ( X + Y + Z ) ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) W, the wavelength of the pure light signal, ! in nanometers. W should lie between 380 nm and 780 nm. ! ! Output, real ( kind = 8 ) X, Y, Z, the CIE xyz chromaticities. These ! lie between 0 and 1, and sum to 1. ! implicit none integer, parameter :: ndat = 81 real ( kind = 8 ) w real ( kind = 8 ), save, dimension ( ndat ) :: wdat = (/ & 380.0D+00, 385.0D+00, 390.0D+00, 395.0D+00, 400.0D+00, & 405.0D+00, 410.0D+00, 415.0D+00, 420.0D+00, 425.0D+00, & 430.0D+00, 435.0D+00, 440.0D+00, 445.0D+00, 450.0D+00, & 455.0D+00, 460.0D+00, 465.0D+00, 470.0D+00, 475.0D+00, & 480.0D+00, 485.0D+00, 490.0D+00, 495.0D+00, 500.0D+00, & 505.0D+00, 510.0D+00, 515.0D+00, 520.0D+00, 525.0D+00, & 530.0D+00, 535.0D+00, 540.0D+00, 545.0D+00, 550.0D+00, & 555.0D+00, 560.0D+00, 565.0D+00, 570.0D+00, 575.0D+00, & 580.0D+00, 585.0D+00, 590.0D+00, 595.0D+00, 600.0D+00, & 605.0D+00, 610.0D+00, 615.0D+00, 620.0D+00, 625.0D+00, & 630.0D+00, 635.0D+00, 640.0D+00, 645.0D+00, 650.0D+00, & 655.0D+00, 660.0D+00, 665.0D+00, 670.0D+00, 675.0D+00, & 680.0D+00, 685.0D+00, 690.0D+00, 695.0D+00, 700.0D+00, & 705.0D+00, 710.0D+00, 715.0D+00, 720.0D+00, 725.0D+00, & 730.0D+00, 735.0D+00, 740.0D+00, 745.0D+00, 750.0D+00, & 755.0D+00, 760.0D+00, 765.0D+00, 770.0D+00, 775.0D+00, & 780.0D+00 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( ndat ) :: xdat = (/ & 0.1741, 0.1740, 0.1738, 0.1736, 0.1733, & 0.1730, 0.1726, 0.1721, 0.1714, 0.1703, & 0.1689, 0.1669, 0.1644, 0.1611, 0.1566, & 0.1510, 0.1440, 0.1355, 0.1241, 0.1096, & 0.0913, 0.0687, 0.0454, 0.0235, 0.0082, & 0.0039, 0.0139, 0.0389, 0.0743, 0.1142, & 0.1547, 0.1929, 0.2296, 0.2658, 0.3016, & 0.3373, 0.3731, 0.4087, 0.4441, 0.4788, & 0.5125, 0.5448, 0.5752, 0.6029, 0.6270, & 0.6482, 0.6658, 0.6801, 0.6915, 0.7006, & 0.7079, 0.7140, 0.7190, 0.7230, 0.7260, & 0.7283, 0.7300, 0.7311, 0.7320, 0.7327, & 0.7334, 0.7340, 0.7344, 0.7346, 0.7347, & 0.7347, 0.7347, 0.7347, 0.7347, 0.7347, & 0.7347, 0.7347, 0.7347, 0.7347, 0.7347, & 0.7347, 0.7347, 0.7347, 0.7347, 0.7347, & 0.7347 /) real ( kind = 8 ) y real ( kind = 8 ), save, dimension ( ndat ) :: ydat = (/ & 0.0050, 0.0050, 0.0049, 0.0049, 0.0048, & 0.0048, 0.0048, 0.0048, 0.0051, 0.0058, & 0.0069, 0.0086, 0.0109, 0.0138, 0.0177, & 0.0227, 0.0297, 0.0399, 0.0578, 0.0868, & 0.1327, 0.2007, 0.2950, 0.4127, 0.5384, & 0.6548, 0.7502, 0.8120, 0.8338, 0.8262, & 0.8059, 0.7816, 0.7543, 0.7243, 0.6923, & 0.6589, 0.6245, 0.5896, 0.5547, 0.5202, & 0.4866, 0.4544, 0.4242, 0.3965, 0.3725, & 0.3514, 0.3340, 0.3197, 0.3083, 0.2993, & 0.2920, 0.2859, 0.2809, 0.2770, 0.2740, & 0.2717, 0.2700, 0.2689, 0.2680, 0.2673, & 0.2666, 0.2660, 0.2656, 0.2654, 0.2653, & 0.2653, 0.2653, 0.2653, 0.2653, 0.2653, & 0.2653, 0.2653, 0.2653, 0.2653, 0.2653, & 0.2653, 0.2653, 0.2653, 0.2653, 0.2653, & 0.2653 /) real ( kind = 8 ) z real ( kind = 8 ), save, dimension ( ndat ) :: zdat = (/ & 0.8209, 0.8210, 0.8213, 0.8215, 0.8219, & 0.8222, 0.8226, 0.8231, 0.8235, 0.8239, & 0.8242, 0.8245, 0.8247, 0.8251, 0.8257, & 0.8263, 0.8263, 0.8246, 0.8181, 0.8036, & 0.7760, 0.7306, 0.6596, 0.5638, 0.4534, & 0.3413, 0.2359, 0.1491, 0.0919, 0.0596, & 0.0394, 0.0255, 0.0161, 0.0099, 0.0061, & 0.0038, 0.0024, 0.0017, 0.0012, 0.0010, & 0.0009, 0.0008, 0.0006, 0.0006, 0.0005, & 0.0004, 0.0002, 0.0002, 0.0002, 0.0001, & 0.0001, 0.0001, 0.0001, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000 /) if ( wdat(1) <= w .and. w <= wdat(ndat) ) then call interp ( ndat, w, wdat, x, xdat ) call interp ( ndat, w, wdat, y, ydat ) call interp ( ndat, w, wdat, z, zdat ) else x = 0.0D+00 y = 0.0D+00 z = 0.0D+00 end if return end subroutine nm_to_xyz_cap ( w, xcap, ycap, zcap ) !*****************************************************************************80 ! !! NM_TO_XYZ_CAP converts a pure light wavelength to CIE XYZ color coordinates. ! ! Definition: ! ! The CIE XYZ color system describes a color in terms of its components ! of X, Y and Z primaries. In ordinary circumstances, all three of ! these components must be nonnegative. ! ! Measurements were made assuming a stimulus of one watt of pure ! light of the indicated wavelength. ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Deane Judd and Gunter Wyszecki, ! Color in Business, Science, and Industry, ! Wiley, 1975, pages 126-127, 130. ! ! Parameters: ! ! Input, real ( kind = 8 ) W, the wavelength in nanometers. W should lie ! between 380 nm and 780 nm. Values outside this range will result in ! output values of XCAP = YCAP = ZCAP = 0. ! ! Output, real ( kind = 8 ) XCAP, YCAP, ZCAP, the CIE XYZ color coordinates. ! The values indicate the amounts of the CIE primaries X, Y and Z ! required to match the color of the stimulus light. ! implicit none integer, parameter :: ndat = 90 real ( kind = 8 ) w real ( kind = 8 ), save, dimension ( ndat ) :: wdat = (/ & 380.0D+00, 385.0D+00, 390.0D+00, 395.0D+00, 400.0D+00, & 405.0D+00, 410.0D+00, 415.0D+00, 420.0D+00, 425.0D+00, & 430.0D+00, 435.0D+00, 440.0D+00, 445.0D+00, 450.0D+00, & 455.0D+00, 460.0D+00, 465.0D+00, 470.0D+00, 475.0D+00, & 480.0D+00, 485.0D+00, 490.0D+00, 495.0D+00, 500.0D+00, & 505.0D+00, 510.0D+00, 515.0D+00, 520.0D+00, 525.0D+00, & 530.0D+00, 535.0D+00, 540.0D+00, 545.0D+00, 550.0D+00, & 555.0D+00, 560.0D+00, 565.0D+00, 570.0D+00, 575.0D+00, & 580.0D+00, 585.0D+00, 590.0D+00, 595.0D+00, 600.0D+00, & 605.0D+00, 610.0D+00, 615.0D+00, 620.0D+00, 625.0D+00, & 630.0D+00, 635.0D+00, 640.0D+00, 645.0D+00, 650.0D+00, & 655.0D+00, 660.0D+00, 665.0D+00, 670.0D+00, 675.0D+00, & 680.0D+00, 685.0D+00, 690.0D+00, 695.0D+00, 700.0D+00, & 705.0D+00, 710.0D+00, 715.0D+00, 720.0D+00, 725.0D+00, & 730.0D+00, 735.0D+00, 740.0D+00, 745.0D+00, 750.0D+00, & 755.0D+00, 760.0D+00, 765.0D+00, 770.0D+00, 775.0D+00, & 780.0D+00, 785.0D+00, 790.0D+00, 795.0D+00, 800.0D+00, & 805.0D+00, 810.0D+00, 815.0D+00, 820.0D+00, 825.0D+00 /) real ( kind = 8 ) xcap real ( kind = 8 ), save, dimension ( ndat ) :: xdat = (/ & 0.0014, 0.0022, 0.0042, 0.0076, 0.0143, & 0.0232, 0.0435, 0.0776, 0.1344, 0.2148, & 0.2839, 0.3285, 0.3483, 0.3481, 0.3362, & 0.3187, 0.2908, 0.2511, 0.1954, 0.1421, & 0.0956, 0.0580, 0.0320, 0.0147, 0.0049, & 0.0024, 0.0093, 0.0291, 0.0633, 0.1096, & 0.1655, 0.2257, 0.2904, 0.3597, 0.4334, & 0.5121, 0.5945, 0.6784, 0.7621, 0.8425, & 0.9163, 0.9786, 1.0263, 1.0567, 1.0622, & 1.0456, 1.0026, 0.9384, 0.8544, 0.7514, & 0.6424, 0.5419, 0.4479, 0.3608, 0.2835, & 0.2187, 0.1649, 0.1212, 0.0874, 0.0636, & 0.0468, 0.0329, 0.0227, 0.0158, 0.0114, & 0.0081, 0.0058, 0.0041, 0.0029, 0.0020, & 0.0014, 0.0010, 0.0007, 0.0005, 0.0003, & 0.0002, 0.0002, 0.0001, 0.0001, 0.0001, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000 /) real ( kind = 8 ) ycap real ( kind = 8 ), save, dimension ( ndat ) :: ydat = (/ & 0.0000, 0.0001, 0.0001, 0.0002, 0.0004, & 0.0006, 0.0012, 0.0022, 0.0040, 0.0073, & 0.0116, 0.0168, 0.0230, 0.0298, 0.0380, & 0.0480, 0.0600, 0.0739, 0.0910, 0.1126, & 0.1390, 0.1693, 0.2080, 0.2586, 0.3230, & 0.4073, 0.5030, 0.6082, 0.7100, 0.7932, & 0.8620, 0.9149, 0.9540, 0.9803, 0.9950, & 1.0000, 0.9950, 0.9786, 0.9520, 0.9154, & 0.8700, 0.8163, 0.7570, 0.6949, 0.6310, & 0.5668, 0.5030, 0.4412, 0.3810, 0.3210, & 0.2650, 0.2170, 0.1750, 0.1382, 0.1070, & 0.0816, 0.0610, 0.0466, 0.0320, 0.0232, & 0.0170, 0.0119, 0.0082, 0.0057, 0.0041, & 0.0029, 0.0021, 0.0015, 0.0010, 0.0007, & 0.0005, 0.0004, 0.0002, 0.0002, 0.0001, & 0.0001, 0.0001, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000 /) real ( kind = 8 ) zcap real ( kind = 8 ), save, dimension ( ndat ) :: zdat = (/ & 0.0065, 0.0105, 0.0201, 0.0362, 0.0679, & 0.1102, 0.2074, 0.3713, 0.6456, 1.0391, & 1.3856, 1.6230, 1.7471, 1.7826, 1.7721, & 1.7441, 1.6692, 1.5281, 1.2876, 1.0419, & 0.8130, 0.6162, 0.4652, 0.3533, 0.2720, & 0.2123, 0.1582, 0.1117, 0.0782, 0.0573, & 0.0422, 0.0298, 0.0203, 0.0134, 0.0087, & 0.0057, 0.0039, 0.0027, 0.0021, 0.0018, & 0.0017, 0.0014, 0.0011, 0.0010, 0.0008, & 0.0006, 0.0003, 0.0002, 0.0002, 0.0001, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & 0.0000, 0.0000, 0.0000, 0.0000, 0.0000 /) if ( wdat(1) <= w .and. w <= wdat(ndat) ) then call interp ( ndat, w, wdat, xcap, xdat ) call interp ( ndat, w, wdat, ycap, ydat ) call interp ( ndat, w, wdat, zcap, zdat ) else xcap = 0.0D+00 ycap = 0.0D+00 zcap = 0.0D+00 end if return end subroutine nonlin_to_lin ( rprime, r ) !*****************************************************************************80 ! !! NONLIN_TO_LIN converts a nonlinear video signal to a linear light intensity. ! ! Definition: ! ! This process is also known as gamma (un)correction. ! ! Modified: ! ! 08 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) RPRIME, the nonlinear video signal. ! ! Output, real ( kind = 8 ) R, the linear light intensity. ! implicit none real ( kind = 8 ) r real ( kind = 8 ) rprime if ( rprime <= -0.081D+00 ) then r = - ( ( ( 0.099D+00 - rprime ) / 1.099D+00 )**(1.0D+00/0.45D+00) ) else if ( abs ( rprime ) <= 0.081D+00 ) then r = rprime / 4.5D+00 else if ( 0.081D+00 <= rprime ) then r = ( ( 0.099D+00 + rprime ) / 1.099D+00 )**(1.0D+00/0.45D+00) end if return end subroutine primaries_to_y ( rx, ry, gx, gy, bx, by, wx, wy, yr, yg, yb ) !*****************************************************************************80 ! !! PRIMARIES_TO_Y computes the luminance function for given primaries. ! ! Formula: ! ! The luminance function has the form: ! ! Y = YR * R + YG * G + YB * B ! ! Modified: ! ! 27 January 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! David Martindale and Alan Paeth, ! Television Color Encoding and Hot Broadcast Colors, ! Graphics Gems II, edited by James Arvo, ! Academic Press, 1991, pages 147-158. ! ! Parameters: ! ! Input, real ( kind = 8 ) RX, RY, the xy chromaticities of the R primary. ! ! Input, real ( kind = 8 ) GX, GY, the xy chromaticities of the G primary. ! ! Input, real ( kind = 8 ) BX, BY, the xy chromaticities of the B primary. ! ! Input, real ( kind = 8 ) WX, WY, the xy chromaticities of the reference ! white. ! ! Output, real ( kind = 8 ) YR, YG, YB, the coefficients of the R, G and B ! primaries in the luminance function. ! implicit none integer, parameter :: n = 3 integer, parameter :: nrhs = 1 real ( kind = 8 ) a(n,n+nrhs) real ( kind = 8 ) bx real ( kind = 8 ) by real ( kind = 8 ) gx real ( kind = 8 ) gy integer info real ( kind = 8 ) rx real ( kind = 8 ) ry real ( kind = 8 ) wx real ( kind = 8 ) wy real ( kind = 8 ) yb real ( kind = 8 ) yg real ( kind = 8 ) yr ! ! Set up the coefficients and right hand side of the linear system. ! a(1,1) = rx a(1,2) = gx a(1,3) = bx a(1,4) = wx / wy a(2,1) = ry a(2,2) = gy a(2,3) = by a(2,4) = wy / wy a(3,1) = 1.0D+00 - rx - ry a(3,2) = 1.0D+00 - gx - gy a(3,3) = 1.0D+00 - bx - by a(3,4) = ( 1.0D+00 - wx - wy ) / wy ! ! Solve the linear system A * x = b. ! call r8mat_solve ( a, n, nrhs, info ) ! ! Extract the solution. ! if ( info == 0 ) then yr = a(1,4) * ry yg = a(2,4) * gy yb = a(3,4) * by else yr = 0.0D+00 yg = 0.0D+00 yb = 0.0D+00 end if return end function r8_cubert ( x ) !*****************************************************************************80 ! !! R8_CUBERT returns the cube root of an R8. ! ! Discussion: ! ! R8_CUBERT is designed to avoid the possible problems that can occur ! when formulas like 0.0**(1/3) or (-1.0)**(1/3) are to be evaluated. ! ! Modified: ! ! 01 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the number whose cube root is desired. ! ! Output, real ( kind = 8 ) R8_CUBERT, the cube root of X. ! implicit none real ( kind = 8 ) r8_cubert real ( kind = 8 ) x if ( 0.0D+00 < x ) then r8_cubert = x**(1.0D+00/3.0D+00) else if ( x == 0.0D+00 ) then r8_cubert = 0.0D+00 else r8_cubert = - ( abs ( x ) )**(1.0D+00/3.0D+00) end if return end function r8_modp ( x, y ) !*****************************************************************************80 ! !! R8_MODP returns the nonnegative remainder of real division. ! ! Formula: ! ! If ! REM = R8_MODP ( X, Y ) ! RMULT = ( X - REM ) / Y ! then ! X = Y * RMULT + REM ! where REM is always nonnegative. ! ! Comments: ! ! The MOD function computes a result with the same sign as the ! quantity being divided. Thus, suppose you had an angle A, ! and you wanted to ensure that it was between 0 and 360. ! Then mod(A,360.0) would do, if A was positive, but if A ! was negative, your result would be between -360 and 0. ! ! On the other hand, R8_MODP(A,360.0) is between 0 and 360, always. ! ! Examples: ! ! I J MOD R8_MODP R8_MODP Factorization ! ! 107 50 7 7 107 = 2 * 50 + 7 ! 107 -50 7 7 107 = -2 * -50 + 7 ! -107 50 -7 43 -107 = -3 * 50 + 43 ! -107 -50 -7 43 -107 = 3 * -50 + 43 ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the number to be divided. ! ! Input, real ( kind = 8 ) Y, the number that divides X. ! ! Output, real ( kind = 8 ) R8_MODP, the nonnegative remainder when ! X is divided by Y. ! implicit none real ( kind = 8 ) r8_modp real ( kind = 8 ) x real ( kind = 8 ) y if ( y == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_MODP - Fatal error!' write ( *, '(a,g14.6)' ) ' R8_MODP ( X, Y ) called with Y = ', y stop end if r8_modp = mod ( x, y ) if ( r8_modp < 0.0D+00 ) then r8_modp = r8_modp + abs ( y ) end if return end subroutine r8_swap ( x, y ) !*****************************************************************************80 ! !! R8_SWAP switches two R8's. ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z z = x x = y y = z return end function r8_uniform_01 ( seed ) !*****************************************************************************80 ! !! R8_UNIFORM_01 returns a unit pseudorandom R8. ! ! Discussion: ! ! An R8 is a real ( kind = 8 ) value. ! ! For now, the input quantity SEED is an integer ( kind = 4 ) variable. ! ! This routine implements the recursion ! ! seed = 16807 * seed mod ( 2**31 - 1 ) ! r8_uniform_01 = seed / ( 2**31 - 1 ) ! ! The integer arithmetic never requires more than 32 bits, ! including a sign bit. ! ! If the initial seed is 12345, then the first three computations are ! ! Input Output R8_UNIFORM_01 ! SEED SEED ! ! 12345 207482415 0.096616 ! 207482415 1790989824 0.833995 ! 1790989824 2035175616 0.947702 ! ! Modified: ! ! 05 July 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley Interscience, page 95, 1998. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should ! NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, ! strictly between 0 and 1. ! implicit none integer ( kind = 4 ) k real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ) seed if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if ! ! Although SEED can be represented exactly as a 32 bit integer, ! it generally cannot be represented exactly as a 32 bit real number! ! r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10 return end subroutine r8mat_solve ( a, n, nrhs, info ) !*****************************************************************************80 ! !! R8MAT_SOLVE uses Gauss-Jordan elimination to solve an N by N linear system. ! ! Modified: ! ! 30 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) A(N,N+NRHS), contains in rows and columns 1 ! to N the coefficient matrix, and in columns N+1 through ! N+NRHS, the right hand sides. On output, the coefficient matrix ! area has been destroyed, while the right hand sides have ! been overwritten with the corresponding solutions. ! ! Input, integer NRHS, the number of right hand sides. NRHS ! must be at least 0. ! ! Output, integer INFO, singularity flag. ! 0, the matrix was not singular, the solutions were computed; ! J, factorization failed on step J, and the solutions could not ! be computed. ! implicit none integer n integer nrhs real ( kind = 8 ) a(n,n+nrhs) real ( kind = 8 ) apivot real ( kind = 8 ) factor integer i integer info integer ipivot integer j info = 0 do j = 1, n ! ! Choose a pivot row. ! ipivot = j apivot = a(j,j) do i = j + 1, n if ( abs ( apivot ) < abs ( a(i,j) ) ) then apivot = a(i,j) ipivot = i end if end do if ( apivot == 0.0D+00 ) then info = j return end if ! ! Interchange. ! do i = 1, n + nrhs call r8_swap ( a(ipivot,i), a(j,i) ) end do ! ! A(J,J) becomes 1. ! a(j,j) = 1.0D+00 a(j,j+1:n+nrhs) = a(j,j+1:n+nrhs) / apivot ! ! A(I,J) becomes 0. ! do i = 1, n if ( i /= j ) then factor = a(i,j) a(i,j) = 0.0D+00 a(i,j+1:n+nrhs) = a(i,j+1:n+nrhs) - factor * a(j,j+1:n+nrhs) end if end do end do return end function radians_to_degrees ( angle ) !*****************************************************************************80 ! !! RADIANS_TO_DEGREES converts an angle from radians to degrees. ! ! Modified: ! ! 10 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) ANGLE, an angle in radians. ! ! Output, real ( kind = 8 ) RADIANS_TO_DEGREES, the equivalent angle ! in degrees. ! implicit none real ( kind = 8 ) angle real ( kind = 8 ) radians_to_degrees real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 radians_to_degrees = ( angle / pi ) * 180.0D+00 return end subroutine rgb709_to_xyz_cap ( r, g, b, xcap, ycap, zcap ) !*****************************************************************************80 ! !! RGB709_TO_XYZ_CAP converts RGB709 to CIE XYZ color coordinates. ! ! Definition: ! ! The CIE XYZ color system describes a color in terms of its components ! of X, Y and Z primaries. In ordinary circumstances, all three of ! these components must be nonnegative. ! ! Modified: ! ! 06 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB 709 color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) XCAP, YCAP, ZCAP, the corresponding CIE XYZ ! color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ) r real ( kind = 8 ) xcap real ( kind = 8 ) ycap real ( kind = 8 ) zcap xcap = 0.412453D+00 * r + 0.35758D+00 * g + 0.180423D+00 * b ycap = 0.212671D+00 * r + 0.71516D+00 * g + 0.072169D+00 * b zcap = 0.019334D+00 * r + 0.119193D+00 * g + 0.950227D+00 * b return end subroutine rgb_check ( r, g, b ) !*****************************************************************************80 ! !! RGB_CHECK corrects out-of-range RGB color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! Examples: ! ! Black ( 0.0, 0.0, 0.0D+00 ) ! Blue ( 0.0, 0.0, 1.0D+00 ) ! Cyan ( 0.0, 1.0, 1.0D+00 ) ! Green ( 0.0, 1.0, 0.0D+00 ) ! Magenta ( 1.0, 0.0, 1.0D+00 ) ! Red ( 1.0, 0.0, 0.0D+00 ) ! White ( 1.0, 1.0, 1.0D+00 ) ! Yellow ( 1.0, 1.0, 0.0D+00 ) ! ! Modified: ! ! 25 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) R, G, B, the RGB color coordinates to ! be checked. Any coordinate less than 0 is set to 0, and any ! coordinate greater than 1 is set to 1. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ) r r = max ( r, 0.0D+00 ) r = min ( r, 1.0D+00 ) g = max ( g, 0.0D+00 ) g = min ( g, 1.0D+00 ) b = max ( b, 0.0D+00 ) b = min ( b, 1.0D+00 ) return end subroutine rgb_uniform ( seed, r, g, b ) !*****************************************************************************80 ! !! RGB_UNIFORM returns a random RGB color. ! ! Modified: ! ! 10 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) R, G, B, the RGB values of the color. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) r8_uniform_01 real ( kind = 8 ) g real ( kind = 8 ) r integer seed r = r8_uniform_01 ( seed ) g = r8_uniform_01 ( seed ) b = r8_uniform_01 ( seed ) return end subroutine rgb_named_uniform ( seed, r, g, b, name ) !*****************************************************************************80 ! !! RGB_NAMED_UNIFORM returns a random named RGB color. ! ! Discussion: ! ! The named colors are extracted at random from those listed ! in "colors.txt". ! ! Modified: ! ! 20 February 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) R, G, B, the RGB values of the color. ! ! Output, character ( len = * ) NAME, the name of the color. ! implicit none real ( kind = 8 ) b real ( kind = 8 ), save, allocatable, dimension ( : ) :: b_saved integer color_index integer, save :: color_num character ( len = 30 ), save :: color_file = 'colors.txt' real ( kind = 8 ) g real ( kind = 8 ), save, allocatable, dimension ( : ) :: g_saved integer i4_uniform integer ib integer ig integer ios integer ir integer iunit logical, save :: loaded = .false. character ( len = * ) name character ( len = 30 ) name2 character ( len = 30 ), save, allocatable, dimension ( : ) :: name_saved real ( kind = 8 ) r real ( kind = 8 ), save, allocatable, dimension ( : ) :: r_saved integer seed if ( .not. loaded ) then call get_unit ( iunit ) open ( unit = iunit, file = color_file, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RGB_NAMED_UNIFORM - Fatal error!' write ( *, '(a)' ) ' Could not open the color name file:' write ( *, '(a)' ) trim ( color_file ) stop end if color_num = 0 do read ( iunit, '(i3,2x,i3,2x,i3,2x,a)', iostat = ios ) ir, ig, ib, name if ( ios /= 0 ) then exit end if color_num = color_num + 1 end do allocate ( r_saved(1:color_num) ) allocate ( g_saved(1:color_num) ) allocate ( b_saved(1:color_num) ) allocate ( name_saved(1:color_num) ) rewind ( unit = iunit ) color_num = 0 do read ( iunit, '(i3,2x,i3,2x,i3,2x,a)', iostat = ios ) ir, ig, ib, name2 if ( ios /= 0 ) then exit end if color_num = color_num + 1 r_saved(color_num) = real ( ir, kind = 8 ) / 255.0D+00 g_saved(color_num) = real ( ig, kind = 8 ) / 255.0D+00 b_saved(color_num) = real ( ib, kind = 8 ) / 255.0D+00 name_saved(color_num) = name2 end do close ( unit = iunit ) loaded = .true. end if color_index = i4_uniform ( 1, color_num, seed ) r = r_saved(color_index) g = g_saved(color_index) b = b_saved(color_index) name = name_saved(color_index) return end subroutine rgb_test ( itest, rtest, gtest, btest ) !*****************************************************************************80 ! !! RGB_TEST supplies RGB values for tests. ! ! Modified: ! ! 12 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITEST, the index of the test. ! ! Output, real ( kind = 8 ) RTEST, GTEST, BTEST, sample RGB color coordinate ! values for testing. If ITEST is outside the range of data, ! then RTEST = GTEST = BTEST = -1.0. ! implicit none real ( kind = 8 ) btest real ( kind = 8 ) gtest integer itest real ( kind = 8 ) rtest if ( itest == 1 ) then rtest = 0.9D+00 gtest = 0.0D+00 btest = 0.0D+00 else if ( itest == 2 ) then rtest = 0.0D+00 gtest = 0.8D+00 btest = 0.0D+00 else if ( itest == 3 ) then rtest = 0.0D+00 gtest = 0.0D+00 btest = 0.7D+00 else if ( itest == 4 ) then rtest = 0.0D+00 gtest = 0.6D+00 btest = 0.6D+00 else if ( itest == 5 ) then rtest = 0.5D+00 gtest = 0.0D+00 btest = 0.5D+00 else if ( itest == 6 ) then rtest = 0.4D+00 gtest = 0.4D+00 btest = 0.0D+00 ! ! Dark gray ! else if ( itest == 7 ) then rtest = 0.3D+00 gtest = 0.3D+00 btest = 0.3D+00 ! ! Black ! else if ( itest == 8 ) then rtest = 0.0D+00 gtest = 0.0D+00 btest = 0.0D+00 ! ! White ! else if ( itest == 9 ) then rtest = 1.0D+00 gtest = 1.0D+00 btest = 1.0D+00 else if ( itest == 10 ) then rtest = 0.1D+00 gtest = 0.3D+00 btest = 0.5D+00 else if ( itest == 11 ) then rtest = 0.3D+00 gtest = 0.5D+00 btest = 0.3D+00 ! ! Signal that ITEST is out of range. ! else rtest = -1.0D+00 gtest = -1.0D+00 btest = -1.0D+00 end if return end subroutine rgb_to_cmy ( r, g, b, c, m, y ) !*****************************************************************************80 ! !! RGB_TO_CMY converts RGB to CMY color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The CMY color system describes a color based on the amounts of the ! base colors cyan, magenta, and yellow. Thus, a particular color ! has three coordinates, (C,M,Y). Each coordinate must be between ! 0 and 1. Black is (1,1,1) and white is (0,0,0). ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) C, M, Y, the corresponding CMY color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) g real ( kind = 8 ) m real ( kind = 8 ) r real ( kind = 8 ) y c = 1.0D+00 - r m = 1.0D+00 - g y = 1.0D+00 - b return end subroutine rgb_to_cmyk ( r, g, b, c, m, y, k ) !*****************************************************************************80 ! !! RGB_TO_CMYK converts RGB to CMYK color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The CMYK color system describes a color based on the amounts of the ! base colors cyan, magenta, yellow, and black. The CMYK system is ! based on the CMY system, except that equal amounts of C, M, and Y ! are replaced by the single color K. Thus, a particular color ! has four coordinates, (C,M,Y,K). Each coordinate must be between ! 0 and 1, and it must also be true that C+K, M+K and Y+K are ! each no greater than 1. ! ! Modified: ! ! 30 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) C, M, Y, K, the corresponding CMYK color ! coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) g real ( kind = 8 ) k real ( kind = 8 ) m real ( kind = 8 ) r real ( kind = 8 ) y ! ! Compute the CMY equivalent colors. ! c = 1.0D+00 - r m = 1.0D+00 - g y = 1.0D+00 - b ! ! Compute the black component. ! k = min ( c, m, y ) ! ! Subtract off the black component to complete the CMYK specification. ! c = c - k m = m - k y = y - k return end subroutine rgb_to_hls ( r, g, b, h, l, s ) !*****************************************************************************80 ! !! RGB_TO_HLS converts RGB to HLS color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The HLS color system describes a color based on the qualities of ! hue, lightness, and saturation. A particular color has three ! coordinates, (H,L,S). The L and S coordinates must be between ! 0 and 1, while the H coordinate must be between 0 and 360, and ! is interpreted as an angle. ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) H, L, S, the corresponding HLS color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) bc real ( kind = 8 ) r8_modp real ( kind = 8 ) g real ( kind = 8 ) gc real ( kind = 8 ) h real ( kind = 8 ) l real ( kind = 8 ) r real ( kind = 8 ) rc real ( kind = 8 ) rgbmax real ( kind = 8 ) rgbmin real ( kind = 8 ) s ! ! Compute lightness. ! rgbmax = max ( r, g, b ) rgbmin = min ( r, g, b ) l = ( rgbmax + rgbmin ) / 2.0D+00 ! ! Compute saturation. ! if ( rgbmax == rgbmin ) then s = 0.0D+00 else if ( l <= 0.5D+00 ) then s = ( rgbmax - rgbmin ) / ( rgbmax + rgbmin ) else s = ( rgbmax - rgbmin ) / ( 2.0D+00 - rgbmax - rgbmin ) end if end if ! ! Compute the hue. ! if ( rgbmax == rgbmin ) then h = 0.0D+00 else rc = ( rgbmax - r ) / ( rgbmax - rgbmin ) gc = ( rgbmax - g ) / ( rgbmax - rgbmin ) bc = ( rgbmax - b ) / ( rgbmax - rgbmin ) if ( r == rgbmax ) then h = bc - gc else if ( g == rgbmax ) then h = 2.0D+00 + rc - bc else h = 4.0D+00 + gc - rc end if h = h * 60.0D+00 ! ! Make sure H lies between 0 and 360.0. ! h = r8_modp ( h, 360.0D+00 ) end if return end subroutine rgb_to_hsi ( r, g, b, h, s, i ) !*****************************************************************************80 ! !! RGB_TO_HSI converts RGB to HSI color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The HSI color system uses coordinates of ! Hue, an angle between 0 and 360, (0=R, 120=G, 240=B) ! Saturation, between 0 and 1, and ! Intensity, between 0 and 1. ! ! Note, Grrr, that there is a typo in the formula for H in Fortner's ! book. ! ! Modified: ! ! 05 August 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Brand Fortner, ! Number by Colors, A Guide to Using Color to Understand Technical Data, ! Springer, 1997, pages 140-143. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) H, S, I, the corresponding HSI color coordinates. ! implicit none real ( kind = 8 ) atan4 real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ) h real ( kind = 8 ) i real ( kind = 8 ) r real ( kind = 8 ) radians_to_degrees real ( kind = 8 ) s h = atan4 ( sqrt ( 3.0D+00 ) * ( g - b ), 2.0D+00 * r - b - g ) h = radians_to_degrees ( h ) i = ( r + g + b ) / 3.0D+00 if ( i == 0.0D+00 ) then s = 0.0D+00 else s = 1.0D+00 - min ( r, g, b ) / i end if return end subroutine rgb_to_hsv ( r, g, b, h, s, v ) !*****************************************************************************80 ! !! RGB_TO_HSV converts RGB to HSV color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The HSV color system describes a color based on the three qualities ! of hue, saturation, and value. A given color will be represented ! by three numbers, (H,S,V). H, the value of hue, is an angle ! between 0 and 360 degrees, with 0 representing red. S is the ! saturation, and is between 0 and 1. Finally, V is the "value", ! a measure of brightness, which goes from 0 for black, increasing ! to a maximum of 1 for the brightest colors. The HSV color system ! is sometimes also called HSB, where the B stands for brightness. ! ! Modified: ! ! 29 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Foley, Andries van Dam, Steven Feiner, John Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates ! to be converted. ! ! Output, real ( kind = 8 ) H, S, V, the corresponding HSV color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) bc real ( kind = 8 ) r8_modp real ( kind = 8 ) g real ( kind = 8 ) gc real ( kind = 8 ) h real ( kind = 8 ) r real ( kind = 8 ) rc real ( kind = 8 ) rgbmax real ( kind = 8 ) rgbmin real ( kind = 8 ) s real ( kind = 8 ) v rgbmax = max ( r, g, b ) rgbmin = min ( r, g, b ) v = rgbmax ! ! Compute the saturation. ! if ( rgbmax /= 0.0D+00 ) then s = ( rgbmax - rgbmin ) / rgbmax else s = 0.0D+00 end if ! ! Compute the hue. ! if ( s == 0.0D+00 ) then h = 0.0D+00 else rc = ( rgbmax - r ) / ( rgbmax - rgbmin ) gc = ( rgbmax - g ) / ( rgbmax - rgbmin ) bc = ( rgbmax - b ) / ( rgbmax - rgbmin ) if ( r == rgbmax ) then h = bc - gc else if ( g == rgbmax ) then h = 2.0D+00 + rc - bc else h = 4.0D+00 + gc - rc end if h = h * 60.0D+00 ! ! Make sure H lies between 0 and 360.0D+00 ! h = r8_modp ( h, 360.0D+00 ) end if return end subroutine rgb_to_hue ( r, g, b, h ) !*****************************************************************************80 ! !! RGB_TO_HUE converts (R,G,B) colors to a hue value between 0 and 1. ! ! Discussion: ! ! The hue computed here should be the same as the H value computed ! for HLS and HSV, except that it ranges from 0 to 1 instead of ! 0 to 360. ! ! A monochromatic color ( white, black, or a shade of gray) does not ! have a hue. This routine will return a special value of H = -1 ! for such cases. ! ! Examples: ! ! Color R G B H ! ! red 1.0 0.0 0.0 0.00 ! yellow 1.0 1.0 0.0 0.16 ! green 0.0 1.0 0.0 0.33 ! cyan 0.0 1.0 1.0 0.50 ! blue 0.0 0.0 1.0 0.67 ! magenta 1.0 0.0 1.0 0.83 ! ! black 0.0 0.0 0.0 -1.00 ! gray 0.5 0.5 0.5 -1.00 ! white 1.0 1.0 1.0 -1.00 ! ! Modified: ! ! 25 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the red, green and blue values of ! the color. ! These values should be between 0 and 1. ! ! Output, real ( kind = 8 ) H, the corresponding hue of the color, ! or -1.0D+00 if the color is monochromatic. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) g real ( kind = 8 ) g2 real ( kind = 8 ) h real ( kind = 8 ) r real ( kind = 8 ) r2 real ( kind = 8 ) rgbmax real ( kind = 8 ) rgbmin ! ! Make sure the colors are between 0 and 1. ! r2 = min ( max ( r, 0.0D+00 ), 1.0D+00 ) g2 = min ( max ( g, 0.0D+00 ), 1.0D+00 ) b2 = min ( max ( b, 0.0D+00 ), 1.0D+00 ) ! ! Compute the minimum and maximum of R, G and B. ! rgbmax = r2 rgbmax = max ( rgbmax, g2 ) rgbmax = max ( rgbmax, b2 ) rgbmin = r2 rgbmin = min ( rgbmin, g2 ) rgbmin = min ( rgbmin, b2 ) ! ! If RGBMAX = RGBMIN, then the color has no hue. ! if ( rgbmax == rgbmin ) then h = - 1.0D+00 ! ! Otherwise, we need to determine the dominant color. ! else if ( r2 == rgbmax ) then h = ( g2 - b2 ) / ( rgbmax - rgbmin ) else if ( g2 == rgbmax ) then h = 2.0D+00 + ( b2 - r2 ) / ( rgbmax - rgbmin ) else if ( b2 == rgbmax ) then h = 4.0D+00 + ( r2 - g2 ) / ( rgbmax - rgbmin ) end if h = h / 6.0D+00 ! ! Make sure H lies between 0 and 1.0. ! if ( h < 0.0D+00 ) then h = h + 1.0D+00 else if ( 1.0D+00 < h ) then h = h - 1.0D+00 end if end if return end subroutine rgb_to_name ( r, g, b, name ) !*****************************************************************************80 ! !! RGB_TO_NAME converts RGB colors to the name of the nearest color. ! ! Discussion: ! ! The names and information are read from the file "COLORS.TXT", a ! modified version of the X Windows color data file "RGB.TXT". ! ! Modified: ! ! 10 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB coordinates of the color. ! ! Output, character ( len = * ) NAME, the name of the color that is the ! "closest" to the given RGB coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) bcolor character ( len = 20 ) :: color_file = 'colors.txt' real ( kind = 8 ) dismin real ( kind = 8 ) dist logical first real ( kind = 8 ) g real ( kind = 8 ) gcolor integer ib integer ig integer ios integer ir integer iunit character ( len = * ) name character ( len = 30 ) namecolor real ( kind = 8 ) r real ( kind = 8 ) rcolor first = .true. name = 'Unknown' call get_unit ( iunit ) open ( unit = iunit, file = color_file, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RGB_TO_NAME - Fatal error!' write ( *, '(a)' ) ' Could not open the color name file:' write ( *, '(a)' ) trim ( color_file ) stop end if do read ( iunit, '(i3,2x,i3,2x,i3,2x,a)', iostat = ios ) ir, ig, ib, namecolor if ( ios /= 0 ) then exit end if rcolor = real ( ir, kind = 8 ) / 255.0D+00 gcolor = real ( ig, kind = 8 ) / 255.0D+00 bcolor = real ( ib, kind = 8 ) / 255.0D+00 dist = sqrt ( ( r - rcolor )**2 + ( g - gcolor ) **2 + ( b - bcolor ) **2 ) if ( first ) then dismin = dist name = namecolor first = .false. else if ( dist < dismin ) then dismin = dist name = namecolor end if if ( dismin == 0.0D+00 ) then exit end if end do close ( unit = iunit ) return end subroutine rgb_to_ncs ( r, g, b, c1, c2, n, c, s ) !*****************************************************************************80 ! !! RGB_TO_NCS converts RGB to NCS color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! ! The NCS or "natural color system" describes a color based on: ! * C1 and C2, two elementary colors from the sequence RYGB or ! C2 = blank for a pure elementary color, or ! C1 = N, C2 = blank for a neutral color); ! * N, the percentage of C2; ! * C, the colorfulness or strength, as a percentage; ! * S, the blackness as a percentage. ! ! The scant documentation I have seen claims that the percentages are ! always less than 100. I don't see why, and for now I'll let them ! lie between 0 and 100. The NCS designation for a color has the form ! "CCSS C1NC2". ! ! Modified: ! ! 20 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Olof Kylander and Karin Kylander, ! GIMP: The Official Manual, ! Coriolis Open Press, 1999. ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the corresponding RGB color coordinates. ! ! Output, character C1, C2, integer N, C, S, the NCS color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) b2 integer c character c1 character c2 real ( kind = 8 ) g real ( kind = 8 ) g2 integer n real ( kind = 8 ) r real ( kind = 8 ) r2 real ( kind = 8 ) rgb_min integer s integer w real ( kind = 8 ) y2 ! ! Copy the input data. ! r2 = r g2 = g b2 = b y2 = 0.0D+00 call rgb_check ( r2, g2, b2 ) ! ! Extract the whiteness value. ! rgb_min = min ( r2, g2, b2 ) w = int ( 100.0D+00 * rgb_min ) ! ! Subtract off the whiteness. ! r2 = r2 - rgb_min g2 = g2 - rgb_min b2 = b2 - rgb_min y2 = 0.0D+00 ! ! If R2 = G2 = B2 = zero, we have an N (neutral) color or black or white. ! if ( r2 == 0.0D+00 .and. g2 == 0.0D+00 .and. b2 == 0.0D+00 ) then if ( w == 0 ) then c1 = 'B' c2 = ' ' n = 0 c = 0 else if ( w == 100 ) then c1 = 'W' c2 = ' ' n = 0 c = 0 else c1 = 'N' c2 = ' ' n = 0 c = 0 end if ! ! If two colors are zero, or if G = R, then we have a pure color. ! else if ( r2 == 0.0D+00 .and. b2 == 0.0D+00 ) then c1 = 'G' c2 = ' ' n = 0 c = int ( 100.0D+00 * g2 ) else if ( r2 == 0.0D+00 .and. g2 == 0.0D+00 ) then c1 = 'B' c2 = ' ' n = 0 c = int ( 100.0D+00 * b2 ) else if ( b2 == 0.0D+00 .and. g2 == 0.0D+00 ) then c1 = 'R' c2 = ' ' n = 0 c = int ( 100.0D+00 * r2 ) else if ( g2 == r2 ) then y2 = g2 g2 = 0.0D+00 r2 = 0.0D+00 c1 = 'Y' c2 = ' ' n = 0 c = int ( 100.0D+00 * y2 ) ! ! Two colors are nonzero. ! else if ( r2 == 0.0D+00 ) then c1 = 'G' c2 = 'B' y2 = 0.0 n = int ( 100.0D+00 * b2 / ( g2 + b2 ) ) else if ( g2 == 0.0D+00 ) then c1 = 'B' c2 = 'R' y2 = 0.0D+00 n = int ( 100.0D+00 * r2 / ( b2 + r2 ) ) else if ( b2 == 0.0D+00 .and. g2 < r2 ) then c1 = 'R' c2 = 'Y' y2 = g2 r2 = r2 - g2 g2 = 0.0D+00 n = int ( 100.0D+00 * y2 / ( r2 + y2 ) ) else if ( b2 == 0.0D+00 .and. r2 < g2 ) then c1 = 'Y' c2 = 'G' y2 = r2 g2 = g2 - r2 r2 = 0.0D+00 n = int ( 100.0D+00 * g2 / ( y2 + g2 ) ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RGB_TO_NCS - Fatal error!' write ( *, '(a)' ) ' Unexpected RGB combination:' write ( *, '(3g14.6)' ) r2, g2, b2 end if c = int ( 100.0D+00 * max ( r2, g2, b2, y2 ) ) s = 100 - c - w return end subroutine rgb_to_rgbprime ( r, g, b, rprime, gprime, bprime ) !*****************************************************************************80 ! !! RGB_TO_RGBPRIME converts RGB to R'G'B' color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The R'G'B' color system is a nonlinear video signal measurement. ! Each coordinate must be between 0 and 1. ! ! Modified: ! ! 07 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates to be ! converted. ! ! Output, real ( kind = 8 ) RPRIME, GPRIME, BPRIME, the corresponding ! R'G'B' color coordinates. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) bprime real ( kind = 8 ) g real ( kind = 8 ) gprime real ( kind = 8 ) r real ( kind = 8 ) rprime call lin_to_nonlin ( r, rprime ) call lin_to_nonlin ( g, gprime ) call lin_to_nonlin ( b, bprime ) return end subroutine rgb_to_ycbcr ( r, g, b, yr, yg, yb, yprime, cb, cr ) !*****************************************************************************80 ! !! RGB_TO_YCBCR converts RGB to Y'CbCr color coordinates. ! ! Definition: ! ! The RGB color system describes a color based on the amounts of the ! base colors red, green, and blue. Thus, a particular color ! has three coordinates, (R,G,B). Each coordinate must be between ! 0 and 1. ! ! The Y'CbCr color system is used in digital television signals. ! The Y' component measures luma, an approximation to the luminance ! or amount of light. Y' is the only component displayed on black ! and white televisions. The Cb and Cr components contain measures ! of the blue and red components of the color. Y' should be between ! 0 and 1, while Cb and Cr should be between -0.5 and 0.5. ! ! Modified: ! ! 31 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB color coordinates to be ! converted. ! ! Input, real ( kind = 8 ) YR, YG, YB, the coefficients of the R, G and B ! primaries in the luminance function. ! ! Output, real ( kind = 8 ) YPRIME, CB, CR, the corresponding Y'CbCr ! color coordinates. ! implicit none real ( kin