brettm
/
3DRWALK
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'eaea2bb3e9'
${ noResults }
3DRWALK/source/flib.for

876 lines
28 KiB
Plaintext
Raw Normal View History Unescape Escape

First Commit
5 years ago
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