c----------------------------------------------------------------setcst
       subroutine setcst
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To set consats.                                             c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
       ipp(1)=4
       ipp(2)=8
       ipp(3)=1
c      mtot=100000
       numa=0
       next=1
c      idir=mtot
       ntm=6
       ntr=5
       nin=1
       not=2
       nsp=3
       nfl=4
       nt7=7
       nt8=8
       nt9=9
       nt10=10
       nt11=11
       nt12=12
       nt13=13
       nt14=14
       nt15=15
       nt16=16
       nt17=17
       nt18=18
       nt19=19
c
       return
       end
c-----------------------------------------------------------------upper
       subroutine upper
c---------------------------------------------------------------------c
c purpose:                                                            c
c         This routine converts lower case to upper case              c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 line,sp,sc
c
       common /cline/line(160)
       common /iline/ii
c
       data sp/' '/,sc/':'/
c
c------check end of line and covert to upper case
c
       isp=ichar(sp)
       do 80 i=1,ii
       if(line(i).eq.sc) goto 90
       nn=ichar(line(i))
       if(nn.gt.96) line(i)=char(nn-isp)
 80    continue
c
c------remove blanks at end of line
c
       jj=0
       do 50 j=1,ii
             if(line(j).ne.sp) goto 70
             jj=jj+1
  50   continue
  70   if(jj.eq.0) goto 85
       if(jj.eq.ii) goto 100
       kk=jj+1
       do 60 j=1,ii-jj
             line(j)=line(kk)
             kk=kk+1
 60    continue
       ii=ii-jj-1
 85    if(line(ii).ne.sp) goto 95
       ii=ii-1
       goto 85
 90    ii=i
c
 95    return
 100   ii=1
       return
       end
c----------------------------------------------------------------bcmane
       subroutine bcname
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To print arry names in 'ia'.                                c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
       k=idir
       do 10 i=1,numa
             do 20 j=1,4
                   name(j)=char(ia(k+j-1))
   20        continue
ccc          write(not,1000) i,name,ia(k+4),ia(k+5),ia(k+7),ia(k+8)
             write(ntm,1000) i,name,ia(k+4),ia(k+5),ia(k+7),ia(k+8)
 1000        format(1x,i7,5x,4a1,',nr=',i7,',nc=',i7,',na=',i12,
     *              ',size=',i12)
             k=k+10
   10  continue
       return
       end
c----------------------------------------------------------------definr
       subroutine definr(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpose:                                                            c
c        To reserve storage for REAL data.                            c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
c
       np=1
       call defin(name,na,nr,nc)
       return 
       end
c----------------------------------------------------------------defini
       subroutine defini(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpose:                                                            c
c        To reserve storage for INTEGER data.                         c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
c
       np=1
       call defin(name,na,nr,nc)
       return 
       end
c-----------------------------------------------------------------defin
       subroutine defin(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpuse:                                                            c
c         To define and reserve storage for array.                    c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c---------------------------------------------------------------------c
c where name = name of array--4 logicals maxmum                       c
c       na = location of array if in blank common                     c
c       nr = number of rows                                           c
c       nc = number of columns                                        c
c       mtot = end of directory                                       c
c       numa = number of arrays in data base                          c
c       next = next avialable storage location                        c
c       idir = start of directory in data base                        c
c       ipp = number of logicals contained in data type               c
c       lenr = number of logicals in physical record                  c
c       np = type of data                                             c
c          = 1 integer data                                           c
c          = 2 real data                                              c
c          = 3 logical data                                           c
c------directory definition for core or sequential files--------------c
c       idir(i,n) = name of array --iname(4,char)
c       idir(5,n) = number of rows      -- nr                         c
c       idir(6,n) = number of colomns   -- nc                         c
c       idir(7,n) = type of data        -- np                         c
c       idir(8,n) = incore address      -- na                         c
c                 = -1 if sequential file on disk                     c
c                 = -2 if direct access on disk                       c
c       idir(9,n) = size of array                                     c
c       idir(10,n) = 0 if in core storage                             c
c------directory defintion for direct access files--------------------c
c       idir(5,n) = number of integers                                c
c       idir(6,n) = number of real words                              c
c       idir(7,n) = number of logicals                                c
c       idir(8,n) = number of logical records                         c
c       idir(9,n) = logical record number                             c
c       idir(10,n) = lun if on logical unit lun                       c
c---------------------------------------------------------------------c
c
c------evaluate storage requirements
c
       if((np.ne.1).and.(np.ne.3)) np=2
       nsize=(nr*nc*ipp(np)-1)/(ipp(1)*2)
       nsize=nsize*2+2
       na=next
       next=next+nsize
c
c------set up new directory
c
       numa=numa+1
       idir=idir-10
       i=idir
c
c------check storage limits
c
       if(i.ge.next) goto 100
       i=next-i+mtot-1
       write(ntm,2000) i,mtot,(name(k),k=1,4)
       stop
 100   call icon(name,ia(i))
       ia(i+4)=nr
       ia(i+5)=nc
       ia(i+6)=np
       ia(i+7)=na
       ia(i+8)=nsize
       ia(i+9)=0
 900   return
c---------------------------------------------------------------------c
 2000  format(/,'storage fault in defin',/,'storage required =',i9,
     *        /,'storage available =',i9,
     *        /,'name = ',4a)
       end
c
c----------------------------------------------------------------locate
       subroutine locate(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To locate array NAME in IA.                                 c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name
       dimension name(4),iname(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nun,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c------locate and return properties on array
c
       na=0
       call icon(name,iname)
       i=ifind(iname,0)
       if(i.eq.0) goto 900
c
c------return array properties
c
       na=ia(i+7)
       nr=ia(i+4)
       nc=ia(i+5)
       np=ia(i+6)
       return
c---------------------------------------------------------------------c
 900   write(ntm,1000)  name
 1000  format(/,' NO SUCH ARRAY ',4a1,' IN IA ',/)
       return
       end
c
c----------------------------------------------------------------delete
       subroutine delete(name)
c---------------------------------------------------------------------c
c purpose:                                                            c
c          To delete array NAME.                                      c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name
       dimension name(4),iname(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c------delete array from storage
c
 100   call icon(name,iname)
       i=ifind(iname,0)
       if(i.eq.0) goto 900
c
c------check on storage location
c
 200   nsize=ia(i+8)
c
c------set size of array
c
       next=next-nsize
       numa=numa-1
       na=ia(i+7)
c
c------check if out of core or direct access
c
       if(na.gt.0) goto 500
       write(ntm,1000) name
       goto 800
 500   if(na.eq.next) goto 800
c
c------compact storage
c
       ii=na+nsize
       nnxt=next-1
       do 700 j=na,nnxt
              ia(j)=ia(ii)
              ii=ii+1
 700   continue
c
c------compact and update directory
c
 800   na=i-idir
       idir=idir+10
       if(na.eq.0) goto 900
       na=na/10
       do 860 k=1,na
              ii=i+9
              do 850 j=1,10
                     ia(ii)=ia(ii-10)
                     ii=ii-1
 850          continue
              if(ia(i+7).le.0) goto 860
              if(ia(i+9).eq.0) ia(i+7)=ia(i+7)-nsize
              i=i-10
 860   continue
c
 900   return 
c---------------------------------------------------------------------c
 1000  format(/,' NAME ',4a1,' IS BEING USED FOR AN OUT OF CORE FILE'/)
       end
c
c------------------------------------------------------------------icon
       subroutine icon(name,iname)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To convert logicals to integer data.                        c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       dimension iname(4)
c
       do 100 i=1,4
              iname(i)=ichar(name(i))
 100   continue
c
       return
       end
c-----------------------------------------------------------------ifind
       function ifind(iname,lun)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         This function is used to find location of array.            c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       dimension iname(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
       i=idir
       do 100 n=1,numa
              if(lun.ne.ia(i+9)) goto 300
              if(iname(1).ne.ia(i  )) goto 300
              if(iname(2).ne.ia(i+1)) goto 300
              if(iname(3).ne.ia(i+2)) goto 300
              if(iname(4).eq.ia(i+3)) goto 200
 300          i=i+10
 100   continue
       i=0
 200   ifind=i
c
       return
       end
c----------------------------------------------------------------refinr
       subroutine refinr(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To reserve storage for Real array.                          c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
c
       np=1
       call refin(name,na,nr,nc)
       return
       end
c----------------------------------------------------------------refini
       subroutine refini(name,na,nr,nc)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To reserve storage for Integer array.                       c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       common mtot,np,ia(1)
c
       np=1
       call refin(name,na,nr,nc)
       return
       end
c-----------------------------------------------------------------refin
       subroutine refin(name,na,nr,nc) 
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To refinde and reserve new storage for array.               c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 name(4)
       dimension iname(4)
       common mtot,np,ia(1)
       common /dbsys/numa,next,idir,ipp(3)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c------locate origin array
c
       call icon(name,iname)
       i=ifind(iname,0)
       nr1=ia(i+4)
       nc1=ia(i+5)
       na=ia(i+7)
       nsize1=ia(i+8)
       nsize=(nr*nc*ipp(np)-1)/(ipp(1)*2)
       nsize=nsize*2+2
       nszicr=nsize-nsize1
       nrincr=nr-nr1
       ncincr=nc-nc1
       if(nszicr.eq.0) goto 450
c
c------set size of array
c
       nexto=next-1
       next=next+nszicr
       if(i.gt.next) goto 450
       i=next-i+mtot-1
       print *,'name,nr,nc=',name,nr,nc
       write(ntm,1000) i,mtot,(name(k),k=1,4)
       stop
  450  ia(i+4)=nr
       ia(i+5)=nc
       ia(i+8)=nsize
       if(nszicr.eq.0) goto 900
c
c------compact storage
c
       nextn=next-1
       nnew=na+nsize
       nold=na+nsize1
       if(np.eq.3) goto 500
       if(nrincr.eq.0) goto 500
       nrincr=nrincr*np
       nexto=nexto-nrincr
       nnew=na
       nold=na
       do 10 k=1,nc1
             nnew=nnew+nr*np
             nold=nnew-nrincr
             nexto=nexto+nrincr
             if(i.gt.nexto) goto 480
             i=nexto-i+mtot
             print *,'name,nr,nc=',name,nr,nc
             write(ntm,1000) i,mtot,(name(m),m=1,4)
             stop
  480        if(nrincr.gt.0) goto 510
             ij=nnew
             do 20 j=nold,nexto
                   ia(ij)=ia(j)
                   ij=ij+1
   20        continue
             goto 10
  510        ij1=nexto+nrincr
             do 50 j=nold,nexto
                   ii1=nexto-j+nold
                   ia(ij1)=ia(ii1)
                   ij1=ij1-1
   50        continue
   10  continue
       nnew=na+nsize
       nexto=nexto+nrincr
       nold=nnew-(nextn-nexto)
  500  if(i.eq.idir) goto 900
       if(nextn.eq.nexto) goto 600
       if(nnew.gt.nold) goto 520
       ij=nold
       do 30 j=nnew,nextn
             ia(j)=ia(ij)
             ij=ij+1
   30  continue
       goto 600
  520  ij1=nexto
       do 60 j=nnew,nextn
             ii1=nextn-j+nnew
             ia(ii1)=ia(ij1)
             ij1=ij1-1
  60   continue
c
c------compact and update directory
c
  600  ij=(i-idir)/10
       if(ij.eq.0) goto 900
       i=i-10
       do 40 j=1,ij
             if(ia(i+7).le.0) goto 40
             if(ia(i+9).eq.0) ia(i+7)=ia(i+7)+nszicr
             i=i-10
   40  continue
c
  900  return
c---------------------------------------------------------------------c
 1000  format(/,' STORAGE FAULT IN REFIN',/,' STORAGE REQUIRED =',I9,
     *        /,' STORAGE AVIABLE =',I9,
     *        /,' NAME = ',4a)
       end
c------------------------------------------------------------------find
       subroutine find(sep,nostr,nn)
c---------------------------------------------------------------------c
c input parameters:                                                   c
c                  sep--separator                                     c
c                  nn--flag whether there is separator or not         c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character line*160,sep*80
       common /cline/line
       common /iline/ii
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c------find separator in input file
c
       nn=0
   50  read(nin,1000,err=900,end=900) line(1:80)
       ii=80
c
c------convert to upper case
c
       call upper
       if(sep(1:nostr).ne.line(1:nostr)) goto 50
       nn=1
 900   return
c---------------------------------------------------------------------c
 1000  format(a80)
       end
c------------------------------------------------------------------free
       subroutine free
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To read a line of free field data.                          c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character*1 line,sp,bs,sc,c         
       common /cline/line(160)
       common /iline/ ii
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
       data sp/' '/,c/'%'/,sc/':'/,bs/'\\'/
c
c------read line of free field data
c
       do 40 i=1,160
             line(i)=sp
 40    continue
 50    i=1
       ii=80
 60    read(nin,1000,err=100) (line(k),k=i,ii)
c
c------check for additional line
c
 70    do 80 k=i,ii
             if(line(k).ne.bs) goto 80
             i=k
             ii=k+79
             if(ii.gt.160) ii=160
             goto 60
 80    continue
       call upper
c
c------check for comment 
c
       if(line(1).ne.c) goto 900
       write(ntm,2000) (line(i),i=1,ii)
       goto 50
c
c------error in data
c
 100   write(ntm,2100)
       call freept
c
 900   return
c---------------------------------------------------------------------c
 1000  format(80a1)
 2000  format(1x,80a1)
 2100  format(/'* Error in reading input line *'/)
       end
c----------------------------------------------------------------preept
       subroutine freept
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To write record to file NOT and NTM.                        c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character*1 line
c
       common /iline/ii
       common /cline/line(160)
       common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
     *               ,nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19
c
c------echo of free field information
c
       write(ntm,1000) (line(i),i=1,ii)
       return
 1000  format(1x,80a1)
       end
c-----------------------------------------------------------------freeh
       subroutine freeh(ic,idata,nc,num)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To extract hollerith data.                                  c
c---------------------------------------------------------------------c
c      num -- negative read strings separated by blank space or comma c
c      num -- positive read nc number of characters                   c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character*1 line,ic,blk,comma,io,eqs,colin,idata
       dimension idata(nc,num)
       common /cline/line(160)
       common /iline/ii
       data blk/' '/,comma/','/,io/'0'/,eqs/'='/,colin/':'/
c
c------find hollerith string
c
       num0=abs(num)
 90    i=0
       do 210 j=1,num0
       do 210 n=1,nc
              idata(n,j)=blk
 210   continue
       if(ic.eq.blk) goto 200
       do 100 i=2,ii
              if((line(i-1).eq.ic).and.(line(i).eq.eqs)) goto 200
 100   continue
       return
c
c------extract hollerith string
c
 200   do 300 j=1,num0
 260          i=i+1
              if(i.gt.ii) goto 400
              do 290 n=1,nc
                     if(line(i).eq.eqs) goto 400
                     if(line(i).eq.colin) goto 300
                     if(num.gt.0) goto 280
                     if(line(i).eq.blk) goto 300
                     if(line(i).eq.comma) goto 300
 280                 idata(n,j)=line(i)
                     if(n.eq.nc) goto 290
                     i=i+1
 290          continue
 300   continue
c
 400   return
       end
c-----------------------------------------------------------------freei
       subroutine freei(ic,idata,num)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To extract integer data.                                    c
c---------------------------------------------------------------------c
c input parameter:                                                    c
c                 ic--flag of data      ic=' ' unidentifier           c
c                                       ic=else  identifier           c
c                 num--number of data                                 c
c---------------------------------------------------------------------c
c output parameter:                                                   c
c                 idata--integer array                                c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character*1 line,ic,blk,comma,io,eqs,neg,colin,lne,pls
       dimension idata(num)
       common /cline/line(160)
       common /iline/ii
       common /ilist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10
       data blk/' '/,comma/','/,io/'0'/,eqs/'='/,neg/'-'/,colin/':'/
       data pls/'+'/
c
c------find integer string
c
 90    i=0
       do 210 j=1,num
              idata(j)=0
 210   continue
       if(ic.eq.blk) goto 200
       do 100 i=1,ii
              if(line(i).eq.ic.and.line(i+1).eq.eqs) goto 200
 100   continue
       return
c
c------zero integer string
c
 200   if(line(i+1).eq.eqs) i=i+1
       do 250 j=1,num
              isign=1
c
c------skip blanks between integers
c
 215          if(line(i+1).ne.blk) goto 220
              i=i+1
              if(i.gt.ii) goto 900
              goto 215
 220          i=i+1
              if(i.gt.ii) goto 230
c
c------check for sign
c
              if(line(i).ne.pls) goto 235
              i=i+1
              if(i.gt.ii) goto 230
 235          lne=line(i)
              if(lne.ne.neg) goto 225
              isign=-1
              goto 220
c
c------extract integer
c
 225          if(lne.eq.blk) goto 230
              if(lne.eq.comma) goto 230
              if(lne.eq.colin) goto 230
              nn=ichar(lne)-ichar(io)
              if((nn.lt.0).or.(nn.gt.9)) goto 900
              idata(j)=10*idata(j)+nn
              goto 220
c
c------set sign
c
 230          idata(j)=idata(j)*isign
 250   continue
 900   return
       end
c-----------------------------------------------------------------freer
       subroutine freer(ic,data,num)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To extract real data.                                       c
c---------------------------------------------------------------------c
c      implicit real*8 (a-h,o-z)
       character*1 line,blk,ic,mul,div,add,sub,eqs,e
       dimension data(num)
       common /cline/line(160)
       common /iline/ii
c
       data blk/' '/,mul/'*'/,div/'\/'/,add/'+'/,sub/'-'/,e/'E'/,
     *      eqs/'='/
c
c------find real string
c
 90    i=0
       do 260 j=1,num
              data(j)=0.0
 260   continue
       if(ic.eq.blk) goto 250
       do 100 i=1,ii
              if((line(i).eq.ic).and.(line(i+1).eq.eqs)) goto 250
 100   continue
       return
c
c------extract real data
c
 250   do 300 j=1,num
              jj=0
 270          if(i.gt.ii) goto 300
              call rdata(i,xx,nn)
              if(jj.ne.0) goto 275
              data(j)=xx
              goto 290
c
c------arithmetric statement
c
 275          if(jj.eq.1) data(j)=data(j)*xx
              if(jj.eq.2) data(j)=data(j)/xx
              if(jj.eq.3) data(j)=data(j)+xx
              if(jj.eq.4) data(j)=data(j)-xx
              if(jj.ne.5) goto 290
c
c------exponential data
c
              jj=abs(xx)
              if(jj.eq.0) goto 290
              do 280 k=1,jj
                     if(xx.lt.0.0) data(j)=data(j)/10.0
                     if(xx.gt.0.0) data(j)=data(j)*10.0
 280          continue
c
c------set type of statement
c
 290          jj=0
              if(line(i).eq.mul) jj=1
              if(line(i).eq.div) jj=2
              if(line(i).eq.add) jj=3
              if(line(i).eq.sub) jj=4
              if(line(i).eq.e)   jj=5
              if(line(i+1).eq.eqs) jj=0
              if(jj.ne.0) goto 270
              if(nn.gt.9) return
 300   continue
c---------------------------------------------------------------------c
       return
       end
c-----------------------------------------------------------------rdata
       subroutine rdata(i,xx,nn)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To convert string to real floating point number.            c
c---------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       character*1 line,blk,comma,io,dot,neg,eqs,pls
       common /cline/line(160)
       common /iline/ii
       data blk/' '/,comma/','/,io/'0'/,dot/'.'/,neg/'-'/,eqs/'='/
       data pls/'+'/
c
c------converts string to real floating point number
c
       if(line(i+1).eq.eqs) i=i+1
       y=0
       is=1
       xx=0.0
 250   if(line(i+1).ne.blk) goto 255
       i=i+1
       if(i.gt.ii) goto 300
       goto 250
 255   if(line(i+1).ne.neg) goto 260
       is=-1
       i=i+1
       if(i.gt.ii) goto 300
 260   if(line(i+1).ne.pls) goto 265
       i=i+1
       if(i.gt.ii) goto 300
 265   if(line(i+1).ne.blk) goto 270
       i=i+1
       if(i.gt.ii) goto 300
       goto 265
 270   i=i+1
       if(i.gt.ii) goto 300
       if(line(i).eq.blk.and.line(i+1).eq.blk) goto 270
       nn=ichar(line(i))-ichar(io)
       xn=isign(nn,is)
       if(line(i).ne.dot) goto 275
       y=1.0
       goto 270
 275   if(line(i).eq.blk) goto 300
       if(line(i).eq.comma) goto 300
       if(nn.lt.0.or.nn.gt.9) goto 300
       if(y.eq.0) goto 280
       y=y/10.0
       xn=xn*y
       xx=xx+xn
       goto 270
 280   xx=10.0*xx+xn
       goto 270
 300   return
       end
c
c---------------------------------------------------------------clearr
       subroutine clearr(adata,nr,nc)
c--------------------------------------------------------------------c
c purpose:                                                           c
c         This routine is used to initialize real array ADATA.       c
c--------------------------------------------------------------------c
ccc    implicit real*8 (a-h,o-z)
       dimension adata(nr,nc)
c
       do 10 i=1,nr
             do 20 j=1,nc
                   adata(i,j)=0.0
   20        continue
   10  continue
       return
       end