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