!---------------------------------------------------------------------------- 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