+++ /dev/null
-C $Date: 1994/10/12 17:24:21 $
-C $Revision: 2.5 $
-C
-C
-C
- logical function find_arg(ipos,line,errflag)
- parameter (maxlen=80)
- character*80 line
- character*1 empty /' '/,equal /'='/
- logical errflag
-* This function returns .TRUE., if an argument follows keyword keywd; if so
-* IPOS will point to the first non-blank character of the argument. Returns
-* .FALSE., if no argument follows the keyword; in this case IPOS points
-* to the first non-blank character of the next keyword.
- do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
- ipos=ipos+1
- enddo
- errflag=.false.
- if (line(ipos:ipos).eq.equal) then
- find_arg=.true.
- ipos=ipos+1
- do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
- ipos=ipos+1
- enddo
- if (ipos.gt.maxlen) errflag=.true.
- else
- find_arg=.false.
- endif
- return
- end
- logical function find_group(iunit,jout,key1)
- character*(*) key1
- character*80 karta,ucase
- integer ilen
- external ilen
- logical lcom
- rewind (iunit)
- karta=' '
- ll=ilen(key1)
- do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta))
- read (iunit,'(a)',end=10) karta
- enddo
- write (jout,'(2a)') '> ',karta(1:78)
- find_group=.true.
- return
- 10 find_group=.false.
- return
- end
- logical function iblnk(charc)
- character*1 charc
- integer n
- n = ichar(charc)
- iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ')
- return
- end
- integer function ilen(string)
- character*(*) string
- logical iblnk
-
- ilen = len(string)
-1 if ( ilen .gt. 0 ) then
- if ( iblnk( string(ilen:ilen) ) ) then
- ilen = ilen - 1
- goto 1
- endif
- endif
- return
- end
- integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset)
- character*16 keywd,keywdset(1:nkey,0:nkey)
- character*16 ucase
- do i=1,narg
- if (ucase(keywd).eq.keywdset(i,ikey)) then
-* Match found
- in_keywd_set=i
- return
- endif
- enddo
-* No match to the allowed set of keywords if this point is reached.
- in_keywd_set=0
- return
- end
- character*(*) function lcase(string)
- integer i, k, idiff
- character*(*) string
- character*1 c
- character*40 chtmp
-c
- i = len(lcase)
- k = len(string)
- if (i .lt. k) then
- k = i
- if (string(k+1:) .ne. ' ') then
- chtmp = string
- endif
- endif
- idiff = ichar('a') - ichar('A')
- lcase = string
- do 99 i = 1, k
- c = string(i:i)
- if (lge(c,'A') .and. lle(c,'Z')) then
- lcase(i:i) = char(ichar(c) + idiff)
- endif
- 99 continue
- return
- end
- logical function lcom(ipos,karta)
- character*80 karta
- character koment(2) /'!','#'/
- lcom=.false.
- do i=1,2
- if (karta(ipos:ipos).eq.koment(i)) lcom=.true.
- enddo
- return
- end
- logical function lower_case(ch)
- character*(*) ch
- lower_case=(ch.ge.'a' .and. ch.le.'z')
- return
- end
- subroutine mykey(line,keywd,ipos,blankline,errflag)
-* This subroutine seeks a non-empty substring keywd in the string LINE.
-* The substring begins with the first character different from blank and
-* "=" encountered right to the pointer IPOS (inclusively) and terminates
-* at the character left to the first blank or "=". When the subroutine is
-* exited, the pointer IPOS is moved to the position of the terminator in LINE.
-* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains
-* only separators or the maximum length of the data line (80) has been reached.
-* The logical variable ERRFLAG is set at .TRUE. if the string
-* consists only from a "=".
- parameter (maxlen=80)
- character*1 empty /' '/,equal /'='/,comma /','/
- character*(*) keywd
- character*80 line
- logical blankline,errflag,lcom
- errflag=.false.
- do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen))
- ipos=ipos+1
- enddo
- if (ipos.gt.maxlen .or. lcom(ipos,line) ) then
-* At this point the rest of the input line turned out to contain only blanks
-* or to be commented out.
- blankline=.true.
- return
- endif
- blankline=.false.
- istart=ipos
-* Checks whether the current char is a separator.
- do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal
- & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen)
- ipos=ipos+1
- enddo
- iend=ipos-1
-* Error flag set to .true., if the length of the keyword was found less than 1.
- if (iend.lt.istart) then
- errflag=.true.
- return
- endif
- keywd=line(istart:iend)
- return
- end
- subroutine numstr(inum,numm)
- character*10 huj /'0123456789'/
- character*(*) numm
- inumm=inum
- inum1=inumm/10
- inum2=inumm-10*inum1
- inumm=inum1
- numm(3:3)=huj(inum2+1:inum2+1)
- inum1=inumm/10
- inum2=inumm-10*inum1
- inumm=inum1
- numm(2:2)=huj(inum2+1:inum2+1)
- inum1=inumm/10
- inum2=inumm-10*inum1
- inumm=inum1
- numm(1:1)=huj(inum2+1:inum2+1)
- return
- end
- character*(*) function ucase(string)
- integer i, k, idiff
- character*(*) string
- character*1 c
- character*40 chtmp
-c
- i = len(ucase)
- k = len(string)
- if (i .lt. k) then
- k = i
- if (string(k+1:) .ne. ' ') then
- chtmp = string
- endif
- endif
- idiff = ichar('a') - ichar('A')
- ucase = string
- do 99 i = 1, k
- c = string(i:i)
- if (lge(c,'a') .and. lle(c,'z')) then
- ucase(i:i) = char(ichar(c) - idiff)
- endif
- 99 continue
- return
- end
projects / unres.git / blobdiff