1016 lines
27 KiB
FortranFixed
1016 lines
27 KiB
FortranFixed
! program main
|
|
! implicit none
|
|
! integer n,i,j,kpvt(100),info,irowinc,index,nii,job,
|
|
! & inert(3)
|
|
! double precision aa(300),ac(300),sum,b(200),bc(200),
|
|
! & a2(100,100),ra2c(100,100),ran2,work(100),
|
|
! & lnabsdet,signunit,det(2)
|
|
|
|
! n=20
|
|
! do i=1,n*(n+1)/2
|
|
! ac(i)=dble(i)*ran2()
|
|
! enddo
|
|
|
|
! do i=1,n
|
|
! b(i)=(0.9d0+2.0d0*dble(i)-0.001d0*dble(i*i))*ran2()
|
|
! bc(i)=b(i)
|
|
! enddo
|
|
|
|
! irowinc=1
|
|
! do i=1,n
|
|
! do j=1,n
|
|
! if(j.le.i)then
|
|
! index=j+irowinc-1
|
|
! if(j.eq.i)then
|
|
! nii=j+irowinc-1
|
|
! endif
|
|
! else
|
|
! index=nii+j-1
|
|
! nii=nii+j-1
|
|
! endif
|
|
! a2(i,j)=ac(index)
|
|
! enddo
|
|
! irowinc=irowinc+i
|
|
! enddo
|
|
|
|
! call dspfa(ac,n,kpvt,info)
|
|
! job=11
|
|
! call dspdi(ac,n,kpvt,det,inert,work,job)
|
|
! irowinc=1
|
|
! do i=1,n
|
|
! do j=1,n
|
|
! if(j.le.i)then
|
|
! index=j+irowinc-1
|
|
! if(j.eq.i)then
|
|
! nii=j+irowinc-1
|
|
! endif
|
|
! else
|
|
! index=nii+j-1
|
|
! nii=nii+j-1
|
|
! endif
|
|
! ra2c(i,j)=ac(index)
|
|
! enddo
|
|
! irowinc=irowinc+i
|
|
! enddo
|
|
! do i=1,20
|
|
! write(2,310)(ra2c(i,j),j=1,20)
|
|
! enddo
|
|
! write(2,*)
|
|
! write(*,*) det(1) * 10.0d0**det(2)
|
|
|
|
! call inv_det_matix(a2(1:n,1:n),n,n,ra2c(1:n,1:n),
|
|
! & lnabsdet,signunit,info)
|
|
|
|
! write(*,*)signunit*dexp(lnabsdet)
|
|
! do i=1,20
|
|
! write(2,310)(ra2c(i,j),j=1,20)
|
|
! enddo
|
|
|
|
! stop
|
|
|
|
|
|
! call dspsl(ac,n,kpvt,b)
|
|
! do i=1,n
|
|
! write(*,*)b(i)
|
|
! enddo
|
|
! write(*,*)
|
|
! call svdlinsys(n,n,a2(1:n,1:n),bc,aa)
|
|
! do i=1,n
|
|
! write(*,*)aa(i)-b(i)
|
|
! enddo
|
|
!310 format(1x,20f15.8)
|
|
! end
|
|
|
|
|
|
subroutine dspfa(ap,n,kpvt,info)
|
|
integer n,kpvt(1),info
|
|
double precision ap(1)
|
|
c
|
|
c dspfa factors a double precision symmetric matrix stored in
|
|
c packed form by elimination with symmetric pivoting.
|
|
c
|
|
c to solve a*x = b , follow dspfa by dspsl.
|
|
c to compute inverse(a)*c , follow dspfa by dspsl.
|
|
c to compute determinant(a) , follow dspfa by dspdi.
|
|
c to compute inertia(a) , follow dspfa by dspdi.
|
|
c to compute inverse(a) , follow dspfa by dspdi.
|
|
c
|
|
c on entry
|
|
c
|
|
c ap double precision (n*(n+1)/2)
|
|
c the packed form of a symmetric matrix a . the
|
|
c columns of the upper triangle are stored sequentially
|
|
c in a one-dimensional array of length n*(n+1)/2 .
|
|
c see comments below for details.
|
|
c
|
|
c n integer
|
|
c the order of the matrix a .
|
|
c
|
|
c output
|
|
c
|
|
c ap a block diagonal matrix and the multipliers which
|
|
c were used to obtain it stored in packed form.
|
|
c the factorization can be written a = u*d*trans(u)
|
|
c where u is a product of permutation and unit
|
|
c upper triangular matrices , trans(u) is the
|
|
c transpose of u , and d is block diagonal
|
|
c with 1 by 1 and 2 by 2 blocks.
|
|
c
|
|
c kpvt integer(n)
|
|
c an integer vector of pivot indices.
|
|
c
|
|
c info integer
|
|
c = 0 normal value.
|
|
c = k if the k-th pivot block is singular. this is
|
|
c not an error condition for this subroutine,
|
|
c but it does indicate that dspsl or dspdi may
|
|
c divide by zero if called.
|
|
c
|
|
c packed storage
|
|
c
|
|
c the following program segment will pack the upper
|
|
c triangle of a symmetric matrix.
|
|
c
|
|
c k = 0
|
|
c do 20 j = 1, n
|
|
c do 10 i = 1, j
|
|
c k = k + 1
|
|
c ap(k) = a(i,j)
|
|
c 10 continue
|
|
c 20 continue
|
|
c
|
|
c linpack. this version dated 08/14/78 .
|
|
c james bunch, univ. calif. san diego, argonne nat. lab.
|
|
c
|
|
c subroutines and functions
|
|
c
|
|
c blas daxpysym,dswap,idamax
|
|
c fortran dabs,dmax1,dsqrt
|
|
c
|
|
c internal variables
|
|
c
|
|
double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
|
|
double precision absakk,alpha,colmax,rowmax
|
|
integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
|
|
integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
|
|
logical swap
|
|
|
|
c
|
|
c initialize
|
|
c
|
|
c alpha is used in choosing pivot block size.
|
|
alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0
|
|
c
|
|
info = 0
|
|
c
|
|
c main loop on k, which goes from n to 1.
|
|
c
|
|
k = n
|
|
ik = (n*(n - 1))/2
|
|
10 continue
|
|
c
|
|
c leave the loop if k=0 or k=1.
|
|
c
|
|
c ...exit
|
|
if (k .eq. 0) go to 200
|
|
if (k .gt. 1) go to 20
|
|
kpvt(1) = 1
|
|
if (ap(1) .eq. 0.0d0) info = 1
|
|
c ......exit
|
|
go to 200
|
|
20 continue
|
|
c
|
|
c this section of code determines the kind of
|
|
c elimination to be performed. when it is completed,
|
|
c kstep will be set to the size of the pivot block, and
|
|
c swap will be set to .true. if an interchange is
|
|
c required.
|
|
c
|
|
km1 = k - 1
|
|
kk = ik + k
|
|
absakk = dabs(ap(kk))
|
|
c
|
|
c determine the largest off-diagonal element in
|
|
c column k.
|
|
c
|
|
imax = idamax(k-1,ap(ik+1),1)
|
|
imk = ik + imax
|
|
colmax = dabs(ap(imk))
|
|
if (absakk .lt. alpha*colmax) go to 30
|
|
kstep = 1
|
|
swap = .false.
|
|
go to 90
|
|
30 continue
|
|
c
|
|
c determine the largest off-diagonal element in
|
|
c row imax.
|
|
c
|
|
rowmax = 0.0d0
|
|
imaxp1 = imax + 1
|
|
im = imax*(imax - 1)/2
|
|
imj = im + 2*imax
|
|
do 40 j = imaxp1, k
|
|
rowmax = dmax1(rowmax,dabs(ap(imj)))
|
|
imj = imj + j
|
|
40 continue
|
|
if (imax .eq. 1) go to 50
|
|
jmax = idamax(imax-1,ap(im+1),1)
|
|
jmim = jmax + im
|
|
rowmax = dmax1(rowmax,dabs(ap(jmim)))
|
|
50 continue
|
|
imim = imax + im
|
|
if (dabs(ap(imim)) .lt. alpha*rowmax) go to 60
|
|
kstep = 1
|
|
swap = .true.
|
|
go to 80
|
|
60 continue
|
|
if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70
|
|
kstep = 1
|
|
swap = .false.
|
|
go to 80
|
|
70 continue
|
|
kstep = 2
|
|
swap = imax .ne. km1
|
|
80 continue
|
|
90 continue
|
|
if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100
|
|
c
|
|
c column k is zero. set info and iterate the loop.
|
|
c
|
|
kpvt(k) = k
|
|
info = k
|
|
go to 190
|
|
100 continue
|
|
if (kstep .eq. 2) go to 140
|
|
c
|
|
c 1 x 1 pivot block.
|
|
c
|
|
if (.not.swap) go to 120
|
|
c
|
|
c perform an interchange.
|
|
c
|
|
call dswap(imax,ap(im+1),1,ap(ik+1),1)
|
|
imj = ik + imax
|
|
do 110 jj = imax, k
|
|
j = k + imax - jj
|
|
jk = ik + j
|
|
t = ap(jk)
|
|
ap(jk) = ap(imj)
|
|
ap(imj) = t
|
|
imj = imj - (j - 1)
|
|
110 continue
|
|
120 continue
|
|
c
|
|
c perform the elimination.
|
|
c
|
|
ij = ik - (k - 1)
|
|
do 130 jj = 1, km1
|
|
j = k - jj
|
|
jk = ik + j
|
|
mulk = -ap(jk)/ap(kk)
|
|
t = mulk
|
|
call daxpysym(j,t,ap(ik+1),1,ap(ij+1),1)
|
|
ijj = ij + j
|
|
ap(jk) = mulk
|
|
ij = ij - (j - 1)
|
|
130 continue
|
|
c
|
|
c set the pivot array.
|
|
c
|
|
kpvt(k) = k
|
|
if (swap) kpvt(k) = imax
|
|
go to 190
|
|
140 continue
|
|
c
|
|
c 2 x 2 pivot block.
|
|
c
|
|
km1k = ik + k - 1
|
|
ikm1 = ik - (k - 1)
|
|
if (.not.swap) go to 160
|
|
c
|
|
c perform an interchange.
|
|
c
|
|
call dswap(imax,ap(im+1),1,ap(ikm1+1),1)
|
|
imj = ikm1 + imax
|
|
do 150 jj = imax, km1
|
|
j = km1 + imax - jj
|
|
jkm1 = ikm1 + j
|
|
t = ap(jkm1)
|
|
ap(jkm1) = ap(imj)
|
|
ap(imj) = t
|
|
imj = imj - (j - 1)
|
|
150 continue
|
|
t = ap(km1k)
|
|
ap(km1k) = ap(imk)
|
|
ap(imk) = t
|
|
160 continue
|
|
c
|
|
c perform the elimination.
|
|
c
|
|
km2 = k - 2
|
|
if (km2 .eq. 0) go to 180
|
|
ak = ap(kk)/ap(km1k)
|
|
km1km1 = ikm1 + k - 1
|
|
akm1 = ap(km1km1)/ap(km1k)
|
|
denom = 1.0d0 - ak*akm1
|
|
ij = ik - (k - 1) - (k - 2)
|
|
do 170 jj = 1, km2
|
|
j = km1 - jj
|
|
jk = ik + j
|
|
bk = ap(jk)/ap(km1k)
|
|
jkm1 = ikm1 + j
|
|
bkm1 = ap(jkm1)/ap(km1k)
|
|
mulk = (akm1*bk - bkm1)/denom
|
|
mulkm1 = (ak*bkm1 - bk)/denom
|
|
t = mulk
|
|
call daxpysym(j,t,ap(ik+1),1,ap(ij+1),1)
|
|
t = mulkm1
|
|
call daxpysym(j,t,ap(ikm1+1),1,ap(ij+1),1)
|
|
ap(jk) = mulk
|
|
ap(jkm1) = mulkm1
|
|
ijj = ij + j
|
|
ij = ij - (j - 1)
|
|
170 continue
|
|
180 continue
|
|
c
|
|
c set the pivot array.
|
|
c
|
|
kpvt(k) = 1 - k
|
|
if (swap) kpvt(k) = -imax
|
|
kpvt(k-1) = kpvt(k)
|
|
190 continue
|
|
ik = ik - (k - 1)
|
|
if (kstep .eq. 2) ik = ik - (k - 2)
|
|
k = k - kstep
|
|
go to 10
|
|
200 continue
|
|
return
|
|
end
|
|
|
|
subroutine daxpysym(n,da,dx,incx,dy,incy)
|
|
c
|
|
c constant times a vector plus a vector.
|
|
c uses unrolled loops for increments equal to one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*),da
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
if(n.le.0)return
|
|
if (da .eq. 0.0d0) return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dy(iy) = dy(iy) + da*dx(ix)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,4)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dy(i) = dy(i) + da*dx(i)
|
|
30 continue
|
|
if( n .lt. 4 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,4
|
|
dy(i) = dy(i) + da*dx(i)
|
|
dy(i + 1) = dy(i + 1) + da*dx(i + 1)
|
|
dy(i + 2) = dy(i + 2) + da*dx(i + 2)
|
|
dy(i + 3) = dy(i + 3) + da*dx(i + 3)
|
|
50 continue
|
|
return
|
|
end
|
|
|
|
subroutine dswap (n,dx,incx,dy,incy)
|
|
c
|
|
c interchanges two vectors.
|
|
c uses unrolled loops for increments equal one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*),dtemp
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments not equal
|
|
c to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dtemp = dx(ix)
|
|
dx(ix) = dy(iy)
|
|
dy(iy) = dtemp
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,3)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dtemp = dx(i)
|
|
dx(i) = dy(i)
|
|
dy(i) = dtemp
|
|
30 continue
|
|
if( n .lt. 3 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,3
|
|
dtemp = dx(i)
|
|
dx(i) = dy(i)
|
|
dy(i) = dtemp
|
|
dtemp = dx(i + 1)
|
|
dx(i + 1) = dy(i + 1)
|
|
dy(i + 1) = dtemp
|
|
dtemp = dx(i + 2)
|
|
dx(i + 2) = dy(i + 2)
|
|
dy(i + 2) = dtemp
|
|
50 continue
|
|
return
|
|
end
|
|
|
|
integer function idamax(n,dx,incx)
|
|
c
|
|
c finds the index of element having max. absolute value.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dmax
|
|
integer i,incx,ix,n
|
|
c
|
|
idamax = 0
|
|
if( n.lt.1 .or. incx.le.0 ) return
|
|
idamax = 1
|
|
if(n.eq.1)return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
ix = 1
|
|
dmax = dabs(dx(1))
|
|
ix = ix + incx
|
|
do 10 i = 2,n
|
|
if(dabs(dx(ix)).le.dmax) go to 5
|
|
idamax = i
|
|
dmax = dabs(dx(ix))
|
|
5 ix = ix + incx
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
20 dmax = dabs(dx(1))
|
|
do 30 i = 2,n
|
|
if(dabs(dx(i)).le.dmax) go to 30
|
|
idamax = i
|
|
dmax = dabs(dx(i))
|
|
30 continue
|
|
return
|
|
end
|
|
|
|
subroutine dspdi(ap,n,kpvt,det,inert,work,job)
|
|
integer n,job
|
|
double precision ap(1),work(1)
|
|
double precision det(2)
|
|
integer kpvt(1),inert(3)
|
|
c
|
|
c dspdi computes the determinant, inertia and inverse
|
|
c of a double precision symmetric matrix using the factors from
|
|
c dspfa, where the matrix is stored in packed form.
|
|
c
|
|
c on entry
|
|
c
|
|
c ap double precision (n*(n+1)/2)
|
|
c the output from dspfa.
|
|
c
|
|
c n integer
|
|
c the order of the matrix a.
|
|
c
|
|
c kpvt integer(n)
|
|
c the pivot vector from dspfa.
|
|
c
|
|
c work double precision(n)
|
|
c work vector. contents ignored.
|
|
c
|
|
c job integer
|
|
c job has the decimal expansion abc where
|
|
c if c .ne. 0, the inverse is computed,
|
|
c if b .ne. 0, the determinant is computed,
|
|
c if a .ne. 0, the inertia is computed.
|
|
c
|
|
c for example, job = 111 gives all three.
|
|
c
|
|
c on return
|
|
c
|
|
c variables not requested by job are not used.
|
|
c
|
|
c ap contains the upper triangle of the inverse of
|
|
c the original matrix, stored in packed form.
|
|
c the columns of the upper triangle are stored
|
|
c sequentially in a one-dimensional array.
|
|
c
|
|
c det double precision(2)
|
|
c determinant of original matrix.
|
|
c determinant = det(1) * 10.0**det(2)
|
|
c with 1.0 .le. dabs(det(1)) .lt. 10.0
|
|
c or det(1) = 0.0.
|
|
c
|
|
c inert integer(3)
|
|
c the inertia of the original matrix.
|
|
c inert(1) = number of positive eigenvalues.
|
|
c inert(2) = number of negative eigenvalues.
|
|
c inert(3) = number of zero eigenvalues.
|
|
c
|
|
c error condition
|
|
c
|
|
c a division by zero will occur if the inverse is requested
|
|
c and dspco has set rcond .eq. 0.0
|
|
c or dspfa has set info .ne. 0 .
|
|
c
|
|
c linpack. this version dated 08/14/78 .
|
|
c james bunch, univ. calif. san diego, argonne nat. lab.
|
|
c
|
|
c subroutines and functions
|
|
c
|
|
c blas daxpysym,dcopysym,ddotsym,dswap
|
|
c fortran dabs,iabs,mod
|
|
c
|
|
c internal variables.
|
|
c
|
|
double precision akkp1,ddotsym,temp
|
|
double precision ten,d,t,ak,akp1
|
|
integer ij,ik,ikp1,iks,j,jb,jk,jkp1
|
|
integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep
|
|
logical noinv,nodet,noert
|
|
c
|
|
noinv = mod(job,10) .eq. 0
|
|
nodet = mod(job,100)/10 .eq. 0
|
|
noert = mod(job,1000)/100 .eq. 0
|
|
c
|
|
if (nodet .and. noert) go to 140
|
|
if (noert) go to 10
|
|
inert(1) = 0
|
|
inert(2) = 0
|
|
inert(3) = 0
|
|
10 continue
|
|
if (nodet) go to 20
|
|
det(1) = 1.0d0
|
|
det(2) = 0.0d0
|
|
ten = 10.0d0
|
|
20 continue
|
|
t = 0.0d0
|
|
ik = 0
|
|
do 130 k = 1, n
|
|
kk = ik + k
|
|
d = ap(kk)
|
|
c
|
|
c check if 1 by 1
|
|
c
|
|
if (kpvt(k) .gt. 0) go to 50
|
|
c
|
|
c 2 by 2 block
|
|
c use det (d s) = (d/t * c - t) * t , t = dabs(s)
|
|
c (s c)
|
|
c to avoid underflow/overflow troubles.
|
|
c take two passes through scaling. use t for flag.
|
|
c
|
|
if (t .ne. 0.0d0) go to 30
|
|
ikp1 = ik + k
|
|
kkp1 = ikp1 + k
|
|
t = dabs(ap(kkp1))
|
|
d = (d/t)*ap(kkp1+1) - t
|
|
go to 40
|
|
30 continue
|
|
d = t
|
|
t = 0.0d0
|
|
40 continue
|
|
50 continue
|
|
c
|
|
if (noert) go to 60
|
|
if (d .gt. 0.0d0) inert(1) = inert(1) + 1
|
|
if (d .lt. 0.0d0) inert(2) = inert(2) + 1
|
|
if (d .eq. 0.0d0) inert(3) = inert(3) + 1
|
|
60 continue
|
|
c
|
|
if (nodet) go to 120
|
|
det(1) = d*det(1)
|
|
if (det(1) .eq. 0.0d0) go to 110
|
|
70 if (dabs(det(1)) .ge. 1.0d0) go to 80
|
|
det(1) = ten*det(1)
|
|
det(2) = det(2) - 1.0d0
|
|
go to 70
|
|
80 continue
|
|
90 if (dabs(det(1)) .lt. ten) go to 100
|
|
det(1) = det(1)/ten
|
|
det(2) = det(2) + 1.0d0
|
|
go to 90
|
|
100 continue
|
|
110 continue
|
|
120 continue
|
|
ik = ik + k
|
|
130 continue
|
|
140 continue
|
|
c
|
|
c compute inverse(a)
|
|
c
|
|
if (noinv) go to 270
|
|
k = 1
|
|
ik = 0
|
|
150 if (k .gt. n) go to 260
|
|
km1 = k - 1
|
|
kk = ik + k
|
|
ikp1 = ik + k
|
|
kkp1 = ikp1 + k
|
|
if (kpvt(k) .lt. 0) go to 180
|
|
c
|
|
c 1 by 1
|
|
c
|
|
ap(kk) = 1.0d0/ap(kk)
|
|
if (km1 .lt. 1) go to 170
|
|
call dcopysym(km1,ap(ik+1),1,work,1)
|
|
ij = 0
|
|
do 160 j = 1, km1
|
|
jk = ik + j
|
|
ap(jk) = ddotsym(j,ap(ij+1),1,work,1)
|
|
call daxpysym(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
|
|
ij = ij + j
|
|
160 continue
|
|
ap(kk) = ap(kk) + ddotsym(km1,work,1,ap(ik+1),1)
|
|
170 continue
|
|
kstep = 1
|
|
go to 220
|
|
180 continue
|
|
c
|
|
c 2 by 2
|
|
c
|
|
t = dabs(ap(kkp1))
|
|
ak = ap(kk)/t
|
|
akp1 = ap(kkp1+1)/t
|
|
akkp1 = ap(kkp1)/t
|
|
d = t*(ak*akp1 - 1.0d0)
|
|
ap(kk) = akp1/d
|
|
ap(kkp1+1) = ak/d
|
|
ap(kkp1) = -akkp1/d
|
|
if (km1 .lt. 1) go to 210
|
|
call dcopysym(km1,ap(ikp1+1),1,work,1)
|
|
ij = 0
|
|
do 190 j = 1, km1
|
|
jkp1 = ikp1 + j
|
|
ap(jkp1) = ddotsym(j,ap(ij+1),1,work,1)
|
|
call daxpysym(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1)
|
|
ij = ij + j
|
|
190 continue
|
|
ap(kkp1+1) = ap(kkp1+1)
|
|
* + ddotsym(km1,work,1,ap(ikp1+1),1)
|
|
ap(kkp1) = ap(kkp1)
|
|
* + ddotsym(km1,ap(ik+1),1,ap(ikp1+1),1)
|
|
call dcopysym(km1,ap(ik+1),1,work,1)
|
|
ij = 0
|
|
do 200 j = 1, km1
|
|
jk = ik + j
|
|
ap(jk) = ddotsym(j,ap(ij+1),1,work,1)
|
|
call daxpysym(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
|
|
ij = ij + j
|
|
200 continue
|
|
ap(kk) = ap(kk) + ddotsym(km1,work,1,ap(ik+1),1)
|
|
210 continue
|
|
kstep = 2
|
|
220 continue
|
|
c
|
|
c swap
|
|
c
|
|
ks = iabs(kpvt(k))
|
|
if (ks .eq. k) go to 250
|
|
iks = (ks*(ks - 1))/2
|
|
call dswap(ks,ap(iks+1),1,ap(ik+1),1)
|
|
ksj = ik + ks
|
|
do 230 jb = ks, k
|
|
j = k + ks - jb
|
|
jk = ik + j
|
|
temp = ap(jk)
|
|
ap(jk) = ap(ksj)
|
|
ap(ksj) = temp
|
|
ksj = ksj - (j - 1)
|
|
230 continue
|
|
if (kstep .eq. 1) go to 240
|
|
kskp1 = ikp1 + ks
|
|
temp = ap(kskp1)
|
|
ap(kskp1) = ap(kkp1)
|
|
ap(kkp1) = temp
|
|
240 continue
|
|
250 continue
|
|
ik = ik + k
|
|
if (kstep .eq. 2) ik = ik + k + 1
|
|
k = k + kstep
|
|
go to 150
|
|
260 continue
|
|
270 continue
|
|
return
|
|
end
|
|
|
|
subroutine dcopysym(n,dx,incx,dy,incy)
|
|
c
|
|
c copies a vector, x, to a vector, y.
|
|
c uses unrolled loops for increments equal to one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*)
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dy(iy) = dx(ix)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,7)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dy(i) = dx(i)
|
|
30 continue
|
|
if( n .lt. 7 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,7
|
|
dy(i) = dx(i)
|
|
dy(i + 1) = dx(i + 1)
|
|
dy(i + 2) = dx(i + 2)
|
|
dy(i + 3) = dx(i + 3)
|
|
dy(i + 4) = dx(i + 4)
|
|
dy(i + 5) = dx(i + 5)
|
|
dy(i + 6) = dx(i + 6)
|
|
50 continue
|
|
return
|
|
end
|
|
|
|
double precision function ddotsym(n,dx,incx,dy,incy)
|
|
c
|
|
c forms the dot product of two vectors.
|
|
c uses unrolled loops for increments equal to one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*),dtemp
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
ddotsym = 0.0d0
|
|
dtemp = 0.0d0
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dtemp = dtemp + dx(ix)*dy(iy)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
ddotsym = dtemp
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,5)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dtemp = dtemp + dx(i)*dy(i)
|
|
30 continue
|
|
if( n .lt. 5 ) go to 60
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,5
|
|
dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
|
|
* dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
|
|
50 continue
|
|
60 ddotsym = dtemp
|
|
return
|
|
end
|
|
|
|
subroutine dspsl(ap,n,kpvt,b)
|
|
integer n,kpvt(1)
|
|
double precision ap(1),b(1)
|
|
c
|
|
c dsisl solves the double precision symmetric system
|
|
c a * x = b
|
|
c using the factors computed by dspfa.
|
|
c
|
|
c on entry
|
|
c
|
|
c ap double precision(n*(n+1)/2)
|
|
c the output from dspfa.
|
|
c
|
|
c n integer
|
|
c the order of the matrix a .
|
|
c
|
|
c kpvt integer(n)
|
|
c the pivot vector from dspfa.
|
|
c
|
|
c b double precision(n)
|
|
c the right hand side vector.
|
|
c
|
|
c on return
|
|
c
|
|
c b the solution vector x .
|
|
c
|
|
c error condition
|
|
c
|
|
c a division by zero may occur if dspco has set rcond .eq. 0.0
|
|
c or dspfa has set info .ne. 0 .
|
|
c
|
|
c to compute inverse(a) * c where c is a matrix
|
|
c with p columns
|
|
c call dspfa(ap,n,kpvt,info)
|
|
c if (info .ne. 0) go to ...
|
|
c do 10 j = 1, p
|
|
c call dspsl(ap,n,kpvt,c(1,j))
|
|
c 10 continue
|
|
c
|
|
c linpack. this version dated 08/14/78 .
|
|
c james bunch, univ. calif. san diego, argonne nat. lab.
|
|
c
|
|
c subroutines and functions
|
|
c
|
|
c blas daxpysym,ddotsym
|
|
c fortran iabs
|
|
c
|
|
c internal variables.
|
|
c
|
|
double precision ak,akm1,bk,bkm1,ddotsym,denom,temp
|
|
integer ik,ikm1,ikp1,k,kk,km1k,km1km1,kp
|
|
c
|
|
c loop backward applying the transformations and
|
|
c d inverse to b.
|
|
c
|
|
k = n
|
|
ik = (n*(n - 1))/2
|
|
10 if (k .eq. 0) go to 80
|
|
kk = ik + k
|
|
if (kpvt(k) .lt. 0) go to 40
|
|
c
|
|
c 1 x 1 pivot block.
|
|
c
|
|
if (k .eq. 1) go to 30
|
|
kp = kpvt(k)
|
|
if (kp .eq. k) go to 20
|
|
c
|
|
c interchange.
|
|
c
|
|
temp = b(k)
|
|
b(k) = b(kp)
|
|
b(kp) = temp
|
|
20 continue
|
|
c
|
|
c apply the transformation.
|
|
c
|
|
call daxpysym(k-1,b(k),ap(ik+1),1,b(1),1)
|
|
30 continue
|
|
c
|
|
c apply d inverse.
|
|
c
|
|
b(k) = b(k)/ap(kk)
|
|
k = k - 1
|
|
ik = ik - k
|
|
go to 70
|
|
40 continue
|
|
c
|
|
c 2 x 2 pivot block.
|
|
c
|
|
ikm1 = ik - (k - 1)
|
|
if (k .eq. 2) go to 60
|
|
kp = iabs(kpvt(k))
|
|
if (kp .eq. k - 1) go to 50
|
|
c
|
|
c interchange.
|
|
c
|
|
temp = b(k-1)
|
|
b(k-1) = b(kp)
|
|
b(kp) = temp
|
|
50 continue
|
|
c
|
|
c apply the transformation.
|
|
c
|
|
call daxpysym(k-2,b(k),ap(ik+1),1,b(1),1)
|
|
call daxpysym(k-2,b(k-1),ap(ikm1+1),1,b(1),1)
|
|
60 continue
|
|
c
|
|
c apply d inverse.
|
|
c
|
|
km1k = ik + k - 1
|
|
kk = ik + k
|
|
ak = ap(kk)/ap(km1k)
|
|
km1km1 = ikm1 + k - 1
|
|
akm1 = ap(km1km1)/ap(km1k)
|
|
bk = b(k)/ap(km1k)
|
|
bkm1 = b(k-1)/ap(km1k)
|
|
denom = ak*akm1 - 1.0d0
|
|
b(k) = (akm1*bk - bkm1)/denom
|
|
b(k-1) = (ak*bkm1 - bk)/denom
|
|
k = k - 2
|
|
ik = ik - (k + 1) - k
|
|
70 continue
|
|
go to 10
|
|
80 continue
|
|
c
|
|
c loop forward applying the transformations.
|
|
c
|
|
k = 1
|
|
ik = 0
|
|
90 if (k .gt. n) go to 160
|
|
if (kpvt(k) .lt. 0) go to 120
|
|
c
|
|
c 1 x 1 pivot block.
|
|
c
|
|
if (k .eq. 1) go to 110
|
|
c
|
|
c apply the transformation.
|
|
c
|
|
b(k) = b(k) + ddotsym(k-1,ap(ik+1),1,b(1),1)
|
|
kp = kpvt(k)
|
|
if (kp .eq. k) go to 100
|
|
c
|
|
c interchange.
|
|
c
|
|
temp = b(k)
|
|
b(k) = b(kp)
|
|
b(kp) = temp
|
|
100 continue
|
|
110 continue
|
|
ik = ik + k
|
|
k = k + 1
|
|
go to 150
|
|
120 continue
|
|
c
|
|
c 2 x 2 pivot block.
|
|
c
|
|
if (k .eq. 1) go to 140
|
|
c
|
|
c apply the transformation.
|
|
c
|
|
b(k) = b(k) + ddotsym(k-1,ap(ik+1),1,b(1),1)
|
|
ikp1 = ik + k
|
|
b(k+1) = b(k+1) + ddotsym(k-1,ap(ikp1+1),1,b(1),1)
|
|
kp = iabs(kpvt(k))
|
|
if (kp .eq. k) go to 130
|
|
c
|
|
c interchange.
|
|
c
|
|
temp = b(k)
|
|
b(k) = b(kp)
|
|
b(kp) = temp
|
|
130 continue
|
|
140 continue
|
|
ik = ik + k + k + 1
|
|
k = k + 2
|
|
150 continue
|
|
go to 90
|
|
160 continue
|
|
return
|
|
end |