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