Module WordPkg
!
!  module containing routines
!  useful in manipulation of (mostly blank-delimited) words in strings
!
!  Copyright W. J. Metzger, Nijmegen 2005, 2007, 2011, 2014
!
! **********************************************************************
! Summary of License
 
!   This program is free software; you can redistribute it and/or modify
!   it under the terms of the GNU General Public License as published by
!   the Free Software Foundation; either version 2 of the License, or
!   (at your option) any later version.
 
!   This program is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU General Public License for more details.
 
!   To obtain the GNU General Public License write to the Free Software
!   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
! To report bugs, suggest enhancements, etc. to the Author,
! Contact:
!  Dr. W. J. Metzger            Experimental High Energy Physics Group
!  tel. +31-24-3653127          Faculty of Science
!       +31-24-3652099 (secr.)  Radboud University Nijmegen
!  fax. +31-24-3652191          Toernooiveld 1
!                               6525 ED  Nijmegen,  The Netherlands
!  e-mail:  wes@hef.ru.nl       or   Wesley.Metzger@cern.ch
!  http://home.cern.ch/metzger/ or   http://www.hef.ru.nl/~wes
!
!  Version  1.0   10 Nov 2005
!  Version  1.1   23 Nov 2007   add WordFormat
!  Version  1.2   18 Mar 2011   add InsertWord
!  Version  1.3   16 Jun 2014   add Right
!
   Private
   Public  Words, WordIndex, WordPos, Word, DelWord, Space, Copies, Center, Translate, &
           WordParse, IntegerWord, NaturalWord, RealWord, WordFormat, Upper, Lower,    &
           Strip, InsertWord, Right, Left
   Interface WordFormat
      Module Procedure WordFormatI, WordFormatI1, WordFormatR1, WordFormatD1, WordFormatL
   End Interface WordFormat
   Interface WordParse
      Module Procedure WordParseBl, WordParseSp
   End Interface WordParse
   Interface Word
      Module Procedure WordBl, WordSp
   End Interface Word
Contains
   FUNCTION WORDS(Line)
   IMPLICIT NONE
   Integer WORDS
!
!  returns number of blank delimited words in Line
!
   INTEGER i1, ll
   CHARACTER(LEN=*), Intent(IN) :: Line
   CHARACTER(LEN=1), Parameter  :: blank=' '
   CHARACTER(LEN=1)             :: oldch
 
   WORDS = 0
   ll = LEN(Line)
   Do i1 = 1, ll
      IF ( Line(i1:i1).NE.blank ) GoTo 1
   EndDo
   RETURN   ! blank line
!
 1 oldch = blank
   Do While ( i1 .LE. ll )
      If ( Line(i1:i1).EQ.blank .AND. oldch.NE.blank ) WORDS = WORDS + 1
      oldch = Line(i1:i1)
      i1 = i1 + 1
   EndDo
   If ( oldch.NE.blank ) WORDS = WORDS + 1
   Return
   END FUNCTION WORDS
!--------------------------------------------------------------------
   FUNCTION WordIndex(str, NW)
   IMPLICIT NONE
   Integer                      :: WordIndex
   CHARACTER(LEN=*), Intent(IN) :: str
   Integer,          Intent(IN) :: NW
!
!  Returns the character position of the first character of blank delimited
!  word number NW
!  If NW refers to a non-existable word, 0 is returned.
!
   CHARACTER(LEN=1), Parameter  :: blank=' '
   CHARACTER(LEN=1)             :: oldch
   Integer                      :: WORDS, i1, i2, ll
   Character(Len=Len(str)+1)    :: line
 
   If (NW <= 0) then
      WordIndex = 0
      Return
   EndIf
   WORDS = 0
   line = Trim(str) // blank
   ll = Len(Line)
   Do i1 = 1, ll
      IF ( Line(i1:i1) .NE. blank ) GoTo 1
   EndDo
   WordIndex = 0
   RETURN   ! blank line
!
 1 oldch = blank
   i2 = i1
   Do While ( i1 .LE. ll )
      If ( Line(i1:i1).EQ.blank ) then
         If ( oldch.NE.blank ) then
            WORDS = WORDS + 1
            If (WORDS == NW) then
               WordIndex = i2
               Return
            EndIf
         EndIf
         If ( Line(i1+1:i1+1) .ne. blank) i2 = i1 + 1
      EndIf
      oldch = Line(i1:i1)
      i1 = i1 + 1
   EndDo
   If ( oldch.NE.blank ) WORDS = WORDS + 1
   If (WORDS == NW) then
      WordIndex = i1
   Else
      WordIndex = 0
   EndIf
   Return
   END FUNCTION WordIndex
!--------------------------------------------------------------------
   FUNCTION WordPos(phrase, str, start)
   IMPLICIT NONE
   Integer                       :: WordPos
   CHARACTER(LEN=*), Intent(IN)  :: phrase, str
   Integer, Intent(IN), Optional :: start
   Integer                       :: I1
!
!  Returns the word number in str which indicates where phrase begins
!  provided that phrase is a subphrase of string.
!  Optional argument start (default 1) is the word in str at which the search starts
!  Otherwise 0 is returned.
!
   If (Present(start)) then
      I1 = Index(' '//str(WordIndex(str,start):), ' '//phrase)
   Else
      I1 = Index(str, phrase)
   EndIf
   If (I1 == 0) then
      WordPos = 0
   Else
      WordPos = Words(str(1:I1))
      If (Present(start)) WordPos = WordPos + start - 1
   EndIf
   END FUNCTION WordPos
!--------------------------------------------------------------------
   FUNCTION WordBl(str, n)  Result(WN)
   Character(Len=*), Intent(IN) :: str
   Integer,          Intent(IN) :: n
   Character(Len=Len(str))      :: WN
!
!  returns (blank-delimited) word n from str
!
   Character(Len=Len(str)+1)    :: string
   CHARACTER(LEN=1), Parameter  :: blank=' '
 
      wn = ''
      If (n .le. 0) Return
 
      NWORDS = 0
      String = Adjustl(str) // blank
      ls = LEN(String)
      Do i1 = 1, ls
         i = Scan(String, blank)
         If (i > 1) then
            NWORDS = NWORDS + 1
            If (NWORDS == n) then
               Wn = Trim(Adjustl(String(1:i-1)))
               Exit
            Endif
            String = Adjustl(String(i:ls))
         Else
            Exit
         EndIf
      EndDo
 
   End FUNCTION WordBl
!--------------------------------------------------------------------
   FUNCTION WordSp(str, n, SEP)  Result(WN)
   Character(Len=*), Intent(IN) :: str
   Integer,          Intent(IN) :: n
   CHARACTER(LEN=*), Intent(IN) :: SEP
   Character(Len=Len(str))      :: WN
!
!  returns word n from str
!  where words are deliminated by any character in SEP (default blank)
!
   Character(Len=Len(str)+1)    :: string
   CHARACTER(LEN=1), Parameter  :: blank=' '
 
      wn = ''
      If (n .le. 0) Return
 
      NWORDS = 0
      String = str // sep(1:1)
      ls = LEN(String)
      Do i1 = 1, ls
         i = Scan(String, SEP)
         If (i > 1) then
            NWORDS = NWORDS + 1
            If (NWORDS == n) then
               Wn = Trim(String(1:i-1))
               Exit
            Endif
!            String = String(i+1:ls)
         ElseIf (i == 1) then
         Else
            Exit
         EndIf
         String = String(i+1:ls)
      EndDo
 
   End FUNCTION WordSp
!--------------------------------------------------------------------
   FUNCTION DelWord(str, start, length)  Result(strnew)
   Implicit NONE
   Character(Len=*),  Intent(IN) :: str
   Integer,           Intent(IN) :: start
   Integer, Optional, Intent(IN) :: length
   Character(Len=Len(str))       :: strnew
!
!  DelWord(str,start[,length])
!   Returns a new string obtained from str by
!      removing length words and all blanks between them, from str,
!      starting at word number start.
!   The default value for length is the rest of the string.
!   All consecutive spaces immediately after the last deleted word, but no
!   spaces before the first deleted word are removed.
!   Nothing is removed if length is zero.
!
   Integer                       :: leng, lenstr, is1, is2
 
!  Check for valid arguments
 
!  The valid range of start is the positive whole numbers; the first word in
!  string is numbered 1.
   If (start <= 0) then
      strnew = str
      Return
   EndIf
!  The valid range of length is the non-negative integers.
!  Nothing is removed if length is zero.
   If (Present(length)) then
      If (length <= 0) then
        strnew = str
        Return
      Else
        leng = length
      EndIf
   Else
      leng = Len(str)  ! certainly more than the number of words in str
   EndIf
 
   lenstr = Len(str)
!  Find word start
   is1 = WordIndex(str, start)
   If (is1 == 0) then   ! fewer than start words in str
      strnew = str
      Return
   EndIf
!  Find word start+leng
   is2 = WordIndex(str, start + leng) - 1
   If (is2 < 0) is2 = lenstr
!  Remove characters is1 through is2
   If (is1 > 1) then
      If (is2 < lenstr) then
         strnew = str(1:is1-1) // str(is2+1:lenstr)
      Else
         strnew = str(1:is1-1)
      EndIf
   Else
      If (is2 < lenstr) then
         strnew = str(is2+1:)
      Else
         strnew = ''
      EndIf
   EndIf
 
   End FUNCTION DelWord
!--------------------------------------------------------------------
   FUNCTION Space(str, length, padchar)  Result (trs)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      Integer,          Intent(IN), Optional :: length
      CHARACTER(LEN=1), Intent(IN), Optional :: padchar
      CHARACTER(LEN=1)                       :: pad
      CHARACTER(LEN=Len(str)*10)             :: tr, trs
      Integer                                :: L, i, j
!
!     string is returned, stripped of any trailing or leading blanks,
!     and any consecutive blanks inside string replaced by length(default 1)
!     occurences of character padchar (default blank)
!
!     Note that str can be longer than trs if length > 1
!     Hopefully declaring tr 10 times longer than str is sufficient in practice
!
      If (Present(length)) then
         L = length
      Else
         L = 1
      EndIf
      If (Present(padchar)) then
         pad = padchar
      Else
         pad = ' '
      EndIf
      tr = AdjustL(Trim(str))
      j = 1
      Do
         i = Index(Trim(tr(j:)), ' ')
         If (i == 0) Exit
         j = j + i
         tr = Trim(tr(1:j-1)) // Copies(pad, L) // Trim(AdjustL(tr(j:)))
         j = j + L
      EndDo
      trs = tr
   End FUNCTION Space
!--------------------------------------------------------------------
   FUNCTION Strip(str, ltb, char)  Result (trs)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      Character(LEN=*), Intent(IN), Optional :: ltb
      CHARACTER(LEN=1), Intent(IN), Optional :: char
      CHARACTER(LEN=Len(str))                :: trs
      Logical                                :: leading, trailing
      CHARACTER(LEN=1)                       :: ch
      Integer                                :: L
      CHARACTER(LEN=1)                       :: btl
!
!     string is returned, stripped of any trailing and/or leading occurences
!     of char (default blank)
!     if ltb(1:1) is L only leading  occurences are stripped
!     if ltb(1:1) is T only trailing occurences are stripped
!     inter-word occurences of chara are not affected
!
      leading  = .true.
      trailing = .true.
      L = Len(str)
      If (Present(ltb)) then
         btl = Translate(AdjustL(ltb))
         If ( btl == 'L') trailing = .false.
         If ( btl == 'T')  leading = .false.
      EndIf
      If (Present(char)) then
         ch = char
      Else
         ch = ' '
      EndIf
      trs = str
      If (trailing) then
         Do While (trs(L:L) == ch)
           trs(L:L) = ' '
           L = L - 1
         EndDo
      EndIf
      If (leading) then
         Do While (trs(1:1) == ch)
           trs = trs(2:)
         EndDo
      EndIf
   End FUNCTION Strip
!--------------------------------------------------------------------
   FUNCTION Copies(str, n)  Result (tr)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)   :: str
      Integer,          Intent(IN)   :: n
      CHARACTER(LEN=Len(str)*n)      :: tr
      Integer                        :: i
!
!     Returns a string with n concatenated copies of str.
!     Note: there is no space inserted between the copies
!
         tr = ''
         Do i = 1, n
            tr = str // tr
         EndDo
   End FUNCTION Copies
!--------------------------------------------------------------------
   FUNCTION Center(str, n, pad)  Result(tr)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      Integer,          Intent(IN)           :: n
      CHARACTER(LEN=1), Intent(IN), Optional :: pad
      CHARACTER(LEN=n)                       :: tr
      CHARACTER(LEN=1)                       :: padc
      Integer                                :: i, l
!
!     Returns a string of length n with the input string str centered in it
!     If n > length(str), str is padded with the character pad (default space)
!     If n < length(str), characters are removed from each end
!     If the total number of characters to be added or removed is odd, one character more is added
!        or removed from the right end than from the left end.
!
      l = Len(str)
      If ( n > l ) then
         If (Present(pad)) then
            padc = pad
         Else
            padc = ' '
         EndIf
         tr = Copies(padc, n)
         i = (n-l) / 2
         tr(i+1:i+l) = str
      ElseIf ( n < l ) then
         i = l-n /2
         tr = str(i+1:i+n)
      Else
         tr = str
      EndIf
 
   End FUNCTION Center
!--------------------------------------------------------------------
   FUNCTION Lower(str, start, length)  Result (tr)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      Integer,          Intent(IN), Optional :: start, length
      CHARACTER(LEN=Len(str))                :: tr
      Integer                                :: b, e, l
      Character(LEN=26), Parameter           :: low = 'aeioubcdfghjklmnpqrstvwxyz'
      Character(LEN=26), Parameter           :: upp = 'AEIOUBCDFGHJKLMNPQRSTVWXYZ'
!
!     translates to lower case the substring of str that starts at start
!     and has length characters
!     length defaults to the rest of the string.  length must be a non-negative integer
!     start defaults to 1.  start must be a postive integer.
!     If  length + start - 1  is greater than the length of str,  the substring is
!     assumed to be to the end of str, i.e., length is assumed to be length + start - 1
!     Examples:
!        Upper('Happy Camper')           returns   'HAPPY CAMPER'
!        Upper('fred', 2)                returns   'fRED'
!        Upper('fred', 1, 1)             returns   'Fred'
!        Upper('fred', 2, 10)            returns   'fRED'
!
      If (Present(start)) then
         b = start
      Else
         b = 1
      EndIf
      If (Present(length)) then
         l = length
      Else
         l = Len(str) - b + 1
      EndIf
      e = Min(Len(str), b + l - 1)
      tr = str
      tr(b:e) = Translate(tr(b:e), low, upp)
   End FUNCTION Lower
!--------------------------------------------------------------------
   FUNCTION Upper(str, start, length)  Result (tr)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      Integer,          Intent(IN), Optional :: start, length
      CHARACTER(LEN=Len(str))                :: tr
      Integer                                :: b, e, l
!
!     translates to upper case the substring of str that starts at start
!     and has length characters
!     length defaults to the rest of the string.  length must be a non-negative integer
!     start defaults to 1.  start must be a postive integer.
!     If  length + start - 1  is greater than the length of str,  the substring is
!     assumed to be to the end of str, i.e., length is assumed to be length + start - 1
!     Examples:
!        Upper('Happy Camper')           returns   'HAPPY CAMPER'
!        Upper('fred', 2)                returns   'fRED'
!        Upper('fred', 1, 1)             returns   'Fred'
!        Upper('fred', 2, 10)            returns   'fRED'
!
      If (Present(start)) then
         b = start
      Else
         b = 1
      EndIf
      If (Present(length)) then
         l = length
      Else
         l = Len(str) - b + 1
      EndIf
      e = Min(Len(str), b + l - 1)
      tr = str
      tr(b:e) = Translate(tr(b:e))
   End FUNCTION Upper
!--------------------------------------------------------------------
   FUNCTION Translate(str, tableout, tablein, pad)  Result (tr)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)           :: str
      CHARACTER(LEN=*), Intent(IN), Optional :: tableout, tablein
      CHARACTER(LEN=1), Intent(IN), Optional :: pad
      CHARACTER(LEN=Len(str))                :: tr
!
!     translates characters in str according to tables tablein and tableout
!       If a character of str is in tablein, it is changed to the corresponding
!       character in tableout; otherwise it is not changed.
!
!     If tablein and tableout are not specified, the characters of str are translated to
!     upper case
!
!     If Len(tableout) < Len(tablein), tableout is padded with the character pad
!     The default pad character is a blank.
!
!     If tablein is not specified, it is set to the ASCII character sequence
!     given by Achar(0) - Achar(255)
!
      CHARACTER(LEN=256)           :: in, out
      Integer                      :: nc, i, j
 
      If (Present(pad)) then
         Do i = 1, 256
            out(i:i) = pad
         EndDo
      Else
         out = ' '
      EndIf
 
      If ( .not.Present(tableout) .and. .not.Present(tablein) ) then
         in  = 'aeioubcdfghjklmnpqrstvwxyz'
         out = 'AEIOUBCDFGHJKLMNPQRSTVWXYZ'
         nc = 26
      Else
         If (Present(tableout)) out(1:Len(tableout)) = tableout
         If (Present(tablein)) then
            in = tablein
            nc = Len(tablein)
         Else
            Do i = 1, 256
               in(i:i) = AChar(i-1)
            EndDo
            nc = 256
         EndIf
      EndIf
      tr = str
      Do i = 1, Len(str)
         j = Index(in(1:nc), tr(i:i))
         If (j > 0) tr(i:i) = out(j:j)
      EndDo
   End FUNCTION Translate
!--------------------------------------------------------------------
   SUBROUTINE WordParseBl(LINE, NWORDS, WDS)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)    :: Line
      INTEGER,          Intent(OUT)   :: NWORDS
      CHARACTER(LEN=*), Dimension(:)  :: wds
!
!     returns NWORDS = number of blank delimited words in LINE
!         and these words in WDS(1:NWORDS)
!     If there are more words in LINE than is the dimension of WDS,
!         NWORDS is set to the dimension of WDS
!
      CHARACTER(LEN=1), Parameter     :: blank=' '
      Integer                         :: i, i1, ls, NWmax
      Character(Len=Len(Line)+1)      :: string
 
      wds(:) = blank
      NWORDS = 0
      NWmax  = Size(wds)
      If (NWmax .le. 0) Return
      String = Adjustl(Line) // blank
      ls = LEN_trim(String) + 1
      Do i1 = 1, ls
         i = Scan(String, blank)
         If (i > 1) then
            NWORDS = NWORDS + 1
            Wds(NWORDS) = String(1:i-1)
            String = Adjustl(String(i:ls))
            If (NWORDS .ge. NWmax) Exit
         ElseIf (i == 1) then
            String = String(2:ls)
         Else
            Exit
         EndIf
      EndDo
   END SUBROUTINE WordParseBl
!--------------------------------------------------------------------
   SUBROUTINE WordParseSp(LINE, NWORDS, WDS, SEP)
      IMPLICIT NONE
      CHARACTER(LEN=*), Intent(IN)                :: Line
      INTEGER,          Intent(OUT)               :: NWORDS
      CHARACTER(LEN=*), Intent(OUT), Dimension(:) :: wds
      CHARACTER(LEN=*), Intent(IN)                :: SEP
!
!     returns NWORDS = number of words in LINE
!           where words are delimited by any character in SEP
!         and these words in WDS(1:NWORDS)
!     If there are more words in LINE than is the dimension of WDS,
!         NWORDS is set to the dimension of WDS
!
      CHARACTER(LEN=1), Parameter     :: blank=' '
      Integer                         :: i, i1, ls, NWmax
      Character(Len=Len(Line)+1)      :: string
! print*, 'enter wordparses ', sep, ' ', Trim(line)
      wds(:) = blank
      NWORDS = 0
      NWmax  = Size(wds)
      If (NWmax .le. 0) Return
!      String = Adjustl(Line) // sep(1:1)
      String =         Line  // sep(1:1)
      ls = LEN(String)
      Do i1 = 1, ls
         i = Scan(String, sep)
! print*, 'wordparses scan ', Trim(string), i
         If (i > 1) then
            NWORDS = NWORDS + 1
            Wds(NWORDS) = String(1:i-1)
            String = Adjustl(String(i:ls))
            If (NWORDS .ge. NWmax) Exit
         ElseIf (i == 1) then
            String = String(2:ls)
         Else
            Exit
         EndIf
      EndDo
! print*, 'wordparses end ', nwords, (' '//Trim(wds(i)), i = 1, nwords)
   END SUBROUTINE WordParseSp
!--------------------------------------------------------------------
   FUNCTION IntegerWord(W)
      Logical IntegerWord
      CHARACTER(LEN=*), Intent(IN) :: W
!
!     returns  .TRUE.  if W is compatible with being an integer
!
      Character(Len=Len(W)+1)      :: s
 
      s = Adjustl(w)
      l = Len_Trim(s)
      If (s(1:1) == '+' .or. s(1:1) == '-') then
         i = 2
      Else
         i = 1
      EndIf
      IntegerWord = Verify(s(i:l),'0123456789') .eq. 0
   End FUNCTION IntegerWord
!--------------------------------------------------------------------
   FUNCTION NaturalWord(W)
      Logical NaturalWord
      CHARACTER(LEN=*), Intent(IN) :: W
!
!     returns  .TRUE.  if W is compatible with being a natural number,
!        i.e., unsigned  integer
!     N.B. 0 is regarded as a natural number, contrary to some conventions
!
      Character(Len=Len(W)+1)      :: s
 
      s = Adjustl(w)
      l = Len_Trim(s)
      NaturalWord = Verify(s(1:l),'0123456789') .eq. 0
   End FUNCTION NaturalWord
!--------------------------------------------------------------------
   FUNCTION RealWord(W)
      Logical RealWord
      CHARACTER(LEN=*), Intent(IN) :: W
!
!     returns  .TRUE.  if W is compatible with being a real
!
      Character(Len=Len(W)+1)      :: s
 
      s = Adjustl(w)
      l = Len_Trim(s)
      RealWord = IntegerWord(s(1:l))
      If (RealWord) Return
      If (s(1:1) == '+' .or. s(1:1) == '-') then
         i = 2
      Else
         i = 1
      EndIf
      ie = Index(s(1:l),'E')
      If (ie == 0) ie = Index(s(1:l),'D')
      If (ie == 0) ie = Index(s(1:l),'e')
      If (ie == 0) ie = Index(s(1:l),'d')
      If (ie == 0) then
         RealWord = Verify(s(i:l),'0123456789.') .eq. 0
      Else
         RealWord = Verify(s(i:ie-1),'0123456789.') .eq. 0  &
                   .and. IntegerWord(s(ie+1:l))
      EndIf
      If (RealWord) then
         If (ie == 0) then
            ie = l
         Else
            ie = ie - 1
         EndIf
!        check that not more than 1 decimal point
         RealWord = (Scan(s(1:ie), '.') == Scan(s(1:ie), '.', back=.true.))
      EndIf
   End FUNCTION RealWord
!--------------------------------------------------------------------
   FUNCTION WordFormatI(int, before)  Result(WF)
      Integer, Intent(IN)          :: int
      Integer, Intent(IN)          :: before
      Character(Len=Max(before,1)) :: WF
!
      Character(Len=30)            :: f
      Integer                      :: b
!
!     returns string of length before with character representation of int
!
      If (before .le. 0) then
         b = 1
      Else
         b = before
      EndIf
      Write(f,"(i30)") before
      f = "(I" // Trim(AdjustL(f)) // ")"
      Write(WF, f) int
   End FUNCTION WordFormatI
!--------------------------------------------------------------------
   FUNCTION WordFormatI1(int)  Result(WF)
      Integer, Intent(IN) :: int
      Character(Len=30)   :: WF, f
!
!     returns string with character representation of int
!
      Write(f, "(I0)") int
      WF = AdjustL(f)
   End FUNCTION WordFormatI1
!--------------------------------------------------------------------
   FUNCTION WordFormatR1(r)  Result(WF)
      Real, Intent(IN)  :: r
      Character(Len=30) :: WF, f
!
!     returns string with character representation of r
!
      If (r < 0.01 .or. r > 1000.) then
         Write(f, "(E30.12)") r
      Else
         Write(f, "(F30.12)") r
      EndIf
      WF = AdjustL(f)
   End FUNCTION WordFormatR1
!--------------------------------------------------------------------
   FUNCTION WordFormatD1(r)  Result(WF)
      DoublePrecision, Intent(IN) :: r
      Character(Len=30)           :: WF, f
!
!     returns string with character representation of r
!
      If (r < 0.01 .or. r > 1000.) then
         Write(f, "(E30.12)") r
      Else
         Write(f, "(F30.12)") r
      EndIf
      WF = AdjustL(f)
   End FUNCTION WordFormatD1
!--------------------------------------------------------------------
   FUNCTION WordFormatL(l)  Result(WF)
      Logical, Intent(IN) :: l
      Character(Len=1)    :: WF
!
!     returns string with character representation of l
!
      Write(WF, "(L1)") l
   End FUNCTION WordFormatL
!--------------------------------------------------------------------
   FUNCTION InsertWord(strin, strold, start)  Result(strnew)
   Implicit NONE
   Character(Len=*),  Intent(IN) :: strin, strold
   Integer, Optional, Intent(IN) :: start
   Character(Len=Len(strin)+Len(strold)+2) :: strnew
!
!  InsertWord(strin, strold [,start])
!   Returns a new string obtained from strold by
!      inserting strin, preceded and followed by a blank, in strold
!      after word number start.
!   The default value for start is 0, i.e., insert before the first word
!   If start is greater than the number of words in strold,
!      strin is added at the end
!
   Integer                       :: nw, is
 
   nw = Words(strold)
   If (nw == 0) then
      strnew = AdjustL(strin)
      Return
   EndIf
 
   If (Present(start)) then
      is = Min(start, nw)
   Else
      is = 0
   EndIf
 
   If (is <= 0) then
      strnew = Trim(AdjustL(strin)) // ' ' // AdjustL(strold)
   ElseIf (is == nw) then
      strnew = Trim(strold) // ' ' // AdjustL(strin)
   Else
      strnew = DelWord(strold, is + 1)
      strnew = Trim(strnew) // ' ' // AdjustL(strin)
      strnew = Trim(strnew) // ' ' // AdjustL(DelWord(strold, 1, is))
   EndIf
   Return
 
   End FUNCTION InsertWord
 
!--------------------------------------------------------------------
   Recursive FUNCTION Right(string, N, padchar)  Result(WN)
   Character(Len=*), Intent(IN) :: string
   Integer,          Intent(IN) :: N
   Character(Len=1), Optional   :: padchar
   Character(Len=Abs(N))        :: WN
!
!  returns right-most N characters of Trim(string) padded on left with padchar
!  default for padchar is a blank
!
!  In principle, N cannot be negative, but here use sign of N:
!     If N < 0, use the entire string rather than Trim(string)
!     e.g.,  Right('abcd  ',  3)  returns  'bcd'
!     e.g.,  Right('abcd  ', -3)  returns  'd  '
!
   CHARACTER(LEN=1), Parameter  :: blank=' '
   Character(Len=1)             :: pad
   Character(Len=Len(string))   :: str
   Integer                      :: nc, l
   If (N == 0) Return
   If (Present(padchar)) then
      pad = padchar
   Else
      pad = blank
   EndIf
   If (N > 0) then
      wn = Right(Trim(string), -N, pad)
      Return
   EndIf
 
   str = string
   l = Len(str)
   nc = Abs(N)
 
   If (nc == l) then
      WN = str
   ElseIf (nc < l) then
      WN = str(l-nc+1:)
   Else
      i = nc - l
      WN(i+1:nc) = str
      WN(1:i) = Repeat(pad, i)
   EndIf
 
   End FUNCTION Right
 
!--------------------------------------------------------------------
   Recursive FUNCTION Left(string, N, padchar)  Result(WN)
   Character(Len=*), Intent(IN) :: string
   Integer,          Intent(IN) :: N
   Character(Len=1), Optional   :: padchar
   Character(Len=Abs(N))        :: WN
!
!  returns left-most N characters of Trim(string) padded on right with padchar
!  default for padchar is a blank
!
!  In principle, N cannot be negative, but here use sign of N:
!     If N < 0, use the entire string rather than Trim(string)
!     e.g.,  Left('a ',  3, '%')  returns  'a%%'
!     e.g.,  Left('a ', -3, '%')  returns  'd %'
!
   CHARACTER(LEN=1), Parameter  :: blank=' '
   Character(Len=1)             :: pad
   Character(Len=Len(string))   :: str
   Integer                      :: nc, l
   If (N == 0) Return
   If (Present(padchar)) then
      pad = padchar
   Else
      pad = blank
   EndIf
   If (N > 0) then
      wn = Left(Trim(string), -N, pad)
      Return
   EndIf
 
   str = string
   l = Len(str)
   nc = Abs(N)
 
   If (nc == l) then
      WN = str
   ElseIf (nc < l) then
      WN = str(1:nc)
   Else
 
      WN(1:l) = str
      WN(l+1:nc) = Repeat(pad, nc - l)
   EndIf
 
   End FUNCTION Left
 
!--------------------------------------------------------------------
 
End Module WordPkg
 
!  PROGRAM TEST
!      use wordpkg
!      IMPLICIT NONE
!
!!       call t_wordparse
!!       call t_word
!!       call t_wordtype
!!       call t_wordindex
!!       call t_delword
!!       call t_translate
!!       call t_wordpos
!!       call t_copies
!!       call t_space
!        call t_insert
!
!  CONTAINS
!     subroutine t_insert
!      print *, "InsertWord('new1  new2', ' old') returns '", InsertWord('new1  new2', ' old'), "'"
!      print *, "InsertWord('n1 n2', ' old',  0) returns '", InsertWord('n1 n2', 'old',  0), "'"
!      print *, "InsertWord('n1 n2', ' old', -1) returns '", InsertWord('n1 n2', 'old', -1), "'"
!      print *, "InsertWord('n1 n2', ' old1  old2', 1) returns '", InsertWord('n1 n2', ' old1  old2', 1), "'"
!      print *, "InsertWord('n1 n2', ' old', 3) returns '", InsertWord('n1 n2', ' old', 3), "'"
!     end subroutine t_insert
!     subroutine t_copies
!      print *, "COPIES('az',3) returns '", COPIES('az',3), "'"
!      print *, "COPIES('',3)   returns '", COPIES('',3), "'"
!      print *, "COPIES('z',0)  returns '", COPIES('z',0), "'"
!      print *, "COPIES('',0)   returns '", COPIES('',0), "'"
!     end subroutine t_copies
!
!     subroutine t_space
!      character(Len=120) :: c
!      c =       SPACE(' Foo bar ')
!      print *, "SPACE(' Foo bar ')              returns '", Trim(c), "'"
!      c =       SPACE(' Foo  bar ')
!      print *, "SPACE(' Foo  bar ')             returns '", Trim(c), "'"
!      c =       SPACE(' Foo  bar bar2 ')
!      print *, "SPACE(' Foo  bar bar2 ')        returns '", Trim(c), "'"
!      c =       SPACE(' Foo bar ',2)
!      print *, "SPACE(' Foo bar ',2)            returns '", Trim(c), "'"
!      c =       SPACE(' Foo bar ', padchar='*')
!      print *, "SPACE(' Foo bar ', padchar='*') returns '", Trim(c), "'"
!      c =       SPACE('Foo bar',3, '-')
!      print *, "SPACE('Foo bar',3, '-')         returns '", Trim(c), "'"
!      c =       SPACE('Foo     bar',3, '-')
!      print *, "SPACE('Foo     bar',3, '-')     returns '", Trim(c), "'"
!      c =       SPACE('Foo bar', padchar='o')
!      print *, "SPACE('Foo bar', padchar='o')   returns '", Trim(c), "'"
!      c =       SPACE(' 3D-124 q=2 m=3-12   phi 5.764 +2.2 -3.3 +-2.96')
!      print *, "SPACE(' 3D-124 q=2 m=3-12   phi 5.764 +2.2 -3.3 +-2.96') returns '", Trim(c), "'"
!     end subroutine t_space
!
!     subroutine t_wordparse
!      INTEGER  NW
!      CHARACTER(Len=15) :: line1=' '
!      CHARACTER(Len=7)  :: line2=' aaa bc'
!      CHARACTER(Len=15) :: line3='aaa  bc   '
!      CHARACTER(Len=15) :: line4='  abcd   '
!      CHARACTER(Len=55) :: line5=' 1. 2.3e6 12345678 9 ab dd ff gg h z'
!      CHARACTER(Len=4), Dimension(8) :: w=(/ 'a','b','c','d','e','f','g','h'/)
!
!      PRINT *, WORDS(line1), line1
!      PRINT *, WORDS(line2), line2
!      PRINT *, WORDS(line3), line3
!      PRINT *, WORDS(line4), line4
!      PRINT *, WORDS(line5), line5
!      PRINT *,  w
!      nw=8
!      Call WordParse(line2,nw,w(1:4))
!      PRINT *,  line2, nw, w
!      Call WordParse(line1,nw,w(1:7))
!      PRINT *, line1, nw, w(1:nw)
!      Call WordParse(line3,nw,w)
!      PRINT *,  line3, nw, w(1:nw)
!      Call WordParse(line4,nw,w)
!      PRINT *,  line4, nw, w(1:nw)
!      Call WordParse(line5,nw,w)
!      PRINT *, line5, nw, w(1:nw)
!     END        subroutine t_wordparse
!
!     subroutine t_word
!         character(len=*), parameter :: str='  abcdefgh ijk lmn o pqr '
!         character(len=*), parameter :: sts='abcdefgh ijk lmn o pqr '
!         character(len=*), parameter :: stt=''
!         integer i
!
!       do i = 1,7
!         print*, word(str,i)
!       enddo
!       do i = 1,2
!         print*, word(sts,i)
!       enddo
!       do i = 1,2
!         print*, word(stt,i)
!       enddo
!     end     subroutine t_word
!     subroutine t_wordindex
!         character(len=*), parameter :: str='  abcdefgh ijk lmn o pqr '
!         character(len=*), parameter :: sts='abcdefgh   ijk lmn'
!         character(len=*), parameter :: stt=''
!         integer i
!
!       print*, str
!       do i = 0,6
!         print*, wordindex(str,i)
!       enddo
!       print*, sts
!       do i = 1,4
!         print*, wordindex(sts,i)
!       enddo
!       print*, stt
!       do i = 1,2
!         print*, wordindex(stt,i)
!       enddo
!     end     subroutine t_wordindex
!     subroutine t_wordpos
!         Integer :: i
!         i = WORDPOS('or not','to be or not to be')
!         print*, "WORDPOS('or not','to be or not to be') returns", i
!         i = WORDPOS('not to','to be or not to be')
!         print*, "WORDPOS('not to','to be or not to be') returns", i
!         i = WORDPOS('to be','to be or not to be')
!         print*, "WORDPOS('to be','to be or not to be') returns", i
!         i = WORDPOS('to be','to be or not to be',3)
!         print*, "WORDPOS('to be','to be or not to be',3) returns", i
!     end     subroutine t_wordpos
!     subroutine t_wordtype
!         character(len=*), parameter :: str='  -1.3 '
!         character(len=*), parameter :: sts='  22'
!         character(len=*), parameter :: stt='-2'
!         character(len=*), parameter :: stw='-2.2e-53'
!         character(len=*), parameter :: stx='-2e5'
!         character(len=*), parameter :: sty='-2 5'
!         character(len=*), parameter :: stz='-2a5'
!         print*, 'Real ?'
!         print*, str, realword(str)
!         print*, sts, realword(sts)
!         print*, stt, realword(stt)
!         print*, stw, realword(stw)
!         print*, stx, realword(stx)
!         print*, sty, realword(sty)
!         print*, stz, realword(stz)
!         print*, 'Integer ?'
!         print*, str, integerword(str)
!         print*, sts, integerword(sts)
!         print*, stt, integerword(stt)
!         print*, stw, integerword(stw)
!         print*, stx, integerword(stx)
!         print*, sty, integerword(sty)
!         print*, stz, integerword(stz)
!     end     subroutine t_wordtype
!     subroutine t_delword
!      Print*,'Testing DelWord'
!      Print*," DELWORD('This is a test',3) ", DELWORD('This is a test',3)
!      Print*," DELWORD('This is a test',2,1) ", DELWORD('This is a test',2,1)
!      Print*," DELWORD('This is a test',2,5) ", DELWORD('This is a test',2,5)
!      Print*," DELWORD('This is a test',1,3) ", DELWORD('This is a test',1,3)
!      Print*," DELWORD('This is a test',0) ", DELWORD('This is a test',0)
!     end subroutine t_delword
!     subroutine t_translate
!      character(len=5) t
!      Print*,'Testing Translate'
!      Print*," Translate('AcBz')           ", Translate('AcBz')
!      Print*," Translate('AcBz','$+','cz') ", Translate('AcBz','$+','cz')
!      Print*," Translate('AcBz','$+','cBz','*') ", Translate('AcBz','$+','cBz','*')
!      Print*," Translate('AcBz', ,'cBz','*') ", Translate('AcBz', tablein='cBz',pad='*')
!      t = achar(0)//achar(31)//achar(2)//achar(3)//achar(30)
!      Print*,"Translate(achar(0)//achar(31)//achar(2)//achar(3)/achar(30),'abcd',,'#') " &
!             , Translate(t, 'abcd', pad='#')
!     end subroutine t_translate
!  END PROGRAM TEST
