module strings

  private

  public :: lowerc, upperc, split_on_delim, valid_file_name
  public :: tolower, toupper  !--- These are depreciated

  type delim_list_item_t
    character(len=1)   :: delim
    character(len=256) :: item
  end type delim_list_item_t

  !--- Define a container to hold a pointer to delim_list_item_t
  !--- which may be used to define an array of pointers or
  !--- to safely pass a pointer into a subroutine
  type delim_list_t
    type(delim_list_item_t), pointer :: list => null()
  end type delim_list_t

contains

  !-----------------------------------------------------------------------------
  !--- Split a string into a list of sub-strings
  !--- Sub-strings are delimited by the single character in delim1
  !--- Leading and trailing whitespace is ignored around each sub-string
  !--- Using a space as the delimiter is allowed.
  !--- Larry Solheim, Aug 2012
  !-----------------------------------------------------------------------------
  subroutine split_on_delim(list,nlist,strng_in,delim1,delim2)

    implicit none

    character(*) :: list(:)
    integer :: nlist
    character(*) :: strng_in, delim1
    character(*), optional :: delim2

    !--- local
    character(len=1024) :: strng
    character(len=1) :: delim
    integer :: idx1, idx2, idx3
    logical :: ok

    !--- Only the first character from delim1 is used
    delim = delim1(1:1)

    if (len_trim(list(1)) .gt. len(strng)) then
      write(6,*)"split_on_delim: Input list char length exceeds maximum ",len(strng)
      call abort
    endif

    if (len_trim(strng_in) .gt. len(strng)) then
      write(6,*)"split_on_delim: Input string char length exceeds maximum ",len(strng)
      call abort
    endif

    !--- Break the input string into fields separated by delim
    nlist=0
    strng=" "
    strng=trim(adjustl(strng_in))
    idx3=len(strng)
    ok = .true.
    do while (ok)
      idx1 = index(strng,delim)
      if (delim.eq." " .and. len_trim(strng).le.0) exit
      if (idx1.eq.1) then
        !--- "delim" is the first char in strng
        !--- The string either starts with "delim" or there are
        !--- adjacent "delim"s in it
        !--- Ignore these empty list elements
        strng = adjustl(strng(idx1+1:idx3))
        cycle
      else if (idx1.gt.1) then
        !--- Add this field to the list of fields
        nlist=nlist+1
        list(nlist) = " "
        list(nlist) = trim(adjustl(strng(1:idx1-1)))
        strng = adjustl(strng(idx1+1:idx3))
      else
        if (len_trim(strng).gt.0) then
          !--- Add the last field to the list of fields
          nlist=nlist+1
          list(nlist) = " "
          list(nlist) = trim(adjustl(strng))
        endif
        !--- There are no more fields
        exit
      endif
    enddo

  end subroutine split_on_delim

#undef work_in_progress
#ifdef work_in_progress
  !-----------------------------------------------------------------------------
  !--- This subroutine is currently under construction
  !-----------------------------------------------------------------------------
  subroutine split_on_delims(list,nlist,strng_in,delim1,delim2)
    !******************************************************************
    ! Split a string into a list of sub-strings
    ! Sub-strings are delimited by the single character in delim1
    ! Leading and trailing whitespace is ignored around each sub-string
    ! Using a space as the delimiter is allowed.
    ! Larry Solheim, Aug 2012
    !******************************************************************

    implicit none

    character(*) :: list(:)
    integer :: nlist
    character(*) :: strng_in, delim1, delim2
    type(delim_list_t), pointer :: olist

    !--- local
    character(len=1024) :: strng
    character(len=1) :: delima
    character(len=1) :: delimb
    integer :: idx1, idx2, idx3, idx4
    logical :: ok

    !--- Only the first character from delim1 and delim2 are used
    delima = delim1(1:1)
    delimb = delim2(1:1)

    if (len_trim(list(1)) .gt. len(strng)) then
      write(6,*)"split_on_delims: Input list char length exceeds maximum ",len(strng)
      call abort
    endif

    if (len_trim(strng_in) .gt. len(strng)) then
      write(6,*)"split_on_delims: Input string char length exceeds maximum ",len(strng)
      call abort
    endif

    !--- Break the input string into fields separated by delims
    nlist=0
    strng=" "
    strng=trim(adjustl(strng_in))
    idx4=len(strng)
    ok = .true.
    do while (ok)
      idx1 = index(strng,delima)
      idx2 = index(strng,delimb)
      if (idx1.gt.0 .and. idx2.gt.0) then
        !--- Both delimiters appear in the string
        if (idx1.lt.idx2) then
          !--- delima appears first in the string
          if (delima.eq." " .and. len_trim(strng).le.0) exit
          if (idx1.eq.1) then
            !--- "delima" is the first char in strng
            !--- The string either starts with "delima" or there are
            !--- adjacent "delima"s in it
            !--- Ignore these empty list elements
            strng = adjustl(strng(idx1+1:idx4))
            cycle
          else if (idx1.gt.1) then
            !--- Add this field to the list of fields
            nlist=nlist+1
            list(nlist) = " "
            list(nlist) = trim(adjustl(strng(1:idx1-1)))
            strng = adjustl(strng(idx1+1:idx4))
          else
            if (len_trim(strng).gt.0) then
              !--- Add the last field to the list of fields
              nlist=nlist+1
              list(nlist) = " "
              list(nlist) = trim(adjustl(strng))
            endif
            !--- There are no more fields
            exit
          endif
        else
          !--- delimb appears first in the string
          if (delimb.eq." " .and. len_trim(strng).le.0) exit
          if (idx2.eq.1) then
            !--- "delimb" is the first char in strng
            !--- The string either starts with "delimb" or there are
            !--- adjacent "delimb"s in it
            !--- Ignore these empty list elements
            strng = adjustl(strng(idx2+1:idx4))
            cycle
          else if (idx2.gt.1) then
            !--- Add this field to the list of fields
            nlist=nlist+1
            list(nlist) = " "
            list(nlist) = trim(adjustl(strng(1:idx2-1)))
            strng = adjustl(strng(idx2+1:idx4))
          else
            if (len_trim(strng).gt.0) then
              !--- Add the last field to the list of fields
              nlist=nlist+1
              list(nlist) = " "
              list(nlist) = trim(adjustl(strng))
            endif
            !--- There are no more fields
            exit
          endif
        endif
      else if (idx1.gt.0) then
        !--- Only delima appears in the string
        if (delima.eq." " .and. len_trim(strng).le.0) exit
        if (idx1.eq.1) then
          !--- "delima" is the first char in strng
          !--- The string either starts with "delima" or there are
          !--- adjacent "delima"s in it
          !--- Ignore these empty list elements
          strng = adjustl(strng(idx1+1:idx4))
          cycle
        else if (idx1.gt.1) then
          !--- Add this field to the list of fields
          nlist=nlist+1
          list(nlist) = " "
          list(nlist) = trim(adjustl(strng(1:idx1-1)))
          strng = adjustl(strng(idx1+1:idx4))
        else
          if (len_trim(strng).gt.0) then
            !--- Add the last field to the list of fields
            nlist=nlist+1
            list(nlist) = " "
            list(nlist) = trim(adjustl(strng))
          endif
          !--- There are no more fields
          exit
        endif
      else if (idx2.gt.0) then
        !--- Only delimb appears in the string
        if (delimb.eq." " .and. len_trim(strng).le.0) exit
        if (idx2.eq.1) then
          !--- "delimb" is the first char in strng
          !--- The string either starts with "delimb" or there are
          !--- adjacent "delimb"s in it
          !--- Ignore these empty list elements
          strng = adjustl(strng(idx2+1:idx4))
          cycle
        else if (idx2.gt.1) then
          !--- Add this field to the list of fields
          nlist=nlist+1
          list(nlist) = " "
          list(nlist) = trim(adjustl(strng(1:idx2-1)))
          strng = adjustl(strng(idx2+1:idx4))
        else
          if (len_trim(strng).gt.0) then
            !--- Add the last field to the list of fields
            nlist=nlist+1
            list(nlist) = " "
            list(nlist) = trim(adjustl(strng))
          endif
          !--- There are no more fields
          exit
        endif
      else
        !--- Neither delima nor delimb appear in the string
        if (len_trim(strng).gt.0) then
          !--- Add the last field to the list of fields
          nlist=nlist+1
          list(nlist) = " "
          list(nlist) = trim(adjustl(strng))
        endif
        !--- There are no more fields
        exit
      endif

    enddo

  end subroutine split_on_delims
#endif

  !-----------------------------------------------------------------------------
  !--- Convert all upper case A-Z characters in the input string to lower case
  !-----------------------------------------------------------------------------
  function lowerc(strng) result(lc)
    character(*), intent(in) :: strng
    character( len=1024 ) :: lc
    integer :: idx, ich

    if ( len_trim(strng) > 1024 ) then
      write(6,*)'lowerc: Input string to long.'
      call xit("lowerc",-1)
    endif

    lc = " "
    lc = trim(strng)

    do idx=1,len_trim(strng)
      ich = iachar( lc(idx:idx) )
      if ( ich > 64 .and. ich < 91 ) then
        !--- This is an upper case character
        !--- Convert it to lower case
        lc(idx:idx) = achar( ich+32 )
      endif
    enddo
  end function lowerc

  !-----------------------------------------------------------------------------
  !--- Convert all lower case a-z characters in the input string to upper case
  !-----------------------------------------------------------------------------
  function upperc(strng) result(uc)
    character(*), intent(in) :: strng
    character( len=1024 ) :: uc
    integer :: idx, ich

    if ( len_trim(strng) > 1024 ) then
      write(6,*)'lowerc: Input string to long.'
      call xit("lowerc",-1)
    endif

    uc = " "
    uc = trim(strng)

    do idx=1,len_trim(strng)
      ich = iachar( uc(idx:idx) )
      if ( ich > 96 .and. ich < 123 ) then
        !--- This is a lower case character
        !--- Convert it to upper case
        uc(idx:idx) = achar( ich-32 )
      endif
    enddo
  end function upperc

  !-----------------------------------------------------------------------------
  !--- Transpose A-Z to a-z  *** DEPRECIATED ...USE FUNCTION lowerc INSTEAD ***
  !--- Larry Solheim, Aug 2012
  !-----------------------------------------------------------------------------
  subroutine tolower(chin,chout)
    implicit none
    character*(*) chin,chout
    integer i
    if (len(chout).lt.len_trim(chin)) then
      write(6,*)'tolower: Output string too short'
      call abort
    endif
    chout=' '
    chout=trim(chin)
    do i=1,len_trim(chin)
      select case (chin(i:i))
        case ("A")
          chout(i:i)="a"
        case ("B")
          chout(i:i)="b"
        case ("C")
          chout(i:i)="c"
        case ("D")
          chout(i:i)="d"
        case ("E")
          chout(i:i)="e"
        case ("F")
          chout(i:i)="f"
        case ("G")
          chout(i:i)="g"
        case ("H")
          chout(i:i)="h"
        case ("I")
          chout(i:i)="i"
        case ("J")
          chout(i:i)="j"
        case ("K")
          chout(i:i)="k"
        case ("L")
          chout(i:i)="l"
        case ("M")
          chout(i:i)="m"
        case ("N")
          chout(i:i)="n"
        case ("O")
          chout(i:i)="o"
        case ("P")
          chout(i:i)="p"
        case ("Q")
          chout(i:i)="q"
        case ("R")
          chout(i:i)="r"
        case ("S")
          chout(i:i)="s"
        case ("T")
          chout(i:i)="t"
        case ("U")
          chout(i:i)="u"
        case ("V")
          chout(i:i)="v"
        case ("W")
          chout(i:i)="w"
        case ("X")
          chout(i:i)="x"
        case ("Y")
          chout(i:i)="y"
        case ("Z")
          chout(i:i)="z"
      end select
    enddo
  end subroutine tolower

  !-----------------------------------------------------------------------------
  !--- Transpose a-z to A-Z  *** DEPRECIATED ...USE FUNCTION upperc INSTEAD ***
  !--- Larry Solheim, Aug 2012
  !-----------------------------------------------------------------------------
  subroutine toupper(chin,chout)
    implicit none
    character*(*) chin,chout
    integer i
    if (len(chout).lt.len_trim(chin)) then
      write(6,*)'toupper: Output string too short'
      call xit("TOUPPER",-1)
    endif
    chout=' '
    chout=trim(chin)
    do i=1,len_trim(chin)
      select case (chin(i:i))
        case ("a")
          chout(i:i)="A"
        case ("b")
          chout(i:i)="B"
        case ("c")
          chout(i:i)="C"
        case ("d")
          chout(i:i)="D"
        case ("e")
          chout(i:i)="E"
        case ("f")
          chout(i:i)="F"
        case ("g")
          chout(i:i)="G"
        case ("h")
          chout(i:i)="H"
        case ("i")
          chout(i:i)="I"
        case ("j")
          chout(i:i)="J"
        case ("k")
          chout(i:i)="K"
        case ("l")
          chout(i:i)="L"
        case ("m")
          chout(i:i)="M"
        case ("n")
          chout(i:i)="N"
        case ("o")
          chout(i:i)="O"
        case ("p")
          chout(i:i)="P"
        case ("q")
          chout(i:i)="Q"
        case ("r")
          chout(i:i)="R"
        case ("s")
          chout(i:i)="S"
        case ("t")
          chout(i:i)="T"
        case ("u")
          chout(i:i)="U"
        case ("v")
          chout(i:i)="V"
        case ("w")
          chout(i:i)="W"
        case ("x")
          chout(i:i)="X"
        case ("y")
          chout(i:i)="Y"
        case ("z")
          chout(i:i)="Z"
      end select
    enddo
  end subroutine toupper

  !-----------------------------------------------------------------------------
  !--- Convert the input string to a valid file name
  !--- In addition replace all spaces with undescores
  !--- Larry Solheim, Aug 2012
  !-----------------------------------------------------------------------------
  character(len=1024) function valid_file_name(name_in) result(name_out)
    implicit none
    character(*) :: name_in
    integer :: idx, ich

    if (len_trim(name_in).gt.1024) then
      write(6,*)'valid_file_name: Input string is too long.'
      call abort
    endif

    !--- Initialize name_out as the input file name
    !--- with any leading white space removed
    name_out=' '
    name_out=trim(adjustl(name_in))

    !--- Modify name_out if any chars are not suitable for a system file name
    do idx=1,len_trim(name_out)
      ich = ichar(name_out(idx:idx))
      ALL: select case (ich)
        case (:47) ALL  !--- ascii values <= 47
          select case (ich)
            case (32)
              !--- replace spaces with underscore
              name_out(idx:idx)='_'
            case (43,45,46)
              !--- Leave plus (43), hyphen (45) and period (46) "as is"
            case default
              !--- Replace everything else with a dash
              name_out(idx:idx)='-'
          end select 
        case (48:57) ALL  !--- integers 0-9
          !--- Leave integers "as is"
        case (58:64) ALL  !--- chars --> : ; < = > ? @ <--
          !--- Replace these chars with a dash
          name_out(idx:idx)='-'
        case (65:90) ALL  !--- A-Z
          !--- Leave A-Z "as is"
        case (91:96) ALL  !--- chars --> [ \ ] ^ _ ` <--
          select case (ich)
            case (95)
              !--- Leave underscore "as is"
            case default
              !--- Replace everything else with a dash
              name_out(idx:idx)='-'
          end select 
        case (97:122) ALL  !--- a-z
          !--- Leave a-z "as is"
        case (123:) ALL  !--- ascii values >= 123
          select case (ich)
            case (126)
              !--- Leave tilda "as is"
            case default
              !--- Replace everything else with a dash
              name_out(idx:idx)='-'
          end select
        case default ALL
          !--- Otherwise replace with a dash
          name_out(idx:idx)='-'
      end select ALL
    enddo

  end function valid_file_name

end module strings
