rm uscdiff
[unres.git] / source / cluster / 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