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.
876 lines
28 KiB
Fortran
876 lines
28 KiB
Fortran
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
|
|
|