New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,110 @@
|
||||
program main
|
||||
implicit none
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(100,100),princomp(100,100),transdata(100,100)
|
||||
integer i,j,k
|
||||
sample(1,1)=2.5d0
|
||||
sample(2,1)=0.5d0
|
||||
sample(3,1)=2.2d0
|
||||
sample(4,1)=1.9d0
|
||||
sample(5,1)=3.1d0
|
||||
sample(6,1)=2.3d0
|
||||
sample(7,1)=2.0d0
|
||||
sample(8,1)=1.0d0
|
||||
sample(9,1)=1.5d0
|
||||
sample(10,1)=1.1d0
|
||||
sample(1,2)=2.4d0
|
||||
sample(2,2)=0.7d0
|
||||
sample(3,2)=2.9d0
|
||||
sample(4,2)=2.2d0
|
||||
sample(5,2)=3.0d0
|
||||
sample(6,2)=2.7d0
|
||||
sample(7,2)=1.6d0
|
||||
sample(8,2)=1.1d0
|
||||
sample(9,2)=1.6d0
|
||||
sample(10,2)=0.9d0
|
||||
nsamp=10
|
||||
mdim=2
|
||||
mpc=2
|
||||
call princompana(nsamp,mdim,sample,mpc,princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
write(*,*)j,princomp(j,1)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=1,nsamp
|
||||
write(*,*)j,transdata(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata)
|
||||
implicit none
|
||||
!-----------Inputs----------------------------------------
|
||||
!mpc is the number of principal components to keep
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(nsamp,mdim)
|
||||
!-----------Outputs---------------------------------------
|
||||
!princomp is the projection of a sample on the principal axes
|
||||
!transdata is the data of the orginal sample filtered with mpc principal components
|
||||
double precision eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim)
|
||||
!---------------------------------------------------------
|
||||
integer i,j,k
|
||||
call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
princomp(j,i)=0.0d0
|
||||
do k=1,mdim
|
||||
princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do j=1,mdim
|
||||
do i=1,nsamp
|
||||
transdata(i,j)=sampmean(j)
|
||||
do k=1,mpc
|
||||
transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,sampmean,sampadj)
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
|
||||
!to the smallest eigenvalue
|
||||
call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),covarmatrix(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
call eigensystem
|
||||
return
|
||||
end
|
||||
|
||||
subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,sampmean,sampadj)
|
||||
implicit none
|
||||
integer nsamp, mdim
|
||||
double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
integer i,j,k
|
||||
do j=1,mdim
|
||||
sampmean(j)=0.0d0
|
||||
do i=1,nsamp
|
||||
sampmean(j)=sampmean(j)+sample(i,j)
|
||||
enddo
|
||||
sampmean(j)=sampmean(j)/dble(nsamp)
|
||||
do i=1,nsamp
|
||||
sampadj(i,j)=sample(i,j)-sampmean(j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=i,mdim
|
||||
covarmatrix(i,j)=0.0d0
|
||||
do k=1,nsamp
|
||||
covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
|
||||
enddo
|
||||
enddo
|
||||
covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,112 @@
|
||||
! program main
|
||||
! implicit none
|
||||
! integer nsamp,mdim,mpc
|
||||
! double precision sample(100,100),princomp(100,100),
|
||||
! &transdata(100,100),x(100),eigenvector(100,100),eigenvalue(100)
|
||||
! integer i,j,k
|
||||
! open(unit=1,file='Table8.3.txt')
|
||||
! read(1,*)
|
||||
! nsamp=0
|
||||
!10 read(1,*,end=100)i,(x(j),j=1,6)
|
||||
! if(i.le.1)goto 10
|
||||
! nsamp=nsamp+1
|
||||
! do j=1,6
|
||||
! sample(nsamp,j)=x(j)
|
||||
! enddo
|
||||
! goto 10
|
||||
!100 close(1)
|
||||
! mdim=6
|
||||
! mpc=2
|
||||
! call princompana(nsamp,mdim,sample(1:nsamp,1:mdim),mpc,
|
||||
! &princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim),
|
||||
! &eigenvector(1:mdim,1:mdim),eigenvalue)
|
||||
! do i=1,mpc
|
||||
! do j=1,nsamp
|
||||
! write(*,*)j,princomp(j,i)
|
||||
! enddo
|
||||
! enddo
|
||||
! do i=1,mdim
|
||||
! do j=1,nsamp
|
||||
! write(*,*)j,transdata(j,i)
|
||||
! enddo
|
||||
! enddo
|
||||
! end
|
||||
|
||||
subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata,
|
||||
&eigenvector,eigenvalue)
|
||||
implicit none
|
||||
!-----------Inputs----------------------------------------
|
||||
!mpc is the number of principal components to keep
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(nsamp,mdim)
|
||||
!-----------Outputs---------------------------------------
|
||||
!princomp is the projection of a sample on the principal axes
|
||||
!transdata is the data of the orginal sample filtered with mpc principal components
|
||||
double precision eigenvalue(mdim),eigenvector(mdim,mdim),
|
||||
&sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim),
|
||||
&sampadj(nsamp,mdim)
|
||||
!---------------------------------------------------------
|
||||
integer i,j,k
|
||||
call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,
|
||||
&eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
princomp(j,i)=0.0d0
|
||||
do k=1,mdim
|
||||
princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do j=1,mdim
|
||||
do i=1,nsamp
|
||||
transdata(i,j)=sampmean(j)
|
||||
do k=1,mpc
|
||||
transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,
|
||||
&sampmean,sampadj)
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),eigenvalue(mdim),
|
||||
&eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
|
||||
!to the smallest eigenvalue
|
||||
call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),
|
||||
&eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
call eigen_sym_up(mdim,eigenvector(1:mdim,1:mdim),eigenvalue)
|
||||
return
|
||||
end
|
||||
|
||||
subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,
|
||||
&sampmean,sampadj)
|
||||
implicit none
|
||||
!covarmatrix is an upper trangle
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),
|
||||
&sampmean(mdim),sampadj(nsamp,mdim)
|
||||
integer i,j,k
|
||||
do j=1,mdim
|
||||
sampmean(j)=0.0d0
|
||||
do i=1,nsamp
|
||||
sampmean(j)=sampmean(j)+sample(i,j)
|
||||
enddo
|
||||
sampmean(j)=sampmean(j)/dble(nsamp)
|
||||
do i=1,nsamp
|
||||
sampadj(i,j)=sample(i,j)-sampmean(j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=i,mdim
|
||||
covarmatrix(i,j)=0.0d0
|
||||
do k=1,nsamp
|
||||
covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
|
||||
enddo
|
||||
covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,91 @@
|
||||
Group WDIM CIRCUM FBEYE EYEHD EARHD JAW
|
||||
1 13.5 57.2 19.5 12.5 14.0 11.0
|
||||
1 15.5 58.4 21.0 12.0 16.0 12.0
|
||||
1 14.5 55.9 19.0 10.0 13.0 12.0
|
||||
1 15.5 58.4 20.0 13.5 15.0 12.0
|
||||
1 14.5 58.4 20.0 13.0 15.5 12.0
|
||||
1 14.0 61.0 21.0 12.0 14.0 13.0
|
||||
1 15.0 58.4 19.5 13.5 15.5 13.0
|
||||
1 15.0 58.4 21.0 13.0 14.0 13.0
|
||||
1 15.5 59.7 20.5 13.5 14.5 12.5
|
||||
1 15.5 59.7 20.5 13.0 15.0 13.0
|
||||
1 15.0 57.2 19.0 14.0 14.5 11.5
|
||||
1 15.5 59.7 21.0 13.0 16.0 12.5
|
||||
1 16.0 57.2 19.0 14.0 14.5 12.0
|
||||
1 15.5 62.2 21.5 14.0 16.0 12.0
|
||||
1 15.5 57.2 19.5 13.5 15.0 12.0
|
||||
1 14.0 61.0 20.0 15.0 15.0 12.0
|
||||
1 14.5 58.4 20.0 12.0 14.5 12.0
|
||||
1 15.0 56.9 19.0 13.0 14.0 12.5
|
||||
1 15.5 59.7 20.0 12.5 14.0 12.5
|
||||
1 15.0 57.2 19.5 12.0 14.0 11.0
|
||||
1 15.0 56.9 19.0 12.0 13.0 12.0
|
||||
1 15.5 56.9 19.5 14.5 14.5 13.0
|
||||
1 17.5 63.5 21.5 14.0 15.5 13.5
|
||||
1 15.5 57.2 19.0 13.0 15.5 12.5
|
||||
1 15.5 61.0 20.5 12.0 13.0 12.5
|
||||
1 15.5 61.0 21.0 14.5 15.5 12.5
|
||||
1 15.5 63.5 21.8 14.5 16.5 13.5
|
||||
1 14.5 58.4 20.5 13.0 16.0 10.5
|
||||
1 15.5 56.9 20.0 13.5 14.0 12.0
|
||||
1 16.0 61.0 20.0 12.5 14.5 12.5
|
||||
2 15.5 60.0 21.1 10.3 13.4 12.4
|
||||
2 15.4 59.7 20.0 12.8 14.5 11.3
|
||||
2 15.1 59.7 20.2 11.4 14.1 12.1
|
||||
2 14.3 56.9 18.9 11.0 13.4 11.0
|
||||
2 14.8 58.0 20.1 9.6 11.1 11.7
|
||||
2 15.2 57.5 18.5 9.9 12.8 11.4
|
||||
2 15.4 58.0 20.8 10.2 12.8 11.9
|
||||
2 16.3 58.0 20.1 8.8 13.0 12.9
|
||||
2 15.5 57.0 19.6 10.5 13.9 11.8
|
||||
2 15.0 56.5 19.6 10.4 14.5 12.0
|
||||
2 15.5 57.2 20.0 11.2 13.4 12.4
|
||||
2 15.5 56.5 19.8 9.2 12.8 12.2
|
||||
2 15.7 57.5 19.8 11.8 12.6 12.5
|
||||
2 14.4 57.0 20.4 10.2 12.7 12.3
|
||||
2 14.9 54.8 18.5 11.2 13.8 11.3
|
||||
2 16.5 59.8 20.2 9.4 14.3 12.2
|
||||
2 15.5 56.1 18.8 9.8 13.8 12.6
|
||||
2 15.3 55.0 19.0 10.1 14.2 11.6
|
||||
2 14.5 55.6 19.3 12.0 12.6 11.6
|
||||
2 15.5 56.5 20.0 9.9 13.4 11.5
|
||||
2 15.2 55.0 19.3 9.9 14.4 11.9
|
||||
2 15.3 56.5 19.3 9.1 12.8 11.7
|
||||
2 15.3 56.8 20.2 8.6 14.2 11.5
|
||||
2 15.8 55.5 19.2 8.2 13.0 12.6
|
||||
2 14.8 57.0 20.2 9.8 13.8 10.5
|
||||
2 15.2 56.9 19.1 9.6 13.0 11.2
|
||||
2 15.9 58.8 21.0 8.6 13.5 11.8
|
||||
2 15.5 57.3 20.1 9.6 14.1 12.3
|
||||
2 16.5 58.0 19.5 9.0 13.9 13.3
|
||||
2 17.3 62.6 21.5 10.3 13.8 12.8
|
||||
3 14.9 56.5 20.4 7.4 13.0 12.0
|
||||
3 15.4 57.5 19.5 10.5 13.8 11.5
|
||||
3 15.3 55.4 19.2 9.7 13.3 11.5
|
||||
3 14.6 56.0 19.8 8.5 12.0 11.5
|
||||
3 16.2 56.5 19.5 11.5 14.5 11.8
|
||||
3 14.6 58.0 19.9 13.0 13.4 11.5
|
||||
3 15.9 56.7 18.7 10.8 12.8 12.6
|
||||
3 14.7 55.8 18.7 11.1 13.9 11.2
|
||||
3 15.5 58.5 19.4 11.5 13.4 11.9
|
||||
3 16.1 60.0 20.3 10.6 13.7 12.2
|
||||
3 15.2 57.8 19.9 10.4 13.5 11.4
|
||||
3 15.1 56.0 19.4 10.0 13.1 10.9
|
||||
3 15.9 59.8 20.5 12.0 13.6 11.5
|
||||
3 16.1 57.7 19.7 10.2 13.6 11.5
|
||||
3 15.7 58.7 20.7 11.3 13.6 11.3
|
||||
3 15.3 56.9 19.6 10.5 13.5 12.1
|
||||
3 15.3 56.9 19.5 9.9 14.0 12.1
|
||||
3 15.2 58.0 20.6 11.0 15.1 11.7
|
||||
3 16.6 59.3 19.9 12.1 14.6 12.1
|
||||
3 15.5 58.2 19.7 11.7 13.8 12.1
|
||||
3 15.8 57.5 18.9 11.8 14.7 11.8
|
||||
3 16.0 57.2 19.8 10.8 13.9 12.0
|
||||
3 15.4 57.0 19.8 11.3 14.0 11.4
|
||||
3 16.0 59.2 20.8 10.4 13.8 12.2
|
||||
3 15.4 57.6 19.6 10.2 13.9 11.7
|
||||
3 15.8 60.3 20.8 12.4 13.4 12.1
|
||||
3 15.4 55.0 18.8 10.7 14.2 10.8
|
||||
3 15.5 58.4 19.8 13.1 14.5 11.7
|
||||
3 15.7 59.0 20.4 12.1 13.0 12.7
|
||||
3 17.3 61.7 20.7 11.9 13.3 13.3
|
||||
@@ -0,0 +1,69 @@
|
||||
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DAXPY constant times a vector plus a vector.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (DA.EQ.0.0d0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,4)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DY(I) + DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
IF (N.LT.4) RETURN
|
||||
MP1 = M + 1
|
||||
DO 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)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DY(IY) + DA*DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,70 @@
|
||||
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DCOPY copies a vector, x, to a vector, y.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,7)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DX(I)
|
||||
END DO
|
||||
IF (N.LT.7) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO 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)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,72 @@
|
||||
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DDOT forms the dot product of two vectors.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
DDOT = 0.0d0
|
||||
DTEMP = 0.0d0
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DTEMP + DX(I)*DY(I)
|
||||
END DO
|
||||
IF (N.LT.5) THEN
|
||||
DDOT=DTEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO 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)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DTEMP + DX(IX)*DY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
DDOT = DTEMP
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,316 @@
|
||||
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGEMM performs one of the matrix-matrix operations
|
||||
*
|
||||
* C := alpha*op( A )*op( B ) + beta*C,
|
||||
*
|
||||
* where op( X ) is one of
|
||||
*
|
||||
* op( X ) = X or op( X ) = X**T,
|
||||
*
|
||||
* alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* TRANSA - CHARACTER*1.
|
||||
* On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*
|
||||
* TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*
|
||||
* TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANSB - CHARACTER*1.
|
||||
* On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*
|
||||
* TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*
|
||||
* TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix
|
||||
* op( A ) and of the matrix C. M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix
|
||||
* op( B ) and the number of columns of the matrix C. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry, K specifies the number of columns of the matrix
|
||||
* op( A ) and the number of rows of the matrix op( B ). K must
|
||||
* be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
* k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
* Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
* part of the array A must contain the matrix A, otherwise
|
||||
* the leading k by m part of the array A must contain the
|
||||
* matrix A.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
* LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
* least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
* n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
* Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
* part of the array B must contain the matrix B, otherwise
|
||||
* the leading n by k part of the array B must contain the
|
||||
* matrix B.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
* LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
* least max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then C need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
* Before entry, the leading m by n part of the array C must
|
||||
* contain the matrix C, except when beta is zero, in which
|
||||
* case C need not be set on entry.
|
||||
* On exit, the array C is overwritten by the m by n matrix
|
||||
* ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*
|
||||
* LDC - INTEGER.
|
||||
* On entry, LDC specifies the first dimension of C as declared
|
||||
* in the calling (sub) program. LDC must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* transposed and set NROWA, NCOLA and NROWB as the number of rows
|
||||
* and columns of A and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And if alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
130 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 140 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
DO 160 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
DO 190 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 180 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
180 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMM .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,265 @@
|
||||
SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGEMV performs one of the matrix-vector operations
|
||||
*
|
||||
* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are vectors and A is an
|
||||
* m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*
|
||||
* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*
|
||||
* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix A.
|
||||
* M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry, the leading m by n part of the array A must
|
||||
* contain the matrix of coefficients.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
* and at least
|
||||
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
* Before entry, the incremented array X must contain the
|
||||
* vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
* and at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
* Before entry with BETA non-zero, the incremented array Y
|
||||
* must contain the vector y. On exit, Y is overwritten by the
|
||||
* updated vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
DO 110 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,162 @@
|
||||
SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGER performs the rank 1 operation
|
||||
*
|
||||
* A := alpha*x*y**T + A,
|
||||
*
|
||||
* where alpha is a scalar, x is an m element vector, y is an n element
|
||||
* vector and A is an m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix A.
|
||||
* M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the m
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry, the leading m by n part of the array A must
|
||||
* contain the matrix of coefficients. On exit, A is
|
||||
* overwritten by the updated matrix.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGER ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGER .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,67 @@
|
||||
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DNRM2 := sqrt( x'*x )
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* -- This version written on 25-October-1982.
|
||||
* Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
* Sven Hammarling, Nag Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DNRM2.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,64 @@
|
||||
SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSCAL scales a vector by a constant.
|
||||
* uses unrolled loops for increment equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 3/93 to return if incx .le. 0.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
IF (N.LT.5) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
DX(I) = DA*DX(I)
|
||||
DX(I+1) = DA*DX(I+1)
|
||||
DX(I+2) = DA*DX(I+2)
|
||||
DX(I+3) = DA*DX(I+3)
|
||||
DX(I+4) = DA*DX(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,77 @@
|
||||
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* interchanges two vectors.
|
||||
* uses unrolled loops for increments equal one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,3)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DX(I)
|
||||
DX(I) = DY(I)
|
||||
DY(I) = DTEMP
|
||||
END DO
|
||||
IF (N.LT.3) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO 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
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DX(IX)
|
||||
DX(IX) = DY(IY)
|
||||
DY(IY) = DTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,266 @@
|
||||
SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n symmetric matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array A is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of A is not referenced.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y. On exit, Y is overwritten by the updated
|
||||
* vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when A is stored in upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 I = 1,J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when A is stored in lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*A(J,J)
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,233 @@
|
||||
SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2 performs the symmetric rank 2 operation
|
||||
*
|
||||
* A := alpha*x*y**T + alpha*y*x**T + A,
|
||||
*
|
||||
* where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
* by n symmetric matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array A is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of A is not referenced. On exit, the
|
||||
* upper triangular part of the array A is overwritten by the
|
||||
* upper triangular part of the updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of A is not referenced. On exit, the
|
||||
* lower triangular part of the array A is overwritten by the
|
||||
* lower triangular part of the updated matrix.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 10 I = 1,J
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 I = 1,J
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 50 I = J,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 I = J,N
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2 .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,329 @@
|
||||
SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2K performs one of the symmetric rank 2k operations
|
||||
*
|
||||
* C := alpha*A*B**T + alpha*B*A**T + beta*C,
|
||||
*
|
||||
* or
|
||||
*
|
||||
* C := alpha*A**T*B + alpha*B**T*A + beta*C,
|
||||
*
|
||||
* where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
* and A and B are n by k matrices in the first case and k by n
|
||||
* matrices in the second case.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array C is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A +
|
||||
* beta*C.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix C. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
* of columns of the matrices A and B, and on entry with
|
||||
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
|
||||
* of rows of the matrices A and B. K must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
* k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
* Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
* part of the array A must contain the matrix A, otherwise
|
||||
* the leading k by n part of the array A must contain the
|
||||
* matrix A.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
* then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
* be at least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
* k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
* Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
* part of the array B must contain the matrix B, otherwise
|
||||
* the leading k by n part of the array B must contain the
|
||||
* matrix B.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
* then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
* be at least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array C must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of C is not referenced. On exit, the
|
||||
* upper triangular part of the array C is overwritten by the
|
||||
* upper triangular part of the updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array C must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of C is not referenced. On exit, the
|
||||
* lower triangular part of the array C is overwritten by the
|
||||
* lower triangular part of the updated matrix.
|
||||
*
|
||||
* LDC - INTEGER.
|
||||
* On entry, LDC specifies the first dimension of C as declared
|
||||
* in the calling (sub) program. LDC must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + alpha*B*A**T + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + alpha*B**T*A + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2K.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,349 @@
|
||||
SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRMM performs one of the matrix-matrix operations
|
||||
*
|
||||
* B := alpha*op( A )*B, or B := alpha*B*op( A ),
|
||||
*
|
||||
* where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
* non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*
|
||||
* op( A ) = A or op( A ) = A**T.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* SIDE - CHARACTER*1.
|
||||
* On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
* the left or right as follows:
|
||||
*
|
||||
* SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
*
|
||||
* SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the matrix A is an upper or
|
||||
* lower triangular matrix as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*
|
||||
* UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANSA - CHARACTER*1.
|
||||
* On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*
|
||||
* TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*
|
||||
* TRANSA = 'C' or 'c' op( A ) = A**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* DIAG - CHARACTER*1.
|
||||
* On entry, DIAG specifies whether or not A is unit triangular
|
||||
* as follows:
|
||||
*
|
||||
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*
|
||||
* DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
* triangular.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of B. M must be at
|
||||
* least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of B. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
* zero then A is not referenced and B need not be set before
|
||||
* entry.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
|
||||
* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
* Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular matrix and the strictly lower triangular part of
|
||||
* A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular matrix and the strictly upper triangular part of
|
||||
* A is not referenced.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced either, but are assumed to be unity.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
* then LDA must be at least max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
|
||||
* Before entry, the leading m by n part of the array B must
|
||||
* contain the matrix B, and on exit is overwritten by the
|
||||
* transformed matrix.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. LDB must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*A*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 50 J = 1,N
|
||||
DO 40 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
DO 30 I = 1,K - 1
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
B(K,J) = TEMP
|
||||
END IF
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
B(K,J) = TEMP
|
||||
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
|
||||
DO 60 I = K + 1,M
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*A**T*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 110 J = 1,N
|
||||
DO 100 I = M,1,-1
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 90 K = 1,I - 1
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
90 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
DO 130 I = 1,M
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 120 K = I + 1,M
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
120 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*A.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 180 J = N,1,-1
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
150 CONTINUE
|
||||
DO 170 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 160 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
DO 220 J = 1,N
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 190 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
190 CONTINUE
|
||||
DO 210 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 200 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*A**T.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 260 K = 1,N
|
||||
DO 240 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 230 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 250 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
ELSE
|
||||
DO 300 K = N,1,-1
|
||||
DO 280 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 270 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 290 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
300 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMM .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,282 @@
|
||||
SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A**T*x,
|
||||
*
|
||||
* where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
* upper or lower triangular matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the matrix is an upper or
|
||||
* lower triangular matrix as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*
|
||||
* UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' x := A*x.
|
||||
*
|
||||
* TRANS = 'T' or 't' x := A**T*x.
|
||||
*
|
||||
* TRANS = 'C' or 'c' x := A**T*x.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* DIAG - CHARACTER*1.
|
||||
* On entry, DIAG specifies whether or not A is unit
|
||||
* triangular as follows:
|
||||
*
|
||||
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*
|
||||
* DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
* triangular.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular matrix and the strictly lower triangular part of
|
||||
* A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular matrix and the strictly upper triangular part of
|
||||
* A is not referenced.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced either, but are assumed to be unity.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x. On exit, X is overwritten with the
|
||||
* tranformed vector x.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 I = N,J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 120 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 110 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 130 I = J + 1,N
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
130 CONTINUE
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
150 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,38 @@
|
||||
SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs)
|
||||
INTEGER ma,mp,ndata,np,NMAX,MMAX
|
||||
REAL chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),x(ndata),
|
||||
*y(ndata),TOL
|
||||
EXTERNAL funcs
|
||||
PARAMETER (NMAX=1000,MMAX=50,TOL=1.e-5)
|
||||
CU USES svbksb,svdcmp
|
||||
INTEGER i,j
|
||||
REAL sum,thresh,tmp,wmax,afunc(MMAX),b(NMAX)
|
||||
do 12 i=1,ndata
|
||||
call funcs(x(i),afunc,ma)
|
||||
tmp=1./sig(i)
|
||||
do 11 j=1,ma
|
||||
u(i,j)=afunc(j)*tmp
|
||||
11 continue
|
||||
b(i)=y(i)*tmp
|
||||
12 continue
|
||||
call svdcmp(u,ndata,ma,mp,np,w,v)
|
||||
wmax=0.
|
||||
do 13 j=1,ma
|
||||
if(w(j).gt.wmax)wmax=w(j)
|
||||
13 continue
|
||||
thresh=TOL*wmax
|
||||
do 14 j=1,ma
|
||||
if(w(j).lt.thresh)w(j)=0.
|
||||
14 continue
|
||||
call svbksb(u,w,v,ndata,ma,mp,np,b,a)
|
||||
chisq=0.
|
||||
do 16 i=1,ndata
|
||||
call funcs(x(i),afunc,ma)
|
||||
sum=0.
|
||||
do 15 j=1,ma
|
||||
sum=sum+a(j)*afunc(j)
|
||||
15 continue
|
||||
chisq=chisq+((y(i)-sum)/sig(i))**2
|
||||
16 continue
|
||||
return
|
||||
END
|
||||
Reference in New Issue
Block a user