home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
SIMTEL
/
CPMUG
/
CPMUG049.ARK
/
MINV.FOR
< prev
next >
Wrap
Text File
|
1984-04-29
|
2KB
|
119 lines
programminvt
integer*1l,n
dimensiona(5,5),l(5)
integer*1char
reallog,log10
datan/5/
datakb/3/,kons/3/
datarpd/.01745329/,dpr/57.29578/
datapi/3.141593/
do 23000i=1,n
do 23002j=1,n
a(j,i)=1./real(i+j-1)
23002 continue
23003 continue
23000 continue
23001 continue
write(kons,20)a
20 format(1x,5g12.6)
callminv(a,n,l,det)
write(kons,20)det
write(kons,20)a
callminv(a,n,l,det)
write(kons,20)det
write(kons,20)a
stop
end
subroutineminv(a,n,l,det)
dimensiona(n,n),l(n)
integer*1l,j,k,n,it,i
datakb/3/,kons/3/
datarpd/.01745329/,dpr/57.29578/
datapi/3.141593/
nd=n
do 23004j=1,n
l(j)=j
23004 continue
23005 continue
det=1.
do 23006k=1,n
if(.not.(fmxmgv(a(k,k),n,n-k+1,jr).eq.0.))goto 23008
write(kons,900)
goto 23007
23008 continue
900 format(1x,15hSingular Matrix)
if(.not.(jr.ne.1))goto 23010
j=k-1+jr
it=l(k)
l(k)=l(j)
l(j)=it
callfvswap(a(1,k),1,a(1,j),1,nd)
det=-det
23010 continue
q=a(k,k)
det=q*det
a(k,k)=1.
do 23012i=1,n
a(i,k)=a(i,k)/q
23012 continue
23013 continue
continue
j=1
23014 if(.not.(j.le.n))goto 23016
if(.not.(j.eq.k))goto 23017
goto 23015
23017 continue
q=-a(k,j)
a(k,j)=0.
do 23019i=1,n
a(i,j)=a(i,k)*q+a(i,j)
23019 continue
23020 continue
23015 j=j+1
goto 23014
23016 continue
23006 continue
23007 continue
n1=n-1
do 23021k=1,n1
continue
i=k
23023 if(.not.(i.le.n.and.l(i).ne.k))goto 23025
23024 i=i+1
goto 23023
23025 continue
callfvswap(a(k,1),nd,a(i,1),nd,nd)
l(i)=l(k)
23021 continue
23022 continue
return
end
functionfmxmgv(a,ia,l,k)
dimensiona(1)
fmxmgv=0.
is=1
do 23026i=1,l
absa=abs(a(is))
if(.not.(absa.gt.fmxmgv))goto 23028
fmxmgv=absa
k=i
23028 continue
is=is+ia
23026 continue
23027 continue
return
end
subroutinefvswap(a,ia,b,ib,n)
dimensiona(1),b(1)
isa=1
isb=1
do 23030i=1,n
t=a(isa)
a(isa)=b(isb)
b(isb)=t
isa=isa+ia
isb=isb+ib
23030 continue
23031 continue
return
end