src/res_mat.f

Fortran project RESTRAX, source module src/res_mat.f.

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