hsv_to_rgb Subroutine

private pure elemental subroutine hsv_to_rgb(h, s, v, r, g, b)

Arguments

Type IntentOptional Attributes Name
real(kind=rk), intent(in) :: h
real(kind=rk), intent(in) :: s
real(kind=rk), intent(in) :: v
integer(kind=ik), intent(out) :: r
integer(kind=ik), intent(out) :: g
integer(kind=ik), intent(out) :: b

Called by

proc~~hsv_to_rgb~~CalledByGraph proc~hsv_to_rgb hsv_to_rgb proc~convert color%convert proc~convert->proc~hsv_to_rgb proc~initialize_colors initialize_colors proc~initialize_colors->proc~convert proc~set color%set proc~initialize_colors->proc~set program~demo_color demo_color program~demo_color->proc~convert proc~find_nearest color%find_nearest program~demo_color->proc~find_nearest proc~print_available_colors color%print_available_colors program~demo_color->proc~print_available_colors proc~save_available_colors color%save_available_colors program~demo_color->proc~save_available_colors program~demo_color->proc~set program~example26 example26 program~example26->proc~convert program~example26->proc~set program~example27 example27 program~example27->proc~convert program~example27->proc~find_nearest program~example27->proc~set proc~find_nearest->proc~initialize_colors proc~print_available_colors->proc~initialize_colors proc~save_available_colors->proc~initialize_colors proc~set_by_name color%set_by_name proc~set_by_name->proc~initialize_colors proc~set->proc~set_by_name program~example29 example29 program~example29->proc~print_available_colors program~example29->proc~save_available_colors program~example28 example28 program~example28->proc~set

Source Code

   elemental pure subroutine hsv_to_rgb(h, s, v, r, g, b)
      real(rk), intent(in) :: h, s, v
      integer(ik), intent(out) :: r, g, b
      real(rk) :: c, h_prime, x, m
      real(rk) :: h_dash, r1, g1, b1

      c = v/100.0_rk * s/100.0_rk
      h_prime = h / 60.0_rk

      h_dash = mod(h_prime, 6.0_rk)
      x = c * (1.0_rk - abs(h_dash - 2.0_rk * floor(h_dash / 2.0_rk) - 1.0_rk))

      select case (int(h_dash))
       case (0)
         r1 = c
         g1 = x
         b1 = 0.0_rk
       case (1)
         r1 = x
         g1 = c
         b1 = 0.0_rk
       case (2)
         r1 = 0.0_rk
         g1 = c
         b1 = x
       case (3)
         r1 = 0.0_rk
         g1 = x
         b1 = c
       case (4)
         r1 = x
         g1 = 0.0_rk
         b1 = c
       case (5)
         r1 = c
         g1 = 0.0_rk
         b1 = x
       case default
         r1 = 0.0_rk
         g1 = 0.0_rk
         b1 = 0.0_rk
      end select

      m = v/100.0_rk - c
      r = nint(255.0_rk * (r1 + m), kind=ik)
      g = nint(255.0_rk * (g1 + m), kind=ik)
      b = nint(255.0_rk * (b1 + m), kind=ik)

      r = max(0, min(255, r))
      g = max(0, min(255, g))
      b = max(0, min(255, b))
   end subroutine hsv_to_rgb