Fortran Wiki
jucolor

!                                Color Library Version 4.0
! 
!    SYNOPSIS 
!           The Color library lets you convert between common color models.
! 
!    DESCRIPTION 
! 
!           Color is a complex topic; but it is often much more convenient
!           to specify colors using something other than the RGB color
!           model. Some of the most common models are:
! 
!           + RGB - Color TV monitors
!           + YIQ - Broadcast TV color system
!           + CMY - Cyan, Magenta, Yellow : pigment-based printing devices
!           + HLS - Hue, Lightness, Saturation
!           + HSV - Hue, Saturation, Value
! 
!           As many sources will contest to, conversions are a tricky
!           business but these simplified conversions work quite well for
!           most basic needs.
! 
!           All calls are expected to be made thru JUCOLOR(). If you wish to
!           call the support routines directly to get performance gains it
!           is up to you to ensure that the input data is properly
!           conditioned.
! 
!   Principle Routines
! 
!           + JUCOLOR() A single routine that interfaces to all the
!             low-level color conversion routines; performing range
!             checking and parameter validation.
!           + RGBMONO() given RGB values, calculate a gray_scale intensity
! 
!   Internal Routines
! 
!           + HLSRGB given hue, lightness, saturation calculate red,
!             green, and blue components
!                o RGBVAL ensure a value is in the appropriate range and
!                  quadrant
!           + HVSRGB given hue, saturation, value calculate red, green,
!             and blue components
!           + RGBHLS given red, green, blue calculate hue, lightness,
!             and saturation components
!           + RGBHVS given red, green, blue calculate hue, saturation
!             and value components
!           Internally, For each color model supported, there is a routine
!           to convert that model to the RGB model, and to convert from
!           the RGB model to that model. This allows many models to be
!           supported, with only 2*N routines required to go from any
!           model to any other.  That is, to go from model a to model b
!           the intent is that you would use:
! 
!             call modela2rgb(...)
!             call rgb2modelb(...)
! 
!           (This library does not yet rigorously support that concept,
!           however).
! 
!           The color library is heavily based on chapter 17 of
!           "Fundamentals of Interactive Computer Graphics"; J. D. Foley
!           and A. Van Dam .
!      _________________________________________________________________
! 
!      * Last Modified: 19971123
!      _________________________________________________________________
!#ifdef TESTPRG
      program testit
      real r,g,b
      real h,l,s
      integer status

!     hls to rgb
      call jucolor('hls',000.0,050.0,100.0,'rgb',r,g,b,status)
      write(*,*)'INPUT HLS PURE RED ==> OUTPUT RGB values are ',r,g,b
      write(*,'(80(''=''))')

      call jucolor('hls',120.0,050.0,100.0,'rgb',r,g,b,status)
      write(*,*)'INPUT HLS PURE GREEN OUTPUT RGB values are ',r,g,b
      write(*,'(80(''=''))')

      call jucolor('hls',240.0,050.0,100.0,'rgb',r,g,b,status)
      write(*,*)'INPUT HLS PURE BLUE OUTPUT RGB values are ',r,g,b
      write(*,'(80(''=''))')

!     rgb to hls 
      call jucolor('rgb',100.0,000.0,000.0,'hls',h,l,s,status)
      write(*,*)'INPUT RGB PURE RED OUTPUT HLS values are ',h,l,s
      write(*,'(80(''=''))')

      call jucolor('rgb',000.0,100.0,000.0,'hls',h,l,s,status)
      write(*,*)'INPUT RGB PURE GREEN OUTPUT HLS values are ',h,l,s
      write(*,'(80(''=''))')

      call jucolor('rgb',000.0,000.0,100.0,'hls',h,l,s,status)
      write(*,*)'INPUT RGB PURE BLUE OUTPUT HLS values are ',h,l,s
      write(*,*)'values are ',h,l,s
      write(*,'(80(''=''))')

      end
!#endif
!
!                              subroutine jucolor
!       &(modei, clr1i, clr2i, clr3i, modeo, clr1o, clr2o, clr3o, status)
!
!   jucolor converts a color's components from one color model to another.
!   it supports the following color models:
!
! Color Model                         Model Parameters
! hls         hue, lightness, saturation
! hvs         hue, value, saturation
! rgb         red, green, blue
! yiq         luma(gray scale),orange-blue chrominance, purple-green chrominance
!
!     * modei, clr1i, clr2i, clr3i & modeo are input values to this
!       procedure.
!     * status, clr1o, clr2o & clr3o are output values from this
!       procedure.
!     * modei and modeo are character variables, the others are real.
!     * modei specifies the color model that applies to the input color
!       components clr1i, clr2i, & clr3i.
!     * modeo specifies the color model desired for the output color
!       components clr1o, clr2o, & clr3o.
!
!   valid values for modei and modeo as well as the corresponding meanings
!   for clr1*, clr2*, and clr3* are as shown below:
!
!   CAPTION: Color Models 
!
!   mode clr1    clr2       clr3
!   hls  hue  lightness  saturation
!   hsl  hue  saturation lightness
!   hvs  hue  value      saturation
!   hvs  hue  saturation value
!   rgb  red  green      blue
!   yiq  ?    ?          ?
!
!     * lightness, value, saturation, red, green, blue, & y range from 0
!       to 100,
!     * hue ranges from 0 to 360 degrees,
!     * i ranges from -60 to 60,
!     * q ranges from -52 to 52
!
!   as a minimum, this procedure equates the output color values to the
!   input color values.
!
!   status is returned to signal the following conditions:
!
!  -1  modei = modeo, so no substantial conversion was done,
!   1  one of the input color values was outside the allowable range,
!   2  modei was invalid
!   3  modeo was invalid
!     _________________________________________________________________
!
!     * References:
!     * Dependencies:
!     * Examples:
!     * Authors:
!     _________________________________________________________________
      subroutine jucolor(modei,clr1i,clr2i,clr3i,modeo,clr1o,clr2o,clr3o,istat)
!@(#) converts a color's components from one color model to another
!     It supports the following color models:
!     .    hls  -  hue, lightness, saturation
!     .    hvs  -  hue, value,     saturation
!     .    rgb  -  red, green,     blue
!     .    yiq  -   ?    ?          ?
!
!---- modei,  clr1i,  clr2i,  clr3i & modeo are input values to this procedure.
!---- istat, clr1o,  clr2o & clr3o are output values from this procedure.
!
!---- modei and modeo are character variables, the others are real.
!
!---- modei specifies the color model that applies to the input color
!     components  clr1i, clr2i, & clr3i.
!---- modeo specifies the color model desired for the output color
!     components  clr1o, clr2o, & clr3o.
!
!---- valid values for modei and modeo as well as the corresponding
!     meanings for clr1_, clr2_, and clr3_  are as shown below:
!     .    mode      clr1       clr2         clr3
!     .    'hls'     hue        lightness    saturation
!     .    'hsl'     hue        saturation   lightness
!     .    'hvs'     hue        value        saturation
!     .    'hsv'     hue        saturation   value
!     .    'rgb'     red        green        blue
!     .    'yiq'      ?          ?            ?
!
!---- lightness, value, saturation, red, green, blue, & y range
!     from 0 to 100,
!     hue ranges from 0 to 360 degrees,
!     i   ranges from -60 to 60,
!     q   ranges from -52 to 52
!
!---- as a minimum, this procedure equates the output color values
!     to the input color values.
!
!---- istat is returned to signal the following conditions:
!     .    -1   modei = modeo, so no substantial conversion was done,
!     .     1   one of the input color values was outside the allowable range,
!     .     2   modei was invalid
!     .     3   modeo was invalid
!
      character*(*) modei ,modeo
      character*3   modeiu,modeou
      real clr1i,clr2i,clr3i &
     &,    clr1o,clr2o,clr3o &
     &,    c1   ,c2   ,c3    &
     &,    r    ,g    ,b
      integer    istat
!---- reset the status flag.
      istat=0
!---- as a minimum, set the output colors equal to the input colors.
      clr1o=clr1i
      clr2o=clr2i
      clr3o=clr3i
!---- ensure that the input character strings are uppercase
      modeiu(1:3)=modei(1:3)
      modeou(1:3)=modeo(1:3)
!---- check for a trivial instance.
      if(modeiu(1:3) .eq. modeou(1:3)) then
         istat=-1
         return
      endif
!---- check for a transpose of terms, another trivial instance.
      if(modeiu(1:1).eq.'h') then
         if( modeiu(1:3).eq.'hls' .and. modeou(1:3).eq.'hsl'  &
     &   .or.modeiu(1:3).eq.'hsl' .and. modeou(1:3).eq.'hls'  &
     &   .or.modeiu(1:3).eq.'hvs' .and. modeou(1:3).eq.'hsv'  &
     &   .or.modeiu(1:3).eq.'hsv' .and. modeou(1:3).eq.'hvs') then
            clr2o=clr3i
            clr3o=clr2i
            istat=-1
            return
         endif
      endif
!
!---- assign new variables so that the input arguments can't possibly
!     be changed by subsequent procedures.
!
      c1=clr1i
      c2=clr2i
      c3=clr3i
!
!---- check for valid range of values.
!
      if(modeiu(1:1) .eq. 'h') then
         if(c1 .lt.   0.0 .or. c1 .gt. 360.0) istat = 1
      else
         if(c1 .lt.   0.0 .or. c1 .gt. 100.0) istat = 1
      endif
      if(modeiu(1:1) .eq. 'y') then
!
!----    i don't believe that this is an exhaustive test of value ranges
!        for yiq.  for example yiq=(100.0,60.0,52.0) when converted to
!        rgb produces values greater than 100!!!!????
!
         if(c2 .lt. -60.0 .or. c2 .gt.  60.0) istat = 1
         if(c3 .lt. -52.0 .or. c3 .gt.  52.0) istat = 1
      else
         if(c2 .lt.   0.0 .or. c2 .gt. 100.0) istat = 1
         if(c3 .lt.   0.0 .or. c3 .gt. 100.0) istat = 1
      endif
      if(istat .ne. 0) return
!
!---- first, convert input values to rgb values.
!
      if     (modeiu(1:3) .eq. 'hls') then
         call hlsrgb(c1,c2,c3,r,g,b)
      else if(modeiu(1:3) .eq. 'hsl') then
         call hlsrgb(c1,c3,c2,r,g,b)
      else if(modeiu(1:3) .eq. 'hvs') then
         call hvsrgb(c1,c2,c3,r,g,b)
      else if(modeiu(1:3) .eq. 'hsv') then
         call hvsrgb(c1,c3,c2,r,g,b)
      else if(modeiu(1:3) .eq. 'rgb') then
         r=c1
         g=c2
         b=c3
      else if(modeiu(1:3) .eq. 'yiq') then
         r= 1.0*c1 + 0.94826224*c2 + 0.62401264*c3
         g= 1.0*c1 - 0.27606635*c2 - 0.63981043*c3
         b= 1.0*c1 - 1.1054502 *c2 + 1.7298578 *c3
!
!---     if outside the valid range of values, truncate to allow for
!        reasonable roundoff and then retest.  this should pass values
!        essentially 0 or 100, but fail others.
!        the above formula for rgb from yiq can give answers slightly
!        less than 0 and slightly greater than 100.  the truncation
!        should fix this. (maybe there is a better way to do this?)
!        the retest should then catch the instances such as
!        yiq=(100.,60.,52) as mentioned earlier.
!
         if(r.lt.0.0 .or. r.gt.100.0) r=aint(r*10000.0)/10000.0
         if(g.lt.0.0 .or. g.gt.100.0) g=aint(g*10000.0)/10000.0
         if(b.lt.0.0 .or. b.gt.100.0) b=aint(b*10000.0)/10000.0
         if(                                &
     &   r.lt.0.0 .or. r.gt.100.0 .or.      &
     &   g.lt.0.0 .or. g.gt.100.0 .or.      &
     &   b.lt.0.0 .or. b.gt.100.0) then
            istat=1
            return
         endif
      else
         istat=2
         return
      endif
!
!---- then convert to the desired output values
!
      if     (modeou(1:3) .eq. 'hls') then
         call rgbhls(r,g,b,clr1o,clr2o,clr3o)
      else if(modeou(1:3) .eq. 'hsl') then
         call rgbhls(r,g,b,clr1o,clr3o,clr2o)
      else if(modeou(1:3) .eq. 'hvs') then
         call rgbhvs(r,g,b,clr1o,clr2o,clr3o)
      else if(modeou(1:3) .eq. 'hsv') then
         call rgbhvs(r,g,b,clr1o,clr3o,clr2o)
      else if(modeou(1:3) .eq. 'rgb') then
         clr1o=r
         clr2o=g
         clr3o=b
      else if(modeou(1:3) .eq. 'yiq') then
         clr1o=0.30*r + 0.59*g + 0.11*b
         clr2o=0.60*r - 0.28*g - 0.32*b
         clr3o=0.21*r - 0.52*g + 0.31*b
      else
         istat=3
         return
      endif
!
!---- eliminate any roundoff that exceeds the limits.  this assumes
!     we may occasionally get some values slightly past the limits
!     that should really be equal to the limit.  i've seen this happen
!     beyond the 7th decimal place on the vax with the upper limits;
!     i really haven't seen it on the lower bounds.  of course if there
!     was a real programming problem with some of the other color
!     conversion routines such that they returned incorrect output
!     values well beyond the limits, this roundoff procedure may mask
!     such a problem since it assumes anything beyond the limits is
!     only a slight roundoff problem.
!
      if   (clr1o .lt.   0.0) clr1o =   0.0
      if(modeou(1:1) .eq. 'h') then
         if(clr1o .gt. 360.0) clr1o = 360.0
      else
         if(clr1o .gt. 100.0) clr1o = 100.0
      endif
      if(modeou(1:1) .eq. 'y') then
         if(clr2o .lt. -60.0) clr2o = -60.0
         if(clr2o .gt.  60.0) clr2o =  60.0
         if(clr3o .lt. -52.0) clr3o = -52.0
         if(clr3o .gt.  52.0) clr3o =  52.0
      else
         if(clr2o .lt.   0.0) clr2o =   0.0
         if(clr2o .gt. 100.0) clr2o = 100.0
         if(clr3o .lt.   0.0) clr3o =   0.0
         if(clr3o .gt. 100.0) clr3o = 100.0
      endif
      return
      end
!     _________________________________________________________________
!
!subroutine rgbval(clr1,clr2,h)
!
!   SYNOPSIS 
!          This function is an internal routine used by hlsrgb().
!
!   DESCRIPTION 
!
!        integer, intent=(in) :: h
!                H is the hue value in degrees
!
!        real, intent=(in) :: clr1
!
!        real, intent=(in) :: clr2
!
!   DEPENDENCIES 
!
!          + NONE
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!
!          + This is heavily based on chapter 17 of "Fundamentals of
!            Interactive Computer Graphics"; J. D. Foley and A. Van Dam.
!
!   AUTHOR 
!
!          + John S. Urban
!          + Kevin Kendall
!     _________________________________________________________________
      real function rgbval(clr1,clr2,h)
!@(#) ensure a value is in the appropriate range and quadrant
      real clr1,clr2,h,h2
      h2=h
10    if(h2.gt.360.0) then
         h2=h2-360.0
         goto 10
      endif
20    if(h2.lt.0.0) then
         h2=h2+360.0
         goto 20
      endif
      if(h2.lt.60.0) then
         rgbval=clr1+(clr2-clr1)*h2/60.0
      else if(h2.lt.180.0) then
         rgbval=clr2
      else if(h2.lt.240.0) then
         rgbval=clr1+(clr2-clr1)*(240.0-h2)/60.0
      else
         rgbval=clr1
      endif
      return
      end

!subroutine rgbhvs(r,g,b,h,v,s)
!
!   SYNOPSIS 
!          RGBHVS() calculates the hue, value, & saturation for a color
!          given in red, green, & blue components values.
!
!   DESCRIPTION 
!
!        real, intent=(in) :: r
!                R is the red component as a value of 0 to 100.
!
!        real, intent=(in) :: g
!                G is the green component as a value of 0 to 100.
!
!        real, intent=(in) :: b
!                B is the blue component as a value of 0 to 100.
!
!        real, intent=(out) :: h
!                H is the hue value in the range of 0 to 360 degrees
!
!        real, intent=(out) :: v
!                V is the "value" as a percent value from 0 to 100.
!
!        real, intent=(out) :: s
!                S is the saturation as a percent from 0 to 100.
!
!   DEPENDENCIES 
!          + amax1
!          + amin1
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!          + This is heavily based on chapter 17 of "Fundamentals of
!            Interactive Computer Graphics"; J. D. Foley and A. Van Dam.
!   AUTHOR 
!          + John S. Urban
!          + Kevin Kendall
!     _________________________________________________________________
      subroutine rgbhvs(r0,g0,b0,h,v,s)
!@(#) given red, green, blue calculate hue, saturation and value components 

!
!---- this procedure calculates a hue, saturation, value equivalent for a
!     color given in red, green, & blue components.
!     given  : r, g, b each as a value of 0 to 100.
!     desired: h as a value of 0 to 360 degrees.
!     .        s and v each as a value of 0 to 100.
!     this particular algorithm was taken from foley and van dam.
!
      real r0,g0,b0
      real r,g,b,h,v,s
      real clrmax,clrmin,clrdel,rr,gg,bb
      r=r0
      g=g0
      b=b0
      r=r/100.0
      g=g/100.0
      b=b/100.0
      clrmax=amax1(r,g,b)
      clrmin=amin1(r,g,b)
      clrdel=clrmax-clrmin
      v=clrmax
      if(clrmax.ne.0.0)then
         s=clrdel/clrmax
      else
         s=0.0
      endif
      if(s.ne.0.0)then
         rr=(clrmax-r)/clrdel
         gg=(clrmax-g)/clrdel
         bb=(clrmax-b)/clrdel
         if(r.eq.clrmax)then
            h=bb-gg
         else if(g.eq.clrmax) then
            h=2.0+rr-bb
         else if(b.eq.clrmax) then
            h=4.0+gg-rr
         endif
         h=h*60.0
         if(h.lt.0.0) then
            h=h+360.0
         endif
      endif
      v=v*100.0
      s=s*100.0
      return
      end
!subroutine rgbhls(r,g,b,h,l,s)
!
!   SYNOPSIS 
!          RGBHLS() calculates the hue, lightness, and saturation for a
!          color given in red, green, and blue components values.
!
!   DESCRIPTION 
!
!        real, intent=(in) :: r
!                R is the red component as a value of 0 to 100.
!
!        real, intent=(in) :: g
!                G is the green component as a value of 0 to 100.
!
!        real, intent=(in) :: b
!                B is the blue component as a value of 0 to 100.
!
!        real, intent=(out) :: h
!                H is the hue value in the range of 0 to 360 degrees
!
!        real, intent=(out) :: l
!                L is the lightness as a percent value from 0 to 100.
!
!        real, intent=(out) :: s
!                S is the saturation as a percent from 0 to 100.
!
!   DEPENDENCIES 
!
!          + NONE
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!
!          + This is heavily based on chapter 17 of "Fundamentals of
!            Interactive Computer Graphics"; J. D. Foley and A. Van Dam.
!
!   AUTHOR 
!
!          + John S. Urban
!          + Kevin Kendall
!     _________________________________________________________________
      subroutine rgbhls(r0,g0,b0,h,l,s)
!@(#) given red,green,blue calculate hue,lightness, and saturation components 

!     given  : r, g, b each as a value of 0 to 100.
!     desired: h as a value of 0 to 360 degrees.
!     .        l and s each as a value of 0 to 100.
!     this particular algorithm was taken from a foley and van dam.
!
      real r0,g0,b0
      real r,g,b,h,l,s
      real clrmax,clrmin,clrdel,clrsum,rr,gg,bb
      r=r0
      g=g0
      b=b0
      r=r/100.0
      g=g/100.0
      b=b/100.0
      clrmax=amax1(r,g,b)
      clrmin=amin1(r,g,b)
      clrdel=clrmax-clrmin
      clrsum=clrmax+clrmin
      l     =clrsum/2.0
      if(clrdel.ne.0.0) then
         rr=(clrmax-r)/clrdel
         gg=(clrmax-g)/clrdel
         bb=(clrmax-b)/clrdel
         if(l.le.0.5) then
            s=clrdel/clrsum
         else
            s=clrdel/(2.0-clrsum)
         endif
         if     (r.eq.clrmax) then
            h=bb-gg
         else if(g.eq.clrmax) then
            h=2.0+rr-bb
         else if(b.eq.clrmax) then
            h=4.0+gg-rr
         endif
         h=h*60.0
         if(h.lt.0.0) then
            h=h+360.0
         endif
      else
         s=0.0
         h=0.0
      endif
      l=l*100.0
      s=s*100.0
      return
      end
!subroutine hvsrgb(h,v,s,r,g,b)
!
!   SYNOPSIS 
!          HVSRGB() calculates the red, green, & blue components for a
!          color given in hue, value, & saturation values.
!
!   DESCRIPTION 
!
!        real, intent=(in) :: h
!                H is the hue value in the range of 0 to 360 degrees
!
!        real, intent=(in) :: v
!                V is the "value" as a percent value from 0 to 100.
!
!        real, intent=(in) :: s
!                S is the saturation as a percent from 0 to 100.
!
!        real, intent=(out) :: r
!                R is the red component as a value of 0 to 100.
!
!        real, intent=(out) :: g
!                G is the green component as a value of 0 to 100.
!
!        real, intent=(out) :: b
!                B is the blue component as a value of 0 to 100.
!
!   DEPENDENCIES 
!
!          + NONE
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!
!          + This is heavily based on chapter 17 of "Fundamentals of
!            Interactive Computer Graphics"; J. D. Foley and A. Van Dam.
!
!   AUTHOR 
!
!          + John S. Urban
!          + Kevin Kendall
!     _________________________________________________________________
      subroutine hvsrgb(h0,v0,s0,r,g,b)
!@(#) given hue, saturation, value calculate red, green, & blue components 
!
!     given  : h as value of 0 to 360 degrees.
!     .        s and v each as a value of 0 to 100.
!     desired: r, g, and b as a value of 0 to 100.
!     this particular algorithm was taken from foley and van dam.
!
      real    h0,v0,s0
      real    h,v,s,r,g,b
      integer ifloor
      real    f,p,q,t
      h=h0
      v=v0
      s=s0
      v=v/100.0
      s=s/100.0
      if(s.eq.0.0) then
         r=v
         g=v
         b=v
      endif
      if(h.eq.360.0) then
         h=0.0
      endif
      h=h/60.0
      ifloor=int(h)
      f=h-ifloor
      p=v*(1.0-s)
      q=v*(1.0-(s*f))
      t=v*(1.0-(s*(1-f)))
      if(ifloor.eq.0) then
         r=v
         g=t
         b=p
      else if(ifloor.eq.1) then
         r=q
         g=v
         b=p
      else if(ifloor.eq.2) then
         r=p
         g=v
         b=t
      else if(ifloor.eq.3) then
         r=p
         g=q
         b=v
      else if(ifloor.eq.4) then
         r=t
         g=p
         b=v
      else if(ifloor.eq.5) then
         r=v
         g=p
         b=q
      endif
      r=r*100.0
      g=g*100.0
      b=b*100.0
      return
      end
!subroutine hlsrgb(h,l,s,r,g,b)
!
!   SYNOPSIS 
!          HLSRGB() calculates the red, green, & blue components for a
!          color given in hue, lightness, & saturation values.
!
!   DESCRIPTION 
!
!        real, intent=(in) :: h
!                H is the hue value in the range of 0 to 360 degrees
!
!        real, intent=(in) :: l
!                L is the lightness as a percent value from 0 to 100.
!
!        real, intent=(in) :: s
!                S is the saturation as a percent from 0 to 100.
!
!        real, intent=(out) :: r
!                R is the red component as a value of 0 to 100.
!
!        real, intent=(out) :: g
!                G is the green component as a value of 0 to 100.
!
!        real, intent=(out) :: b
!                B is the blue component as a value of 0 to 100.
!
!   DEPENDENCIES 
!
!          + rgbval
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!
!          + This is heavily based on chapter 17 of "Fundamentals of
!            Interactive Computer Graphics"; J. D. Foley and A. Van Dam.
!
!   AUTHOR 
!
!          + John S. Urban
!          + Kevin Kendall
!     _________________________________________________________________
      subroutine hlsrgb(h0,l0,s0,r,g,b)
!
!@(#) given hue, lightness, saturation calculate red, green, & blue components
!     given  : h as a value of 0 to 360 degrees.
!     .        l and s each as a value of 0 to 100.
!     desired: r, g, and b each as a value of 0 to 100.
!     this particular algorithm was taken from Foley and Van Dam.
!
      real h0,l0,s0
      real h,l,s,r,g,b
      real clr1,clr2,rgbval
      h=h0
      l=l0
      s=s0
      l=l/100.0
      s=s/100.0
      if(s.eq.0.0) then
         r=l
         g=l
         b=l
      endif
      if(l.le.0.5) then
         clr2=l*(1.0+s)
      else
         clr2=l+s-l*s
      endif
      clr1=2.0*l-clr2
      r=rgbval(clr1,clr2,h+120.0)  *100.0
      g=rgbval(clr1,clr2,h)       *100.0
      b=rgbval(clr1,clr2,h-120.0)  *100.0
      return
      end
!subroutine rgbmono(rr,rg,rb,ri)
!
!   SYNOPSIS 
!          For converting colors to a reasonable grayscale
!
!          For converting colors to a reasonable grayscale. Monochrome
!          devices that support intensity can have intensity calculated
!          from the specified Red, Green, Blue intensities as 0.30*R +
!          0.59*G + 0.11*B, as in US color television systems, NTSC
!          encoding. Note that most devices do not have an infinite range
!          of monochrome intensities available.
!
!   DESCRIPTION 
!
!        real, intent=(in) :: RR
!                RR is the red component of the input color in the range 0
!                to 100
!
!        real, intent=(in) :: RG
!                RG is the green component of the input color in the range
!                0 to 100
!
!        real, intent=(in) :: RB
!                RB is the blue component of the input color in the range
!                0 to 100
!
!        real, intent=(out) :: RI
!                RI is the grayscale intensity calculated in the range 0
!                to 100
!
!   DEPENDENCIES 
!
!          + NONE
!
!   SEE ALSO
!          see JUCOLOR().
!
!   REFERENCES 
!
!          +
!
!   AUTHOR 
!     _________________________________________________________________
      SUBROUTINE RGBMONO(RR,RG,RB,RI)
!@(#) For converting RGB colors to a reasonable grayscale

! monochrome devices that support intensity can have intensity 
! calculated from the specified Red, Green, Blue
! intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television
! systems, NTSC encoding.  Note that most devices do not have an
! infinite range of monochrome intensities available.

! red, green, blue, & intensity range from 0 to 100
      REAL RR,RG,RB
      REAL RI
      RI = 0.30*RR + 0.59*RG + 0.11*RB
      RETURN
      END

category: code