Filter colormaps and write metadata.
| Type | Intent | Optional | 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 |
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