!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
!                                                                     !
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
!BOP
!  !MODULE: m_string - a module to process strings
!
!  !DESCRIPTION: 
!     Make some operations in strings
!
!  !INTERFACE:

MODULE m_string
  !
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: replace      ! Replace a string by another
  PUBLIC :: str_template ! Replace variables in a template
  PUBLIC :: num2str      ! convert a number to string
!  PUBLIC :: str2num      ! convert a number to string
  PUBLIC :: GetTokens    ! Get tokens by line
  PUBLIC :: find         ! find substring
  PUBLIC :: split        ! split string
  PUBLIC :: check        ! check if a substring is inside a string
  
  PUBLIC	:: operator (.upper.)	! convert a string to uppercase
  PUBLIC	:: uppercase
  PUBLIC	:: operator (.lower.)	! convert a string to lowercase
  PUBLIC	:: lowercase

  interface Str_Template
     module procedure str_Template_
  end interface

  interface replace
     module procedure replace_
  end interface

  interface num2str ; module procedure &
     int2str,   & ! convert integer to string
     float2str    ! convert float to string
  end interface

!  interface str2num; module procedure &
!        str2int, &
!        str2float
!  end interface

  interface GetTokens
     module procedure GetTokens_
  end interface

  interface find 
     module procedure indexarray, indexstr
  end interface

  interface operator (.upper.)
     module procedure upper_case
  end interface

  interface uppercase
     module procedure upper_case
  end interface
  
  interface operator (.lower.)
     module procedure lower_case
  end interface

  interface lowercase
     module procedure lower_case
  end interface

  ! !REVISION HISTORY:
  ! 15 Dec 2010 - J. G. de Mattos - Initial Version
  ! 02 Mar 2011 - J. G. de Mattos - Initial code to strTemplate
  ! 30 Nov 2012 - J. G. de Mattos - All input parameters optionals in strTemplate
  ! 05 Fev 2014 - J. G. de Mattos - Adding julian day mask
  ! 20 jun 2014 - J. G. de Mattos - Adding GetTokens feature
  ! 01 Sep 2014 - J. G. de Mattos - Adding find substring
  ! 05 May 2020 - J. G. de Mattos - Merge with m_chars.F90 of mpeu library
  !
  ! !BUGS:
  !   Not yet
  !
  !EOP
  !---------------------------------------------------------------------!
  !BOC
  !
  ! PARAMETERS
  !
  CHARACTER(len=3),PARAMETER,DIMENSION(12) :: mon_lc = (/&
       'jan','feb','mar','apr','may','jun',&
       'jul','aug','sep','oct','nov','dec'/)

  CHARACTER(len=3),PARAMETER,DIMENSION(12) :: mon_wd = (/&
       'Jan','Feb','Mar','Apr','May','Jun',&
       'Jul','Aug','Sep','Oct','Nov','Dec'/)

  CHARACTER(len=3),PARAMETER,DIMENSION(12) :: mon_uc = (/&
       'JAN','FEB','MAR','APR','MAY','JUN',&
       'JUL','AUG','SEP','OCT','NOV','DEC'/)

CONTAINS
  !---------------------------------------------------------------------!
  !BOP
  !
  ! !ROUTINE: str_template -  A template formatting a string with variables
  !
  ! !DESCRIPTION:
  !
  !   A template resolver formatting a string with a string variable
  !   and time variables.  The format descriptors are similar to those
  !   used in the GrADS.
  !
  !  %y4    substitute with a 4 digit year
  !  %y2    a 2 digit year
  !  %m1    a 1 or 2 digit month
  !  %m2    a 2 digit month
  !  %mc    a 3 letter month in lower cases
  !  %Mc    a 3 letter month with a leading letter in upper case
  !  %MC    a 3 letter month in upper cases
  !  %d1    a 1 or 2 digit day
  !  %d2    a 2 digit day
  !  %h1    a 1 or 2 digit hour
  !  %h2    a 2 digit hour
  !  %h3    a 3 digit hour (?)
  !  %n2    a 2 digit minute
  !  %e     a string ensemble identify
  !  %jd    a julian day without hours decimals
  !  %jdh   a julian day with hour decimals
  !  %jy    a day of current year without hours decimals
  !  %jyh   a day of current year with hours decimals

  !
  !  %ix1   initial 1 digit decade 
  !  %ix3   initial 3 digit decade 
  !  %iy2   initial 2 digit year 
  !  %iy4   initial 4 digit year 
  !  %im1   initial 1 or 2 digit month 
  !  %im2   initial 2 digit month (leading zero if needed) 
  !  %imc   initial 3 character month abbreviation 
  !  %id1   initial 1 or 2 digit day (leading zero if needed) 
  !  %id2   initial 2 digit day 
  !  %ih1   initial 1 or 2 digit hour 
  !  %ih2   initial 2 digit hour 
  !  %ih3   initial 3 digit hour 
  !  %in2   initial 2 digit minute (leading zero if needed)

  !
  !  %fx1   forecast 1 digit decade 
  !  %fx3   forecast 3 digit decade 
  !  %fy2   forecast 2 digit year 
  !  %fy4   forecast 4 digit year 
  !  %fm1   forecast 1 or 2 digit month 
  !  %fm2   forecast 2 digit month (leading zero if needed) 
  !  %fmc   forecast 3 character month abbreviation 
  !  %fd1   forecast 1 or 2 digit day (leading zero if needed) 
  !  %fd2   forecast 2 digit day 
  !  %fh1   forecast 1 or 2 digit hour 
  !  %fh2   forecast 2 digit hour 
  !  %fh3   forecast 3 digit hour 
  !  %fn2   forecast 2 digit minute (leading zero if needed)
  !
  ! !INTERFACE:

  SUBROUTINE str_template_(strg,nymd,nhms,fymd,fhms,jd,doy,label)
    IMPLICIT NONE
    !
    ! !INPUT/OUTPUT PARAMETERS:
    !
    CHARACTER(len=*), INTENT(INOUT) :: strg
    !
    ! !INPUT PARAMETERS:
    !
    INTEGER,      OPTIONAL, INTENT(IN)   :: nymd
    INTEGER,      OPTIONAL, INTENT(IN)   :: nhms
    INTEGER,      OPTIONAL, INTENT(IN)   :: fymd
    INTEGER,      OPTIONAL, INTENT(IN)   :: fhms
    REAL(kind=8), OPTIONAL, INTENT(IN)   :: jd
    REAL(kind=8), OPTIONAL, INTENT(IN)   :: doy

    CHARACTER(LEN=*), OPTIONAL, INTENT(IN)   :: label


    !
    ! !REVISION HISTORY:
    !  Joao Gerd - 02Mar2011 - Codigo Inicial
    !  Joao Gerd - 30Nov2012 - All input parameters optionals in strTemplate
    !  Joao Gerd - 05Fev2014 - Adding julian day mask

    !EOP
    !---------------------------------------------------------------------!
    !BOC   
    INTEGER :: year4, year2, month, day
    INTEGER :: hour, minute, second

    INTEGER :: fyear4, fyear2, fmonth, fday
    INTEGER :: fhour, fminute, fsecond

    IF(PRESENT(nymd)) THEN

       year4  = INT( nymd / 10000 )
       year2  = MOD( year4, 100 )
       month  = MOD( nymd, 10000 ) / 100 
       day    = MOD( nymd, 100 )

       !
       ! Default template variables
       !

       call replace_( strg, '%y2', int2str(year2,'(I2.2)') )
       call replace_( strg, '%y4', int2str(year4,'(I4.4)') )
       call replace_( strg, '%m1', int2str(month,'(I1)') )
       call replace_( strg, '%m2', int2str(month,'(I2.2)') )
       call replace_( strg, '%mc', mon_lc(month) )
       call replace_( strg, '%Mc', mon_wd(month) )
       call replace_( strg, '%MC', mon_uc(month) )
       call replace_( strg, '%d1', int2str(day,'(I1)') )
       call replace_( strg, '%d2', int2str(day,'(I2.2)') )

       !
       ! Initial/Analysis time template
       !

       call replace_( strg, '%iy2', int2str(year2,'(I2.2)') )
       call replace_( strg, '%iy4', int2str(year4,'(I4.4)') )
       call replace_( strg, '%im1', int2str(month,'(I1)') )
       call replace_( strg, '%im2', int2str(month,'(I2.2)') )
       call replace_( strg, '%imc', mon_lc(month) )
       call replace_( strg, '%iMc', mon_wd(month) )
       call replace_( strg, '%iMC', mon_uc(month) )
       call replace_( strg, '%id1', int2str(day,'(I1)') )
       call replace_( strg, '%id2', int2str(day,'(I2.2)') )

    ENDIF

    IF(PRESENT(nhms)) THEN

       hour   = INT( nhms / 10000 ) 
       minute = MOD( nhms, 10000 ) / 100
       second = MOD( nhms, 100 )

       !
       ! Default template variables
       !
       call replace_( strg, '%h1', int2str(hour,'(I1)') )
       call replace_( strg, '%h2', int2str(hour,'(I2.2)') )
       call replace_( strg, '%h3', int2str(hour,'(I3.3)') )
       call replace_( strg, '%n2', int2str(minute,'(I2.2)') )
       !
       ! Initial/Analysis time template
       !
       call replace_( strg, '%ih1', int2str(hour,'(I1)') )
       call replace_( strg, '%ih2', int2str(hour,'(I2.2)') )
       call replace_( strg, '%ih3', int2str(hour,'(I3.3)') )
       call replace_( strg, '%in2', int2str(minute,'(I2.2)') )

    ENDIF

    !
    ! Final/Forecast time template
    !

    IF ( PRESENT(fymd))THEN 

       fyear4  = INT( fymd / 10000 )
       fyear2  = MOD( fyear4, 100 )
       fmonth  = MOD( fymd, 10000 ) / 100 
       fday    = MOD( fymd, 100 )

       call replace_( strg, '%fy2', int2str(fyear2,'(I2.2)') )
       call replace_( strg, '%fy4', int2str(fyear4,'(I4.4)') )
       call replace_( strg, '%fm1', int2str(fmonth,'(I1)') )
       call replace_( strg, '%fm2', int2str(fmonth,'(I2.2)') )
       call replace_( strg, '%fmc', mon_lc(fmonth) )
       call replace_( strg, '%fMc', mon_wd(fmonth) )
       call replace_( strg, '%fMC', mon_uc(fmonth) )
       call replace_( strg, '%fd1', int2str(fday,'(I1)') )
       call replace_( strg, '%fd2', int2str(fday,'(I2.2)') )

    END IF

    IF (PRESENT(fhms) ) THEN

       fhour   = INT( fhms / 10000 ) 
       fminute = MOD( fhms, 10000 ) / 100
       fsecond = MOD( fhms, 100 )

       call replace_( strg, '%fh1', int2str(fhour,'(I1)') )
       call replace_( strg, '%fh2', int2str(fhour,'(I2.2)') )
       call replace_( strg, '%fh3', int2str(fhour,'(I3.3)') )
       call replace_( strg, '%fn2', int2str(fminute,'(I2.2)') )

    END IF

    IF (PRESENT(label)) call replace_( strg, '%e', adjustl(trim(label)))

    IF (PRESENT(jd))THEN
       call replace_(strg, '%jdh', float2str(jd, '(F15.3)'))
       call replace_(strg, '%jd', int2str(int(jd), '(I10.3)'))
    ENDIF

    IF(PRESENT(doy))THEN
       call replace_(strg, '%jyh', float2str(doy, '(F15.3)'))
       call replace_(strg, '%jy', int2str(int(doy), '(I10.3)'))
    ENDIF

  END SUBROUTINE str_template_
  !---------------------------------------------------------------------!
  !BOP
  !
  ! !ROUTINE: replace
  !
  ! !DESCRIPTION: Rotina para substituir a mask pela repl na strg
  !
  ! !INTERFACE:

  SUBROUTINE replace_(strg,mask,repl)

    !
    !
    IMPLICIT NONE

    ! !INPUT/OUTPUT PARAMETERS:

    CHARACTER(len=*),INTENT(INOUT)  :: strg ! String

    ! !INPUT PARAMETERS:

    CHARACTER(len=*),INTENT(IN)     :: mask ! maskout
    CHARACTER(len=*),INTENT(IN)     :: repl ! replacing string
    !
    ! !REVISION HISTORY:
    !  Joao Gerd - 20Feb2011 - Codigo Inicial
    !
    !EOP
    !---------------------------------------------------------------------!
    !BOC
    CHARACTER(len=300) ::  sub, tmp
    INTEGER :: len_tmp, len_repl, len_mask, len_strg
    INTEGER :: i, j

    len_strg = LEN_TRIM(strg)
    len_repl = LEN_TRIM(repl)
    len_mask = LEN_TRIM(mask)

    tmp = ''
    i   = 1
    j   = 1

    do while( j .LE. len_strg )

       sub = strg(j:j+len_mask-1)

       if( TRIM(sub) .EQ. TRIM(mask) )then

          len_tmp                         = LEN_TRIM(tmp)
          tmp(len_tmp+1:len_tmp+len_repl) = TRIM(repl)

          i = j + len_mask
          j = i

       endif

       len_tmp                  = LEN_TRIM(tmp)
       tmp(len_tmp+1:len_tmp+1) = strg(j:j)

       j = j + 1 

    enddo

    strg = tmp

    return
  END SUBROUTINE replace_
  !EOC
  !---------------------------------------------------------------------!
  !
  !

subroutine GetTokens_(line,tokens,ntokens,del)
   implicit none
   character(len=*)           :: line
   integer                    :: ntokens
   character(len=*)           :: tokens(:)
   character(len=*), optional :: del
!--------------------------------------------------------------------!
!
    
   integer              :: length
   integer              :: i,j
   character(len=10)    :: delimiter
   character, parameter :: BLK = achar(32)   ! blank (space)

   length    = len_trim(line)    
   j         = 1
   ntokens   = 0
   tokens    = BLK
   delimiter = BLK
   if(present(del)) delimiter = del

   do while (j.le.length)

      !
      ! loop over next blank
      !

      do while (line(j:j).eq.trim(delimiter))
         j = j + 1
         if(j.gt.length)exit
      enddo

      !
      ! loop over next token
      !

      ntokens = ntokens + 1
      i = 1
      do while (line(j:j).ne.trim(delimiter))
         tokens(ntokens)(i:i) = line(j:j)
         j = j + 1
         i = i + 1
         if (j.gt.length) exit
      enddo

   end do

   end subroutine

  character(20) function int2str(num,format) 
    integer, intent(in):: num
    character(len=*), intent(in) :: format
    character(20) :: str
    ! convert integer to string using formatted write
    write(str, format ) num
    int2str = adjustl(str)
  end function int2str

  character(20) function float2str(num,format) 
    real(kind=8), intent(in):: num
    character(len=*), intent(in) :: format
    character(20) :: str
    ! convert integer to string using formatted write
    write(str, format ) num
    float2str = adjustl(str)
  end function float2str

!  function str2int(str) result(num)
!     character(len=*), intent(in) :: str
!     integer :: num
!
!     read(str,*)num
!
!  end function
!
!  function str2float(str) result(num)
!     character(len=*), intent(in) :: str
!     real :: num
!
!     read(str,*)num
!
!  end function

  integer  function indexarray(str,tok) result(count)
    implicit none

    character(len=*), intent(in) :: str(:)
    character(len=*), intent(in) :: tok
    integer :: idx, i
    logical :: found


    found = .false.
    
    count = 1
    do i=1,size(str)
       idx=index(trim(tok),trim(str(i)))
       if(idx.gt.0)then
          found = .true.
          exit
       endif
       count = count + 1
    enddo
    if(.not.found) count = 0

  end function indexarray

  integer  function indexstr(str,tok) result(idx)
    implicit none

    character(len=*), intent(in) :: str
    character(len=*), intent(in) :: tok


    idx=index(trim(tok),trim(str))

  end function indexstr
  !-----------------------------------------------------------------------------!
  !             Modeling and Development Division - DMD/CPTEC/INPE              !
  !-----------------------------------------------------------------------------!
  !BOP
  !
  ! !IROUTINE: split - parse string into an array using specified delimiters
  !
  ! !DESCRIPTION: parses a string using specified delimiter characters and
  !               store tokens into an allocatable array
  !
  !
  ! !INTERFACE:
  !

  subroutine split(str, ntokens, tokens, del)

    !
    ! !INPUT PARAMETERS:
    !
    character(len=*), intent(in) :: str
    character(len=*), optional, intent(in) :: del
    !
    ! !OUTPUT PARAMETERS:
    !
    integer, intent(out) :: ntokens
    character(len=*), allocatable, intent(out) :: tokens(:)

    ! !REVISION HISTORY:
    !
    !   13 May 2020 - J. G. de Mattos -  Initial code.
    !
    !EOP
    !-----------------------------------------------------------------------------!
    !BOC

    character, parameter :: BLK = achar(32)   ! blank (space)
    character(len=1)     :: delimiter
    integer              :: i, j
    integer              :: StrLen

    ! linked list to store temporary tokens
    type token
       character(len=10)    :: tk
       type(token), pointer :: next => null()
    endtype token
    type(token), pointer :: root => null()
    type(token), pointer :: current => null()

    ! setting up delimter
    delimiter = BLK
    if (present(del)) delimiter = del

    ! get string length
    StrLen = len_trim(str)

    ! at least we has one token
    ntokens = 1

    ! find tokens using delimiter
    allocate (root)
    current => root
    j = 1
    do i = 1, StrLen

       if (str(i:i) == trim(delimiter)) then
          ntokens = ntokens + 1
          current%tk = str(j:i - 1)
          allocate (current%next)
          current => current%next
          j = i + 1
       endif

    enddo
    !get last token
    current%tk = str(j:len_trim(str))

    !copy tokens to output array
    allocate (tokens(ntokens))
    current => root
    do i = 1, ntokens
       tokens(i) = trim(current%tk)
       current => current%next
    enddo

    !
    ! deallocate temporary token list
    !
    current => root%next
    do while (associated(current))
       deallocate (root)
       root => current
       current => root%next
    enddo

  end subroutine split
  !EOC
  !-----------------------------------------------------------------------------!

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: upper_case - convert lowercase letters to uppercase.
!
! !DESCRIPTION:
!
! !INTERFACE:

  function upper_case(str) result(ustr)
    implicit none
  character(len=*), intent(in) :: str
  character(len=len(str))      :: ustr

! !REVISION HISTORY:
! 	13Aug96 - J. Guo	- (to do)
!EOP
!_______________________________________________________________________
    integer i
    integer,parameter :: il2u=ichar('A')-ichar('a')

    ustr=str
    do i=1,len_trim(str)
      if(str(i:i).ge.'a'.and.str(i:i).le.'z')	&
      	ustr(i:i)=char(ichar(str(i:i))+il2u)
    end do
  end function upper_case

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: lower_case - convert uppercase letters to lowercase.
!
! !DESCRIPTION:
!
! !INTERFACE:

  function lower_case(str) result(lstr)
    implicit none
    character(len=*), intent(in) :: str
    character(len=len(str))      :: lstr

! !REVISION HISTORY:
! 	13Aug96 - J. Guo	- (to do)
!EOP
!_______________________________________________________________________
    integer i
    integer,parameter :: iu2l=ichar('a')-ichar('A')

    lstr=str
    do i=1,len_trim(str)
      if(str(i:i).ge.'A'.and.str(i:i).le.'Z')	&
      	lstr(i:i)=char(ichar(str(i:i))+iu2l)
    end do
  end function lower_case

!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: check - check if the substring is contained in the string.
!
! !DESCRIPTION:
!
! !INTERFACE:

  function check(substr, str) result(found)
     character(len=*) :: substr
     character(len=*) :: str
     logical          :: found
! 	25Mar21 - J. Gerd	- (to do)
!EOP
!-----------------------------------------------------------------------

     integer :: i, istart, iend
     integer :: strLen
     integer :: subStrLen

     character(len=1024) :: string, subString 

     strLen    = len_trim(str)
     subStrLen = len_trim(substr)

     string    = lower_case(str)
     subString = lower_case(subStr)

     found = .false.
     do i = 1, strLen!-subStrLen
        istart = i
        iend   = min(i+subStrLen-1,strLen)
        if (trim(substring) == string(istart:iend))then
           found = .true.
           exit
        endif
     enddo

     
  end function


END MODULE m_string