demo_M_color Program

Uses

Contents

Source Code


Variables

Type Attributes Name Initial
real :: blue
character(len=20) :: echoname
real :: gray
real :: green
integer :: ierr
character(len=20) :: name
real :: red
character(len=100) :: string

Subroutines

subroutine chk(modelout, name, rgb, other)

Arguments

Type IntentOptional Attributes Name
character(len=*), intent(in) :: modelout
character(len=*), intent(in) :: name
integer, intent(in) :: rgb(3)
integer, intent(in) :: other(3)

Source Code

     program demo_M_color
     use M_color, only : hue
     use M_color, only : closest_color_name
     use M_color, only : color_name2rgb
     use M_color, only : rgbmono
     implicit none
     character(len=100) :: string ! at least 20 characters
     character(len=20)  :: name
     character(len=20)  :: echoname
     real               :: red,green,blue
     real               :: gray
     integer            :: ierr
        ! find the names of colors given RGB values
        write(*,*)'Find names given values'

        call closest_color_name( 100.0,   0.0,   0.0, string)
        write(*,*)trim(string)

        call closest_color_name(   0.0, 100.0,   0.0, string)
        write(*,*)trim(string)

        call closest_color_name(   0.0,   0.0, 100.0, string)
        write(*,*)trim(string)

        ! list colors known to colorname2rgb(3f) & corresponding RGB values
        write(*,*)'given names find RGB values'
        ! get the RGB values and English name of the color
        call color_name2rgb('RED',red,green,blue,echoname)
        ! display the English name and RGB values for the name
        write(*,*)echoname,int([red,green,blue])

        write(*,*)'Do some conversions between RGB, HLS, and HLS'
        write(*,*)'and check them against expected values'
        !               NAME        RGB(0-255)            HLS(0-100)
        call chk('hls','red',     [100, 0,   0  ], [0,   50,  100])
        call chk('hls','orange',  [100, 65,  0  ], [39,  50,  100])
        call chk('hls','yellow',  [100, 100, 0  ], [60,  50,  100])
        call chk('hls','green',   [0,   100, 0  ], [120, 50,  100])
        call chk('hls','cyan',    [0,   100, 100], [180, 50,  100])
        call chk('hls','blue',    [0,   0,   100], [240, 50,  100])
        call chk('hls','magenta', [100, 0,   100], [300, 50,  100])
        call chk('hls','black',   [0,   0,   0  ], [0,   0,   0  ])
        call chk('hls','white',   [100, 100, 100], [0,   100, 0  ])
        !               NAME        RGB(0-255)           HSV(0-100)
        call chk('hsv','red',     [100, 0,   0  ], [0,   100, 100])
        call chk('hsv','yellow',  [100, 100, 0  ], [60,  100, 100])
        call chk('hsv','green',   [0,   100, 0  ], [120, 100, 100])
        call chk('hsv','cyan',    [0,   100, 100], [180, 100, 100])
        call chk('hsv','blue',    [0,   0,   100], [240, 100, 100])
        call chk('hsv','magenta', [100, 0,   100], [300, 100, 100])
        call chk('hsv','white',   [100, 100, 100], [0,   0,   100])
        call chk('hsv','black',   [0,   0,   0  ], [0,   0,   0  ])
        call chk('hsv','gray50',  [50,  50,  50 ], [0,   0,   50 ])
        call chk('hsv','silver',  [75,  75,  75 ], [0,   0,   75 ])
        call chk('hsv','red4',    [55,  0,   0  ], [0,   100, 55 ])
        call chk('hsv','olive',   [50,  50,  0  ], [60,  100, 50 ])
        call chk('hsv','lime',    [0,   100, 0  ], [120, 100, 100])
        call chk('hsv','teal',    [0,   50,  50 ], [180, 100, 50 ])
        call chk('hsv','navy',    [0,   0,   50 ], [240, 100, 50 ])
        call chk('hsv','purple',  [63,  13,  94 ], [277, 87,  94 ])
        call chk('hsv','magenta4',[55,  0,   55 ], [300, 100, 55 ])
        call chk('hsv','maroon',  [69,  19,  38 ], [338, 73,  69 ])

        write(*,*)'Get some grayscale values from RGB color values'
        call rgbmono(100.,  0.,  0.,gray,ierr);write(*,*)'red     ',gray
        call rgbmono(  0.,100.,  0.,gray,ierr);write(*,*)'green   ',gray
        call rgbmono(  0.,  0.,100.,gray,ierr);write(*,*)'blue    ',gray
        call rgbmono(100.,100.,  0.,gray,ierr);write(*,*)'Yellow  ',gray
        call rgbmono(  0.,100.,100.,gray,ierr);write(*,*)'Cyan    ',gray
        call rgbmono(100.,  0.,100.,gray,ierr);write(*,*)'Magenta ',gray
        call rgbmono(100.,100.,100.,gray,ierr);write(*,*)'White   ',gray
        call rgbmono( 00.,  0.,  0.,gray,ierr);write(*,*)'Black   ',gray
        call rgbmono( 50.,  0.,  0.,gray,ierr);write(*,*)'Maroon  ',gray
        call rgbmono(100., 50., 50.,gray,ierr);write(*,*)'Pink    ',gray
        contains
        subroutine chk(modelout,name,rgb,other)
        ! given a color convert to MODELOUT and compare to expected values
        character(len=*),intent(in)   :: name
        integer,intent(in)            :: rgb(3), other(3)
        character(len=*),intent(in)   :: modelout
        real                          :: val1,val2,val3
        integer                       :: status
           ! convert RGB values to MODELOUT values
           call hue('rgb',REAL(rgb(1)),REAL(rgb(2)),REAL(rgb(3)),&
           & modelout,val1,val2,val3,status)
           ! left-justify name to 10 characters or more
           write(*,'(a,1x)',advance='no') &
           & [ character(len=max(10,len_trim(name))) ::' '//trim(name)]
           write(*,'(a,1x,3(i3,1x))',advance='no') &
           & modelout//' EXPECTED',other
           write(*,'(a,1x,3(i3,1x))',advance='no') &
           & 'GOT',int([val1+0.5,val2+0.5,val3+0.5])
           write(*,'(a,i0)')'STATUS ',status
        end subroutine chk
     end program demo_M_color