source/wham/src-M/misc.f

   1 C $Date: 1994/10/12 17:24:21 $
   2 C $Revision: 2.5 $
   3 C
   4 C
   5 C
   6       logical function find_arg(ipos,line,errflag)
   7       parameter (maxlen=80)
   8       character*80 line
   9       character*1 empty /' '/,equal /'='/
  10       logical errflag
  11 * This function returns .TRUE., if an argument follows keyword keywd; if so
  12 * IPOS will point to the first non-blank character of the argument. Returns
  13 * .FALSE., if no argument follows the keyword; in this case IPOS points
  14 * to the first non-blank character of the next keyword.
  15       do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
  16         ipos=ipos+1
  17       enddo
  18       errflag=.false.
  19       if (line(ipos:ipos).eq.equal) then
  20          find_arg=.true.
  21          ipos=ipos+1
  22          do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
  23            ipos=ipos+1
  24          enddo
  25          if (ipos.gt.maxlen) errflag=.true.
  26       else
  27          find_arg=.false.
  28       endif
  29       return
  30       end
  31       logical function find_group(iunit,jout,key1)
  32       character*(*) key1
  33       character*80 karta,ucase
  34       integer ilen
  35       external ilen
  36       logical lcom
  37       rewind (iunit)
  38       karta=' '
  39       ll=ilen(key1)
  40       do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta))
  41         read (iunit,'(a)',end=10) karta
  42       enddo
  43       write (jout,'(2a)') '> ',karta(1:78)
  44       find_group=.true.
  45       return
  46    10 find_group=.false.
  47       return
  48       end
  49       logical function iblnk(charc)
  50       character*1 charc
  51       integer n
  52       n = ichar(charc)
  53       iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ')
  54       return
  55       end
  56       integer function ilen(string)
  57       character*(*) string
  58       logical iblnk
  59
  60       ilen = len(string)
  61 1     if ( ilen .gt. 0 ) then
  62          if ( iblnk( string(ilen:ilen) ) ) then
  63             ilen = ilen - 1
  64             goto 1
  65          endif
  66       endif
  67       return
  68       end
  69       integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset)
  70       character*16 keywd,keywdset(1:nkey,0:nkey)
  71       character*16 ucase
  72       do i=1,narg
  73         if (ucase(keywd).eq.keywdset(i,ikey)) then
  74 * Match found
  75           in_keywd_set=i
  76           return
  77         endif
  78       enddo
  79 * No match to the allowed set of keywords if this point is reached.
  80       in_keywd_set=0
  81       return
  82       end
  83       character*(*) function lcase(string)
  84       integer i, k, idiff
  85       character*(*) string
  86       character*1 c
  87       character*40 chtmp
  88 c
  89       i = len(lcase)
  90       k = len(string)
  91       if (i .lt. k) then
  92          k = i
  93          if (string(k+1:) .ne. ' ') then
  94             chtmp = string
  95          endif
  96       endif
  97       idiff = ichar('a') - ichar('A')
  98       lcase = string
  99       do 99 i = 1, k
 100          c = string(i:i)
 101          if (lge(c,'A') .and. lle(c,'Z')) then
 102             lcase(i:i) = char(ichar(c) + idiff)
 103          endif
 104    99 continue
 105       return
 106       end
 107       logical function lcom(ipos,karta)
 108       character*80 karta
 109       character koment(2) /'!','#'/
 110       lcom=.false.
 111       do i=1,2
 112         if (karta(ipos:ipos).eq.koment(i)) lcom=.true.
 113       enddo
 114       return
 115       end
 116       logical function lower_case(ch)
 117       character*(*) ch
 118       lower_case=(ch.ge.'a' .and. ch.le.'z')
 119       return
 120       end
 121       subroutine mykey(line,keywd,ipos,blankline,errflag)
 122 * This subroutine seeks a non-empty substring keywd in the string LINE.
 123 * The substring begins with the first character different from blank and
 124 * "=" encountered right to the pointer IPOS (inclusively) and terminates
 125 * at the character left to the first blank or "=". When the subroutine is
 126 * exited, the pointer IPOS is moved to the position of the terminator in LINE.
 127 * The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains
 128 * only separators or the maximum length of the data line (80) has been reached.
 129 * The logical variable ERRFLAG is set at .TRUE. if the string
 130 * consists only from a "=".
 131       parameter (maxlen=80)
 132       character*1 empty /' '/,equal /'='/,comma /','/
 133       character*(*) keywd
 134       character*80 line
 135       logical blankline,errflag,lcom
 136       errflag=.false.
 137       do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen))
 138         ipos=ipos+1
 139       enddo
 140       if (ipos.gt.maxlen .or. lcom(ipos,line) ) then
 141 * At this point the rest of the input line turned out to contain only blanks
 142 * or to be commented out.
 143         blankline=.true.
 144         return
 145       endif
 146       blankline=.false.
 147       istart=ipos
 148 * Checks whether the current char is a separator.
 149       do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal
 150      & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen)
 151         ipos=ipos+1
 152       enddo
 153       iend=ipos-1
 154 * Error flag set to .true., if the length of the keyword was found less than 1.
 155       if (iend.lt.istart) then
 156         errflag=.true.
 157         return
 158       endif
 159       keywd=line(istart:iend)
 160       return
 161       end
 162       subroutine numstr(inum,numm)
 163       character*10 huj /'0123456789'/
 164       character*(*) numm
 165       inumm=inum
 166       inum1=inumm/10
 167       inum2=inumm-10*inum1
 168       inumm=inum1
 169       numm(3:3)=huj(inum2+1:inum2+1)
 170       inum1=inumm/10
 171       inum2=inumm-10*inum1
 172       inumm=inum1
 173       numm(2:2)=huj(inum2+1:inum2+1)
 174       inum1=inumm/10
 175       inum2=inumm-10*inum1
 176       inumm=inum1
 177       numm(1:1)=huj(inum2+1:inum2+1)
 178       return
 179       end
 180       character*(*) function ucase(string)
 181       integer i, k, idiff
 182       character*(*) string
 183       character*1 c
 184       character*40 chtmp
 185 c
 186       i = len(ucase)
 187       k = len(string)
 188       if (i .lt. k) then
 189          k = i
 190          if (string(k+1:) .ne. ' ') then
 191             chtmp = string
 192          endif
 193       endif
 194       idiff = ichar('a') - ichar('A')
 195       ucase = string
 196       do 99 i = 1, k
 197          c = string(i:i)
 198          if (lge(c,'a') .and. lle(c,'z')) then
 199             ucase(i:i) = char(ichar(c) - idiff)
 200          endif
 201    99 continue
 202       return
 203       end