!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
subroutine minv(ab,n,nd,scratch,det,eps,m,mode) 4,1
implicit none
C
C A subroutine that calculates the determinant and inverse of
C a matrix, as well as solving systems of linear equations.
C Martin J. McBride. 11/25/85.
C General Electric CRD, Information System Operation.
C
#include "comlun.cdk"
integer n,nd,m,mode,outer,row,col,i,scol,srow,pivcnt
real*8 ab(nd,1),scratch(1),det,eps,mult,colnum,temp
real*8 div
C Initialize scratch space, with 1 to N holding the diagonal of the identity
C matrix used to compute the inverse and N+1 to 2N holding the positions of
C the first N columns of the matrix (for use when pivot occurs).
do 5 i = 1,n
5 scratch(i) = 1.0
colnum = 1.0
do 6 i = n+1,2*n
scratch(i) = colnum
colnum = colnum + 1.0
6 continue
C Make left, square matrix an upper triangular matrix.
det = 0.0
pivcnt = 0
do 10 outer = 1,n-1
if (abs(ab(outer,outer)) .le. eps) then
call pivot2(ab,n,nd,outer,scratch,eps)
if (ab(outer,outer) .eq. 0.0) then
write(nulout,*) ' '
write(nulout,*) '*************************************'
write(nulout,*) ' MINV called with singular matrix.'
write(nulout,*) '*************************************'
write(nulout,*) ' '
stop
endif
pivcnt = pivcnt + 1
endif
do 20 row = outer+1,n
mult = ab(row,outer)/ab(outer,outer)
do 30 col = outer,n+m
30 ab(row,col) = ab(row,col) - ab(outer,col)*mult
do 25 scol = 1,outer-1
25 ab(row,scol) = ab(row,scol) - ab(outer,scol)*mult
ab(row,outer) = ab(row,outer) - scratch(outer)*mult
20 continue
10 continue
C Compute determinant.
det = ab(1,1)
do 40 i = 2,n
40 det = det*ab(i,i)
det = (-1.0)**pivcnt * det
C Return if inverse is not to be found and there are no systems of equations
C to solve.
if (mode .eq. 0 .and. m .eq. 0) return
C Place ones in diagonal of square matrix A.
do 80 row = 1,n
div = ab(row,row)
do 90 col = 1,n+m
ab(row,col) = ab(row,col)/div
90 continue
scratch(row) = scratch(row)/div
80 continue
C Reduce upper triangle to zeros to give matrix A = I.
do 50 outer = 2,n
do 60 row = outer-1,1,-1
mult = ab(row,outer)/ab(outer,outer)
do 70 col = outer,n+m
70 ab(row,col) = ab(row,col) - ab(outer,col)*mult
do 65 scol = 1,row-1
65 ab(row,scol) = ab(row,scol) - ab(outer,scol)*mult
scratch(row) = scratch(row) - ab(outer,row)*mult
do 63 scol = row+1,outer-1
63 ab(row,scol) = ab(row,scol) - ab(outer,scol)*mult
ab(row,outer) = ab(row,outer) - scratch(outer)*mult
60 continue
50 continue
C Move diagonals of inverse to matrix AB.
do 85 i = 1,n
85 ab(i,i) = scratch(i)
C If pivot was made, switch rows corresponding to the columns that were
C pivoted.
if (pivcnt .eq. 0) return
row = 1
do 95 i = 1,n-1
srow = int(scratch(row+n))
if (srow .ne. row) then
do 92 col = 1,n+m
temp = ab(row,col)
ab(row,col) = ab(srow,col)
ab(srow,col) = temp
92 continue
temp = scratch(row+n)
scratch(row+n) = scratch(srow+n)
scratch(srow+n) = temp
else
row = row + 1
endif
95 continue
return
end