program colors_prb
!
!*******************************************************************************
!
!! COLORS_PRB calls the test programs for COLORS.
!
  implicit none
!
  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'COLORS_PRB'
  write ( *, '(a)' ) '  Simple tests for the COLORS color converter.'
 
  call test01
  call test02
  call test03
  call test04
  call test05
  call test06
  call test07
  call test08
  call test09
  call test10

  call test11
  call test12
  call test13
  call test14
  call test15
  call test16
  call test17
  call test18
  call test19
  call test20

  call test21
  call test22
  call test23
  call test24
  call test25
  call test26
  call test27
  call test28

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'COLORS_PRB'
  write ( *, '(a)' ) '  Normal end of execution.'
 
  stop
end
subroutine test01
!
!*******************************************************************************
!
!! TEST01 tests CMY_TO_RGB.
!! TEST01 tests RGB_TO_CMY.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real c
  real g
  real g2
  integer itest
  real m
  real r
  real r2
  real y
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST01'
  write ( *, '(a)' ) '  CMY_TO_RGB converts CMY to RGB colors.'
  write ( *, '(a)' ) '  RGB_TO_CMY converts RGB to CMY colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     C       M       Y    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_cmy ( r, g, b, c, m, y )

    call cmy_to_rgb ( c, m, y, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, c, m, y, r2, g2, b2
 
  end do

  return
end
subroutine test02
!
!*******************************************************************************
!
!! TEST02 tests CMYK_TO_RGB.
!! TEST02 tests RGB_TO_CMYK.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real c
  real g
  real g2
  integer itest
  real k
  real m
  real r
  real r2
  real y
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST02'
  write ( *, '(a)' ) '  CMYK_TO_RGB converts CMYK to RGB colors.'
  write ( *, '(a)' ) '  RGB_TO_CMYK converts RGB to CMYK colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     C       M       Y    ' &
    // '   K        Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_cmyk ( r, g, b, c, m, y, k )

    call cmyk_to_rgb ( c, m, y, k, r2, g2, b2 )

    write ( *, '(10f8.3)' ) r, g, b, c, m, y, k, r2, g2, b2
 
  end do

  return
end
subroutine test03
!
!*******************************************************************************
!
!! TEST03 tests HLS_TO_RGB.
!! TEST03 tests RGB_TO_HLS.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  real h
  integer itest
  real l
  real r
  real r2
  real s
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST03'
  write ( *, '(a)' ) '  HLS_TO_RGB converts HLS to RGB colors.'
  write ( *, '(a)' ) '  RGB_TO_HLS converts RGB to HLS colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     H       L       S    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_hls ( r, g, b, h, l, s )

    call hls_to_rgb ( h, l, s, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, h, l, s, r2, g2, b2
 
  end do

  return
end
subroutine test04
!
!*******************************************************************************
!
!! TEST04 tests HSV_TO_RGB.
!! TEST04 tests RGB_TO_HSV.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  real h
  integer itest
  real r
  real r2
  real s
  real v
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST04'
  write ( *, '(a)' ) '  HSV_TO_RGB converts HSV to RGB colors.'
  write ( *, '(a)' ) '  RGB_TO_HSV converts RGB to HSV colors;'

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     H       S       V    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_hsv ( r, g, b, h, s, v )

    call hsv_to_rgb ( h, s, v, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, h, s, v, r2, g2, b2
 
  end do

  return
end
subroutine test05
!
!*******************************************************************************
!
!! TEST05 tests LAB_TO_XYZ.
!! TEST05 tests XYZ_TO_LAB.
!
  implicit none
!
  integer, parameter :: ntest = 17
!
  real astar
  real bstar
  integer itest
  real lstar
  real nm
  real nmhi
  real nmlo
  real temp
  real x
  real xcap
  real xcap2
  real xcapn
  real xn
  real y
  real ycap
  real ycap2
  real ycapn
  real yn
  real z
  real zcap
  real zcap2
  real zcapn
  real zn
!
  nmlo = 380.0E+00
  nmhi = 700.0E+00
  ycapn = 100.0E+00

  call name_to_xyz ( 'D65', xn, yn, zn )

  call xyy_to_xyz ( xn, yn, xcapn, ycapn, zcapn )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST05'
  write ( *, '(a)' ) '  LAB_TO_XYZ converts L*a*b* to XYZ colors.'
  write ( *, '(a)' ) '  XYZ_TO_LAB converts XYZ to L*a*b* colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Illuminant XYZ color coordinates:'
  write ( *, '(3g14.6)' ) xcapn, ycapn, zcapn 
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  NM  Xin     Yin     Zin       L*       a*' &
    // '       b*      Xout   Yout   Zout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    nm = ( real ( ntest - itest ) * nmlo &
      + real ( itest - 1 ) * nmhi ) / real ( ntest - 1 )

    call nm_to_xyz ( nm, x, y, z )
    ycap = 0.95E+00 * ycapn
    call xyy_to_xyz ( x, y, xcap, ycap, zcap )
!
!  Make sure every component of (XCAP,YCAP,ZCAP) is smaller than
!  (XCAPN,YCAPN,ZCAPN).
!
    temp = 1.0E+00
    if ( xcap > 0.0E+00 .and. xcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * xcapn / xcap )
    end if
    if ( ycap > 0.0E+00 .and. ycapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * ycapn / ycap )
    end if
    if ( zcap > 0.0E+00 .and. zcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * zcapn / zcap )
    end if

    xcap = xcap * temp
    ycap = ycap * temp
    zcap = zcap * temp

    call xyz_to_lab ( xcap, ycap, zcap, xcapn, ycapn, zcapn, &
      lstar, astar, bstar )

    call lab_to_xyz ( lstar, astar, bstar, xcap2, ycap2, zcap2, &
      xcapn, ycapn, zcapn )

    write ( *, '(f5.1,3f8.3,3f9.3,3f8.3)' ) &
      nm, xcap, ycap, zcap, lstar, astar, bstar, xcap2, ycap2, zcap2
 
  end do

  return
end
subroutine test06
!
!*******************************************************************************
!
!! TEST06 tests LCC_TO_RGBPRIME.
!! TEST06 tests RGBPRIME_TO_LCC.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real bprime
  real bprime2
  real chroma1
  real chroma2
  real g
  real gprime
  real gprime2
  integer itest
  real luma
  real r
  real rprime
  real rprime2
  real yb
  real yg
  real yr
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST06'
  write ( *, '(a)' ) '  LCC_TO_RGBPRIME converts LCC to R''G''B'' colors;'
  write ( *, '(a)' ) '  RGBPRIME_TO_LCC converts R''G''B'' to LCC colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    R''in    G''in    B''in    Luma    Chroma1 ' &
    // 'Chroma2 R''out   G''out   B''out'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_rgbprime ( r, g, b, rprime, gprime, bprime )

    call rgbprime_to_lcc ( rprime, gprime, bprime, yr, yg, yb, luma, chroma1, &
      chroma2 )

    call lcc_to_rgbprime ( luma, chroma1, chroma2, yr, yg, yb, &
      rprime2, gprime2, bprime2 )

    write ( *, '(9f8.3)' ) rprime, gprime, bprime, luma, chroma1, &
      chroma2, rprime2, gprime2, bprime2

  end do

  return
end
subroutine test07
!
!*******************************************************************************
!
!! TEST07 tests LCC_TO_YCBCR.
!! TEST07 tests YCBCR_TO_LCC.
!
  implicit none
!
  integer, parameter :: ntest = 5
!
  real chroma1in
  real chroma1out
  real chroma2in
  real chroma2out
  real cb
  real cr
  integer itest
  real lumain
  real lumaout
  real y
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST07'
  write ( *, '(a)' ) '  LCC_TO_YCBCR converts LCC to YCBCR colors;'
  write ( *, '(a)' ) '  YCBCR_TO_LCC converts YCBCR to LCC colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Luma   Chroma1    Chroma2     Y''     Cb' &
    // '      Cr      Luma  Chroma1   Chroma2'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call ycc_test ( itest, lumain, chroma1in, chroma2in )

    call lcc_to_ycbcr ( lumain, chroma1in, chroma2in, y, cb, cr )

    call ycbcr_to_lcc ( y, cb, cr, lumaout, chroma1out, chroma2out )

    write ( *, '(9f8.3)' ) lumain, chroma1in, chroma2in, y, cb, cr, lumaout, &
      chroma1out, chroma2out
 
  end do

  return
end
subroutine test08
!
!*******************************************************************************
!
!! TEST08 tests LCC_TO_YCC.
!! TEST08 tests YCC_TO_LCC.
!
  implicit none
!
  integer, parameter :: ntest = 5
!
  real c1in
  real c1out
  real c2in
  real c2out
  real chroma1
  real chroma2
  integer itest
  real luma
  real yin
  real yout
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST08'
  write ( *, '(a)' ) '  LCC_TO_YCC converts LCC to PhotoYCC colors.'
  write ( *, '(a)' ) '  YCC_TO_LCC converts PhotoYCC to LCC colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    Yin    C1in     C2in     Luma     Chroma1' &
    // '      Chroma2      Yout    C1out    C2out'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call ycc_test ( itest, yin, c1in, c2in )

    call ycc_to_lcc ( yin, c1in, c2in, luma, chroma1, chroma2 )

    call lcc_to_ycc ( luma, chroma1, chroma2, yout, c1out, c2out )

    write ( *, '(9f8.3)' ) yin, c1in, c2in, luma, chroma1, chroma2, yout, &
      c1out, c2out
 
  end do

  return
end
subroutine test09
!
!*******************************************************************************
!
!! TEST09 tests LIN_TO_NONLIN.
!! TEST09 tests NONLIN_TO_LIN.
!
  implicit none
!
  integer i
  real r
  real r2
  real rprime
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST09'
  write ( *, '(a)' ) '  LIN_TO_NONLIN converts linear to nonlinear RGB;'
  write ( *, '(a)' ) '  NONLIN_TO_LIN converts nonlinear to linear RGB.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    Rin     R''      Rout'
  write ( *, '(a)' ) ' '

  do i = -1, 26

    r = real ( i ) / 25.0E+00

    call lin_to_nonlin ( r, rprime )
    call nonlin_to_lin ( rprime, r2 )

    write ( *, '(9f8.3)' ) r, rprime, r2 
 
  end do

  return
end
subroutine test10
!
!*******************************************************************************
!
!! TEST10 tests LUV_TO_XYZ.
!! TEST10 tests XYZ_TO_LUV.
!
  implicit none
!
  integer, parameter :: ntest = 17
!
  integer itest
  real lstar
  real nm
  real nmhi
  real nmlo
  real temp
  real unprime
  real ustar
  real vnprime
  real vstar
  real wnprime
  real x
  real xcap
  real xcap2
  real xcapn
  real xn
  real y
  real ycap
  real ycap2
  real ycapn
  real yn
  real z
  real zcap
  real zcap2
  real zcapn
  real zn
!
  nmlo = 380.0E+00
  nmhi = 700.0E+00
  ycapn = 100.0E+00
  call name_to_xyz ( 'D65', xn, yn, zn )
  call xyy_to_xyz ( xn, yn, xcapn, ycapn, zcapn )
  call xyz_to_uvwprime ( xcapn, ycapn, zcapn, unprime, vnprime, wnprime )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST10'
  write ( *, '(a)' ) '  LUV_TO_XYZ converts L*u*v* to XYZ colors.'
  write ( *, '(a)' ) '  XYZ_TO_LUV converts XYZ to L*u*v* colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Illuminant XYZ color coordinates:'
  write ( *, '(3g14.6)') xcapn, ycapn, zcapn 
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Illuminant u''v''w'' color coordinates:'
  write ( *, '(3g14.6)' ) unprime, vnprime, wnprime
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   NM Xin     Yin     Zin       L*       u*' &
    // '       v*      Xout   Yout   Zout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    nm = ( real ( ntest - itest ) * nmlo &
      + real ( itest - 1 ) * nmhi ) / real ( ntest - 1 )
    call nm_to_xyz ( nm, x, y, z )
    ycap = 0.95E+00 * ycapn
    call xyy_to_xyz ( x, y, xcap, ycap, zcap )
!
!  Make sure every component of (XCAP,YCAP,ZCAP) is smaller than
!  (XCAPN,YCAPN,ZCAPN).
!
    temp = 1.0E+00
    if ( xcap > 0.0E+00 .and. xcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * xcapn / xcap )
    end if
    if ( ycap > 0.0E+00 .and. ycapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * ycapn / ycap )
    end if
    if ( zcap > 0.0E+00 .and. zcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * zcapn / zcap )
    end if

    xcap = xcap * temp
    ycap = ycap * temp
    zcap = zcap * temp

    call xyz_to_luv ( xcap, ycap, zcap, xcapn, ycapn, zcapn, lstar, ustar, &
      vstar )

    call luv_to_xyz ( lstar, ustar, vstar, xcap2, ycap2, zcap2, &
      xcapn, ycapn, zcapn )

    write ( *, '(f5.1,3f8.3,3f9.3,3f8.3)' ) &
      nm, xcap, ycap, zcap, lstar, ustar, vstar, xcap2, ycap2, zcap2
 
  end do

  return
end
subroutine test11
!
!*******************************************************************************
!
!! TEST11 tests NAME_TO_PRIMARIES.
!! TEST11 tests PRIMARIES_TO_Y.
!
  implicit none
!
  real bx
  real by
  real gx
  real gy
  real rx
  real ry
  real wx
  real wy
  real yb
  real yg
  real yr
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST11'
  write ( *, '(a)' ) '  NAME_TO_PRIMARIES returns the CIE xy'
  write ( *, '(a)' ) '    chromaticities of the primaries and'
  write ( *, '(a)' ) '    reference white used for various'
  write ( *, '(a)' ) '    television standards;'
  write ( *, '(a)' ) '  PRIMARIES_TO_Y computes the coefficients in'
  write ( *, '(a)' ) '    the luminance function, given the'
  write ( *, '(a)' ) '    chromaticities of the three primaries,'
  write ( *, '(a)' ) '    and the reference white.'
!
!  Get primary values for NTSC..
!
  call name_to_primaries ( 'NTSC', rx, ry, gx, gy, bx, by, wx, wy )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Primary definition:'
  write ( *, '(a)' ) ' '
  write ( *, '(a,2g14.6)' ) '  R primary        ', rx, ry
  write ( *, '(a,2g14.6)' ) '  G primary        ', gx, gy
  write ( *, '(a,2g14.6)' ) '  B primary	 ', bx, by
  write ( *, '(a,2g14.6)' ) '  Reference white: ', wx, wy

  call primaries_to_y ( rx, ry, gx, gy, bx, by, wx, wy, yr, yg, yb )

  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  R luminance coefficient ', yr
  write ( *, '(a,g14.6)' ) '  G luminance coefficient ', yg
  write ( *, '(a,g14.6)' ) '  B luminance coefficient ', yb

  return
end
subroutine test12
!
!*******************************************************************************
!
!! TEST12 tests NAME_TEST.
!! TEST12 tests NAME_TO_RGB.
!
  implicit none
!
  integer, parameter :: ntest = 15
!
  real b2
  real g2
  integer itest
  character ( len = 30 ) name
  real r2
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST12'
  write ( *, '(a)' ) '  NAME_TO_RGB converts a name to RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Name    Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call name_test ( itest, name )

    call name_to_rgb ( name, r2, g2, b2 )

    write ( *, '(a,2x,3f8.3)' ) name, r2, g2, b2
 
  end do

  return
end
subroutine test13
!
!*******************************************************************************
!
!! TEST13 tests NAME_TO_RGB.
!! TEST13 tests RGB_TO_NAME.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  integer itest
  character ( len = 30 ) name
  real r
  real r2
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST13'
  write ( *, '(a)' ) '  NAME_TO_RGB converts a name to RGB colors.'
  write ( *, '(a)' ) '  RGB_TO_NAME converts RGB colors to a name;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Pick RGB at random.'
  write ( *, '(a)' ) '   R       G       B      Nearest Name   Rout  Gout  Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call r_random ( 0.0E+00, 1.0E+00, r )
    call r_random ( 0.0E+00, 1.0E+00, g )
    call r_random ( 0.0E+00, 1.0E+00, b )

    call rgb_to_name ( r, g, b, name )

    call name_to_rgb ( name, r2, g2, b2 )
 
    write ( *, '(3f8.3,2x,a,2x,3f8.3)' ) r, g, b, name, r2, g2, b2

  end do

  return
end
subroutine test14
!
!*******************************************************************************
!
!! TEST14 tests NM_TO_XYZ.
!! TEST14 tests XYY_TO_XYZ.
!! TEST14 tests XYZ_TO_XYY.
!
!  Discussion:
!
!    Thanks to Harald Anlauf, of the Technical University of Darmstadt,
!    for pointing out an error in an output format, 30 April 2002.
!
  implicit none
!
  integer, parameter :: ntest = 17
!
  integer itest
  real nm
  real nmhi
  real nmlo
  real x
  real x2
  real xcap
  real y
  real y2
  real ycap
  real zcap
  real z
!
  nmlo = 380.0E+00
  nmhi = 700.0E+00
  ycap = 2.0E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST14'
  write ( *, '(a)' ) '  NM_TO_XYZ converts wavelengths to xyz colors;'
  write ( *, '(a)' ) '  XYY_TO_XYZ converts xyY to XYZ colors;'
  write ( *, '(a)' ) '  XYZ_TO_XYY converts XYZ to xyY colors.'
  write ( *, '(a,g14.6)' ) '  (Assume a luminosity of YCAP = ', ycap
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    NM      xin     yin     Yin     X       Y     ' &
    // '   Z      xout    yout    Yout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    nm = ( real ( ntest - itest ) * nmlo &
      + real ( itest - 1 ) * nmhi ) / real ( ntest - 1 )

    call nm_to_xyz ( nm, x, y, z )

    call xyy_to_xyz ( x, y, xcap, ycap, zcap )

    call xyz_to_xyy ( xcap, ycap, zcap, x2, y2 )

    write ( *, '(10f8.3)' ) nm, x, y, ycap, xcap, ycap, zcap, x2, y2, ycap
 
  end do

  return
end
subroutine test15
!
!*******************************************************************************
!
!! TEST15 tests RGB_TO_HUE.
!
  implicit none
!
  real b
  real g
  real h
  real r
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST15'
  write ( *, '(a)' ) '  RGB_TO_HUE computes a hue between 0 and 1'
  write ( *, '(a)' ) '  corresponding to a given (R,G,B) color.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   R       G       B       H'
  write ( *, '(a)' ) ' '

  r = 1.00E+00
  g = 0.00E+00
  b = 0.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 1.00E+00
  g = 1.00E+00
  b = 0.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.00E+00
  g = 1.00E+00
  b = 0.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.00E+00
  g = 1.00E+00
  b = 1.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.00E+00
  g = 0.00E+00
  b = 1.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 1.00E+00
  g = 0.00E+00
  b = 1.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.00E+00
  g = 0.00E+00
  b = 0.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.50E+00
  g = 0.50E+00
  b = 0.50E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 1.00E+00
  g = 1.00E+00
  b = 1.00E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.94E+00
  g = 0.70E+00
  b = 0.15E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.24E+00
  g = 0.70E+00
  b = 0.85E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  r = 0.24E+00
  g = 0.24E+00
  b = 0.85E+00

  call rgb_to_hue ( r, g, b, h )
  write ( *, '(4f8.4)' ) r, g, b, h

  return
end
subroutine test16
!
!*******************************************************************************
!
!! TEST16 tests RGB_TO_RGBPRIME.
!! TEST16 tests RGBPRIME_TO_RGB.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real bprime
  real g
  real g2
  real gprime
  integer itest
  real r
  real r2
  real rprime
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST16'
  write ( *, '(a)' ) '  RGB_TO_RGBPRIME: RGB => R''G''B'' colors;'
  write ( *, '(a)' ) '  RGBPRIME_TO_RGB: R''G''B'' => RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     R''    G''      B''   ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_rgbprime ( r, g, b, rprime, gprime, bprime )

    call rgbprime_to_rgb ( rprime, gprime, bprime, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, rprime, gprime, bprime, r2, g2, b2
 
  end do

  return
end
subroutine test17
!
!*******************************************************************************
!
!! TEST17 tests RGB_TO_YCBCR.
!! TEST17 tests YCBCR_TO_RGB.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real cb
  real cr
  real g
  real g2
  integer itest
  real r
  real r2
  real yb
  real yg
  real yprime
  real yr
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST17'
  write ( *, '(a)' ) '  RGB_TO_YCBCR converts RGB to Y''CbCr colors;'
  write ( *, '(a)' ) '  YCBCR_TO_RGB converts Y''CbCr to RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     Yprime  Cb      Cr   ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_ycbcr ( r, g, b, yr, yg, yb, yprime, cb, cr )

    call ycbcr_to_rgb ( yprime, cb, cr, yr, yg, yb, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, yprime, cb, cr, r2, g2, b2
 
  end do

  return
end
subroutine test18
!
!*******************************************************************************
!
!! TEST18 tests RGB_TO_YIQ.
!! TEST18 tests YIQ_TO_RGB.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  real i
  integer itest
  real q
  real r
  real r2
  real yb
  real yg
  real yprime
  real yr
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST18'
  write ( *, '(a)' ) '  RGB_TO_YIQ converts RGB to Y''IQ colors;'
  write ( *, '(a)' ) '  YIQ_TO_RGB converts Y''IQ to RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     Y''      I       Q    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_yiq ( r, g, b, yr, yg, yb, yprime, i, q )

    call yiq_to_rgb ( yprime, i, q, yr, yg, yb, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, yprime, i, q, r2, g2, b2
 
  end do

  return
end
subroutine test19
!
!*******************************************************************************
!
!! TEST19 tests RGB_TO_YUV.
!! TEST19 tests YUV_TO_RGB.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  integer itest
  real r
  real r2
  real u
  real v
  real yb
  real yg
  real yprime
  real yr
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST19'
  write ( *, '(a)' ) '  RGB_TO_YUV converts RGB to Y''UV colors;'
  write ( *, '(a)' ) '  YUV_TO_RGB converts Y''UV to RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     Y''      U       V    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_yuv ( r, g, b, yr, yg, yb, yprime, u, v )

    call yuv_to_rgb ( yprime, u, v, yr, yg, yb, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, yprime, u, v, r2, g2, b2
 
  end do

  return
end
subroutine test20
!
!*******************************************************************************
!
!! TEST20 tests RGB709_TO_XYZ.
!! TEST20 tests XYZ_TO_RGB709.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  integer itest
  real r
  real r2
  real xcap
  real ycap
  real zcap
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST20'
  write ( *, '(a)' ) '  RGB709_TO_XYZ: RGB709 => CIE XYZ colors;'
  write ( *, '(a)' ) '  XYZ_TO_RGB709: CIE XYZ => RGB709 colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     X       Y       Z    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb709_to_xyz ( r, g, b, xcap, ycap, zcap )

    call xyz_to_rgb709 ( xcap, ycap, zcap, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, xcap, ycap, zcap, r2, g2, b2
 
  end do

  return
end
subroutine test21
!
!*******************************************************************************
!
!! TEST21 tests RGBCIE_TO_XYZ.
!! TEST21 tests XYZ_TO_RGBCIE.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real b2
  real g
  real g2
  integer itest
  real r
  real r2
  real xcap
  real ycap
  real zcap
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST21'
  write ( *, '(a)' ) '  RGBCIE_TO_XYZ converts CIE RGB to XYZ colors;'
  write ( *, '(a)' ) '  XYZ_TO_RGBCIE converts XYZ to CIE RGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   Rin     Gin     Bin     X       Y       Z    ' &
    // '   Rout    Gout    Bout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgbcie_to_xyz ( r, g, b, xcap, ycap, zcap )

    call xyz_to_rgbcie ( xcap, ycap, zcap, r2, g2, b2 )

    write ( *, '(9f8.3)' ) r, g, b, xcap, ycap, zcap, r2, g2, b2
 
  end do

  return
end
subroutine test22
!
!*******************************************************************************
!
!! TEST22 tests SRGB_TO_XYZ.
!! TEST22 tests XYZ_TO_SRGB.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real g
  integer itest
  real r
  integer sb
  integer sb2
  integer sg
  integer sg2
  integer sr
  integer sr2
  real xcap
  real xcap2
  real ycap
  real ycap2
  real zcap
  real zcap2
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST22'
  write ( *, '(a)' ) '  SRGB_TO_XYZ converts sRGB to XYZ colors;'
  write ( *, '(a)' ) '  XYZ_TO_SRGBCIE converts XYZ to sRGB colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '   Xin     Yin     Zin    sR  sG  sB   Xout    Yout    Zout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgbcie_to_xyz ( r, g, b, xcap, ycap, zcap )

    call xyz_to_srgb ( xcap, ycap, zcap, sr, sg, sb )

    call srgb_to_xyz ( sr, sg, sb, xcap2, ycap2, zcap2 )

    write ( *, '(3f8.3,3i4,3f8.3)' ) &
      xcap, ycap, zcap, sr, sg, sb, xcap2, ycap2, zcap2
 
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'Repeat test, but study sRGB->XYZ->sRGB'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '  sR  sG  sB   X       Y       Z     sR2 sG2 sB2'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgbcie_to_xyz ( r, g, b, xcap, ycap, zcap )

    call xyz_to_srgb ( xcap, ycap, zcap, sr, sg, sb )

    call srgb_to_xyz ( sr, sg, sb, xcap, ycap, zcap )

    call xyz_to_srgb ( xcap, ycap, zcap, sr2, sg2, sb2 )

    write ( *, '(3i4,3f8.3,3i4)' ) &
      sr, sg, sb, xcap, ycap, zcap, sr2, sg2, sb2
 
  end do
  return
end
subroutine test23
!
!*******************************************************************************
!
!! TEST23 tests T_TO_SPD.
!
  implicit none
!
  integer i
  integer ihi
  integer j
  real lambda
  real power
  real t
  real thi
  real tlo
!
  ihi = 10E+00
  tlo = 1000.0E+00
  thi = 10000.0E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST23'
  write ( *, '(a)' ) '  T_TO_SPD evaluates the black body spectral'
  write ( *, '(a)' ) '  power distribution function SPD(T,LAMBDA).'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '   T        Lambda      SPD(T,LAMBDA)'
  write ( *, '(a)' ) ' '

  do i = 1, ihi

    t = ( real ( ihi - i ) * tlo + real ( i ) * thi ) / real ( ihi )

    write ( *, * ) ' '

    do j = 380, 780, 40

      lambda = real ( j )
    
      call t_to_spd ( t, lambda, power )

      write ( *, '(7g12.5)' ) t, lambda, power

    end do

  end do

  return
end
subroutine test24
!
!*******************************************************************************
!
!! TEST24 tests T_TO_XY.
!
!  Discussion:
!
!    Thanks to Harald Anlauf, of the Technical University of Darmstadt,
!    for pointing out an error in an output format, 30 April 2002.
!
  implicit none
!
  integer i
  integer ihi
  real t
  real thi
  real tlo
  real x
  real xcap
  real y
  real ycap
  real z
  real zcap
!
  ihi = 20
  tlo = 1000.0E+00
  thi = 1400.0E+00
  ycap = 100.0E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST24'
  write ( *, '(a)' ) '  T_TO_XYZ returns the CIE xyz chromaticities of'
  write ( *, '(a)' ) '  a black body radiator at temperature T.'
  write ( *, '(a,g14.6)' ) '  Assume constant luminosity YCAP = ', ycap
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '     T         x         y         z        X' &
    // '         Y          Z'
  write ( *, '(a)' ) ' '

  do i = -2, ihi

    t = ( real ( ihi - i ) * tlo + real ( i ) * thi ) / real ( ihi )

    call t_to_xyz ( t, x, y, z )

    call xyy_to_xyz ( x, y, xcap, ycap, zcap )

    write ( *, '(7f10.4)' ) t, x, y, z, xcap, ycap, zcap

  end do

  return
end
subroutine test25
!
!*******************************************************************************
!
!! TEST25 tests UVPRIMEY_TO_XYZ.
!! TEST25 tests XYZ_TO_UVWPRIME.
!
  implicit none
!
  integer, parameter :: ntest = 17
!
  integer itest
  real nm
  real nmhi
  real nmlo
  real temp
  real uprime
  real vprime
  real wprime
  real x
  real xcap
  real xcap2
  real xcapn
  real xn
  real y
  real ycap
  real ycapn
  real yn
  real z
  real zcap
  real zcap2
  real zcapn
  real zn
!
  nmlo = 380.0E+00
  nmhi = 700.0E+00
  ycapn = 100.0E+00
  call name_to_xyz ( 'D65', xn, yn, zn )
  call xyy_to_xyz ( xn, yn, xcapn, ycapn, zcapn )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST25'
  write ( *, '(a)' ) '  UVPRIMEY_TO_XYZ converts u''v''Y to XYZ colors.'
  write ( *, '(a)' ) '  XYZ_TO_UVWPRIME converts XYZ to u''v''w'' colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Illuminant XYZ color coordinates:'
  write ( *, '(3g14.6)' ) xcapn, ycapn, zcapn 
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    Xin     Yin     Zin       u''       v''' &
    // '       w''      Xout   Yout   Zout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    nm = ( real ( ntest - itest ) * nmlo &
      + real ( itest - 1 ) * nmhi ) / real ( ntest - 1 )

    call nm_to_xyz ( nm, x, y, z )
    ycap = 0.95E+00 * ycapn
    call xyy_to_xyz ( x, y, xcap, ycap, zcap )
!
!  Make sure every component of (XCAP,YCAP,ZCAP) is smaller than
!  (XCAPN,YCAPN,ZCAPN).
!
    temp = 1.0E+00
    if ( xcap > 0.0E+00 .and. xcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * xcapn / xcap )
    end if
    if ( ycap > 0.0E+00 .and. ycapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * ycapn / ycap )
    end if
    if ( zcap > 0.0E+00 .and. zcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * zcapn / zcap )
    end if

    xcap = xcap * temp
    ycap = ycap * temp
    zcap = zcap * temp

    call xyz_to_uvwprime ( xcap, ycap, zcap, uprime, vprime, wprime )

    call uvprimey_to_xyz ( uprime, vprime, xcap2, ycap, zcap2 )

    write ( *, '(3f8.3,3f9.3,3f8.3)' ) &
      xcap, ycap, zcap, uprime, vprime, wprime, xcap2, ycap, zcap2
 
  end do

  return
end
subroutine test26
!
!*******************************************************************************
!
!! TEST26 tests XYZ_TO_YCC.
!! TEST26 tests YCC_TO_XYZ.
!
  implicit none
!
  integer, parameter :: ntest = 17
!
  real c1
  real c2
  integer itest
  real nm
  real nmhi
  real nmlo
  real temp
  real x
  real xcap
  real xcap2
  real xcapn
  real xn
  real y
  real yb
  real ycap
  real ycap2
  real ycapn
  real yg
  real yn
  real yr
  real yval
  real z
  real zcap
  real zcap2
  real zcapn
  real zn
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  nmlo = 380.0E+00
  nmhi = 700.0E+00
  ycapn = 100.0E+00
  call name_to_xyz ( 'D65', xn, yn, zn )
  call xyy_to_xyz ( xn, yn, xcapn, ycapn, zcapn )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST26'
  write ( *, '(a)' ) '  XYZ_TO_YCC converts XYZ to PhotoYCC colors;'
  write ( *, '(a)' ) '  YCC_TO_XYZ converts PhotoYCC to XYZ colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Illuminant XYZ color coordinates:'
  write ( *, '(3g14.6)' ) xcapn, ycapn, zcapn
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' NM     Xin     Yin     Zin     Y       C1' &
    // '      C2      Xout    Yout    Zout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    nm = ( real ( ntest - itest ) * nmlo &
      + real ( itest - 1 ) * nmhi ) / real ( ntest - 1 )

    call nm_to_xyz ( nm, x, y, z )
    ycap = 0.95E+00 * ycapn
    call xyy_to_xyz ( x, y, xcap, ycap, zcap )
!
!  Make sure every component of (XCAP,YCAP,ZCAP) is smaller than
!  (XCAPN,YCAPN,ZCAPN).
!
    temp = 1.0E+00
    if ( xcap > 0.0E+00 .and. xcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * xcapn / xcap )
    end if
    if ( ycap > 0.0E+00 .and. ycapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * ycapn / ycap )
    end if
    if ( zcap > 0.0E+00 .and. zcapn > 0.0E+00 ) then
      temp = min ( temp, 0.95E+00 * zcapn / zcap )
    end if

    xcap = xcap * temp
    ycap = ycap * temp
    zcap = zcap * temp

    call xyz_to_ycc ( xcap, ycap, zcap, yr, yg, yb, yval, c1, c2 )

    call ycc_to_xyz ( yval, c1, c2, yr, yg, yb, xcap2, ycap2, zcap2 )

    write ( *, '(f5.1,9f8.3)' ) nm, xcap, ycap, zcap, yval, c1, c2, xcap2, &
      ycap2, zcap2
 
  end do

  return
end
subroutine test27
!
!*******************************************************************************
!
!! TEST27 tests YCBCR_TO_YCC.
!! TEST27 tests YCC_TO_YCBCR.
!
  implicit none
!
  integer, parameter :: ntest = 5
!
  real c1in
  real c1out
  real c2in
  real c2out
  real cb
  real cr
  integer itest
  real y
  real yin
  real yout
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST27'
  write ( *, '(a)' ) '  YCBCR_TO_YCC converts YCBCR to PhotoYCC colors.'
  write ( *, '(a)' ) '  YCC_TO_YCBCR converts PhotoYCC to YCBCR colors;'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    Yin    C1in     C2in     Y''     Cb' &
    // '      Cr      Yout    C1out    C2out'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call ycc_test ( itest, yin, c1in, c2in )

    call ycc_to_ycbcr ( yin, c1in, c2in, y, cb, cr )

    call ycbcr_to_ycc ( y, cb, cr, yout, c1out, c2out )

    write ( *, '(9f8.3)' ) yin, c1in, c2in, y, cb, cr, yout, c1out, c2out
 
  end do

  return
end
subroutine test28
!
!*******************************************************************************
!
!! TEST28 tests YIQ_TO_YUV.
!! TEST28 tests YUV_TO_YIQ.
!
  implicit none
!
  integer, parameter :: ntest = 10
!
  real b
  real g
  real i
  real i2
  integer itest
  real q
  real q2
  real r
  real u
  real v
  real yb
  real yg
  real yprime
  real yprime2
  real yprime3
  real yr
!
  yr = 0.299E+00
  yg = 0.587E+00
  yb = 0.114E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST28'
  write ( *, '(a)' ) '  YIQ_TO_YUV converts Y''IQ to Y''UV colors;'
  write ( *, '(a)' ) '  YUV_TO_YIQ converts Y''UV to Y''IQ colors.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    Y''in    Iin     Qin     Y''      U' &
    // '       V       Y''out   Iout    Qout'
  write ( *, '(a)' ) ' '

  do itest = 1, ntest

    call rgb_test ( itest, r, g, b )

    call rgb_to_yiq ( r, g, b, yr, yg, yb, yprime, i, q )

    call yiq_to_yuv ( yprime, i, q, yprime2, u, v )

    call yuv_to_yiq ( yprime2, u, v, yprime3, i2, q2 )

    write ( *, '(9f8.3)' ) yprime, i, q, yprime2, u, v, yprime3, i2, q2
 
  end do

  return
end