[cantera]: removing deprecated blas dir
This commit is contained in:
Nicholas Malaya
parent
eaeb49c22e
commit
cf336ff305
45 changed files with 5 additions and 7413 deletions
|
|
@ -1,24 +0,0 @@
|
|||
fc_sources = dasum.f dcabs1.f ddot.f dgemm.f dger.f drot.f drotm.f \
|
||||
dsbmv.f dsdot.f dspr2.f dswap.f dsymv.f dsyr2k.f \
|
||||
dsyrk.f dtbsv.f dtpsv.f dtrmv.f dtrsv.f dznrm2.f \
|
||||
idamax.f izamax.f xerbla.f daxpy.f dcopy.f dgbmv.f \
|
||||
dgemv.f dnrm2.f drotg.f drotmg.f dscal.f dspmv.f \
|
||||
dspr.f dsymm.f dsyr2.f dsyr.f dtbmv.f dtpmv.f dtrmm.f \
|
||||
dtrsm.f dzasum.f icamax.f isamax.f lsame.f
|
||||
|
||||
AM_CPPFLAGS =
|
||||
AM_CXXFLAGS = $(AM_CPPFLAGS)
|
||||
AM_FCFLAGS = $(AM_CPPFLAGS)
|
||||
|
||||
lib_LTLIBRARIES = $(top_builddir)/build/lib/libctblas.la
|
||||
library_includedir = $(top_builddir)/build/include
|
||||
library_include_HEADERS = $(h_sources)
|
||||
|
||||
#-----------------------
|
||||
# Cantera Converters C/C++ library
|
||||
#-----------------------
|
||||
|
||||
__top_builddir__build_lib_libctblas_la_LDFLAGS = $(all_libraries) -release $(GENERIC_RELEASE)
|
||||
__top_builddir__build_lib_libctblas_la_SOURCES = $(fc_sources) $(cc_sources)
|
||||
|
||||
CLEANFILES = *.o
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
double precision function dasum(n,dx,incx)
|
||||
c
|
||||
c takes the sum of the absolute values.
|
||||
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(*),dtemp
|
||||
integer i,incx,m,mp1,n,nincx
|
||||
c
|
||||
dasum = 0.0d0
|
||||
dtemp = 0.0d0
|
||||
if( n.le.0 .or. incx.le.0 )return
|
||||
if(incx.eq.1)go to 20
|
||||
c
|
||||
c code for increment not equal to 1
|
||||
c
|
||||
nincx = n*incx
|
||||
do 10 i = 1,nincx,incx
|
||||
dtemp = dtemp + dabs(dx(i))
|
||||
10 continue
|
||||
dasum = dtemp
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
c
|
||||
c clean-up loop
|
||||
c
|
||||
20 m = mod(n,6)
|
||||
if( m .eq. 0 ) go to 40
|
||||
do 30 i = 1,m
|
||||
dtemp = dtemp + dabs(dx(i))
|
||||
30 continue
|
||||
if( n .lt. 6 ) go to 60
|
||||
40 mp1 = m + 1
|
||||
do 50 i = mp1,n,6
|
||||
dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2))
|
||||
* + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
|
||||
50 continue
|
||||
60 dasum = dtemp
|
||||
return
|
||||
end
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
subroutine daxpy(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
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
double precision function dcabs1(z)
|
||||
double complex z,zz
|
||||
double precision t(2)
|
||||
equivalence (zz,t(1))
|
||||
zz = z
|
||||
dcabs1 = dabs(t(1)) + dabs(t(2))
|
||||
return
|
||||
end
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
subroutine dcopy(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
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
double precision function ddot(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
|
||||
ddot = 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
|
||||
ddot = 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 ddot = dtemp
|
||||
return
|
||||
end
|
||||
|
|
@ -1,300 +0,0 @@
|
|||
SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
|
||||
$ BETA, Y, INCY )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
INTEGER INCX, INCY, KL, KU, LDA, M, N
|
||||
CHARACTER*1 TRANS
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGBMV performs one of the matrix-vector operations
|
||||
*
|
||||
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are vectors and A is an
|
||||
* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'*x + beta*y.
|
||||
*
|
||||
* TRANS = 'C' or 'c' y := alpha*A'*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.
|
||||
*
|
||||
* KL - INTEGER.
|
||||
* On entry, KL specifies the number of sub-diagonals of the
|
||||
* matrix A. KL must satisfy 0 .le. KL.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* KU - INTEGER.
|
||||
* On entry, KU specifies the number of super-diagonals of the
|
||||
* matrix A. KU must satisfy 0 .le. KU.
|
||||
* 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 ( kl + ku + 1 ) by n part of the
|
||||
* array A must contain the matrix of coefficients, supplied
|
||||
* column by column, with the leading diagonal of the matrix in
|
||||
* row ( ku + 1 ) of the array, the first super-diagonal
|
||||
* starting at position 2 in row ku, the first sub-diagonal
|
||||
* starting at position 1 in row ( ku + 2 ), and so on.
|
||||
* Elements in the array A that do not correspond to elements
|
||||
* in the band matrix (such as the top left ku by ku triangle)
|
||||
* are not referenced.
|
||||
* The following program segment will transfer a band matrix
|
||||
* from conventional full matrix storage to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* K = KU + 1 - J
|
||||
* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
* A( K + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* 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
|
||||
* ( kl + ku + 1 ).
|
||||
* 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, 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.
|
||||
*
|
||||
*
|
||||
* 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 ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
|
||||
$ LENX, LENY
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( KL.LT.0 )THEN
|
||||
INFO = 4
|
||||
ELSE IF( KU.LT.0 )THEN
|
||||
INFO = 5
|
||||
ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN
|
||||
INFO = 8
|
||||
ELSE IF( INCX.EQ.0 )THEN
|
||||
INFO = 10
|
||||
ELSE IF( INCY.EQ.0 )THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DGBMV ', 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 the band 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, 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
|
||||
KUP1 = KU + 1
|
||||
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 )
|
||||
K = KUP1 - J
|
||||
DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
Y( I ) = Y( I ) + TEMP*A( K + 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
|
||||
K = KUP1 - J
|
||||
DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
Y( IY ) = Y( IY ) + TEMP*A( K + I, J )
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF( J.GT.KU )
|
||||
$ KY = KY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A'*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = 1, N
|
||||
TEMP = ZERO
|
||||
K = KUP1 - J
|
||||
DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
TEMP = TEMP + A( K + 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
|
||||
K = KUP1 - J
|
||||
DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
TEMP = TEMP + A( K + I, J )*X( IX )
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y( JY ) = Y( JY ) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
IF( J.GT.KU )
|
||||
$ KX = KX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,313 +0,0 @@
|
|||
SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
|
||||
$ BETA, C, LDC )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 TRANSA, TRANSB
|
||||
INTEGER M, N, K, LDA, LDB, LDC
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
* .. 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',
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'.
|
||||
*
|
||||
* TRANSA = 'C' or 'c', op( A ) = A'.
|
||||
*
|
||||
* 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'.
|
||||
*
|
||||
* TRANSB = 'C' or 'c', op( B ) = B'.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL NOTA, NOTB
|
||||
INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
|
||||
DOUBLE PRECISION TEMP
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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'*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' + 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'*B' + 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
|
||||
|
|
@ -1,261 +0,0 @@
|
|||
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*1 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'*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are vectors and A is an
|
||||
* m by n matrix.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'*x + beta*y.
|
||||
*
|
||||
* TRANS = 'C' or 'c' y := alpha*A'*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.
|
||||
*
|
||||
*
|
||||
* 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 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
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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'*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
|
||||
|
|
@ -1,157 +0,0 @@
|
|||
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' + 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.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X( * )
|
||||
* ..
|
||||
*
|
||||
* DNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DNRM2 := sqrt( x'*x )
|
||||
*
|
||||
*
|
||||
*
|
||||
* -- 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 ..
|
||||
INTEGER IX
|
||||
DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
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
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
subroutine drot (n,dx,incx,dy,incy,c,s)
|
||||
c
|
||||
c applies a plane rotation.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c modified 12/3/93, array(1) declarations changed to array(*)
|
||||
c
|
||||
double precision dx(*),dy(*),dtemp,c,s
|
||||
integer i,incx,incy,ix,iy,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 = c*dx(ix) + s*dy(iy)
|
||||
dy(iy) = c*dy(iy) - s*dx(ix)
|
||||
dx(ix) = dtemp
|
||||
ix = ix + incx
|
||||
iy = iy + incy
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for both increments equal to 1
|
||||
c
|
||||
20 do 30 i = 1,n
|
||||
dtemp = c*dx(i) + s*dy(i)
|
||||
dy(i) = c*dy(i) - s*dx(i)
|
||||
dx(i) = dtemp
|
||||
30 continue
|
||||
return
|
||||
end
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
subroutine drotg(da,db,c,s)
|
||||
c
|
||||
c construct givens plane rotation.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c
|
||||
double precision da,db,c,s,roe,scale,r,z
|
||||
c
|
||||
roe = db
|
||||
if( dabs(da) .gt. dabs(db) ) roe = da
|
||||
scale = dabs(da) + dabs(db)
|
||||
if( scale .ne. 0.0d0 ) go to 10
|
||||
c = 1.0d0
|
||||
s = 0.0d0
|
||||
r = 0.0d0
|
||||
z = 0.0d0
|
||||
go to 20
|
||||
10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
|
||||
r = dsign(1.0d0,roe)*r
|
||||
c = da/r
|
||||
s = db/r
|
||||
z = 1.0d0
|
||||
if( dabs(da) .gt. dabs(db) ) z = s
|
||||
if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c
|
||||
20 da = r
|
||||
db = z
|
||||
return
|
||||
end
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM)
|
||||
C
|
||||
C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
|
||||
C
|
||||
C (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
|
||||
C (DY**T)
|
||||
C
|
||||
C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
|
||||
C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
|
||||
C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
C
|
||||
C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
C
|
||||
C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
C H=( ) ( ) ( ) ( )
|
||||
C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
C SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
|
||||
C
|
||||
DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21,
|
||||
1 DPARAM,DY,W,ZERO
|
||||
DIMENSION DX(1),DY(1),DPARAM(5)
|
||||
DATA ZERO,TWO/0.D0,2.D0/
|
||||
C
|
||||
DFLAG=DPARAM(1)
|
||||
IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140
|
||||
IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70
|
||||
C
|
||||
NSTEPS=N*INCX
|
||||
IF(DFLAG) 50,10,30
|
||||
10 CONTINUE
|
||||
DH12=DPARAM(4)
|
||||
DH21=DPARAM(3)
|
||||
DO 20 I=1,NSTEPS,INCX
|
||||
W=DX(I)
|
||||
Z=DY(I)
|
||||
DX(I)=W+Z*DH12
|
||||
DY(I)=W*DH21+Z
|
||||
20 CONTINUE
|
||||
GO TO 140
|
||||
30 CONTINUE
|
||||
DH11=DPARAM(2)
|
||||
DH22=DPARAM(5)
|
||||
DO 40 I=1,NSTEPS,INCX
|
||||
W=DX(I)
|
||||
Z=DY(I)
|
||||
DX(I)=W*DH11+Z
|
||||
DY(I)=-W+DH22*Z
|
||||
40 CONTINUE
|
||||
GO TO 140
|
||||
50 CONTINUE
|
||||
DH11=DPARAM(2)
|
||||
DH12=DPARAM(4)
|
||||
DH21=DPARAM(3)
|
||||
DH22=DPARAM(5)
|
||||
DO 60 I=1,NSTEPS,INCX
|
||||
W=DX(I)
|
||||
Z=DY(I)
|
||||
DX(I)=W*DH11+Z*DH12
|
||||
DY(I)=W*DH21+Z*DH22
|
||||
60 CONTINUE
|
||||
GO TO 140
|
||||
70 CONTINUE
|
||||
KX=1
|
||||
KY=1
|
||||
IF(INCX .LT. 0) KX=1+(1-N)*INCX
|
||||
IF(INCY .LT. 0) KY=1+(1-N)*INCY
|
||||
C
|
||||
IF(DFLAG)120,80,100
|
||||
80 CONTINUE
|
||||
DH12=DPARAM(4)
|
||||
DH21=DPARAM(3)
|
||||
DO 90 I=1,N
|
||||
W=DX(KX)
|
||||
Z=DY(KY)
|
||||
DX(KX)=W+Z*DH12
|
||||
DY(KY)=W*DH21+Z
|
||||
KX=KX+INCX
|
||||
KY=KY+INCY
|
||||
90 CONTINUE
|
||||
GO TO 140
|
||||
100 CONTINUE
|
||||
DH11=DPARAM(2)
|
||||
DH22=DPARAM(5)
|
||||
DO 110 I=1,N
|
||||
W=DX(KX)
|
||||
Z=DY(KY)
|
||||
DX(KX)=W*DH11+Z
|
||||
DY(KY)=-W+DH22*Z
|
||||
KX=KX+INCX
|
||||
KY=KY+INCY
|
||||
110 CONTINUE
|
||||
GO TO 140
|
||||
120 CONTINUE
|
||||
DH11=DPARAM(2)
|
||||
DH12=DPARAM(4)
|
||||
DH21=DPARAM(3)
|
||||
DH22=DPARAM(5)
|
||||
DO 130 I=1,N
|
||||
W=DX(KX)
|
||||
Z=DY(KY)
|
||||
DX(KX)=W*DH11+Z*DH12
|
||||
DY(KY)=W*DH21+Z*DH22
|
||||
KX=KX+INCX
|
||||
KY=KY+INCY
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,169 +0,0 @@
|
|||
SUBROUTINE DROTMG (DD1,DD2,DX1,DY1,DPARAM)
|
||||
C
|
||||
C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
||||
C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
|
||||
C DY2)**T.
|
||||
C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
C
|
||||
C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
C
|
||||
C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
C H=( ) ( ) ( ) ( )
|
||||
C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
|
||||
C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
|
||||
C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
|
||||
C
|
||||
C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
|
||||
C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
|
||||
C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
||||
C
|
||||
DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
|
||||
1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1,
|
||||
2 DTEMP,DX1,TWO
|
||||
DIMENSION DPARAM(5)
|
||||
C
|
||||
DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/
|
||||
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
|
||||
IF(.NOT. DD1 .LT. ZERO) GO TO 10
|
||||
C GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
10 CONTINUE
|
||||
C CASE-DD1-NONNEGATIVE
|
||||
DP2=DD2*DY1
|
||||
IF(.NOT. DP2 .EQ. ZERO) GO TO 20
|
||||
DFLAG=-TWO
|
||||
GO TO 260
|
||||
C REGULAR-CASE..
|
||||
20 CONTINUE
|
||||
DP1=DD1*DX1
|
||||
DQ2=DP2*DY1
|
||||
DQ1=DP1*DX1
|
||||
C
|
||||
IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40
|
||||
DH21=-DY1/DX1
|
||||
DH12=DP2/DP1
|
||||
C
|
||||
DU=ONE-DH12*DH21
|
||||
C
|
||||
IF(.NOT. DU .LE. ZERO) GO TO 30
|
||||
C GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
30 CONTINUE
|
||||
DFLAG=ZERO
|
||||
DD1=DD1/DU
|
||||
DD2=DD2/DU
|
||||
DX1=DX1*DU
|
||||
C GO SCALE-CHECK..
|
||||
GO TO 100
|
||||
40 CONTINUE
|
||||
IF(.NOT. DQ2 .LT. ZERO) GO TO 50
|
||||
C GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
50 CONTINUE
|
||||
DFLAG=ONE
|
||||
DH11=DP1/DP2
|
||||
DH22=DX1/DY1
|
||||
DU=ONE+DH11*DH22
|
||||
DTEMP=DD2/DU
|
||||
DD2=DD1/DU
|
||||
DD1=DTEMP
|
||||
DX1=DY1*DU
|
||||
C GO SCALE-CHECK
|
||||
GO TO 100
|
||||
C PROCEDURE..ZERO-H-D-AND-DX1..
|
||||
60 CONTINUE
|
||||
DFLAG=-ONE
|
||||
DH11=ZERO
|
||||
DH12=ZERO
|
||||
DH21=ZERO
|
||||
DH22=ZERO
|
||||
C
|
||||
DD1=ZERO
|
||||
DD2=ZERO
|
||||
DX1=ZERO
|
||||
C RETURN..
|
||||
GO TO 220
|
||||
C PROCEDURE..FIX-H..
|
||||
70 CONTINUE
|
||||
IF(.NOT. DFLAG .GE. ZERO) GO TO 90
|
||||
C
|
||||
IF(.NOT. DFLAG .EQ. ZERO) GO TO 80
|
||||
DH11=ONE
|
||||
DH22=ONE
|
||||
DFLAG=-ONE
|
||||
GO TO 90
|
||||
80 CONTINUE
|
||||
DH21=-ONE
|
||||
DH12=ONE
|
||||
DFLAG=-ONE
|
||||
90 CONTINUE
|
||||
GO TO IGO,(120,150,180,210)
|
||||
C PROCEDURE..SCALE-CHECK
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130
|
||||
IF(DD1 .EQ. ZERO) GO TO 160
|
||||
ASSIGN 120 TO IGO
|
||||
C FIX-H..
|
||||
GO TO 70
|
||||
120 CONTINUE
|
||||
DD1=DD1*GAM**2
|
||||
DX1=DX1/GAM
|
||||
DH11=DH11/GAM
|
||||
DH12=DH12/GAM
|
||||
GO TO 110
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
IF(.NOT. DD1 .GE. GAMSQ) GO TO 160
|
||||
ASSIGN 150 TO IGO
|
||||
C FIX-H..
|
||||
GO TO 70
|
||||
150 CONTINUE
|
||||
DD1=DD1/GAM**2
|
||||
DX1=DX1*GAM
|
||||
DH11=DH11*GAM
|
||||
DH12=DH12*GAM
|
||||
GO TO 140
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
IF(.NOT. DABS(DD2) .LE. RGAMSQ) GO TO 190
|
||||
IF(DD2 .EQ. ZERO) GO TO 220
|
||||
ASSIGN 180 TO IGO
|
||||
C FIX-H..
|
||||
GO TO 70
|
||||
180 CONTINUE
|
||||
DD2=DD2*GAM**2
|
||||
DH21=DH21/GAM
|
||||
DH22=DH22/GAM
|
||||
GO TO 170
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
IF(.NOT. DABS(DD2) .GE. GAMSQ) GO TO 220
|
||||
ASSIGN 210 TO IGO
|
||||
C FIX-H..
|
||||
GO TO 70
|
||||
210 CONTINUE
|
||||
DD2=DD2/GAM**2
|
||||
DH21=DH21*GAM
|
||||
DH22=DH22*GAM
|
||||
GO TO 200
|
||||
220 CONTINUE
|
||||
IF(DFLAG)250,230,240
|
||||
230 CONTINUE
|
||||
DPARAM(3)=DH21
|
||||
DPARAM(4)=DH12
|
||||
GO TO 260
|
||||
240 CONTINUE
|
||||
DPARAM(2)=DH11
|
||||
DPARAM(5)=DH22
|
||||
GO TO 260
|
||||
250 CONTINUE
|
||||
DPARAM(2)=DH11
|
||||
DPARAM(3)=DH21
|
||||
DPARAM(4)=DH12
|
||||
DPARAM(5)=DH22
|
||||
260 CONTINUE
|
||||
DPARAM(1)=DFLAG
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,303 +0,0 @@
|
|||
SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
|
||||
$ BETA, Y, INCY )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
INTEGER INCX, INCY, K, LDA, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSBMV 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 band matrix, with k super-diagonals.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the band matrix A is being supplied as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* being supplied.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* being supplied.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry, K specifies the number of super-diagonals of the
|
||||
* matrix A. K must satisfy 0 .le. K.
|
||||
* 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 ( k + 1 )
|
||||
* by n part of the array A must contain the upper triangular
|
||||
* band part of the symmetric matrix, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row
|
||||
* ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
* position 2 in row k, and so on. The top left k by k triangle
|
||||
* of the array A is not referenced.
|
||||
* The following program segment will transfer the upper
|
||||
* triangular part of a symmetric band matrix from conventional
|
||||
* full matrix storage to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = K + 1 - J
|
||||
* DO 10, I = MAX( 1, J - K ), J
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
* by n part of the array A must contain the lower triangular
|
||||
* band part of the symmetric matrix, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row 1 of
|
||||
* the array, the first sub-diagonal starting at position 1 in
|
||||
* row 2, and so on. The bottom right k by k triangle of the
|
||||
* array A is not referenced.
|
||||
* The following program segment will transfer the lower
|
||||
* triangular part of a symmetric band matrix from conventional
|
||||
* full matrix storage to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = 1 - J
|
||||
* DO 10, I = J, MIN( N, J + K )
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* 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
|
||||
* ( k + 1 ).
|
||||
* 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
|
||||
* 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.
|
||||
* 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
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 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, KPLUS1, KX, KY, L
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( K.LT.0 )THEN
|
||||
INFO = 3
|
||||
ELSE IF( LDA.LT.( K + 1 ) )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( 'DSBMV ', 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 the array 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, 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 upper triangle of A is stored.
|
||||
*
|
||||
KPLUS1 = K + 1
|
||||
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
||||
DO 60, J = 1, N
|
||||
TEMP1 = ALPHA*X( J )
|
||||
TEMP2 = ZERO
|
||||
L = KPLUS1 - J
|
||||
DO 50, I = MAX( 1, J - K ), J - 1
|
||||
Y( I ) = Y( I ) + TEMP1*A( L + I, J )
|
||||
TEMP2 = TEMP2 + A( L + I, J )*X( I )
|
||||
50 CONTINUE
|
||||
Y( J ) = Y( J ) + TEMP1*A( KPLUS1, 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
|
||||
L = KPLUS1 - J
|
||||
DO 70, I = MAX( 1, J - K ), J - 1
|
||||
Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
|
||||
TEMP2 = TEMP2 + A( L + I, J )*X( IX )
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
IF( J.GT.K )THEN
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END IF
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when lower triangle of A is stored.
|
||||
*
|
||||
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( 1, J )
|
||||
L = 1 - J
|
||||
DO 90, I = J + 1, MIN( N, J + K )
|
||||
Y( I ) = Y( I ) + TEMP1*A( L + I, J )
|
||||
TEMP2 = TEMP2 + A( L + 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( 1, J )
|
||||
L = 1 - J
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110, I = J + 1, MIN( N, J + K )
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
|
||||
TEMP2 = TEMP2 + A( L + 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 DSBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
subroutine dscal(n,da,dx,incx)
|
||||
c
|
||||
c scales a vector by a constant.
|
||||
c uses unrolled loops for increment equal to one.
|
||||
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 da,dx(*)
|
||||
integer i,incx,m,mp1,n,nincx
|
||||
c
|
||||
if( n.le.0 .or. incx.le.0 )return
|
||||
if(incx.eq.1)go to 20
|
||||
c
|
||||
c code for increment not equal to 1
|
||||
c
|
||||
nincx = n*incx
|
||||
do 10 i = 1,nincx,incx
|
||||
dx(i) = da*dx(i)
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for increment 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
|
||||
dx(i) = da*dx(i)
|
||||
30 continue
|
||||
if( n .lt. 5 ) return
|
||||
40 mp1 = m + 1
|
||||
do 50 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)
|
||||
50 continue
|
||||
return
|
||||
end
|
||||
|
|
@ -1,74 +0,0 @@
|
|||
*DECK DSDOT
|
||||
DOUBLE PRECISION FUNCTION DSDOT (N, SX, INCX, SY, INCY)
|
||||
C***BEGIN PROLOGUE DSDOT
|
||||
C***PURPOSE Compute the inner product of two vectors with extended
|
||||
C precision accumulation and result.
|
||||
C***LIBRARY SLATEC (BLAS)
|
||||
C***CATEGORY D1A4
|
||||
C***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C)
|
||||
C***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT,
|
||||
C LINEAR ALGEBRA, VECTOR
|
||||
C***AUTHOR Lawson, C. L., (JPL)
|
||||
C Hanson, R. J., (SNLA)
|
||||
C Kincaid, D. R., (U. of Texas)
|
||||
C Krogh, F. T., (JPL)
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C B L A S Subprogram
|
||||
C Description of Parameters
|
||||
C
|
||||
C --Input--
|
||||
C N number of elements in input vector(s)
|
||||
C SX single precision vector with N elements
|
||||
C INCX storage spacing between elements of SX
|
||||
C SY single precision vector with N elements
|
||||
C INCY storage spacing between elements of SY
|
||||
C
|
||||
C --Output--
|
||||
C DSDOT double precision dot product (zero if N.LE.0)
|
||||
C
|
||||
C Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
|
||||
C DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY),
|
||||
C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
|
||||
C defined in a similar way using INCY.
|
||||
C
|
||||
C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
|
||||
C Krogh, Basic linear algebra subprograms for Fortran
|
||||
C usage, Algorithm No. 539, Transactions on Mathematical
|
||||
C Software 5, 3 (September 1979), pp. 308-323.
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***REVISION HISTORY (YYMMDD)
|
||||
C 791001 DATE WRITTEN
|
||||
C 890831 Modified array declarations. (WRB)
|
||||
C 890831 REVISION DATE from Version 3.2
|
||||
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
||||
C 920310 Corrected definition of LX in DESCRIPTION. (WRB)
|
||||
C 920501 Reformatted the REFERENCES section. (WRB)
|
||||
C***END PROLOGUE DSDOT
|
||||
REAL SX(*),SY(*)
|
||||
C***FIRST EXECUTABLE STATEMENT DSDOT
|
||||
DSDOT = 0.0D0
|
||||
IF (N .LE. 0) RETURN
|
||||
IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
|
||||
C
|
||||
C Code for unequal or nonpositive increments.
|
||||
C
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX .LT. 0) KX = 1+(1-N)*INCX
|
||||
IF (INCY .LT. 0) KY = 1+(1-N)*INCY
|
||||
DO 10 I = 1,N
|
||||
DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
C
|
||||
C Code for equal, positive, non-unit increments.
|
||||
C
|
||||
20 NS = N*INCX
|
||||
DO 30 I = 1,NS,INCX
|
||||
DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
|
||||
30 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,262 +0,0 @@
|
|||
SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
INTEGER INCX, INCY, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP( * ), X( * ), Y( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSPMV 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, supplied in packed form.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on.
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 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, K, KK, KX, KY
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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 = 6
|
||||
ELSE IF( INCY.EQ.0 )THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSPMV ', 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 the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* 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
|
||||
KK = 1
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
||||
DO 60, J = 1, N
|
||||
TEMP1 = ALPHA*X( J )
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50, I = 1, J - 1
|
||||
Y( I ) = Y( I ) + TEMP1*AP( K )
|
||||
TEMP2 = TEMP2 + AP( K )*X( I )
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80, J = 1, N
|
||||
TEMP1 = ALPHA*X( JX )
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70, K = KK, KK + J - 2
|
||||
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
||||
TEMP2 = TEMP2 + AP( K )*X( IX )
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the 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*AP( KK )
|
||||
K = KK + 1
|
||||
DO 90, I = J + 1, N
|
||||
Y( I ) = Y( I ) + TEMP1*AP( K )
|
||||
TEMP2 = TEMP2 + AP( K )*X( I )
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y( J ) = Y( J ) + ALPHA*TEMP2
|
||||
KK = KK + ( N - J + 1 )
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120, J = 1, N
|
||||
TEMP1 = ALPHA*X( JX )
|
||||
TEMP2 = ZERO
|
||||
Y( JY ) = Y( JY ) + TEMP1*AP( KK )
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110, K = KK + 1, KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
||||
TEMP2 = TEMP2 + AP( K )*X( IX )
|
||||
110 CONTINUE
|
||||
Y( JY ) = Y( JY ) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + ( N - J + 1 )
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,198 +0,0 @@
|
|||
SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP( * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSPR performs the symmetric rank 1 operation
|
||||
*
|
||||
* A := alpha*x*x' + A,
|
||||
*
|
||||
* where alpha is a real scalar, x is an n element vector and A is an
|
||||
* n by n symmetric matrix, supplied in packed form.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
* AP is overwritten by the upper triangular part of the
|
||||
* updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
* AP is overwritten by the lower triangular part of the
|
||||
* updated matrix.
|
||||
*
|
||||
*
|
||||
* 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, JX, K, KK, KX
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSPR ', INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
||||
$ RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
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 the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( J )
|
||||
K = KK
|
||||
DO 10, I = 1, J
|
||||
AP( K ) = AP( K ) + X( I )*TEMP
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( JX )
|
||||
IX = KX
|
||||
DO 30, K = KK, KK + J - 1
|
||||
AP( K ) = AP( K ) + X( IX )*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( J )
|
||||
K = KK
|
||||
DO 50, I = J, N
|
||||
AP( K ) = AP( K ) + X( I )*TEMP
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( JX )
|
||||
IX = JX
|
||||
DO 70, K = KK, KK + N - J
|
||||
AP( K ) = AP( K ) + X( IX )*TEMP
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPR .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,229 +0,0 @@
|
|||
SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX, INCY, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP( * ), X( * ), Y( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSPR2 performs the symmetric rank 2 operation
|
||||
*
|
||||
* A := alpha*x*y' + alpha*y*x' + A,
|
||||
*
|
||||
* where alpha is a scalar, x and y are n element vectors and A is an
|
||||
* n by n symmetric matrix, supplied in packed form.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
* AP is overwritten by the upper triangular part of the
|
||||
* updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
* AP is overwritten by the lower triangular part of the
|
||||
* updated matrix.
|
||||
*
|
||||
*
|
||||
* 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, K, KK, KX, KY
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSPR2 ', 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 the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
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 )
|
||||
K = KK
|
||||
DO 10, I = 1, J
|
||||
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK + J
|
||||
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, K = KK, KK + J - 1
|
||||
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
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 )
|
||||
K = KK
|
||||
DO 50, I = J, N
|
||||
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
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, K = KK, KK + N - J
|
||||
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPR2 .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,294 +0,0 @@
|
|||
SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
|
||||
$ BETA, C, LDC )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 SIDE, UPLO
|
||||
INTEGER M, N, LDA, LDB, LDC
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYMM performs one of the matrix-matrix operations
|
||||
*
|
||||
* C := alpha*A*B + beta*C,
|
||||
*
|
||||
* or
|
||||
*
|
||||
* C := alpha*B*A + beta*C,
|
||||
*
|
||||
* where alpha and beta are scalars, A is a symmetric matrix and B and
|
||||
* C are m by n matrices.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* SIDE - CHARACTER*1.
|
||||
* On entry, SIDE specifies whether the symmetric matrix A
|
||||
* appears on the left or right in the operation as follows:
|
||||
*
|
||||
* SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
|
||||
*
|
||||
* SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the symmetric matrix A is to be
|
||||
* referenced as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of the
|
||||
* symmetric matrix is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of the
|
||||
* symmetric matrix is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows 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 C.
|
||||
* 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, ka ), where ka is
|
||||
* m when SIDE = 'L' or 'l' and is n otherwise.
|
||||
* Before entry with SIDE = 'L' or 'l', the m by m part of
|
||||
* the array A must contain the symmetric matrix, such that
|
||||
* when UPLO = 'U' or 'u', the leading m by m 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, and when UPLO = 'L' or 'l',
|
||||
* the leading m by m 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.
|
||||
* Before entry with SIDE = 'R' or 'r', the n by n part of
|
||||
* the array A must contain the symmetric matrix, such that
|
||||
* when 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, and when 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. When SIDE = 'L' or 'l' then
|
||||
* LDA must be at least max( 1, m ), otherwise 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.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* 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 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, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL UPPER
|
||||
INTEGER I, INFO, J, K, NROWA
|
||||
DOUBLE PRECISION TEMP1, TEMP2
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Set NROWA as the number of rows of A.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) )THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
UPPER = LSAME( UPLO, 'U' )
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND.
|
||||
$ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN
|
||||
INFO = 1
|
||||
ELSE IF( ( .NOT.UPPER ).AND.
|
||||
$ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN
|
||||
INFO = 2
|
||||
ELSE IF( M .LT.0 )THEN
|
||||
INFO = 3
|
||||
ELSE IF( N .LT.0 )THEN
|
||||
INFO = 4
|
||||
ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
|
||||
INFO = 7
|
||||
ELSE IF( LDB.LT.MAX( 1, M ) )THEN
|
||||
INFO = 9
|
||||
ELSE IF( LDC.LT.MAX( 1, M ) )THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSYMM ', 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
|
||||
*
|
||||
* And when 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( LSAME( SIDE, 'L' ) )THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 70, J = 1, N
|
||||
DO 60, I = 1, M
|
||||
TEMP1 = ALPHA*B( I, J )
|
||||
TEMP2 = ZERO
|
||||
DO 50, K = 1, I - 1
|
||||
C( K, J ) = C( K, J ) + TEMP1 *A( K, I )
|
||||
TEMP2 = TEMP2 + B( K, J )*A( K, I )
|
||||
50 CONTINUE
|
||||
IF( BETA.EQ.ZERO )THEN
|
||||
C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C( I, J ) = BETA *C( I, J ) +
|
||||
$ TEMP1*A( I, I ) + ALPHA*TEMP2
|
||||
END IF
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
DO 100, J = 1, N
|
||||
DO 90, I = M, 1, -1
|
||||
TEMP1 = ALPHA*B( I, J )
|
||||
TEMP2 = ZERO
|
||||
DO 80, K = I + 1, M
|
||||
C( K, J ) = C( K, J ) + TEMP1 *A( K, I )
|
||||
TEMP2 = TEMP2 + B( K, J )*A( K, I )
|
||||
80 CONTINUE
|
||||
IF( BETA.EQ.ZERO )THEN
|
||||
C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C( I, J ) = BETA *C( I, J ) +
|
||||
$ TEMP1*A( I, I ) + ALPHA*TEMP2
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*B*A + beta*C.
|
||||
*
|
||||
DO 170, J = 1, N
|
||||
TEMP1 = ALPHA*A( J, J )
|
||||
IF( BETA.EQ.ZERO )THEN
|
||||
DO 110, I = 1, M
|
||||
C( I, J ) = TEMP1*B( I, J )
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 120, I = 1, M
|
||||
C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J )
|
||||
120 CONTINUE
|
||||
END IF
|
||||
DO 140, K = 1, J - 1
|
||||
IF( UPPER )THEN
|
||||
TEMP1 = ALPHA*A( K, J )
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A( J, K )
|
||||
END IF
|
||||
DO 130, I = 1, M
|
||||
C( I, J ) = C( I, J ) + TEMP1*B( I, K )
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
DO 160, K = J + 1, N
|
||||
IF( UPPER )THEN
|
||||
TEMP1 = ALPHA*A( J, K )
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A( K, J )
|
||||
END IF
|
||||
DO 150, I = 1, M
|
||||
C( I, J ) = C( I, J ) + TEMP1*B( I, K )
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,262 +0,0 @@
|
|||
SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
|
||||
$ BETA, Y, INCY )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
INTEGER INCX, INCY, LDA, N
|
||||
CHARACTER*1 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.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 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
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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
|
||||
|
|
@ -1,197 +0,0 @@
|
|||
SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX, LDA, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR performs the symmetric rank 1 operation
|
||||
*
|
||||
* A := alpha*x*x' + A,
|
||||
*
|
||||
* where alpha is a real scalar, x is an n element vector and A is an
|
||||
* n by n symmetric matrix.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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, JX, KX
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( LDA.LT.MAX( 1, N ) )THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSYR ', INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
||||
$ RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
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 the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
*
|
||||
* Form A when A is stored in upper triangle.
|
||||
*
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( J )
|
||||
DO 10, I = 1, J
|
||||
A( I, J ) = A( I, J ) + X( I )*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( JX )
|
||||
IX = KX
|
||||
DO 30, I = 1, J
|
||||
A( I, J ) = A( I, J ) + X( IX )*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in lower triangle.
|
||||
*
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( J )
|
||||
DO 50, I = J, N
|
||||
A( I, J ) = A( I, J ) + X( I )*TEMP
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = ALPHA*X( JX )
|
||||
IX = JX
|
||||
DO 70, I = J, N
|
||||
A( I, J ) = A( I, J ) + X( IX )*TEMP
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,230 +0,0 @@
|
|||
SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX, INCY, LDA, N
|
||||
CHARACTER*1 UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2 performs the symmetric rank 2 operation
|
||||
*
|
||||
* A := alpha*x*y' + alpha*y*x' + A,
|
||||
*
|
||||
* where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
* by n symmetric matrix.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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
|
||||
|
|
@ -1,327 +0,0 @@
|
|||
SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
|
||||
$ BETA, C, LDC )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 UPLO, TRANS
|
||||
INTEGER N, K, LDA, LDB, LDC
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2K performs one of the symmetric rank 2k operations
|
||||
*
|
||||
* C := alpha*A*B' + alpha*B*A' + beta*C,
|
||||
*
|
||||
* or
|
||||
*
|
||||
* C := alpha*A'*B + alpha*B'*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.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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' + alpha*B*A' +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*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.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL UPPER
|
||||
INTEGER I, INFO, J, L, NROWA
|
||||
DOUBLE PRECISION TEMP1, TEMP2
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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' + alpha*B*A' + 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'*B + alpha*B'*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
|
||||
|
|
@ -1,294 +0,0 @@
|
|||
SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
|
||||
$ BETA, C, LDC )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 UPLO, TRANS
|
||||
INTEGER N, K, LDA, LDC
|
||||
DOUBLE PRECISION ALPHA, BETA
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), C( LDC, * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYRK performs one of the symmetric rank k operations
|
||||
*
|
||||
* C := alpha*A*A' + beta*C,
|
||||
*
|
||||
* or
|
||||
*
|
||||
* C := alpha*A'*A + beta*C,
|
||||
*
|
||||
* where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
* and A is an n by k matrix in the first case and a k by n matrix
|
||||
* in the second case.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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*A' + beta*C.
|
||||
*
|
||||
* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
|
||||
*
|
||||
* TRANS = 'C' or 'c' C := alpha*A'*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 matrix A, and on entry with
|
||||
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
|
||||
* of rows of the matrix A. 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.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL UPPER
|
||||
INTEGER I, INFO, J, L, NROWA
|
||||
DOUBLE PRECISION TEMP
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( LDC.LT.MAX( 1, N ) )THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DSYRK ', 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*A' + beta*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 )THEN
|
||||
TEMP = ALPHA*A( J, L )
|
||||
DO 110, I = 1, J
|
||||
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
||||
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 )THEN
|
||||
TEMP = ALPHA*A( J, L )
|
||||
DO 160, I = J, N
|
||||
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A'*A + beta*C.
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 210, J = 1, N
|
||||
DO 200, I = 1, J
|
||||
TEMP = ZERO
|
||||
DO 190, L = 1, K
|
||||
TEMP = TEMP + A( L, I )*A( L, J )
|
||||
190 CONTINUE
|
||||
IF( BETA.EQ.ZERO )THEN
|
||||
C( I, J ) = ALPHA*TEMP
|
||||
ELSE
|
||||
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240, J = 1, N
|
||||
DO 230, I = J, N
|
||||
TEMP = ZERO
|
||||
DO 220, L = 1, K
|
||||
TEMP = TEMP + A( L, I )*A( L, J )
|
||||
220 CONTINUE
|
||||
IF( BETA.EQ.ZERO )THEN
|
||||
C( I, J ) = ALPHA*TEMP
|
||||
ELSE
|
||||
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYRK .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,342 +0,0 @@
|
|||
SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, K, LDA, N
|
||||
CHARACTER*1 DIAG, TRANS, UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTBMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A'*x,
|
||||
*
|
||||
* where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'*x.
|
||||
*
|
||||
* TRANS = 'C' or 'c' x := A'*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.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
* super-diagonals of the matrix A.
|
||||
* On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
* sub-diagonals of the matrix A.
|
||||
* K must satisfy 0 .le. K.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
* by n part of the array A must contain the upper triangular
|
||||
* band part of the matrix of coefficients, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row
|
||||
* ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
* position 2 in row k, and so on. The top left k by k triangle
|
||||
* of the array A is not referenced.
|
||||
* The following program segment will transfer an upper
|
||||
* triangular band matrix from conventional full matrix storage
|
||||
* to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = K + 1 - J
|
||||
* DO 10, I = MAX( 1, J - K ), J
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
* by n part of the array A must contain the lower triangular
|
||||
* band part of the matrix of coefficients, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row 1 of
|
||||
* the array, the first sub-diagonal starting at position 1 in
|
||||
* row 2, and so on. The bottom right k by k triangle of the
|
||||
* array A is not referenced.
|
||||
* The following program segment will transfer a lower
|
||||
* triangular band matrix from conventional full matrix storage
|
||||
* to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = 1 - J
|
||||
* DO 10, I = J, MIN( N, J + K )
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
* corresponding to the diagonal elements of the matrix are not
|
||||
* referenced, 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
|
||||
* ( k + 1 ).
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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, JX, KPLUS1, KX, L
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( K.LT.0 )THEN
|
||||
INFO = 5
|
||||
ELSE IF( LDA.LT.( K + 1 ) )THEN
|
||||
INFO = 7
|
||||
ELSE IF( INCX.EQ.0 )THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DTBMV ', 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
|
||||
KPLUS1 = K + 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = X( J )
|
||||
L = KPLUS1 - J
|
||||
DO 10, I = MAX( 1, J - K ), J - 1
|
||||
X( I ) = X( I ) + TEMP*A( L + I, J )
|
||||
10 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )*A( KPLUS1, J )
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
DO 30, I = MAX( 1, J - K ), J - 1
|
||||
X( IX ) = X( IX ) + TEMP*A( L + I, J )
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )*A( KPLUS1, J )
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF( J.GT.K )
|
||||
$ KX = KX + 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 )
|
||||
L = 1 - J
|
||||
DO 50, I = MIN( N, J + K ), J + 1, -1
|
||||
X( I ) = X( I ) + TEMP*A( L + I, J )
|
||||
50 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )*A( 1, 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
|
||||
L = 1 - J
|
||||
DO 70, I = MIN( N, J + K ), J + 1, -1
|
||||
X( IX ) = X( IX ) + TEMP*A( L + I, J )
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )*A( 1, J )
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
IF( ( N - J ).GE.K )
|
||||
$ KX = KX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A'*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KPLUS1 = K + 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = N, 1, -1
|
||||
TEMP = X( J )
|
||||
L = KPLUS1 - J
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*A( KPLUS1, J )
|
||||
DO 90, I = J - 1, MAX( 1, J - K ), -1
|
||||
TEMP = TEMP + A( L + I, J )*X( I )
|
||||
90 CONTINUE
|
||||
X( J ) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
KX = KX + ( N - 1 )*INCX
|
||||
JX = KX
|
||||
DO 120, J = N, 1, -1
|
||||
TEMP = X( JX )
|
||||
KX = KX - INCX
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*A( KPLUS1, J )
|
||||
DO 110, I = J - 1, MAX( 1, J - K ), -1
|
||||
TEMP = TEMP + A( L + I, J )*X( IX )
|
||||
IX = IX - INCX
|
||||
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 )
|
||||
L = 1 - J
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*A( 1, J )
|
||||
DO 130, I = J + 1, MIN( N, J + K )
|
||||
TEMP = TEMP + A( L + I, J )*X( I )
|
||||
130 CONTINUE
|
||||
X( J ) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160, J = 1, N
|
||||
TEMP = X( JX )
|
||||
KX = KX + INCX
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*A( 1, J )
|
||||
DO 150, I = J + 1, MIN( N, J + K )
|
||||
TEMP = TEMP + A( L + I, J )*X( IX )
|
||||
IX = IX + INCX
|
||||
150 CONTINUE
|
||||
X( JX ) = TEMP
|
||||
JX = JX + INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,346 +0,0 @@
|
|||
SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, K, LDA, N
|
||||
CHARACTER*1 DIAG, TRANS, UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTBSV solves one of the systems of equations
|
||||
*
|
||||
* A*x = b, or A'*x = b,
|
||||
*
|
||||
* where b and x are n element vectors and A is an n by n unit, or
|
||||
* non-unit, upper or lower triangular band matrix, with ( k + 1 )
|
||||
* diagonals.
|
||||
*
|
||||
* No test for singularity or near-singularity is included in this
|
||||
* routine. Such tests must be performed before calling this routine.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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 equations to be solved as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' A*x = b.
|
||||
*
|
||||
* TRANS = 'T' or 't' A'*x = b.
|
||||
*
|
||||
* TRANS = 'C' or 'c' A'*x = b.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
* super-diagonals of the matrix A.
|
||||
* On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
* sub-diagonals of the matrix A.
|
||||
* K must satisfy 0 .le. K.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
* by n part of the array A must contain the upper triangular
|
||||
* band part of the matrix of coefficients, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row
|
||||
* ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
* position 2 in row k, and so on. The top left k by k triangle
|
||||
* of the array A is not referenced.
|
||||
* The following program segment will transfer an upper
|
||||
* triangular band matrix from conventional full matrix storage
|
||||
* to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = K + 1 - J
|
||||
* DO 10, I = MAX( 1, J - K ), J
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
* by n part of the array A must contain the lower triangular
|
||||
* band part of the matrix of coefficients, supplied column by
|
||||
* column, with the leading diagonal of the matrix in row 1 of
|
||||
* the array, the first sub-diagonal starting at position 1 in
|
||||
* row 2, and so on. The bottom right k by k triangle of the
|
||||
* array A is not referenced.
|
||||
* The following program segment will transfer a lower
|
||||
* triangular band matrix from conventional full matrix storage
|
||||
* to band storage:
|
||||
*
|
||||
* DO 20, J = 1, N
|
||||
* M = 1 - J
|
||||
* DO 10, I = J, MIN( N, J + K )
|
||||
* A( M + I, J ) = matrix( I, J )
|
||||
* 10 CONTINUE
|
||||
* 20 CONTINUE
|
||||
*
|
||||
* Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
* corresponding to the diagonal elements of the matrix are not
|
||||
* referenced, 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
|
||||
* ( k + 1 ).
|
||||
* 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 right-hand side vector b. On exit, X is overwritten
|
||||
* with the solution vector x.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
*
|
||||
* 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, JX, KPLUS1, KX, L
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( K.LT.0 )THEN
|
||||
INFO = 5
|
||||
ELSE IF( LDA.LT.( K + 1 ) )THEN
|
||||
INFO = 7
|
||||
ELSE IF( INCX.EQ.0 )THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DTBSV ', 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 by sequentially with one pass through A.
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) )THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KPLUS1 = K + 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = N, 1, -1
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
L = KPLUS1 - J
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/A( KPLUS1, J )
|
||||
TEMP = X( J )
|
||||
DO 10, I = J - 1, MAX( 1, J - K ), -1
|
||||
X( I ) = X( I ) - TEMP*A( L + I, J )
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KX = KX + ( N - 1 )*INCX
|
||||
JX = KX
|
||||
DO 40, J = N, 1, -1
|
||||
KX = KX - INCX
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/A( KPLUS1, J )
|
||||
TEMP = X( JX )
|
||||
DO 30, I = J - 1, MAX( 1, J - K ), -1
|
||||
X( IX ) = X( IX ) - TEMP*A( L + I, J )
|
||||
IX = IX - INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
L = 1 - J
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/A( 1, J )
|
||||
TEMP = X( J )
|
||||
DO 50, I = J + 1, MIN( N, J + K )
|
||||
X( I ) = X( I ) - TEMP*A( L + I, J )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80, J = 1, N
|
||||
KX = KX + INCX
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/A( 1, J )
|
||||
TEMP = X( JX )
|
||||
DO 70, I = J + 1, MIN( N, J + K )
|
||||
X( IX ) = X( IX ) - TEMP*A( L + I, J )
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A')*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KPLUS1 = K + 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = 1, N
|
||||
TEMP = X( J )
|
||||
L = KPLUS1 - J
|
||||
DO 90, I = MAX( 1, J - K ), J - 1
|
||||
TEMP = TEMP - A( L + I, J )*X( I )
|
||||
90 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( KPLUS1, J )
|
||||
X( J ) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120, J = 1, N
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
DO 110, I = MAX( 1, J - K ), J - 1
|
||||
TEMP = TEMP - A( L + I, J )*X( IX )
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( KPLUS1, J )
|
||||
X( JX ) = TEMP
|
||||
JX = JX + INCX
|
||||
IF( J.GT.K )
|
||||
$ KX = KX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 140, J = N, 1, -1
|
||||
TEMP = X( J )
|
||||
L = 1 - J
|
||||
DO 130, I = MIN( N, J + K ), J + 1, -1
|
||||
TEMP = TEMP - A( L + I, J )*X( I )
|
||||
130 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( 1, J )
|
||||
X( J ) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + ( N - 1 )*INCX
|
||||
JX = KX
|
||||
DO 160, J = N, 1, -1
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
DO 150, I = MIN( N, J + K ), J + 1, -1
|
||||
TEMP = TEMP - A( L + I, J )*X( IX )
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( 1, J )
|
||||
X( JX ) = TEMP
|
||||
JX = JX - INCX
|
||||
IF( ( N - J ).GE.K )
|
||||
$ KX = KX - INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTBSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,299 +0,0 @@
|
|||
SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
CHARACTER*1 DIAG, TRANS, UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP( * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTPMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A'*x,
|
||||
*
|
||||
* where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
* upper or lower triangular matrix, supplied in packed form.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'*x.
|
||||
*
|
||||
* TRANS = 'C' or 'c' x := A'*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.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular matrix packed sequentially,
|
||||
* column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
* respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular matrix packed sequentially,
|
||||
* column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
* respectively, and so on.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced, but are assumed to be unity.
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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, JX, K, KK, KX
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( INCX.EQ.0 )THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DTPMV ', 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 AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) )THEN
|
||||
*
|
||||
* Form x:= A*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KK =1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = X( J )
|
||||
K = KK
|
||||
DO 10, I = 1, J - 1
|
||||
X( I ) = X( I ) + TEMP*AP( K )
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )*AP( KK + J - 1 )
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
DO 30, K = KK, KK + J - 2
|
||||
X( IX ) = X( IX ) + TEMP*AP( K )
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )*AP( KK + J - 1 )
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = ( N*( N + 1 ) )/2
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = N, 1, -1
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
TEMP = X( J )
|
||||
K = KK
|
||||
DO 50, I = N, J + 1, -1
|
||||
X( I ) = X( I ) + TEMP*AP( K )
|
||||
K = K - 1
|
||||
50 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )*AP( KK - N + J )
|
||||
END IF
|
||||
KK = KK - ( N - J + 1 )
|
||||
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, K = KK, KK - ( N - ( J + 1 ) ), -1
|
||||
X( IX ) = X( IX ) + TEMP*AP( K )
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )*AP( KK - N + J )
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - ( N - J + 1 )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A'*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KK = ( N*( N + 1 ) )/2
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = N, 1, -1
|
||||
TEMP = X( J )
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*AP( KK )
|
||||
K = KK - 1
|
||||
DO 90, I = J - 1, 1, -1
|
||||
TEMP = TEMP + AP( K )*X( I )
|
||||
K = K - 1
|
||||
90 CONTINUE
|
||||
X( J ) = TEMP
|
||||
KK = KK - J
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX + ( N - 1 )*INCX
|
||||
DO 120, J = N, 1, -1
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*AP( KK )
|
||||
DO 110, K = KK - 1, KK - J + 1, -1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + AP( K )*X( IX )
|
||||
110 CONTINUE
|
||||
X( JX ) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 140, J = 1, N
|
||||
TEMP = X( J )
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*AP( KK )
|
||||
K = KK + 1
|
||||
DO 130, I = J + 1, N
|
||||
TEMP = TEMP + AP( K )*X( I )
|
||||
K = K + 1
|
||||
130 CONTINUE
|
||||
X( J ) = TEMP
|
||||
KK = KK + ( N - J + 1 )
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160, J = 1, N
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP*AP( KK )
|
||||
DO 150, K = KK + 1, KK + N - J
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + AP( K )*X( IX )
|
||||
150 CONTINUE
|
||||
X( JX ) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + ( N - J + 1 )
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,302 +0,0 @@
|
|||
SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
CHARACTER*1 DIAG, TRANS, UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP( * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTPSV solves one of the systems of equations
|
||||
*
|
||||
* A*x = b, or A'*x = b,
|
||||
*
|
||||
* where b and x are n element vectors and A is an n by n unit, or
|
||||
* non-unit, upper or lower triangular matrix, supplied in packed form.
|
||||
*
|
||||
* No test for singularity or near-singularity is included in this
|
||||
* routine. Such tests must be performed before calling this routine.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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 equations to be solved as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' A*x = b.
|
||||
*
|
||||
* TRANS = 'T' or 't' A'*x = b.
|
||||
*
|
||||
* TRANS = 'C' or 'c' A'*x = b.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular matrix packed sequentially,
|
||||
* column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
* respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular matrix packed sequentially,
|
||||
* column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
* respectively, and so on.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced, but are assumed to be unity.
|
||||
* 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 right-hand side vector b. On exit, X is overwritten
|
||||
* with the solution vector x.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
*
|
||||
* 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, JX, K, KK, KX
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( INCX.EQ.0 )THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF( INFO.NE.0 )THEN
|
||||
CALL XERBLA( 'DTPSV ', 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 AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) )THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KK = ( N*( N + 1 ) )/2
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = N, 1, -1
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/AP( KK )
|
||||
TEMP = X( J )
|
||||
K = KK - 1
|
||||
DO 10, I = J - 1, 1, -1
|
||||
X( I ) = X( I ) - TEMP*AP( K )
|
||||
K = K - 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK - J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + ( N - 1 )*INCX
|
||||
DO 40, J = N, 1, -1
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/AP( KK )
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
DO 30, K = KK - 1, KK - J + 1, -1
|
||||
IX = IX - INCX
|
||||
X( IX ) = X( IX ) - TEMP*AP( K )
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/AP( KK )
|
||||
TEMP = X( J )
|
||||
K = KK + 1
|
||||
DO 50, I = J + 1, N
|
||||
X( I ) = X( I ) - TEMP*AP( K )
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + ( N - J + 1 )
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/AP( KK )
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
DO 70, K = KK + 1, KK + N - J
|
||||
IX = IX + INCX
|
||||
X( IX ) = X( IX ) - TEMP*AP( K )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + ( N - J + 1 )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A' )*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
KK = 1
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = 1, N
|
||||
TEMP = X( J )
|
||||
K = KK
|
||||
DO 90, I = 1, J - 1
|
||||
TEMP = TEMP - AP( K )*X( I )
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/AP( KK + J - 1 )
|
||||
X( J ) = TEMP
|
||||
KK = KK + J
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120, J = 1, N
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
DO 110, K = KK, KK + J - 2
|
||||
TEMP = TEMP - AP( K )*X( IX )
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/AP( KK + J - 1 )
|
||||
X( JX ) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = ( N*( N + 1 ) )/2
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 140, J = N, 1, -1
|
||||
TEMP = X( J )
|
||||
K = KK
|
||||
DO 130, I = N, J + 1, -1
|
||||
TEMP = TEMP - AP( K )*X( I )
|
||||
K = K - 1
|
||||
130 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/AP( KK - N + J )
|
||||
X( J ) = TEMP
|
||||
KK = KK - ( N - J + 1 )
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + ( N - 1 )*INCX
|
||||
JX = KX
|
||||
DO 160, J = N, 1, -1
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
|
||||
TEMP = TEMP - AP( K )*X( IX )
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/AP( KK - N + J )
|
||||
X( JX ) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - (N - J + 1 )
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTPSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,355 +0,0 @@
|
|||
SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
|
||||
$ B, LDB )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
|
||||
INTEGER M, N, LDA, LDB
|
||||
DOUBLE PRECISION ALPHA
|
||||
* .. 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'.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'.
|
||||
*
|
||||
* TRANSA = 'C' or 'c' op( A ) = A'.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL LSIDE, NOUNIT, UPPER
|
||||
INTEGER I, INFO, J, K, NROWA
|
||||
DOUBLE PRECISION TEMP
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( 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'*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'.
|
||||
*
|
||||
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
|
||||
|
|
@ -1,286 +0,0 @@
|
|||
SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, LDA, N
|
||||
CHARACTER*1 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'*x,
|
||||
*
|
||||
* where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
* upper or lower triangular matrix.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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'*x.
|
||||
*
|
||||
* TRANS = 'C' or 'c' x := A'*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.
|
||||
*
|
||||
*
|
||||
* 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, JX, KX
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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'*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
|
||||
|
|
@ -1,378 +0,0 @@
|
|||
SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
|
||||
$ B, LDB )
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
|
||||
INTEGER M, N, LDA, LDB
|
||||
DOUBLE PRECISION ALPHA
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRSM solves one of the matrix equations
|
||||
*
|
||||
* op( A )*X = alpha*B, or X*op( A ) = alpha*B,
|
||||
*
|
||||
* where alpha is a scalar, X and B are m by n matrices, 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'.
|
||||
*
|
||||
* The matrix X is overwritten on B.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* SIDE - CHARACTER*1.
|
||||
* On entry, SIDE specifies whether op( A ) appears on the left
|
||||
* or right of X as follows:
|
||||
*
|
||||
* SIDE = 'L' or 'l' op( A )*X = alpha*B.
|
||||
*
|
||||
* SIDE = 'R' or 'r' X*op( A ) = alpha*B.
|
||||
*
|
||||
* 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'.
|
||||
*
|
||||
* TRANSA = 'C' or 'c' op( A ) = A'.
|
||||
*
|
||||
* 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 right-hand side matrix B, and on exit is
|
||||
* overwritten by the solution matrix X.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*
|
||||
* 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 ..
|
||||
LOGICAL LSIDE, NOUNIT, UPPER
|
||||
INTEGER I, INFO, J, K, NROWA
|
||||
DOUBLE PRECISION TEMP
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( 'DTRSM ', INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF( 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*inv( A )*B.
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 30, I = 1, M
|
||||
B( I, J ) = ALPHA*B( I, J )
|
||||
30 CONTINUE
|
||||
END IF
|
||||
DO 50, K = M, 1, -1
|
||||
IF( B( K, J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ B( K, J ) = B( K, J )/A( K, K )
|
||||
DO 40, I = 1, K - 1
|
||||
B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 100, J = 1, N
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 70, I = 1, M
|
||||
B( I, J ) = ALPHA*B( I, J )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
DO 90 K = 1, M
|
||||
IF( B( K, J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ B( K, J ) = B( K, J )/A( K, K )
|
||||
DO 80, I = K + 1, M
|
||||
B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*inv( A' )*B.
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 130, J = 1, N
|
||||
DO 120, I = 1, M
|
||||
TEMP = ALPHA*B( I, J )
|
||||
DO 110, K = 1, I - 1
|
||||
TEMP = TEMP - A( K, I )*B( K, J )
|
||||
110 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( I, I )
|
||||
B( I, J ) = TEMP
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 160, J = 1, N
|
||||
DO 150, I = M, 1, -1
|
||||
TEMP = ALPHA*B( I, J )
|
||||
DO 140, K = I + 1, M
|
||||
TEMP = TEMP - A( K, I )*B( K, J )
|
||||
140 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( I, I )
|
||||
B( I, J ) = TEMP
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF( LSAME( TRANSA, 'N' ) )THEN
|
||||
*
|
||||
* Form B := alpha*B*inv( A ).
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 210, J = 1, N
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 170, I = 1, M
|
||||
B( I, J ) = ALPHA*B( I, J )
|
||||
170 CONTINUE
|
||||
END IF
|
||||
DO 190, K = 1, J - 1
|
||||
IF( A( K, J ).NE.ZERO )THEN
|
||||
DO 180, I = 1, M
|
||||
B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
IF( NOUNIT )THEN
|
||||
TEMP = ONE/A( J, J )
|
||||
DO 200, I = 1, M
|
||||
B( I, J ) = TEMP*B( I, J )
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 260, J = N, 1, -1
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 220, I = 1, M
|
||||
B( I, J ) = ALPHA*B( I, J )
|
||||
220 CONTINUE
|
||||
END IF
|
||||
DO 240, K = J + 1, N
|
||||
IF( A( K, J ).NE.ZERO )THEN
|
||||
DO 230, I = 1, M
|
||||
B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
IF( NOUNIT )THEN
|
||||
TEMP = ONE/A( J, J )
|
||||
DO 250, I = 1, M
|
||||
B( I, J ) = TEMP*B( I, J )
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*inv( A' ).
|
||||
*
|
||||
IF( UPPER )THEN
|
||||
DO 310, K = N, 1, -1
|
||||
IF( NOUNIT )THEN
|
||||
TEMP = ONE/A( K, K )
|
||||
DO 270, I = 1, M
|
||||
B( I, K ) = TEMP*B( I, K )
|
||||
270 CONTINUE
|
||||
END IF
|
||||
DO 290, J = 1, K - 1
|
||||
IF( A( J, K ).NE.ZERO )THEN
|
||||
TEMP = A( J, K )
|
||||
DO 280, I = 1, M
|
||||
B( I, J ) = B( I, J ) - TEMP*B( I, K )
|
||||
280 CONTINUE
|
||||
END IF
|
||||
290 CONTINUE
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 300, I = 1, M
|
||||
B( I, K ) = ALPHA*B( I, K )
|
||||
300 CONTINUE
|
||||
END IF
|
||||
310 CONTINUE
|
||||
ELSE
|
||||
DO 360, K = 1, N
|
||||
IF( NOUNIT )THEN
|
||||
TEMP = ONE/A( K, K )
|
||||
DO 320, I = 1, M
|
||||
B( I, K ) = TEMP*B( I, K )
|
||||
320 CONTINUE
|
||||
END IF
|
||||
DO 340, J = K + 1, N
|
||||
IF( A( J, K ).NE.ZERO )THEN
|
||||
TEMP = A( J, K )
|
||||
DO 330, I = 1, M
|
||||
B( I, J ) = B( I, J ) - TEMP*B( I, K )
|
||||
330 CONTINUE
|
||||
END IF
|
||||
340 CONTINUE
|
||||
IF( ALPHA.NE.ONE )THEN
|
||||
DO 350, I = 1, M
|
||||
B( I, K ) = ALPHA*B( I, K )
|
||||
350 CONTINUE
|
||||
END IF
|
||||
360 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRSM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,289 +0,0 @@
|
|||
SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, LDA, N
|
||||
CHARACTER*1 DIAG, TRANS, UPLO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRSV solves one of the systems of equations
|
||||
*
|
||||
* A*x = b, or A'*x = b,
|
||||
*
|
||||
* where b and x are n element vectors and A is an n by n unit, or
|
||||
* non-unit, upper or lower triangular matrix.
|
||||
*
|
||||
* No test for singularity or near-singularity is included in this
|
||||
* routine. Such tests must be performed before calling this routine.
|
||||
*
|
||||
* Parameters
|
||||
* ==========
|
||||
*
|
||||
* 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 equations to be solved as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' A*x = b.
|
||||
*
|
||||
* TRANS = 'T' or 't' A'*x = b.
|
||||
*
|
||||
* TRANS = 'C' or 'c' A'*x = b.
|
||||
*
|
||||
* 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 right-hand side vector b. On exit, X is overwritten
|
||||
* with the solution vector x.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
*
|
||||
* 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, JX, KX
|
||||
LOGICAL NOUNIT
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 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( 'DTRSV ', 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 := inv( A )*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 20, J = N, 1, -1
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/A( J, J )
|
||||
TEMP = X( J )
|
||||
DO 10, I = J - 1, 1, -1
|
||||
X( I ) = X( I ) - TEMP*A( I, J )
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + ( N - 1 )*INCX
|
||||
DO 40, J = N, 1, -1
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/A( J, J )
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
DO 30, I = J - 1, 1, -1
|
||||
IX = IX - INCX
|
||||
X( IX ) = X( IX ) - TEMP*A( I, J )
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 60, J = 1, N
|
||||
IF( X( J ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( J ) = X( J )/A( J, J )
|
||||
TEMP = X( J )
|
||||
DO 50, I = J + 1, N
|
||||
X( I ) = X( I ) - TEMP*A( I, J )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80, J = 1, N
|
||||
IF( X( JX ).NE.ZERO )THEN
|
||||
IF( NOUNIT )
|
||||
$ X( JX ) = X( JX )/A( J, J )
|
||||
TEMP = X( JX )
|
||||
IX = JX
|
||||
DO 70, I = J + 1, N
|
||||
IX = IX + INCX
|
||||
X( IX ) = X( IX ) - TEMP*A( I, J )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A' )*x.
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) )THEN
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 100, J = 1, N
|
||||
TEMP = X( J )
|
||||
DO 90, I = 1, J - 1
|
||||
TEMP = TEMP - A( I, J )*X( I )
|
||||
90 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( J, J )
|
||||
X( J ) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120, J = 1, N
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
DO 110, I = 1, J - 1
|
||||
TEMP = TEMP - A( I, J )*X( IX )
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( J, J )
|
||||
X( JX ) = TEMP
|
||||
JX = JX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF( INCX.EQ.1 )THEN
|
||||
DO 140, J = N, 1, -1
|
||||
TEMP = X( J )
|
||||
DO 130, I = N, J + 1, -1
|
||||
TEMP = TEMP - A( I, J )*X( I )
|
||||
130 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( J, J )
|
||||
X( J ) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + ( N - 1 )*INCX
|
||||
JX = KX
|
||||
DO 160, J = N, 1, -1
|
||||
TEMP = X( JX )
|
||||
IX = KX
|
||||
DO 150, I = N, J + 1, -1
|
||||
TEMP = TEMP - A( I, J )*X( IX )
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF( NOUNIT )
|
||||
$ TEMP = TEMP/A( J, J )
|
||||
X( JX ) = TEMP
|
||||
JX = JX - INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
double precision function dzasum(n,zx,incx)
|
||||
c
|
||||
c takes the sum of the absolute values.
|
||||
c jack dongarra, 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 complex zx(*)
|
||||
double precision stemp,dcabs1
|
||||
integer i,incx,ix,n
|
||||
c
|
||||
dzasum = 0.0d0
|
||||
stemp = 0.0d0
|
||||
if( n.le.0 .or. incx.le.0 )return
|
||||
if(incx.eq.1)go to 20
|
||||
c
|
||||
c code for increment not equal to 1
|
||||
c
|
||||
ix = 1
|
||||
do 10 i = 1,n
|
||||
stemp = stemp + dcabs1(zx(ix))
|
||||
ix = ix + incx
|
||||
10 continue
|
||||
dzasum = stemp
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
20 do 30 i = 1,n
|
||||
stemp = stemp + dcabs1(zx(i))
|
||||
30 continue
|
||||
dzasum = stemp
|
||||
return
|
||||
end
|
||||
|
|
@ -1,67 +0,0 @@
|
|||
DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX )
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* DZNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DZNRM2 := sqrt( conjg( x' )*x )
|
||||
*
|
||||
*
|
||||
*
|
||||
* -- This version written on 25-October-1982.
|
||||
* Modified on 14-October-1993 to inline the call to ZLASSQ.
|
||||
* Sven Hammarling, Nag Ltd.
|
||||
*
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE , ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* .. Local Scalars ..
|
||||
INTEGER IX
|
||||
DOUBLE PRECISION NORM, SCALE, SSQ, TEMP
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DIMAG, DBLE, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
IF( N.LT.1 .OR. INCX.LT.1 )THEN
|
||||
NORM = ZERO
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
|
||||
IF( DBLE( X( IX ) ).NE.ZERO )THEN
|
||||
TEMP = ABS( DBLE( X( IX ) ) )
|
||||
IF( SCALE.LT.TEMP )THEN
|
||||
SSQ = ONE + SSQ*( SCALE/TEMP )**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + ( TEMP/SCALE )**2
|
||||
END IF
|
||||
END IF
|
||||
IF( DIMAG( X( IX ) ).NE.ZERO )THEN
|
||||
TEMP = ABS( DIMAG( X( IX ) ) )
|
||||
IF( SCALE.LT.TEMP )THEN
|
||||
SSQ = ONE + SSQ*( SCALE/TEMP )**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + ( TEMP/SCALE )**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE * SQRT( SSQ )
|
||||
END IF
|
||||
*
|
||||
DZNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DZNRM2.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
integer function icamax(n,cx,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
|
||||
complex cx(*)
|
||||
real smax
|
||||
integer i,incx,ix,n
|
||||
complex zdum
|
||||
real cabs1
|
||||
cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
|
||||
c
|
||||
icamax = 0
|
||||
if( n.lt.1 .or. incx.le.0 ) return
|
||||
icamax = 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
|
||||
smax = cabs1(cx(1))
|
||||
ix = ix + incx
|
||||
do 10 i = 2,n
|
||||
if(cabs1(cx(ix)).le.smax) go to 5
|
||||
icamax = i
|
||||
smax = cabs1(cx(ix))
|
||||
5 ix = ix + incx
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
20 smax = cabs1(cx(1))
|
||||
do 30 i = 2,n
|
||||
if(cabs1(cx(i)).le.smax) go to 30
|
||||
icamax = i
|
||||
smax = cabs1(cx(i))
|
||||
30 continue
|
||||
return
|
||||
end
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
integer function isamax(n,sx,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
|
||||
real sx(*),smax
|
||||
integer i,incx,ix,n
|
||||
c
|
||||
isamax = 0
|
||||
if( n.lt.1 .or. incx.le.0 ) return
|
||||
isamax = 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
|
||||
smax = abs(sx(1))
|
||||
ix = ix + incx
|
||||
do 10 i = 2,n
|
||||
if(abs(sx(ix)).le.smax) go to 5
|
||||
isamax = i
|
||||
smax = abs(sx(ix))
|
||||
5 ix = ix + incx
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
20 smax = abs(sx(1))
|
||||
do 30 i = 2,n
|
||||
if(abs(sx(i)).le.smax) go to 30
|
||||
isamax = i
|
||||
smax = abs(sx(i))
|
||||
30 continue
|
||||
return
|
||||
end
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
integer function izamax(n,zx,incx)
|
||||
c
|
||||
c finds the index of element having max. absolute value.
|
||||
c jack dongarra, 1/15/85.
|
||||
c modified 3/93 to return if incx .le. 0.
|
||||
c modified 12/3/93, array(1) declarations changed to array(*)
|
||||
c
|
||||
double complex zx(*)
|
||||
double precision smax
|
||||
integer i,incx,ix,n
|
||||
double precision dcabs1
|
||||
c
|
||||
izamax = 0
|
||||
if( n.lt.1 .or. incx.le.0 )return
|
||||
izamax = 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
|
||||
smax = dcabs1(zx(1))
|
||||
ix = ix + incx
|
||||
do 10 i = 2,n
|
||||
if(dcabs1(zx(ix)).le.smax) go to 5
|
||||
izamax = i
|
||||
smax = dcabs1(zx(ix))
|
||||
5 ix = ix + incx
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
20 smax = dcabs1(zx(1))
|
||||
do 30 i = 2,n
|
||||
if(dcabs1(zx(i)).le.smax) go to 30
|
||||
izamax = i
|
||||
smax = dcabs1(zx(i))
|
||||
30 continue
|
||||
return
|
||||
end
|
||||
|
|
@ -1,87 +0,0 @@
|
|||
LOGICAL FUNCTION LSAME( CA, CB )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 2.0) --
|
||||
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
||||
* Courant Institute, Argonne National Lab, and Rice University
|
||||
* January 31, 1994
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CA, CB
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
|
||||
* case.
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* CA (input) CHARACTER*1
|
||||
* CB (input) CHARACTER*1
|
||||
* CA and CB specify the single characters to be compared.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ICHAR
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER INTA, INTB, ZCODE
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test if the characters are equal
|
||||
*
|
||||
LSAME = CA.EQ.CB
|
||||
IF( LSAME )
|
||||
$ RETURN
|
||||
*
|
||||
* Now test for equivalence if both characters are alphabetic.
|
||||
*
|
||||
ZCODE = ICHAR( 'Z' )
|
||||
*
|
||||
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
|
||||
* machines, on which ICHAR returns a value with bit 8 set.
|
||||
* ICHAR('A') on Prime machines returns 193 which is the same as
|
||||
* ICHAR('A') on an EBCDIC machine.
|
||||
*
|
||||
INTA = ICHAR( CA )
|
||||
INTB = ICHAR( CB )
|
||||
*
|
||||
IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
|
||||
*
|
||||
* ASCII is assumed - ZCODE is the ASCII code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
|
||||
IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
|
||||
*
|
||||
ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
|
||||
*
|
||||
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
|
||||
$ INTA.GE.145 .AND. INTA.LE.153 .OR.
|
||||
$ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
|
||||
IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
|
||||
$ INTB.GE.145 .AND. INTB.LE.153 .OR.
|
||||
$ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
|
||||
*
|
||||
ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
|
||||
*
|
||||
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
|
||||
* plus 128 of either lower or upper case 'Z'.
|
||||
*
|
||||
IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
|
||||
IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
|
||||
END IF
|
||||
LSAME = INTA.EQ.INTB
|
||||
*
|
||||
* RETURN
|
||||
*
|
||||
* End of LSAME
|
||||
*
|
||||
END
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
SUBROUTINE XERBLA( SRNAME, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (preliminary version) --
|
||||
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
||||
* Courant Institute, Argonne National Lab, and Rice University
|
||||
* February 29, 1992
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*6 SRNAME
|
||||
INTEGER INFO
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* XERBLA is an error handler for the LAPACK routines.
|
||||
* It is called by an LAPACK routine if an input parameter has an
|
||||
* invalid value. A message is printed and execution stops.
|
||||
*
|
||||
* Installers may consider modifying the STOP statement in order to
|
||||
* call system-specific exception-handling facilities.
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* SRNAME (input) CHARACTER*6
|
||||
* The name of the routine which called XERBLA.
|
||||
*
|
||||
* INFO (input) INTEGER
|
||||
* The position of the invalid parameter in the parameter list
|
||||
* of the calling routine.
|
||||
*
|
||||
*
|
||||
WRITE( *, FMT = 9999 )SRNAME, INFO
|
||||
*
|
||||
STOP
|
||||
*
|
||||
9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
|
||||
$ 'an illegal value' )
|
||||
*
|
||||
* End of XERBLA
|
||||
*
|
||||
END
|
||||
|
|
@ -23,3 +23,8 @@ __top_builddir__build_lib_libcvode_la_LDFLAGS = $(all_libraries) -release $
|
|||
__top_builddir__build_lib_libcvode_la_SOURCES = $(fc_sources) $(cc_sources)
|
||||
|
||||
CLEANFILES = *.o
|
||||
|
||||
# header file accumulation
|
||||
all:
|
||||
@echo copying headers $<
|
||||
cp *.h $(top_builddir)/build/include/
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue