Source module last modified on Mon, 24 Apr 2006, 17:32;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.4
#////
#//// Subroutines for simple matrix operations:
#////
#////
#//////////////////////////////////////////////////////////////////////
#------------------------------------------
SUBROUTINE INVERT(n,a,na,b,nb)
# Inverts matrix A (A is not destroyed)
#------------------------------------------
implicit none
integer*4 n,na,nb,nmax
parameter(nmax=16)
real*8 a(na,na),b(nb,nb),a1(nmax,nmax),wk(2*nmax)
integer*4 i,j
do 5 i=1,n
do 5 j=1,n
5 a1(i,j)=a(i,j)
# write(*,*) 'res_mat.f, INVERT, N,NA,NB: ',N,NA,NB
call KVERTD(a1,nmax,n,wk)
do 10 i=1,n
do 10 j=1,n
10 b(i,j)=a1(i,j)
return
end
#
#--------------------------------------
SUBROUTINE REDUCE42(a,b,ix,iy,is)
# reduces A(4,4) to B(2,2)
#--------------------------------------
implicit real*8 (a-h,o-z)
real*8 a(4,4),b(2,2),m(4,4,4)
do 3 i=1,4
do 3 j=1,4
m(i,j,4)=a(i,j)
3 continue
do 5 l=1,4
z=m(1,l,4)
m(1,l,4)=m(ix,l,4)
m(ix,l,4)=z
5 continue
do 10 l=1,4
z=m(2,l,4)
m(2,l,4)=m(iy,l,4)
m(iy,l,4)=z
10 continue
do 15 l=1,4
z=m(l,1,4)
m(l,1,4)=m(l,ix,4)
m(l,ix,4)=z
15 continue
do 20 l=1,4
z=m(l,2,4)
m(l,2,4)=m(l,iy,4)
m(l,iy,4)=z
20 continue
l=4
if(is.ne.1) then
do 30 i=4,3,-1
do 30 j=1,i
do 30 k=1,i
m(j,k,i-1)=m(j,k,i)-m(j,i,i)*m(k,i,i)/m(i,i,i)
30 continue
l=2
endif
do 40 i=1,2
do 40 j=1,2
40 b(i,j)=m(i,j,l)
return
end
#----------------------------------------------------------------
real*8 FUNCTION GETFWHM(a,ix)
# cuts A(4,4) at X(4)=0 and makes projection through I,J<>IX
# S=remaining coeficient
# returns SQRT(1/S*8*ln(2))
#----------------------------------------------------------------
implicit none
real*8 a(4,4),m(3,3,3),c8ln2,z
integer*4 i,j,k,ix,l
parameter (c8ln2=5.54517744)
do 3 i=1,3
do 3 j=1,3
m(i,j,3)=a(i,j)
3 continue
#/// exchange rows 1 and IX
do 5 l=1,3
z=m(1,l,3)
m(1,l,3)=m(ix,l,3)
m(ix,l,3)=z
5 continue
#/// exchange columns 1 and IX
do 15 l=1,3
z=m(l,1,3)
m(l,1,3)=m(l,ix,3)
m(l,ix,3)=z
15 continue
do 30 i=3,2,-1
do 30 j=1,i
do 30 k=1,i
m(j,k,i-1)=m(j,k,i)-m(j,i,i)*m(k,i,i)/m(i,i,i)
30 continue
GETFWHM=sqrt(c8ln2/m(1,1,1))
return
end
#--------------------------------------------------------------------
SUBROUTINE STAT_INP(nd,cv,x,p)
# accumulates covariantes matrix of vector X wit probability P
#--------------------------------------------------------------------
INCLUDE 'structures.inc'
record /STATI/ cv
real*8 p,x(crnd)
cv.sumn=cv.sumn+p
cv.nc=cv.nc+1
do 10 i=1,nd
cv.sum1(i)=cv.sum1(i)+x(i)*p
do 10 j=1,nd
cv.sum2(i,j)=cv.sum2(i,j)+x(i)*x(j)*p
10 continue
return
end
#--------------------------------------
SUBROUTINE STAT_CLR(nd,cv)
# cleares covariance matrix
#--------------------------------------
INCLUDE 'structures.inc'
record /STATI/ cv
cv.sumn=0
cv.nc=0
do 10 i=1,nd
cv.sum1(i)=0
cv.dm(i)=0
cv.m(i)=0
do j=1,nd
cv.c(i,j)=0
cv.sum2(i,j)=0
enddo
10 continue
return
end
#--------------------------------------
SUBROUTINE STAT_GET(nd,cv)
# calculates covariance matrix
#--------------------------------------
INCLUDE 'structures.inc'
record /STATI/ cv
if((cv.nc.gt.0).and.(cv.sumn.gt.0)) then
cv.p=cv.sumn/cv.nc
do 10 i=1,nd
cv.m(i)=cv.sum1(i)/cv.sumn
do 10 j=1,nd
cv.c(i,j)=cv.sum2(i,j)/cv.sumn
10 continue
do 20 i=1,nd
do 20 j=1,nd
cv.c(i,j)=cv.c(i,j)-cv.m(i)*cv.m(j)
20 continue
do i=1,nd
cv.dm(i)= sqrt(cv.c(i,i)/cv.nc)
enddo
endif
return
end
#
#----------------------------------------
SUBROUTINE M3XV3_M(it,map,m,b,c)
# Multiply M(3,3) matrix with V(3) vector
# Use MAP(3) mask to skip dimensions which do not need to transform
# Use transposed M if IT<0
#----------------------------------------
logical*4 map(3)
real*8 m(3,3),b(3),c(3)
do 10 j=1,3
if (map(j)) then
c(j)=0.
if (it.gt.0) then
do 20 i=1,3
20 c(j)=c(j)+m(j,i)*b(i)
else
do 30 i=1,3
30 c(j)=c(j)+m(i,j)*b(i)
endif
else
c(j)=b(j)
endif
10 continue
return
end
#
#---------------------------------------------------------------
SUBROUTINE M4xV4_3(m,b,c)
# Multiply submatrix (3x3) with vector (3)
# dimensions of M,B,C = 4 (ignore the 4-th dimensions )
#---------------------------------------------------------------
real*8 m(4,4),b(4),c(4)
do j=1,3
c(j)=0.
do i=1,3
c(j)=c(j)+m(j,i)*b(i)
end do
end do
c(4)=b(4)
end
#---------------------------------------------------------------
SUBROUTINE M4xV3(m,b,c)
# Multiply submatrix (4x4) with vector (3), ignore the 4-th dimension
# dimensions of C = 3
#---------------------------------------------------------------
real*8 m(4,4),b(3),c(3)
do j=1,3
c(j)=0.
do i=1,3
c(j)=c(j)+m(j,i)*b(i)
end do
end do
end
#---------------------------------------------------------------
SUBROUTINE M3xV4(m,b,c)
# Multiply submatrix (3x3) with vector (4), ignore the 4-th dimension
# dimensions of C = 4
#---------------------------------------------------------------
real*8 m(3,3),b(4),c(4)
do j=1,3
c(j)=0.
do i=1,3
c(j)=c(j)+m(j,i)*b(i)
end do
end do
c(4)=b(4)
end
#---------------------------------------------------------------
SUBROUTINE M3xV3(m,b,c)
# Multiply matrix (3x3) with vector (3)
# dimensions of M,B,C = 3
#---------------------------------------------------------------
real*8 m(3,3),b(3),c(3)
do j=1,3
c(j)=0.
do i=1,3
c(j)=c(j)+m(j,i)*b(i)
end do
end do
end
#---------------------------------------------------------------
SUBROUTINE M4xV4(m,b,c)
# Multiply matrix (4x4) with vector (4)
# dimensions of C = 4
#---------------------------------------------------------------
real*8 m(4,4),b(4),c(4)
do j=1,4
c(j)=0.
do i=1,4
c(j)=c(j)+m(j,i)*b(i)
end do
end do
end
#----------------------------------
SUBROUTINE MXV(it,n,np,a,b,c)
# Multiply matrix (NxN) with vector (N)
# dimensions of A,B,C = NP
# if IT<0, then use A transposed
#----------------------------------
real*8 a(np,np),b(np),c(np)
do 10 j=1,n
c(j)=0.
if (it.gt.0) then
do 20 i=1,n
20 c(j)=c(j)+a(j,i)*b(i)
else
do 30 i=1,n
30 c(j)=c(j)+a(i,j)*b(i)
endif
10 continue
return
end
#----------------------------------
SUBROUTINE MXM(it,n,np,a,b,c)
# Multiply matrix (NxN) with matrix (NxN)
# dimensions of A,B,C = NP
# if IT<0, then use A transposed
#----------------------------------
real*8 a(np,np),b(np,np),c(np,np)
do 10 j=1,n
do 10 k=1,n
c(j,k)=0.
if (it.gt.0) then
do 20 i=1,n
20 c(j,k)=c(j,k)+a(j,i)*b(i,k)
else
do 30 i=1,n
30 c(j,k)=c(j,k)+a(i,j)*b(i,k)
endif
10 continue
return
end
#-----------------------------------
SUBROUTINE M3XM3(it,a,b,c)
# Multiply matrix (3x3) with matrix (3x3)
# dimensions of C = 3
# if IT<0, then use A transposed
#-----------------------------------
real*8 a(3,3),b(3,3),c(3,3)
do 10 j=1,3
do 10 k=1,3
c(j,k)=0.
if (it.gt.0) then
do 20 i=1,3
20 c(j,k)=c(j,k)+a(j,i)*b(i,k)
else
do 30 i=1,3
30 c(j,k)=c(j,k)+a(i,j)*b(i,k)
endif
10 continue
return
end
#------------------------------------
SUBROUTINE M4XM4(it,a,b,c)
# Multiply matrix (4x4) with matrix (4x4)
# dimensions of C = 4
# if IT<0, then use A transposed
#------------------------------------
real*8 a(4,4),b(4,4),c(4,4)
do 10 j=1,4
do 10 k=1,4
c(j,k)=0.
if (it.gt.0) then
do 20 i=1,4
20 c(j,k)=c(j,k)+a(j,i)*b(i,k)
else
do 30 i=1,4
30 c(j,k)=c(j,k)+a(i,j)*b(i,k)
endif
10 continue
return
end
#----------------------------------------------
SUBROUTINE M4XM4_3(a,b,c)
# multiplies submatrix (3,3) of matrices (4x4), the rest is delta(i,j)
#----------------------------------------------
real*8 a(4,4),b(4,4),c(4,4)
do j=1,3
c(j,4)=0.
c(4,j)=0.
do k=1,3
c(j,k)=0.
do i=1,3
c(j,k)=c(j,k)+a(j,i)*b(i,k)
end do
end do
end do
c(4,4)=1.
end
#----------------------------------------------
SUBROUTINE BTAB4(a,b,c)
# Computes the matrix product BT*A*B, dim=4
# Assumes B(4,i)=delta(4,i) etc...
#----------------------------------------------
implicit none
integer*4 i,j,k,l
real*8 a(4,4),b(4,4),c(4,4)
do 5 i=1,4
do 5 j=1,4
c(i,j)=0.
do 5 k=1,4
do 5 l=1,4
c(i,j)=c(i,j)+b(k,i)*a(k,l)*b(l,j)
5 continue
end
#----------------------------------------------
SUBROUTINE BTAB(a,b,n1,n2,c)
# Computes the matrix product BT*A*B
#----------------------------------------------
implicit none
integer*4 i,j,k,l,n1,n2
real*8 a(n1,n1),b(n1,n2),c(n2,n2)
do 5 i=1,n2
do 5 j=1,n2
c(i,j)=0.
do 5 k=1,n1
do 5 l=1,n1
c(i,j)=c(i,j)+b(k,i)*a(k,l)*b(l,j)
5 continue
end
#----------------------------------------------
SUBROUTINE BABT(a,b,n1,n2,c)
# Computes the matrix product B*A*BT
#----------------------------------------------
implicit none
integer*4 i,j,k,l,n1,n2
real*8 a(n1,n1),b(n2,n1),c(n2,n2)
do 5 i=1,n2
do 5 j=1,n2
c(i,j)=0.
do 5 k=1,n1
do 5 l=1,n1
c(i,j)=c(i,j)+b(i,k)*a(k,l)*b(j,l)
5 continue
end
# ------------------------------
SUBROUTINE V3AV3(it,a,b,c)
# ------------------------------
real*8 a(3),b(3),c(3)
do 10 i=1,3
10 c(i)=a(i)+it*b(i)
return
end
# ------------------------------
real*8 FUNCTION ABSV3(a)
# ------------------------------
real*8 a(3)
ABSV3=sqrt(V3XV3(a,a))
return
end
# ------------------------------
real*8 FUNCTION V3XV3(a,b)
# ------------------------------
real*8 a(3),b(3),z
z=0
do 10 i=1,3
10 z=z+a(i)*b(i)
V3XV3=z
return
end
# ------------------------------
SUBROUTINE GENROT(iax,phi,aux)
# ------------------------------
real*8 phi,co,si,aux(3,3)
si=sin(phi)
co=sqrt(1-si**2)
do 20 i=1,3
do 20 j=1,3
if(i.eq.j) then
if (i.eq.iax) then
aux(i,j)=1.
else
aux(i,j)=co
endif
else
if((i.eq.iax).or.(j.eq.iax)) then
aux(i,j)=0.
else if (i.gt.j) then
aux(i,j)=si
else
aux(i,j)=-si
endif
endif
20 continue
return
end
#**************************************************************
#
SUBROUTINE SUM(x,y,n,z)
implicit real*8 (a-h,o-z)
real*8 x(n,n),y(n,n),z(n,n)
do 2 i=1,n
do 2 j=1,n
2 z(i,j)=x(i,j)+y(i,j)
return
end
#
#**************************************************************
#
real*8 FUNCTION DETERM(b,n,a)
implicit real*8 (a-h,o-z)
parameter(zero=1.d-20)
# COMPUTES THE DETERMINANT OF THE MATRIX B
real*8 a(n,n),b(n,n)
dia=1.d0
do 55 i=1,n
dia=dia*abs(b(i,i))
do 55 j=1,n
55 a(i,j)=b(i,j)
n1=n-1
DETERM=1.d0
do 1 i=1,n1
j1=i
k1=i
do 10 j2=i,n
do 10 k2=i,n
if(abs(a(j1,k1)).ge.abs(a(j2,k2)))go to 10
j1=j2
k1=k2
10 continue
if(abs(a(j1,k1)).gt.zero*dia)go to 11
# write(*,*) 'Bug... ',A(J1,K1),DIA
DETERM=0.
return
11 continue
if(j1.eq.i)go to 12
do 5 k=i,n
x=a(i,k)
a(i,k)=a(j1,k)
5 a(j1,k)=-x
12 if(k1.eq.i)go to 13
do 6 j=1,n
x=a(j,i)
a(j,i)=a(j,k1)
6 a(j,k1)=-x
13 i1=i+1
do 30 j=i1,n
if(a(j,i).eq.0.d0) go to 30
x=a(j,i)/a(i,i)
do 7 k=i,n
7 a(j,k)=a(j,k)-x*a(i,k)
30 continue
1 DETERM=DETERM*a(i,i)
DETERM=DETERM*a(n,n)
# write(*,*) 'Ready... ',DETERM
return
end
#
#
#
SUBROUTINE DIAG(a,ada,b)
#***********************************************************************
# diagonalizes matrix A(4,4), B(4,4) is corresponding rotation matrix
#***********************************************************************
implicit real*8 (a-h,o-z)
dimension a(16),ada(16),b(16),armax(16),jrmax(16)
data n,nd,e/4,4,1.e-24/
ndn=nd*n
do 1 k=1,ndn
ada(k)=a(k)
b(k)=0.
1 continue
do 2 k=1,n
kk=k*(nd+1)-nd
armax(k)=0.
b(kk)=1.
do 3 l=k,n
if(l-k)4,3,4
4 kl=k+nd*(l-1)
y=abs(ada(kl))
if(armax(k)-y)5,3,3
5 armax(k)=y
jrmax(k)=l
3 continue
2 continue
11 amax=0.
do 6 k=1,n
y=abs(armax(k))
if(amax-y)7,6,6
7 amax=y
i=k
6 continue
j=jrmax(i)
if(e-amax)8,9,9
8 ndi=nd*(i-1)
ndj=nd*(j-1)
ii=i+ndi
jj=j+ndj
ij=i+ndj
ji=j+ndi
aii=ada(ii)
ajj=ada(jj)
aij=ada(ij)
y=2.*aij
x=aii-ajj
t=dsign(1.d0,x)*y/(abs(x)+sqrt(x**2+y**2))
tsq=t**2
c=1./sqrt(abs(1.+tsq))
ty=t*y
s=t*c
csq=c**2
ada(ii)=csq*(aii+ty+ajj*tsq)
ada(jj)=csq*(ajj-ty+aii*tsq)
ada(ij)=0.
ada(ji)=0.
do 10 k=1,n
jtes=(k-i)*(k-j)
ndk=nd*(k-1)
ki=k+ndi
kj=k+ndj
if(jtes)13,12,13
13 jk=j+ndk
ik=i+ndk
ada(ki)=c*ada(ik)+s*ada(jk)
ada(kj)=-s*ada(ik)+c*ada(jk)
ada(jk)=ada(kj)
ada(ik)=ada(ki)
12 x=b(ki)
b(ki)=c*x+s*b(kj)
b(kj)=-s*x+c*b(kj)
10 continue
armax(i)=0.
do 14 k=1,n
if(k-i)15,14,15
15 ik=i+nd*(k-1)
y=abs(ada(ik))
if(armax(i)-y)16,14,14
16 armax(i)=y
jrmax(i)=k
14 continue
armax(j)=0.
do 17 k=1,n
if(k-j)18,17,18
18 jk=j+nd*(k-1)
y=abs(ada(jk))
if(armax(j)-y)19,17,17
19 armax(j)=y
jrmax(j)=k
17 continue
do 20 k=1,n
ites=(k-i)*(k-j)
ki=k+ndi
kj=k+ndj
if(ites)21,20,21
21 x=abs(ada(ki))
y=abs(ada(kj))
jr=j
if(x-y)22,22,23
23 y=x
jr=i
22 if(armax(k)-y)24,20,20
24 armax(k)=y
jrmax(k)=jr
20 continue
goto 11
9 continue
return
end
#-----------------------------------------------------------------
SUBROUTINE LINFIT(x,y,n,dx,dy,dz,nd,amp,bcg,chisq)
# Linear fit of the function (X,Y,N) to the data (DX,DY,DZ,ND)
# Y = AMP*DY + BCG
#-----------------------------------------------------------------
real*4 x(n),y(n),dx(nd),dy(nd),dz(nd)
c1=0
c2=0
c3=0
c4=0
c5=0
c6=0
kk=0
ddx=x(2)-x(1)
do i=1,nd
z=(dx(i)-x(1))/ddx
if(z.ge.0) then
k=int(z)+1
else
k=int(z)
endif
if((k.gt.0).and.(k.lt.n)) then
kk=kk+1
yy=y(k)+(y(k+1)-y(k))*(dx(i)-x(k))/ddx ! linear interpolation
sig2=dz(i)**2
if(sig2.eq.0) sig2=1.
w=1/sig2
c1=c1+dy(i)*w
c2=c2+yy*w
c3=c3+w
c4=c4+dy(i)*yy*w
c5=c5+yy*yy*w
c6=c6+dy(i)*dy(i)*w
endif
end do
if(kk.gt.0) then
if((c2*c2-c3*c5).eq.0) then
amp=0
bcg=0
chisq=c6
else
amp= (c1*c2-c3*c4)/(c2*c2-c3*c5)
bcg=(c4*c2-c5*c1)/(c2*c2-c3*c5)
chisq=(amp**2)*c5+(bcg**2)*c3+c6+2*amp*bcg*c2-2*amp*c4-
1 2*bcg*c1
chisq=chisq/kk
endif
else
amp=0.
bcg=0.
chisq=0.
endif
return
end
#-----------------------------------------------------------------
real*8 FUNCTION CHI2(x,y,n,dx,dy,dz,nd)
# Returns Chi^2 for data DY and function Y
#-----------------------------------------------------------------
real*4 x(n),y(n),dx(nd),dy(nd),dz(nd)
c4=0
c5=0
c6=0
kk=0
ddx=x(2)-x(1)
do i=1,nd
z=(dx(i)-x(1))/ddx
if(z.ge.0) then
k=int(z)+1
else
k=int(z)
endif
if((k.gt.0).and.(k.lt.n)) then
kk=kk+1
yy=y(k)+(y(k+1)-y(k))*(dx(i)-x(k))/ddx ! linear interpolation
sig2=dz(i)**2
if(sig2.eq.0) sig2=1.
w=1/sig2
c4=c4+dy(i)*yy*w
c5=c5+yy*yy*w
c6=c6+dy(i)*dy(i)*w
endif
end do
if(kk.gt.0) then
CHI2=(c6+c5-2*c4)/kk
else
CHI2=0.
endif
return
end
#------------------------------------------------
real*8 FUNCTION ROUNDSCALE(x,ilim,sc,nsc)
# round number X to get scale limit
# ILIM>0 ... upper limit
# ILIM<0 ... lower limit
# SC(NSC) contains limits (e.g. 2,4,6,8)
#------------------------------------------------
implicit none
integer*4 nsc
real*8 x,sc(nsc)
integer*4 ilim,i,inc
real*8 z,d,ex,b
10 format( 'ROUNDSCALE ',a,4(1x,g10.4))
# write(*,10) 'X',X
z=abs(x)
if (z.eq.0) then
ROUNDSCALE=0
return
endif
ex=int(log10(z))
if (z.lt.1) ex=ex-1
b=10
d=10**ex
# write(*,10) 'D',D
if (ilim*sign(1.d0,x).gt.0) then
i=1
inc=1
else
i=nsc
inc=-1
endif
do while (i.gt.0.and.i.le.nsc.and.b.eq.10)
# WRITE(*,10) 'Z/D: ',Z/D,SC(I)
if ((z/d-sc(i))*inc.lt.0.d0) b=sc(i)
i=i+inc
enddo
# WRITE(*,10) 'result=',SIGN(1.D0,X)*B*D
ROUNDSCALE=sign(1.d0,x)*b*d
end
#------------------------------------------------
SUBROUTINE KVERTD(v,lv,n,w)
# invert matrix, from http://www.netlib.org/napack
# rewritten from KVERT to real*8 by J.S.
#------------------------------------------------
# ________________________________________________________
# | |
# | INVERT A GENERAL MATRIX WITH COMPLETE PIVOTING |
# | |
# | INPUT: |
# | |
# | V --ARRAY CONTAINING MATRIX |
# | |
# | LV --LEADING (ROW) DIMENSION OF ARRAY V |
# | |
# | N --DIMENSION OF MATRIX STORED IN ARRAY V |
# | |
# | W --WORK ARRAY WITH AT LEAST 2N ELEMENTS |
# | |
# | OUTPUT: |
# | |
# | V --INVERSE |
# | |
# | BUILTIN FUNCTIONS: ABS |
# |________________________________________________________|
#
implicit none
integer*4 lv,n,h,i,j,k,l,m,o,p,q
# REAL*8 V(LV,1),W(1),S,T
real*8 v(lv,n),w(2*n),s,t
! KVERTD(A1,NMAX,N,WK)
if ( n .eq. 1 ) goto 120
o = n + 1
l = 0
m = 1
10 if ( l .eq. n ) goto 90
k = l
l = m
m = m + 1
# ---------------------------------------
# |*** FIND PIVOT AND START ROW SWAP ***|
# ---------------------------------------
p = l
q = l
s = abs(v(l,l))
do 20 h = l,n
do 20 i = l,n
t = abs(v(i,h))
if ( t .le. s ) goto 20
p = i
q = h
s = t
20 continue
w(n+l) = p
w(o-l) = q
do 30 i = 1,n
t = v(i,l)
v(i,l) = v(i,q)
30 v(i,q) = t
s = v(p,l)
v(p,l) = v(l,l)
if ( s .eq. 0. ) goto 130
# -----------------------------
# |*** COMPUTE MULTIPLIERS ***|
# -----------------------------
v(l,l) = -1.
s = 1./s
do 40 i = 1,n
40 v(i,l) = -s*v(i,l)
j = l
50 j = j + 1
if ( j .gt. n ) j = 1
if ( j .eq. l ) goto 10
t = v(p,j)
v(p,j) = v(l,j)
v(l,j) = t
if ( t .eq. 0. ) goto 50
# ------------------------------
# |*** ELIMINATE BY COLUMNS ***|
# ------------------------------
if ( k .eq. 0 ) goto 70
do 60 i = 1,k
60 v(i,j) = v(i,j) + t*v(i,l)
70 v(l,j) = s*t
if ( m .gt. n ) goto 50
do 80 i = m,n
80 v(i,j) = v(i,j) + t*v(i,l)
goto 50
# -----------------------
# |*** PIVOT COLUMNS ***|
# -----------------------
90 l = w(k+n)
do 100 i = 1,n
t = v(i,l)
v(i,l) = v(i,k)
100 v(i,k) = t
k = k - 1
if ( k .gt. 0 ) goto 90
# --------------------
# |*** PIVOT ROWS ***|
# --------------------
do 110 j = 1,n
do 110 i = 2,n
p = w(i)
h = o - i
t = v(p,j)
v(p,j) = v(h,j)
v(h,j) = t
110 continue
return
120 if ( v(1,1) .eq. 0. ) goto 130
v(1,1) = 1./v(1,1)
return
130 write(6,*) 'MATRIX HAS NO INVERSE'
stop
end