527 lines
13 KiB
Fortran
527 lines
13 KiB
Fortran
!----------------------------------------------------------------------------
|
|
subroutine capital(in,str,lauf,mmax,sl)
|
|
implicit none
|
|
integer mmax,lauf,i,j,sl
|
|
character in(mmax)*(*), str*(*)
|
|
|
|
if (str.eq.'') return
|
|
|
|
j=0
|
|
do i=1,sl
|
|
if (str(i:i).ne.' ') then
|
|
j=i-1
|
|
goto 10
|
|
endif
|
|
enddo
|
|
10 do i=1,sl-j
|
|
str(i:i)=str(i+j:i+j)
|
|
enddo
|
|
do i=sl-j+1,sl
|
|
str(i:i)=' '
|
|
enddo
|
|
|
|
if (str(1:1).eq.'!') return
|
|
|
|
lauf=lauf+1
|
|
do i=1,sl
|
|
in(lauf)(i:i)=str(i:i)
|
|
if (str(i:i).eq.'a') in(lauf)(i:i)='A'
|
|
if (str(i:i).eq.'b') in(lauf)(i:i)='B'
|
|
if (str(i:i).eq.'c') in(lauf)(i:i)='C'
|
|
if (str(i:i).eq.'d') in(lauf)(i:i)='D'
|
|
if (str(i:i).eq.'e') in(lauf)(i:i)='E'
|
|
if (str(i:i).eq.'f') in(lauf)(i:i)='F'
|
|
if (str(i:i).eq.'g') in(lauf)(i:i)='G'
|
|
if (str(i:i).eq.'h') in(lauf)(i:i)='H'
|
|
if (str(i:i).eq.'i') in(lauf)(i:i)='I'
|
|
if (str(i:i).eq.'j') in(lauf)(i:i)='J'
|
|
if (str(i:i).eq.'k') in(lauf)(i:i)='K'
|
|
if (str(i:i).eq.'l') in(lauf)(i:i)='L'
|
|
if (str(i:i).eq.'m') in(lauf)(i:i)='M'
|
|
if (str(i:i).eq.'n') in(lauf)(i:i)='N'
|
|
if (str(i:i).eq.'o') in(lauf)(i:i)='O'
|
|
if (str(i:i).eq.'p') in(lauf)(i:i)='P'
|
|
if (str(i:i).eq.'q') in(lauf)(i:i)='Q'
|
|
if (str(i:i).eq.'r') in(lauf)(i:i)='R'
|
|
if (str(i:i).eq.'s') in(lauf)(i:i)='S'
|
|
if (str(i:i).eq.'t') in(lauf)(i:i)='T'
|
|
if (str(i:i).eq.'u') in(lauf)(i:i)='U'
|
|
if (str(i:i).eq.'v') in(lauf)(i:i)='V'
|
|
if (str(i:i).eq.'w') in(lauf)(i:i)='W'
|
|
if (str(i:i).eq.'x') in(lauf)(i:i)='X'
|
|
if (str(i:i).eq.'y') in(lauf)(i:i)='Y'
|
|
if (str(i:i).eq.'z') in(lauf)(i:i)='Z'
|
|
C..... Addition of the first if-loop
|
|
if (i-3.gt.0) then
|
|
if (in(lauf)(i-3:i).eq.'CHK:') then
|
|
in(lauf)(i+1:sl)=str(i+1:sl)
|
|
return
|
|
endif
|
|
endif
|
|
! if (i+3.le.sl) then
|
|
! if (in(lauf)(i:i+3).eq.'CHK:') then
|
|
! in(lauf)(i+1:sl)=str(i+1:sl)
|
|
! return
|
|
! endif
|
|
! endif
|
|
enddo
|
|
|
|
end
|
|
|
|
!-----------------------------------------------------------------------
|
|
subroutine lcap(str,n)
|
|
implicit none
|
|
integer i, n
|
|
character str*(*), dum*750
|
|
|
|
dum=''
|
|
do i=1,n
|
|
dum(i:i)=str(i:i)
|
|
if (str(i:i).eq.'a') dum(i:i)='A'
|
|
if (str(i:i).eq.'b') dum(i:i)='B'
|
|
if (str(i:i).eq.'c') dum(i:i)='C'
|
|
if (str(i:i).eq.'d') dum(i:i)='D'
|
|
if (str(i:i).eq.'e') dum(i:i)='E'
|
|
if (str(i:i).eq.'f') dum(i:i)='F'
|
|
if (str(i:i).eq.'g') dum(i:i)='G'
|
|
if (str(i:i).eq.'h') dum(i:i)='H'
|
|
if (str(i:i).eq.'i') dum(i:i)='I'
|
|
if (str(i:i).eq.'j') dum(i:i)='J'
|
|
if (str(i:i).eq.'k') dum(i:i)='K'
|
|
if (str(i:i).eq.'l') dum(i:i)='L'
|
|
if (str(i:i).eq.'m') dum(i:i)='M'
|
|
if (str(i:i).eq.'n') dum(i:i)='N'
|
|
if (str(i:i).eq.'o') dum(i:i)='O'
|
|
if (str(i:i).eq.'p') dum(i:i)='P'
|
|
if (str(i:i).eq.'q') dum(i:i)='Q'
|
|
if (str(i:i).eq.'r') dum(i:i)='R'
|
|
if (str(i:i).eq.'s') dum(i:i)='S'
|
|
if (str(i:i).eq.'t') dum(i:i)='T'
|
|
if (str(i:i).eq.'u') dum(i:i)='U'
|
|
if (str(i:i).eq.'v') dum(i:i)='V'
|
|
if (str(i:i).eq.'w') dum(i:i)='W'
|
|
if (str(i:i).eq.'x') dum(i:i)='X'
|
|
if (str(i:i).eq.'y') dum(i:i)='Y'
|
|
if (str(i:i).eq.'z') dum(i:i)='Z'
|
|
enddo
|
|
str(1:n)=dum(1:n)
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
! function to test how many entries are on one line:
|
|
function clen(str,sl)
|
|
implicit none
|
|
integer clen, i, j, sl
|
|
character str*(sl)
|
|
|
|
clen=0
|
|
j=0
|
|
do i=sl,1,-1
|
|
if ((str(i:i).ne.' ').and.(j.eq.0)) then
|
|
clen=clen+1
|
|
j=1
|
|
endif
|
|
if (str(i:i).eq.' ') j=0
|
|
enddo
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
logical function isnumeral(char)
|
|
implicit none
|
|
! Check whether character CHAR is a numeral.
|
|
|
|
character char
|
|
|
|
character numerals(10)
|
|
parameter (numerals = ['0','1','2','3','4','5','6','7','8','9'])
|
|
|
|
isnumeral=any(numerals.eq.char)
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
logical function iswhitespace(char)
|
|
implicit none
|
|
! Check whether CHAR is tab or spc character
|
|
|
|
character char
|
|
|
|
character whitespace(2)
|
|
parameter (whitespace = [' ', ' '])
|
|
|
|
iswhitespace=any(whitespace.eq.char)
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine trimnum(string,outstr,str_len)
|
|
implicit none
|
|
! Extract numbers in STRING as a space separated list in OUTSTR.
|
|
|
|
integer str_len
|
|
character*(str_len) string
|
|
character*(str_len) outstr
|
|
|
|
integer length
|
|
logical foundnum
|
|
|
|
integer k
|
|
|
|
logical isnumeral
|
|
|
|
length=len_trim(string)
|
|
foundnum=.false.
|
|
|
|
outstr=' '
|
|
|
|
do k=1,length
|
|
if (isnumeral(string(k:k))) then
|
|
if (foundnum) then
|
|
outstr = trim(outstr) // string(k:k)
|
|
else if (len_trim(outstr).ne.0) then
|
|
outstr = trim(outstr) // ' ' // string(k:k)
|
|
foundnum=.true.
|
|
else
|
|
outstr = trim(outstr) // string(k:k)
|
|
foundnum=.true.
|
|
endif
|
|
else
|
|
foundnum=.false.
|
|
endif
|
|
enddo
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine strip_string(string,stripped,str_len)
|
|
implicit none
|
|
! Strip lefthand whitespace of STRING as well as excessive
|
|
! whitespace and save to STRIPPED.
|
|
! Example:
|
|
! " the quick brown fox" -> "the quick brown fox"
|
|
|
|
integer str_len
|
|
character*(str_len) string,stripped
|
|
|
|
character char
|
|
logical spaced
|
|
|
|
logical iswhitespace
|
|
|
|
integer k, trimpos
|
|
|
|
stripped=' '
|
|
trimpos=1
|
|
|
|
! spaced indicates whether if a space is found it is the first
|
|
! (separating the word from the next) or redundant
|
|
spaced=.true.
|
|
|
|
do k=1,len_trim(string)
|
|
char=string(k:k)
|
|
if (.not.iswhitespace(char)) then
|
|
spaced=.false.
|
|
else if (.not.spaced) then
|
|
! replace TAB characters if present
|
|
char=' '
|
|
spaced=.true.
|
|
else
|
|
! ignore redundant spaces
|
|
cycle
|
|
endif
|
|
stripped(trimpos:trimpos)=char
|
|
trimpos=trimpos+1
|
|
enddo
|
|
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine nth_word(string,word,n,str_len)
|
|
implicit none
|
|
! If STRING is a space separated list of words, return the Nth word.
|
|
|
|
integer str_len
|
|
character*(str_len) string,word
|
|
integer n
|
|
|
|
character*(str_len) strip
|
|
integer wc
|
|
|
|
logical iswhitespace
|
|
|
|
integer k,j
|
|
|
|
call strip_string(string,strip,str_len)
|
|
|
|
word=' '
|
|
wc=1
|
|
|
|
! find the word
|
|
do k=1,len_trim(strip)
|
|
if (wc.eq.n) exit
|
|
if (iswhitespace(strip(k:k))) then
|
|
wc=wc+1
|
|
endif
|
|
enddo
|
|
do j=k,len_trim(strip)
|
|
if (iswhitespace(strip(j:j))) exit
|
|
word = trim(word) // strip(j:j)
|
|
enddo
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine count_words(string,wordcount,str_len)
|
|
implicit none
|
|
! If STRING is a space separated list of words, return the Nth word.
|
|
|
|
integer str_len
|
|
character*(str_len) string
|
|
integer wordcount
|
|
|
|
character*(str_len) strip
|
|
integer wc
|
|
|
|
logical iswhitespace
|
|
|
|
integer k
|
|
|
|
call strip_string(string,strip,str_len)
|
|
|
|
if (len_trim(strip).gt.0) then
|
|
wc=1
|
|
else
|
|
wordcount=0
|
|
return
|
|
endif
|
|
|
|
! find the word
|
|
do k=1,len_trim(strip)
|
|
if (iswhitespace(strip(k:k))) then
|
|
wc=wc+1
|
|
endif
|
|
enddo
|
|
wordcount=wc
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine upcase(string,upstring,str_len)
|
|
implicit none
|
|
! Transform arbitrary string to uppercase and save to upstring
|
|
|
|
integer str_len
|
|
character*(str_len) string,upstring
|
|
|
|
integer j
|
|
|
|
upstring=' '
|
|
|
|
do j=1,len_trim(string)
|
|
select case (string(j:j))
|
|
case ('a')
|
|
upstring(j:j)= 'A'
|
|
case ('b')
|
|
upstring(j:j)= 'B'
|
|
case ('c')
|
|
upstring(j:j)= 'C'
|
|
case ('d')
|
|
upstring(j:j)= 'D'
|
|
case ('e')
|
|
upstring(j:j)= 'E'
|
|
case ('f')
|
|
upstring(j:j)= 'F'
|
|
case ('g')
|
|
upstring(j:j)= 'G'
|
|
case ('h')
|
|
upstring(j:j)= 'H'
|
|
case ('i')
|
|
upstring(j:j)= 'I'
|
|
case ('j')
|
|
upstring(j:j)= 'J'
|
|
case ('k')
|
|
upstring(j:j)= 'K'
|
|
case ('l')
|
|
upstring(j:j)= 'L'
|
|
case ('m')
|
|
upstring(j:j)= 'M'
|
|
case ('n')
|
|
upstring(j:j)= 'N'
|
|
case ('o')
|
|
upstring(j:j)= 'O'
|
|
case ('p')
|
|
upstring(j:j)= 'P'
|
|
case ('q')
|
|
upstring(j:j)= 'Q'
|
|
case ('r')
|
|
upstring(j:j)= 'R'
|
|
case ('s')
|
|
upstring(j:j)= 'S'
|
|
case ('t')
|
|
upstring(j:j)= 'T'
|
|
case ('u')
|
|
upstring(j:j)= 'U'
|
|
case ('v')
|
|
upstring(j:j)= 'V'
|
|
case ('w')
|
|
upstring(j:j)= 'W'
|
|
case ('x')
|
|
upstring(j:j)= 'X'
|
|
case ('y')
|
|
upstring(j:j)= 'Y'
|
|
case ('z')
|
|
upstring(j:j)= 'Z'
|
|
case default
|
|
upstring(j:j)=string(j:j)
|
|
end select
|
|
enddo
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
subroutine downcase(string,downstring,str_len)
|
|
implicit none
|
|
! Transform arbitrary string to downcase and save to downstring
|
|
|
|
integer str_len
|
|
character*(str_len) string,downstring
|
|
|
|
integer j
|
|
|
|
downstring=' '
|
|
|
|
do j=1,len_trim(string)
|
|
select case (string(j:j))
|
|
case ('A')
|
|
downstring(j:j)= 'a'
|
|
case ('B')
|
|
downstring(j:j)= 'b'
|
|
case ('C')
|
|
downstring(j:j)= 'c'
|
|
case ('D')
|
|
downstring(j:j)= 'd'
|
|
case ('E')
|
|
downstring(j:j)= 'e'
|
|
case ('F')
|
|
downstring(j:j)= 'f'
|
|
case ('G')
|
|
downstring(j:j)= 'g'
|
|
case ('H')
|
|
downstring(j:j)= 'h'
|
|
case ('I')
|
|
downstring(j:j)= 'i'
|
|
case ('J')
|
|
downstring(j:j)= 'j'
|
|
case ('K')
|
|
downstring(j:j)= 'k'
|
|
case ('L')
|
|
downstring(j:j)= 'l'
|
|
case ('M')
|
|
downstring(j:j)= 'm'
|
|
case ('N')
|
|
downstring(j:j)= 'n'
|
|
case ('O')
|
|
downstring(j:j)= 'o'
|
|
case ('P')
|
|
downstring(j:j)= 'p'
|
|
case ('Q')
|
|
downstring(j:j)= 'q'
|
|
case ('R')
|
|
downstring(j:j)= 'r'
|
|
case ('S')
|
|
downstring(j:j)= 's'
|
|
case ('T')
|
|
downstring(j:j)= 't'
|
|
case ('U')
|
|
downstring(j:j)= 'u'
|
|
case ('V')
|
|
downstring(j:j)= 'v'
|
|
case ('W')
|
|
downstring(j:j)= 'w'
|
|
case ('X')
|
|
downstring(j:j)= 'x'
|
|
case ('Y')
|
|
downstring(j:j)= 'y'
|
|
case ('Z')
|
|
downstring(j:j)= 'z'
|
|
case default
|
|
downstring(j:j)=string(j:j)
|
|
end select
|
|
enddo
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
character*16 function int2string(int)
|
|
implicit none
|
|
! Convert integer to string of length 16.
|
|
|
|
integer int
|
|
character*16 istr
|
|
|
|
|
|
istr=' '
|
|
write(istr,*) int
|
|
|
|
do while (istr(1:1).eq.' ')
|
|
istr(1:16) = istr(2:16) // ' '
|
|
enddo
|
|
|
|
int2string=istr
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
character*16 function dble2string(dble)
|
|
implicit none
|
|
! Convert double precision float to string of length 16.
|
|
|
|
double precision dble
|
|
character*16 dstr
|
|
|
|
|
|
dstr=' '
|
|
write(dstr,'(ES16.9)') dble
|
|
|
|
if (dstr(1:1).eq.' ') then
|
|
dstr(1:16) = dstr(2:16) // ' '
|
|
endif
|
|
|
|
dble2string=dstr
|
|
|
|
end
|
|
|
|
!--------------------------------------------------------------------------
|
|
|
|
character*16 function shortdble2string(dble)
|
|
implicit none
|
|
! Convert double precision float to string of length 16 using a
|
|
! shortened format
|
|
|
|
double precision dble
|
|
character*16 dstr
|
|
|
|
|
|
dstr=' '
|
|
write(dstr,'(ES11.2)') dble
|
|
|
|
if (dstr(1:1).eq.' ') then
|
|
dstr(1:16) = dstr(2:16) // ' '
|
|
endif
|
|
|
|
shortdble2string=dstr
|
|
|
|
end
|