! -----------------------------------------------
MODULE String_Functions  ! by David Frank  dave_frank@hotmail.com
                         ! http://home.earthlink.net/~dave_gemini/strings.f90

! Copy (generic) char array to string or string to char array
! Clen           get len of string,  C or blank terminated
! Ctrim          truncate string,    C or blank terminated
! Count_Items    in string that are blank or comma separated
! Extract_Chars  e.g. sex = extract_chars(string,' aeiou'C)
! Reduce_Blanks  in string to 1 blank between items, 0 or 1 trailing blank at end
! Replace_Txt    in string with replacement text arg
! Tally          occurances in string of text arg
! Translate      text arg via indexed code table
! Upper/Lower    case the text arg

INTERFACE Copy    ! generic
   MODULE PROCEDURE copy_a2s, copy_s2a
END INTERFACE Copy

CONTAINS
! ------------------------
FUNCTION Copy_a2s(a)  RESULT (s)    ! copy char array to string
CHARACTER :: a(:)
CHARACTER(SIZE(a)) :: s
INTEGER :: i
DO i = 1,SIZE(a)
   s(i:i) = a(i)
END DO
END FUNCTION Copy_a2s

! ------------------------
FUNCTION Copy_s2a(s)  RESULT (a)   ! copy string to char array
CHARACTER(*) :: s
CHARACTER :: a(LEN(s))
INTEGER :: i
DO i = 1,LEN(s)
   a(i) = s(i:i)
END DO
END FUNCTION Copy_s2a

! ------------------------
PURE INTEGER FUNCTION Clen(s)    ! get len of string  (C or blank terminated)
CHARACTER(*),INTENT(IN) :: s
Clen = INDEX(s,char(0))-1
IF (Clen == -1) Clen = LEN_TRIM(s)  ! not C string, Ctrim == TRIM
END FUNCTION Clen

! ----------------
FUNCTION Ctrim(s1)  RESULT(s2)   ! trim a string  (C or blank terminated)
CHARACTER(*),INTENT(IN) :: s1
CHARACTER(Clen(s1)) :: s2  ! set output length to 1st null -1 or last char
s2 = s1
END FUNCTION Ctrim

! --------------------
INTEGER FUNCTION Count_Items(s)  ! in string that are blank or comma separated
CHARACTER(*) :: s
INTEGER :: i
Count_Items = COUNT( (/ LEN_TRIM(s) > 0, &
              (s(i:i)/=' '.AND.s(i:i)/=',' .AND. &
               s(i+1:i+1)==' '.OR.s(i+1:i+1)==',', i=1,LEN_TRIM(s)-1) /) )

END FUNCTION Count_Items

! -------------------------
FUNCTION Extract_Chars(s,v)   RESULT (sex)
CHARACTER(*) :: s, v
CHARACTER(LEN(s)) :: sex
CHARACTER :: as(LEN(s)), av(LEN(v))
INTEGER :: i
LOGICAL :: mask(LEN(s))

mask = .FALSE.
as = Copy(s) ; av = Copy(v)
FORALL (i=1:size(as), ANY(as(i)==av)) mask(i) = .TRUE.
sex = Copy(PACK(as,mask,SPREAD(' ',1,LEN(s))))
END FUNCTION Extract_Chars

! --------------------
FUNCTION Reduce_Blanks(line)  RESULT (outline)
CHARACTER(*)         :: line
CHARACTER(LEN(line)) :: outline
CHARACTER            :: a(0:len(line)), pad(len(line))
INTEGER              :: n

n = len(line)-1     ;  pad = char(0)
a(1:) = Copy(line)  ;  a(0) = '?'     ! ensure col.1 is output

outline = Copy( PACK( a(1:), a(1:) /= ' ' .OR. a(:n) /= ' ',pad) )

END FUNCTION Reduce_Blanks

! ------------------
FUNCTION Replace_Txt (line,txt,rep)  RESULT (outline)
CHARACTER(*)         :: line, txt, rep
CHARACTER(LEN(line)+200) :: outline   ! allot extra len
CHARACTER            :: ch
INTEGER              :: i, n, lline, ltxt, lrep

lline = LEN(line) ; ltxt = LEN(txt)-1 ; lrep = LEN(rep)-1
i = 0 ; n = 0
DO ; i = i+1 ; IF (i > lline) EXIT  ! eol
   ch = line(i:i) ; n = n+1 ; outline(n:n) = ch  ! copy in/out
   IF (ch /= txt(1:1) ) CYCLE
   IF (line(i:i+ltxt) == txt ) THEN  ! replace txt with rep
      outline(n:n+lrep) = rep
      n = n+lrep ; i = i+ltxt  ! advance in/out indices
   END IF
END DO
outline(n+1:) = ' '    ! trailing blanks pad
END FUNCTION Replace_Txt

! --------------------
INTEGER FUNCTION Tally (line,s)
CHARACTER(*) :: line, s
INTEGER :: i

Tally = COUNT( (/ (line(i:i+LEN(s)-1) == s, i = 1,LEN(line)-LEN(s)+1) /) )
END FUNCTION Tally

! ---------------------------------
FUNCTION Translate(s1,codes)  RESULT (s2)
CHARACTER(*)       :: s1, codes(2)
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER            :: i, j

DO i = 1,LEN(s1)
   ch = s1(i:i)
   j = INDEX(codes(1),ch) ; IF (j > 0) ch = codes(2)(j:j)
   s2(i:i) = ch
END DO
END FUNCTION Translate

! ---------------------------------
FUNCTION Upper(s1)  RESULT (s2)
CHARACTER(*)       :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER,PARAMETER  :: DUC = ICHAR('A') - ICHAR('a')
INTEGER            :: i

DO i = 1,LEN(s1)
   ch = s1(i:i)
   IF (ch >= 'a'.AND.ch <= 'z') ch = CHAR(ICHAR(ch)+DUC)
   s2(i:i) = ch
END DO
END FUNCTION Upper

! ---------------------------------
FUNCTION Lower(s1)  RESULT (s2)
CHARACTER(*)       :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER,PARAMETER  :: DUC = ICHAR('A') - ICHAR('a')
INTEGER            :: i

DO i = 1,LEN(s1)
   ch = s1(i:i)
   IF (ch >= 'A'.AND.ch <= 'Z') ch = CHAR(ICHAR(ch)-DUC)
   s2(i:i) = ch
END DO
END FUNCTION Lower

END MODULE String_Functions

! by David Frank
!include 'strings.f90'   !
! http://home.earthlink.net/~dave_gemini/strings.f90
! ----------------------------------
program extract_chars_from_string  ! include trailing blanks
use string_functions
character(80) :: sex, string = ' the quick brown FOX  ' //char(0)

sex = extract_chars( string, ' AEIOUaeiou'//char(0) )

write (*,*) '|',ctrim(sex),'|'  ! outputs | e ui o O  |

end program