write Subroutine

private impure subroutine write(this, verbose, name, family, gradient, palette, author, license, levels, file_name, append)

Uses

  • proc~~write~~UsesGraph proc~write Colormaps_info%write iso_fortran_env iso_fortran_env proc~write->iso_fortran_env

Filter colormaps and write metadata.

Type Bound

Colormaps_info

Arguments

Type IntentOptional Attributes Name
class(Colormaps_info), intent(in) :: this
integer, intent(in), optional :: verbose
character(len=*), intent(in), optional :: name
character(len=*), intent(in), optional :: family
character(len=*), intent(in), optional :: gradient
character(len=*), intent(in), optional :: palette
character(len=*), intent(in), optional :: author
character(len=*), intent(in), optional :: license
integer, intent(in), optional :: levels
character(len=*), intent(in), optional :: file_name
logical, intent(in), optional :: append

Calls

proc~~write~~CallsGraph proc~write Colormaps_info%write proc~get_ncolormaps Colormaps_info%get_ncolormaps proc~write->proc~get_ncolormaps

Source Code

   impure subroutine write(this, verbose, name, family, gradient, palette, author, license, levels, file_name, append)
      use, intrinsic :: iso_fortran_env, only: output_unit
      class(Colormaps_info), intent(in) :: this
      integer, intent(in), optional :: verbose
      character(*), intent(in), optional :: name, family, gradient, palette, author, license
      integer, intent(in), optional :: levels
      character(*), intent(in), optional :: file_name
      logical, intent(in), optional :: append
      integer :: i, verbose_, unit
      logical :: append_, apply_filter
      integer :: w_name, w_family, w_gradient, w_palette, w_colorbar, w_package, w_author, w_license, w_url, w_levels
      character(len=32) :: tmp
      character(*), parameter :: H_NAME     = 'Name'
      character(*), parameter :: H_FAMILY   = 'Family'
      character(*), parameter :: H_GRADIENT = 'Gradient'
      character(*), parameter :: H_PALETTE  = 'Palette'
      character(*), parameter :: H_LEVELS   = 'Levels'
      character(*), parameter :: H_COLORBAR = 'Colorbar'
      character(*), parameter :: H_PACKAGE  = 'Package'
      character(*), parameter :: H_AUTHOR   = 'Author'
      character(*), parameter :: H_LICENSE  = 'Licence'
      character(*), parameter :: H_URL      = 'URL'
      integer, parameter :: LH_NAME     = len(H_NAME)
      integer, parameter :: LH_FAMILY   = len(H_FAMILY)
      integer, parameter :: LH_GRADIENT = len(H_GRADIENT)
      integer, parameter :: LH_PALETTE  = len(H_PALETTE)
      integer, parameter :: LH_LEVELS   = len(H_LEVELS)
      integer, parameter :: LH_COLORBAR = len(H_COLORBAR)
      integer, parameter :: LH_PACKAGE  = len(H_PACKAGE)
      integer, parameter :: LH_AUTHOR   = len(H_AUTHOR)
      integer, parameter :: LH_LICENSE  = len(H_LICENSE)
      integer, parameter :: LH_URL      = len(H_URL)
      character(len=1), parameter :: SEP1 = '|'
      character(len=1), parameter :: SEP2 = '-'

      ! defaults
      verbose_ = 1
      if (present(verbose)) verbose_ = verbose
      append_  = .false.
      if (present(append)) append_  = append

      ! output unit
      if (present(file_name)) then
         if (append_) then
            open(newunit=unit, file=trim(file_name), status='unknown', position='append', action='write')
         else
            open(newunit=unit, file=trim(file_name), status='replace', action='write')
         end if
      else
         unit = output_unit
      end if

      apply_filter = present(name) .or. present(family) .or. present(gradient) .or. present(palette) .or. present(author) .or. &
                     present(license) .or. present(levels)

      ! initialize column widths from headers
      w_name     = LH_NAME
      w_family   = LH_FAMILY
      w_gradient = LH_GRADIENT
      w_palette  = LH_PALETTE
      w_levels   = LH_LEVELS
      w_colorbar = LH_COLORBAR
      w_package  = LH_PACKAGE
      w_author   = LH_AUTHOR
      w_license  = LH_LICENSE
      w_url      = LH_URL

      ! determine maximum column widths
      do i = 1, this%get_ncolormaps()
         if (.not. passes_filter(i)) cycle
         w_name     = max(w_name,     len_trim(this%colormaps(i)%name))
         w_family   = max(w_family,   len_trim(this%colormaps(i)%family))
         w_gradient = max(w_gradient, len_trim(this%colormaps(i)%gradient))
         w_palette  = max(w_palette,  len_trim(this%colormaps(i)%palette))
         write(tmp,'(i4)') this%colormaps(i)%levels
         w_levels   = max(w_levels,   len_trim(tmp))
         w_colorbar = max(w_colorbar, len_trim(this%colormaps(i)%colorbar))
         w_package  = max(w_package,  len_trim(this%colormaps(i)%package))
         w_author   = max(w_author,   len_trim(this%colormaps(i)%author))
         w_license  = max(w_license,  len_trim(this%colormaps(i)%license))
         w_url      = max(w_url,      len_trim(this%colormaps(i)%url))
      end do

      ! header
      select case (verbose_)
       case (1) ! full table
         write(unit,'(a)') SEP1// &
            cell(H_NAME,     w_name)     //SEP1// &
            cell(H_FAMILY,   w_family)   //SEP1// &
            cell(H_GRADIENT, w_gradient) //SEP1// &
            cell(H_PALETTE,  w_palette)  //SEP1// &
            cell(H_LEVELS,   w_levels)   //SEP1// &
            cell(H_COLORBAR, w_colorbar) //SEP1// &
            cell(H_PACKAGE,  w_package)  //SEP1// &
            cell(H_AUTHOR,   w_author)   //SEP1// &
            cell(H_LICENSE,  w_license)  //SEP1// &
            cell(H_URL,      w_url)      //SEP1

         write(unit,'(a)') SEP1// &
            repeat(SEP2, w_name)     //SEP1// &
            repeat(SEP2, w_family)   //SEP1// &
            repeat(SEP2, w_gradient) //SEP1// &
            repeat(SEP2, w_palette)  //SEP1// &
            repeat(SEP2, w_levels)   //SEP1// &
            repeat(SEP2, w_colorbar) //SEP1// &
            repeat(SEP2, w_package)  //SEP1// &
            repeat(SEP2, w_author)   //SEP1// &
            repeat(SEP2, w_license)  //SEP1// &
            repeat(SEP2, w_url)      //SEP1

       case (4) ! minimal table
         write(unit,'(a)') SEP1// &
            cell(H_NAME,     w_name)     //SEP1// &
            cell(H_FAMILY,   w_family)   //SEP1// &
            cell(H_GRADIENT, w_gradient) //SEP1// &
            cell(H_PALETTE,  w_palette)  //SEP1// &
            cell(H_LEVELS,   w_levels)   //SEP1// &
            cell(H_COLORBAR, w_colorbar) //SEP1

         write(unit,'(a)') SEP1// &
            repeat(SEP2, w_name)     //SEP1// &
            repeat(SEP2, w_family)   //SEP1// &
            repeat(SEP2, w_gradient) //SEP1// &
            repeat(SEP2, w_palette)  //SEP1// &
            repeat(SEP2, w_levels)   //SEP1// &
            repeat(SEP2, w_colorbar) //SEP1

       case default
         ! no header

      end select

      ! data
      do i = 1, this%get_ncolormaps()
         if (.not. passes_filter(i)) cycle

         select case (verbose_)
          case (1) ! full table
            write(tmp,'(i4)') this%colormaps(i)%levels
            write(unit,'(a)') SEP1// &
               cell(this%colormaps(i)%name,     w_name)     //SEP1// &
               cell(this%colormaps(i)%family,   w_family)   //SEP1// &
               cell(this%colormaps(i)%gradient, w_gradient) //SEP1// &
               cell(this%colormaps(i)%palette,  w_palette)  //SEP1// &
               cell(tmp,                        w_levels)   //SEP1// &
               cell(this%colormaps(i)%colorbar, w_colorbar) //SEP1// &
               cell(this%colormaps(i)%package,  w_package)  //SEP1// &
               cell(this%colormaps(i)%author,   w_author)   //SEP1// &
               cell(this%colormaps(i)%license,  w_license)  //SEP1// &
               cell(this%colormaps(i)%url,      w_url)      //SEP1

          case (2) ! box
            write(unit,'(a)')    ''
            write(unit,'(a)')    '**********************************************'
            write(unit,'(a,a)')  H_NAME//'    : ', this%colormaps(i)%name
            write(unit,'(a,a)')  H_FAMILY//'  : ', this%colormaps(i)%family
            write(unit,'(a,a)')  H_GRADIENT//': ', this%colormaps(i)%gradient
            write(unit,'(a,a)')  H_PALETTE//' : ', this%colormaps(i)%palette
            write(unit,'(a,I4)') H_LEVELS//'  : ', this%colormaps(i)%levels
            write(unit,'(a,a)')  H_COLORBAR//': ', this%colormaps(i)%colorbar
            write(unit,'(a,a)')  H_PACKAGE//' : ', this%colormaps(i)%package
            write(unit,'(a,a)')  H_AUTHOR//'  : ', this%colormaps(i)%author
            write(unit,'(a,a)')  H_LICENSE//' : ', this%colormaps(i)%license
            write(unit,'(a,a)')  H_URL//'     : ', this%colormaps(i)%url
            write(unit,'(a)')    '**********************************************'
            write(unit,'(a)')    ''

          case (3) ! name only
            write(unit,'(a)') this%colormaps(i)%name

          case (4) ! minimal table
            write(tmp,'(i4)') this%colormaps(i)%levels
            write(unit,'(a)') SEP1// &
               cell(this%colormaps(i)%name,     w_name)     //SEP1// &
               cell(this%colormaps(i)%family,   w_family)   //SEP1// &
               cell(this%colormaps(i)%gradient, w_gradient) //SEP1// &
               cell(this%colormaps(i)%palette,  w_palette)  //SEP1// &
               cell(tmp,                        w_levels)   //SEP1// &
               cell(this%colormaps(i)%colorbar, w_colorbar) //SEP1

          case default
            print *, 'Invalid verbose level: ', verbose_
            return
         end select
      end do

      write(unit,'(a)') ''
      if (present(file_name)) close(unit)

   contains

      pure logical function passes_filter(idx) result(ok)
         integer, intent(in) :: idx
         ok = .true.
         if (.not. apply_filter) return
         if (present(name))     ok = ok .and. (this%colormaps(idx)%name     == name)
         if (present(family))   ok = ok .and. (this%colormaps(idx)%family   == family)
         if (present(gradient)) ok = ok .and. (this%colormaps(idx)%gradient == gradient)
         if (present(palette))  ok = ok .and. (this%colormaps(idx)%palette  == palette)
         if (present(author))   ok = ok .and. (this%colormaps(idx)%author   == author)
         if (present(license))  ok = ok .and. (this%colormaps(idx)%license  == license)
         if (present(levels))   ok = ok .and. (this%colormaps(idx)%levels   == levels)
      end function passes_filter

      pure function cell(s, w) result(out)
         character(*), intent(in) :: s
         integer,      intent(in) :: w
         character(len=w)         :: out
         integer :: n
         character(len=len(s)) :: t
         t = adjustl(trim(s))
         n = min(w, len_trim(t))
         out = t(1:n)//repeat(' ', w - n)
      end function cell

   end subroutine write