Refs #247. Included lapack source codes. Avoid downloading tar.gz from netlib.org
Based on 3.4.2 version, apply patch.for_lapack-3.4.2.
This commit is contained in:
Zhang Xianyi
75
lapack-netlib/TESTING/MATGEN/CMakeLists.txt
Normal file
75
lapack-netlib/TESTING/MATGEN/CMakeLists.txt
Normal file
@@ -0,0 +1,75 @@
|
||||
#######################################################################
|
||||
# This is the makefile to create a library of the test matrix
|
||||
# generators used in LAPACK. The files are organized as follows:
|
||||
#
|
||||
# SCATGEN -- Auxiliary routines called from both REAL and COMPLEX
|
||||
# DZATGEN -- Auxiliary routines called from both DOUBLE PRECISION
|
||||
# and COMPLEX*16
|
||||
# SMATGEN -- Single precision real matrix generation routines
|
||||
# CMATGEN -- Single precision complex matrix generation routines
|
||||
# DMATGEN -- Double precision real matrix generation routines
|
||||
# ZMATGEN -- Double precision complex matrix generation routines
|
||||
#
|
||||
# The library can be set up to include routines for any combination
|
||||
# of the four precisions. To create or add to the library, enter make
|
||||
# followed by one or more of the precisions desired. Some examples:
|
||||
# make single
|
||||
# make single complex
|
||||
# make single double complex complex16
|
||||
# Alternatively, the command
|
||||
# make
|
||||
# without any arguments creates a library of all four precisions.
|
||||
# The library is called
|
||||
# tmglib.a
|
||||
# and is created at the LAPACK directory level.
|
||||
#
|
||||
# To remove the object files after the library is created, enter
|
||||
# make clean
|
||||
# On some systems, you can force the source files to be recompiled by
|
||||
# entering (for example)
|
||||
# make single FRC=FRC
|
||||
#
|
||||
#######################################################################
|
||||
|
||||
set(SCATGEN slatm1.f slaran.f slarnd.f)
|
||||
|
||||
set(SMATGEN slatms.f slatme.f slatmr.f slatmt.f
|
||||
slagge.f slagsy.f slakf2.f slarge.f slaror.f slarot.f slatm2.f
|
||||
slatm3.f slatm5.f slatm6.f slatm7.f slahilb.f)
|
||||
|
||||
set(CMATGEN clatms.f clatme.f clatmr.f clatmt.f
|
||||
clagge.f claghe.f clagsy.f clakf2.f clarge.f claror.f clarot.f
|
||||
clatm1.f clarnd.f clatm2.f clatm3.f clatm5.f clatm6.f clahilb.f slatm7.f)
|
||||
|
||||
set(DZATGEN dlatm1.f dlaran.f dlarnd.f)
|
||||
|
||||
set(DMATGEN dlatms.f dlatme.f dlatmr.f dlatmt.f
|
||||
dlagge.f dlagsy.f dlakf2.f dlarge.f dlaror.f dlarot.f dlatm2.f
|
||||
dlatm3.f dlatm5.f dlatm6.f dlatm7.f dlahilb.f)
|
||||
|
||||
set(ZMATGEN zlatms.f zlatme.f zlatmr.f zlatmt.f
|
||||
zlagge.f zlaghe.f zlagsy.f zlakf2.f zlarge.f zlaror.f zlarot.f
|
||||
zlatm1.f zlarnd.f zlatm2.f zlatm3.f zlatm5.f zlatm6.f zlahilb.f dlatm7.f)
|
||||
|
||||
if(BUILD_SINGLE)
|
||||
set(ALLOBJ ${SMATGEN} ${SCATGEN})
|
||||
endif()
|
||||
if(BUILD_DOUBLE)
|
||||
set(ALLOBJ ${ALLOBJ} ${DMATGEN} ${DZATGEN})
|
||||
endif()
|
||||
if(BUILD_COMPLEX)
|
||||
set(ALLOBJ ${ALLOBJ} ${CMATGEN} ${SCATGEN})
|
||||
endif()
|
||||
if(BUILD_COMPLEX16)
|
||||
set(ALLOBJ ${ALLOBJ} ${ZMATGEN} ${DZATGEN})
|
||||
endif()
|
||||
|
||||
if (NOT ALLOBJ)
|
||||
set(ALLOBJ ${SMATGEN} ${CMATGEN} ${SCATGEN} ${DMATGEN} ${ZMATGEN}
|
||||
${DZATGEN})
|
||||
else()
|
||||
list(REMOVE_DUPLICATES ALLOBJ)
|
||||
endif()
|
||||
add_library(tmglib ${ALLOBJ} )
|
||||
target_link_libraries(tmglib ${LAPACK_LIBRARIES})
|
||||
lapack_install_library(tmglib)
|
||||
98
lapack-netlib/TESTING/MATGEN/Makefile
Normal file
98
lapack-netlib/TESTING/MATGEN/Makefile
Normal file
@@ -0,0 +1,98 @@
|
||||
include ../../make.inc
|
||||
|
||||
#######################################################################
|
||||
# This is the makefile to create a library of the test matrix
|
||||
# generators used in LAPACK. The files are organized as follows:
|
||||
#
|
||||
# SCATGEN -- Auxiliary routines called from both REAL and COMPLEX
|
||||
# DZATGEN -- Auxiliary routines called from both DOUBLE PRECISION
|
||||
# and COMPLEX*16
|
||||
# SMATGEN -- Single precision real matrix generation routines
|
||||
# CMATGEN -- Single precision complex matrix generation routines
|
||||
# DMATGEN -- Double precision real matrix generation routines
|
||||
# ZMATGEN -- Double precision complex matrix generation routines
|
||||
#
|
||||
# The library can be set up to include routines for any combination
|
||||
# of the four precisions. To create or add to the library, enter make
|
||||
# followed by one or more of the precisions desired. Some examples:
|
||||
# make single
|
||||
# make single complex
|
||||
# make single double complex complex16
|
||||
# Alternatively, the command
|
||||
# make
|
||||
# without any arguments creates a library of all four precisions.
|
||||
# The library is called
|
||||
# tmglib.a
|
||||
# and is created at the LAPACK directory level.
|
||||
#
|
||||
# To remove the object files after the library is created, enter
|
||||
# make clean
|
||||
# On some systems, you can force the source files to be recompiled by
|
||||
# entering (for example)
|
||||
# make single FRC=FRC
|
||||
#
|
||||
#######################################################################
|
||||
|
||||
SCATGEN = slatm1.o slaran.o slarnd.o
|
||||
|
||||
SMATGEN = slatms.o slatme.o slatmr.o slatmt.o \
|
||||
slagge.o slagsy.o slakf2.o slarge.o slaror.o slarot.o slatm2.o \
|
||||
slatm3.o slatm5.o slatm6.o slatm7.o slahilb.o
|
||||
|
||||
CMATGEN = clatms.o clatme.o clatmr.o clatmt.o \
|
||||
clagge.o claghe.o clagsy.o clakf2.o clarge.o claror.o clarot.o \
|
||||
clatm1.o clarnd.o clatm2.o clatm3.o clatm5.o clatm6.o clahilb.o
|
||||
|
||||
DZATGEN = dlatm1.o dlaran.o dlarnd.o
|
||||
|
||||
DMATGEN = dlatms.o dlatme.o dlatmr.o dlatmt.o \
|
||||
dlagge.o dlagsy.o dlakf2.o dlarge.o dlaror.o dlarot.o dlatm2.o \
|
||||
dlatm3.o dlatm5.o dlatm6.o dlatm7.o dlahilb.o
|
||||
|
||||
ZMATGEN = zlatms.o zlatme.o zlatmr.o zlatmt.o \
|
||||
zlagge.o zlaghe.o zlagsy.o zlakf2.o zlarge.o zlaror.o zlarot.o \
|
||||
zlatm1.o zlarnd.o zlatm2.o zlatm3.o zlatm5.o zlatm6.o zlahilb.o
|
||||
|
||||
all: ../../$(TMGLIB)
|
||||
|
||||
ALLOBJ = $(SMATGEN) $(CMATGEN) $(SCATGEN) $(DMATGEN) $(ZMATGEN) \
|
||||
$(DZATGEN)
|
||||
|
||||
../../$(TMGLIB): $(ALLOBJ)
|
||||
$(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
|
||||
$(RANLIB) $@
|
||||
|
||||
single: $(SMATGEN) $(SCATGEN)
|
||||
$(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(SMATGEN) $(SCATGEN)
|
||||
$(RANLIB) ../../$(TMGLIB)
|
||||
|
||||
complex: $(CMATGEN) $(SCATGEN)
|
||||
$(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(CMATGEN) $(SCATGEN)
|
||||
$(RANLIB) ../../$(TMGLIB)
|
||||
|
||||
double: $(DMATGEN) $(DZATGEN)
|
||||
$(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(DMATGEN) $(DZATGEN)
|
||||
$(RANLIB) ../../$(TMGLIB)
|
||||
|
||||
complex16: $(ZMATGEN) $(DZATGEN)
|
||||
$(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(ZMATGEN) $(DZATGEN)
|
||||
$(RANLIB) ../../$(TMGLIB)
|
||||
|
||||
$(SCATGEN): $(FRC)
|
||||
$(SMATGEN): $(FRC)
|
||||
$(CMATGEN): $(FRC)
|
||||
$(DZATGEN): $(FRC)
|
||||
$(DMATGEN): $(FRC)
|
||||
$(ZMATGEN): $(FRC)
|
||||
|
||||
FRC:
|
||||
@FRC=$(FRC)
|
||||
|
||||
clean:
|
||||
rm -f *.o
|
||||
|
||||
.f.o:
|
||||
$(FORTRAN) $(OPTS) -c $< -o $@
|
||||
|
||||
slaran.o: slaran.f ; $(FORTRAN) $(NOOPT) -c $<
|
||||
dlaran.o: dlaran.f ; $(FORTRAN) $(NOOPT) -c $<
|
||||
363
lapack-netlib/TESTING/MATGEN/clagge.f
Normal file
363
lapack-netlib/TESTING/MATGEN/clagge.f
Normal file
@@ -0,0 +1,363 @@
|
||||
*> \brief \b CLAGGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL D( * )
|
||||
* COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAGGE generates a complex general m by n matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with random unitary matrices:
|
||||
*> A = U*D*V. The lower and upper bandwidths may then be reduced to
|
||||
*> kl and ku by additional unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= KL <= M-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The number of nonzero superdiagonals within the band of A.
|
||||
*> 0 <= KU <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (min(M,N))
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA,N)
|
||||
*> The generated m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= M.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension (M+N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL D( * )
|
||||
COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ ONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
REAL WN
|
||||
COMPLEX TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CGERC, CLACGV, CLARNV, CSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MIN, REAL
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCNRM2
|
||||
EXTERNAL SCNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'CLAGGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, MIN( M, N )
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* pre- and post-multiply A by random unitary matrices
|
||||
*
|
||||
DO 40 I = MIN( M, N ), 1, -1
|
||||
IF( I.LT.M ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL CLARNV( 3, ISEED, M-I+1, WORK )
|
||||
WN = SCNRM2( M-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL CSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', M-I+1, N-I+1, ONE,
|
||||
$ A( I, I ), LDA, WORK, 1, ZERO, WORK( M+1 ), 1 )
|
||||
CALL CGERC( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL CLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SCNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the right
|
||||
*
|
||||
CALL CGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL CGERC( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to KL and number of superdiagonals
|
||||
* to KU
|
||||
*
|
||||
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
|
||||
IF( KL.LE.KU ) THEN
|
||||
*
|
||||
* annihilate subdiagonal elements first (necessary if KL = 0)
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = SCNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL CSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL CGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK,
|
||||
$ 1, A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = SCNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL CSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL CLACGV( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
CALL CGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL CGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* annihilate superdiagonal elements first (necessary if
|
||||
* KU = 0)
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = SCNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL CSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL CLACGV( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
CALL CGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL CGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = SCNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL CSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL CGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK,
|
||||
$ 1, A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
DO 50 J = KL + I + 1, M
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
*
|
||||
DO 60 J = KU + I + 1, N
|
||||
A( I, J ) = ZERO
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of CLAGGE
|
||||
*
|
||||
END
|
||||
267
lapack-netlib/TESTING/MATGEN/claghe.f
Normal file
267
lapack-netlib/TESTING/MATGEN/claghe.f
Normal file
@@ -0,0 +1,267 @@
|
||||
*> \brief \b CLAGHE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL D( * )
|
||||
* COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAGHE generates a complex hermitian matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random unitary matrix:
|
||||
*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
|
||||
*> unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA,N)
|
||||
*> The generated n by n hermitian matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL D( * )
|
||||
COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ ONE = ( 1.0E+0, 0.0E+0 ),
|
||||
$ HALF = ( 0.5E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
REAL WN
|
||||
COMPLEX ALPHA, TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CAXPY, CGEMV, CGERC, CHEMV, CHER2, CLARNV,
|
||||
$ CSCAL, XERBLA
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCNRM2
|
||||
COMPLEX CDOTC
|
||||
EXTERNAL SCNRM2, CDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, CONJG, MAX, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'CLAGHE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of hermitian matrix
|
||||
*
|
||||
DO 40 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL CLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SCNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL CHEMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 )
|
||||
CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
CALL CHER2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 60 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = SCNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL CSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE,
|
||||
$ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL CGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL CHEMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*CDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
|
||||
CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply hermitian rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
CALL CHER2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, K+I ), LDA )
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 50 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Store full hermitian matrix
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
DO 70 I = J + 1, N
|
||||
A( J, I ) = CONJG( A( I, J ) )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of CLAGHE
|
||||
*
|
||||
END
|
||||
286
lapack-netlib/TESTING/MATGEN/clagsy.f
Normal file
286
lapack-netlib/TESTING/MATGEN/clagsy.f
Normal file
@@ -0,0 +1,286 @@
|
||||
*> \brief \b CLAGSY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL D( * )
|
||||
* COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAGSY generates a complex symmetric matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random unitary matrix:
|
||||
*> A = U*D*U**T. The semi-bandwidth may then be reduced to k by
|
||||
*> additional unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA,N)
|
||||
*> The generated n by n symmetric matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL D( * )
|
||||
COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ ONE = ( 1.0E+0, 0.0E+0 ),
|
||||
$ HALF = ( 0.5E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, II, J, JJ
|
||||
REAL WN
|
||||
COMPLEX ALPHA, TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CAXPY, CGEMV, CGERC, CLACGV, CLARNV, CSCAL,
|
||||
$ CSYMV, XERBLA
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCNRM2
|
||||
COMPLEX CDOTC
|
||||
EXTERNAL SCNRM2, CDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'CLAGSY', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of symmetric matrix
|
||||
*
|
||||
DO 60 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL CLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SCNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * conjg(u)
|
||||
*
|
||||
CALL CLACGV( N-I+1, WORK, 1 )
|
||||
CALL CSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
CALL CLACGV( N-I+1, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( u, y ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 )
|
||||
CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
* $ A( I, I ), LDA )
|
||||
*
|
||||
DO 50 JJ = I, N
|
||||
DO 40 II = JJ, N
|
||||
A( II, JJ ) = A( II, JJ ) -
|
||||
$ WORK( II-I+1 )*WORK( N+JJ-I+1 ) -
|
||||
$ WORK( N+II-I+1 )*WORK( JJ-I+1 )
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 100 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = SCNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL CSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE,
|
||||
$ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL CGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * conjg(u)
|
||||
*
|
||||
CALL CLACGV( N-K-I+1, A( K+I, I ), 1 )
|
||||
CALL CSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL CLACGV( N-K-I+1, A( K+I, I ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( u, y ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*CDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 )
|
||||
CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
* $ A( K+I, K+I ), LDA )
|
||||
*
|
||||
DO 80 JJ = K + I, N
|
||||
DO 70 II = JJ, N
|
||||
A( II, JJ ) = A( II, JJ ) - A( II, I )*WORK( JJ-K-I+1 ) -
|
||||
$ WORK( II-K-I+1 )*A( JJ, I )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 90 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
* Store full symmetric matrix
|
||||
*
|
||||
DO 120 J = 1, N
|
||||
DO 110 I = J + 1, N
|
||||
A( J, I ) = A( I, J )
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of CLAGSY
|
||||
*
|
||||
END
|
||||
278
lapack-netlib/TESTING/MATGEN/clahilb.f
Normal file
278
lapack-netlib/TESTING/MATGEN/clahilb.f
Normal file
@@ -0,0 +1,278 @@
|
||||
*> \brief \b CLAHILB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK,
|
||||
* INFO, PATH)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
* REAL WORK(N)
|
||||
* COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
|
||||
* CHARACTER*3 PATH
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAHILB generates an N by N scaled Hilbert matrix in A along with
|
||||
*> NRHS right-hand sides in B and solutions in X such that A*X=B.
|
||||
*>
|
||||
*> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
|
||||
*> entries are integers. The right-hand sides are the first NRHS
|
||||
*> columns of M * the identity matrix, and the solutions are the
|
||||
*> first NRHS columns of the inverse Hilbert matrix.
|
||||
*>
|
||||
*> The condition number of the Hilbert matrix grows exponentially with
|
||||
*> its size, roughly as O(e ** (3.5*N)). Additionally, the inverse
|
||||
*> Hilbert matrices beyond a relatively small dimension cannot be
|
||||
*> generated exactly without extra precision. Precision is exhausted
|
||||
*> when the largest entry in the inverse Hilbert matrix is greater than
|
||||
*> 2 to the power of the number of bits in the fraction of the data type
|
||||
*> used plus one, which is 24 for single precision.
|
||||
*>
|
||||
*> In single, the generated solution is exact for N <= 6 and has
|
||||
*> small componentwise error for 7 <= N <= 11.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The dimension of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NRHS
|
||||
*> \verbatim
|
||||
*> NRHS is INTEGER
|
||||
*> The requested number of right-hand sides.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA, N)
|
||||
*> The generated scaled Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension (LDX, NRHS)
|
||||
*> The generated exact solutions. Currently, the first NRHS
|
||||
*> columns of the inverse Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of the array X. LDX >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is REAL array, dimension (LDB, NRHS)
|
||||
*> The generated right-hand sides. Currently, the first NRHS
|
||||
*> columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> = 1: N is too large; the data is still generated but may not
|
||||
*> be not exact.
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] PATH
|
||||
*> \verbatim
|
||||
*> PATH is CHARACTER*3
|
||||
*> The LAPACK path name.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK,
|
||||
$ INFO, PATH)
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
REAL WORK(N)
|
||||
COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
|
||||
CHARACTER*3 PATH
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
* .. Local Scalars ..
|
||||
INTEGER TM, TI, R
|
||||
INTEGER M
|
||||
INTEGER I, J
|
||||
COMPLEX TMP
|
||||
CHARACTER*2 C2
|
||||
|
||||
* .. Parameters ..
|
||||
* NMAX_EXACT the largest dimension where the generated data is
|
||||
* exact.
|
||||
* NMAX_APPROX the largest dimension where the generated data has
|
||||
* a small componentwise relative error.
|
||||
* ??? complex uses how many bits ???
|
||||
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8)
|
||||
|
||||
* d's are generated from random permuation of those eight elements.
|
||||
COMPLEX D1(8), D2(8), INVD1(8), INVD2(8)
|
||||
DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
|
||||
DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
|
||||
|
||||
DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
|
||||
$ (-.5,-.5),(.5,-.5),(.5,.5)/
|
||||
DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
|
||||
$ (-.5,.5),(.5,.5),(.5,-.5)/
|
||||
|
||||
* ..
|
||||
* .. External Functions
|
||||
EXTERNAL CLASET, LSAMEN
|
||||
INTRINSIC REAL
|
||||
LOGICAL LSAMEN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
C2 = PATH( 2: 3 )
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN
|
||||
INFO = -1
|
||||
ELSE IF (NRHS .LT. 0) THEN
|
||||
INFO = -2
|
||||
ELSE IF (LDA .LT. N) THEN
|
||||
INFO = -4
|
||||
ELSE IF (LDX .LT. N) THEN
|
||||
INFO = -6
|
||||
ELSE IF (LDB .LT. N) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF (INFO .LT. 0) THEN
|
||||
CALL XERBLA('CLAHILB', -INFO)
|
||||
RETURN
|
||||
END IF
|
||||
IF (N .GT. NMAX_EXACT) THEN
|
||||
INFO = 1
|
||||
END IF
|
||||
|
||||
* Compute M = the LCM of the integers [1, 2*N-1]. The largest
|
||||
* reasonable N is small enough that integers suffice (up to N = 11).
|
||||
M = 1
|
||||
DO I = 2, (2*N-1)
|
||||
TM = M
|
||||
TI = I
|
||||
R = MOD(TM, TI)
|
||||
DO WHILE (R .NE. 0)
|
||||
TM = TI
|
||||
TI = R
|
||||
R = MOD(TM, TI)
|
||||
END DO
|
||||
M = (M / TI) * I
|
||||
END DO
|
||||
|
||||
* Generate the scaled Hilbert matrix in A
|
||||
* If we are testing SY routines, take
|
||||
* D1_i = D2_i, else, D1_i = D2_i*
|
||||
IF ( LSAMEN( 2, C2, 'SY' ) ) THEN
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = D1(MOD(J,SIZE_D)+1) * (REAL(M) / (I + J - 1))
|
||||
$ * D1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
ELSE
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = D1(MOD(J,SIZE_D)+1) * (REAL(M) / (I + J - 1))
|
||||
$ * D2(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
|
||||
* Generate matrix B as simply the first NRHS columns of M * the
|
||||
* identity.
|
||||
TMP = REAL(M)
|
||||
CALL CLASET('Full', N, NRHS, (0.0,0.0), TMP, B, LDB)
|
||||
|
||||
* Generate the true solutions in X. Because B = the first NRHS
|
||||
* columns of M*I, the true solutions are just the first NRHS columns
|
||||
* of the inverse Hilbert matrix.
|
||||
WORK(1) = N
|
||||
DO J = 2, N
|
||||
WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) )
|
||||
$ * (N +J -1)
|
||||
END DO
|
||||
|
||||
* If we are testing SY routines,
|
||||
* take D1_i = D2_i, else, D1_i = D2_i*
|
||||
IF ( LSAMEN( 2, C2, 'SY' ) ) THEN
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) =
|
||||
$ INVD1(MOD(J,SIZE_D)+1) *
|
||||
$ ((WORK(I)*WORK(J)) / (I + J - 1))
|
||||
$ * INVD1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
ELSE
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) =
|
||||
$ INVD2(MOD(J,SIZE_D)+1) *
|
||||
$ ((WORK(I)*WORK(J)) / (I + J - 1))
|
||||
$ * INVD1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
END
|
||||
|
||||
191
lapack-netlib/TESTING/MATGEN/clakf2.f
Normal file
191
lapack-netlib/TESTING/MATGEN/clakf2.f
Normal file
@@ -0,0 +1,191 @@
|
||||
*> \brief \b CLAKF2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
* $ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Form the 2*M*N by 2*M*N matrix
|
||||
*>
|
||||
*> Z = [ kron(In, A) -kron(B', Im) ]
|
||||
*> [ kron(In, D) -kron(E', Im) ],
|
||||
*>
|
||||
*> where In is the identity matrix of size n and X' is the transpose
|
||||
*> of X. kron(X, Y) is the Kronecker product between the matrices X
|
||||
*> and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX, dimension ( LDA, M )
|
||||
*> The matrix A in the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A, B, D, and E. ( LDA >= M+N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX, dimension ( LDA, N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX, dimension ( LDA, M )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] E
|
||||
*> \verbatim
|
||||
*> E is COMPLEX, dimension ( LDA, N )
|
||||
*>
|
||||
*> The matrices used in forming the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Z
|
||||
*> \verbatim
|
||||
*> Z is COMPLEX, dimension ( LDZ, 2*M*N )
|
||||
*> The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDZ
|
||||
*> \verbatim
|
||||
*> LDZ is INTEGER
|
||||
*> The leading dimension of Z. ( LDZ >= 2*M*N )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
$ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
* ====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IK, J, JK, L, MN, MN2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CLASET
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Initialize Z
|
||||
*
|
||||
MN = M*N
|
||||
MN2 = 2*MN
|
||||
CALL CLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
|
||||
*
|
||||
IK = 1
|
||||
DO 50 L = 1, N
|
||||
*
|
||||
* form kron(In, A)
|
||||
*
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
Z( IK+I-1, IK+J-1 ) = A( I, J )
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* form kron(In, D)
|
||||
*
|
||||
DO 40 I = 1, M
|
||||
DO 30 J = 1, M
|
||||
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
50 CONTINUE
|
||||
*
|
||||
IK = 1
|
||||
DO 90 L = 1, N
|
||||
JK = MN + 1
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
*
|
||||
* form -kron(B', Im)
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
Z( IK+I-1, JK+I-1 ) = -B( J, L )
|
||||
60 CONTINUE
|
||||
*
|
||||
* form -kron(E', Im)
|
||||
*
|
||||
DO 70 I = 1, M
|
||||
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
|
||||
70 CONTINUE
|
||||
*
|
||||
JK = JK + M
|
||||
80 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
90 CONTINUE
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLAKF2
|
||||
*
|
||||
END
|
||||
176
lapack-netlib/TESTING/MATGEN/clarge.f
Normal file
176
lapack-netlib/TESTING/MATGEN/clarge.f
Normal file
@@ -0,0 +1,176 @@
|
||||
*> \brief \b CLARGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARGE pre- and post-multiplies a complex general n by n matrix A
|
||||
*> with a random unitary matrix: A = U*D*U'.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA,N)
|
||||
*> On entry, the original n by n matrix A.
|
||||
*> On exit, A is overwritten by U*A*U' for some random
|
||||
*> unitary matrix U.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ ONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
REAL WN
|
||||
COMPLEX TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CGERC, CLARNV, CSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, REAL
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCNRM2
|
||||
EXTERNAL SCNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -3
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'CLARGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* pre- and post-multiply A by random unitary matrix
|
||||
*
|
||||
DO 10 I = N, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL CLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SCNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = REAL( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:n,1:n) by random reflection from the left
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', N-I+1, N, ONE, A( I, 1 ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL CGERC( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
|
||||
$ LDA )
|
||||
*
|
||||
* multiply A(1:n,i:n) by random reflection from the right
|
||||
*
|
||||
CALL CGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL CGERC( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
|
||||
$ LDA )
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of CLARGE
|
||||
*
|
||||
END
|
||||
146
lapack-netlib/TESTING/MATGEN/clarnd.f
Normal file
146
lapack-netlib/TESTING/MATGEN/clarnd.f
Normal file
@@ -0,0 +1,146 @@
|
||||
*> \brief \b CLARND
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CLARND( IDIST, ISEED )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARND returns a random complex number from a uniform or normal
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> Specifies the distribution of the random numbers:
|
||||
*> = 1: real and imaginary parts each uniform (0,1)
|
||||
*> = 2: real and imaginary parts each uniform (-1,1)
|
||||
*> = 3: real and imaginary parts each normal (0,1)
|
||||
*> = 4: uniformly distributed on the disc abs(z) <= 1
|
||||
*> = 5: uniformly distributed on the circle abs(z) = 1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine calls the auxiliary routine SLARAN to generate a random
|
||||
*> real number from a uniform (0,1) distribution. The Box-Muller method
|
||||
*> is used to transform numbers from a uniform to a normal distribution.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CLARND( IDIST, ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE, TWO
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
|
||||
REAL TWOPI
|
||||
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL T1, T2
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLARAN
|
||||
EXTERNAL SLARAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CMPLX, EXP, LOG, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate a pair of real random numbers from a uniform (0,1)
|
||||
* distribution
|
||||
*
|
||||
T1 = SLARAN( ISEED )
|
||||
T2 = SLARAN( ISEED )
|
||||
*
|
||||
IF( IDIST.EQ.1 ) THEN
|
||||
*
|
||||
* real and imaginary parts each uniform (0,1)
|
||||
*
|
||||
CLARND = CMPLX( T1, T2 )
|
||||
ELSE IF( IDIST.EQ.2 ) THEN
|
||||
*
|
||||
* real and imaginary parts each uniform (-1,1)
|
||||
*
|
||||
CLARND = CMPLX( TWO*T1-ONE, TWO*T2-ONE )
|
||||
ELSE IF( IDIST.EQ.3 ) THEN
|
||||
*
|
||||
* real and imaginary parts each normal (0,1)
|
||||
*
|
||||
CLARND = SQRT( -TWO*LOG( T1 ) )*EXP( CMPLX( ZERO, TWOPI*T2 ) )
|
||||
ELSE IF( IDIST.EQ.4 ) THEN
|
||||
*
|
||||
* uniform distribution on the unit disc abs(z) <= 1
|
||||
*
|
||||
CLARND = SQRT( T1 )*EXP( CMPLX( ZERO, TWOPI*T2 ) )
|
||||
ELSE IF( IDIST.EQ.5 ) THEN
|
||||
*
|
||||
* uniform distribution on the unit circle abs(z) = 1
|
||||
*
|
||||
CLARND = EXP( CMPLX( ZERO, TWOPI*T2 ) )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CLARND
|
||||
*
|
||||
END
|
||||
348
lapack-netlib/TESTING/MATGEN/claror.f
Normal file
348
lapack-netlib/TESTING/MATGEN/claror.f
Normal file
@@ -0,0 +1,348 @@
|
||||
*> \brief \b CLAROR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER INIT, SIDE
|
||||
* INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAROR pre- or post-multiplies an M by N matrix A by a random
|
||||
*> unitary matrix U, overwriting A. A may optionally be
|
||||
*> initialized to the identity matrix before multiplying by U.
|
||||
*> U is generated using the method of G.W. Stewart
|
||||
*> ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
|
||||
*> (BLAS-2 version)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> SIDE specifies whether A is multiplied on the left or right
|
||||
*> by U.
|
||||
*> SIDE = 'L' Multiply A on the left (premultiply) by U
|
||||
*> SIDE = 'R' Multiply A on the right (postmultiply) by UC> SIDE = 'C' Multiply A on the left by U and the right by UC> SIDE = 'T' Multiply A on the left by U and the right by U'
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INIT
|
||||
*> \verbatim
|
||||
*> INIT is CHARACTER*1
|
||||
*> INIT specifies whether or not A should be initialized to
|
||||
*> the identity matrix.
|
||||
*> INIT = 'I' Initialize A to (a section of) the
|
||||
*> identity matrix before applying U.
|
||||
*> INIT = 'N' No initialization. Apply U to the
|
||||
*> input matrix A.
|
||||
*>
|
||||
*> INIT = 'I' may be used to generate square (i.e., unitary)
|
||||
*> or rectangular orthogonal matrices (orthogonality being
|
||||
*> in the sense of CDOTC):
|
||||
*>
|
||||
*> For square matrices, M=N, and SIDE many be either 'L' or
|
||||
*> 'R'; the rows will be orthogonal to each other, as will the
|
||||
*> columns.
|
||||
*> For rectangular matrices where M < N, SIDE = 'R' will
|
||||
*> produce a dense matrix whose rows will be orthogonal and
|
||||
*> whose columns will not, while SIDE = 'L' will produce a
|
||||
*> matrix whose rows will be orthogonal, and whose first M
|
||||
*> columns will be orthogonal, the remaining columns being
|
||||
*> zero.
|
||||
*> For matrices where M > N, just use the previous
|
||||
*> explaination, interchanging 'L' and 'R' and "rows" and
|
||||
*> "columns".
|
||||
*>
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension ( LDA, N )
|
||||
*> Input and output array. Overwritten by U A ( if SIDE = 'L' )
|
||||
*> or by A U ( if SIDE = 'R' )
|
||||
*> or by U A U* ( if SIDE = 'C')
|
||||
*> or by U A U' ( if SIDE = 'T') on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> Leading dimension of A. Must be at least MAX ( 1, M ).
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The array elements should be between 0 and 4095;
|
||||
*> if not they will be reduced mod 4096. Also, ISEED(4) must
|
||||
*> be odd. The random number generator uses a linear
|
||||
*> congruential sequence limited to small integers, and so
|
||||
*> should produce machine independent random numbers. The
|
||||
*> values of ISEED are changed on exit, and can be used in the
|
||||
*> next call to CLAROR to continue the same random number
|
||||
*> sequence.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension ( 3*MAX( M, N ) )
|
||||
*> Workspace. Of length:
|
||||
*> 2*M + N if SIDE = 'L',
|
||||
*> 2*N + M if SIDE = 'R',
|
||||
*> 3*N if SIDE = 'C' or 'T'.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> An error flag. It is set to:
|
||||
*> 0 if no error.
|
||||
*> 1 if CLARND returned a bad random number (installation
|
||||
*> problem)
|
||||
*> -1 if SIDE is not L, R, C, or T.
|
||||
*> -3 if M is negative.
|
||||
*> -4 if N is negative or if SIDE is C or T and N is not equal
|
||||
*> to M.
|
||||
*> -6 if LDA is less than M.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER INIT, SIDE
|
||||
INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE, TOOSML
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
|
||||
$ TOOSML = 1.0E-20 )
|
||||
COMPLEX CZERO, CONE
|
||||
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ CONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
|
||||
REAL FACTOR, XABS, XNORM
|
||||
COMPLEX CSIGN, XNORMS
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
REAL SCNRM2
|
||||
COMPLEX CLARND
|
||||
EXTERNAL LSAME, SCNRM2, CLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CGERC, CLACGV, CLASET, CSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, CMPLX, CONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.EQ.0 .OR. M.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
ITYPE = 0
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
ITYPE = 1
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
ITYPE = 2
|
||||
ELSE IF( LSAME( SIDE, 'C' ) ) THEN
|
||||
ITYPE = 3
|
||||
ELSE IF( LSAME( SIDE, 'T' ) ) THEN
|
||||
ITYPE = 4
|
||||
END IF
|
||||
*
|
||||
* Check for argument errors.
|
||||
*
|
||||
IF( ITYPE.EQ.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.M ) THEN
|
||||
INFO = -6
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'CLAROR', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.1 ) THEN
|
||||
NXFRM = M
|
||||
ELSE
|
||||
NXFRM = N
|
||||
END IF
|
||||
*
|
||||
* Initialize A to the identity matrix if desired
|
||||
*
|
||||
IF( LSAME( INIT, 'I' ) )
|
||||
$ CALL CLASET( 'Full', M, N, CZERO, CONE, A, LDA )
|
||||
*
|
||||
* If no rotation possible, still multiply by
|
||||
* a random complex number from the circle |x| = 1
|
||||
*
|
||||
* 2) Compute Rotation by computing Householder
|
||||
* Transformations H(2), H(3), ..., H(n). Note that the
|
||||
* order in which they are computed is irrelevant.
|
||||
*
|
||||
DO 40 J = 1, NXFRM
|
||||
X( J ) = CZERO
|
||||
40 CONTINUE
|
||||
*
|
||||
DO 60 IXFRM = 2, NXFRM
|
||||
KBEG = NXFRM - IXFRM + 1
|
||||
*
|
||||
* Generate independent normal( 0, 1 ) random numbers
|
||||
*
|
||||
DO 50 J = KBEG, NXFRM
|
||||
X( J ) = CLARND( 3, ISEED )
|
||||
50 CONTINUE
|
||||
*
|
||||
* Generate a Householder transformation from the random vector X
|
||||
*
|
||||
XNORM = SCNRM2( IXFRM, X( KBEG ), 1 )
|
||||
XABS = ABS( X( KBEG ) )
|
||||
IF( XABS.NE.CZERO ) THEN
|
||||
CSIGN = X( KBEG ) / XABS
|
||||
ELSE
|
||||
CSIGN = CONE
|
||||
END IF
|
||||
XNORMS = CSIGN*XNORM
|
||||
X( NXFRM+KBEG ) = -CSIGN
|
||||
FACTOR = XNORM*( XNORM+XABS )
|
||||
IF( ABS( FACTOR ).LT.TOOSML ) THEN
|
||||
INFO = 1
|
||||
CALL XERBLA( 'CLAROR', -INFO )
|
||||
RETURN
|
||||
ELSE
|
||||
FACTOR = ONE / FACTOR
|
||||
END IF
|
||||
X( KBEG ) = X( KBEG ) + XNORMS
|
||||
*
|
||||
* Apply Householder transformation to A
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
|
||||
*
|
||||
* Apply H(k) on the left of A
|
||||
*
|
||||
CALL CGEMV( 'C', IXFRM, N, CONE, A( KBEG, 1 ), LDA,
|
||||
$ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL CGERC( IXFRM, N, -CMPLX( FACTOR ), X( KBEG ), 1,
|
||||
$ X( 2*NXFRM+1 ), 1, A( KBEG, 1 ), LDA )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.GE.2 .AND. ITYPE.LE.4 ) THEN
|
||||
*
|
||||
* Apply H(k)* (or H(k)') on the right of A
|
||||
*
|
||||
IF( ITYPE.EQ.4 ) THEN
|
||||
CALL CLACGV( IXFRM, X( KBEG ), 1 )
|
||||
END IF
|
||||
*
|
||||
CALL CGEMV( 'N', M, IXFRM, CONE, A( 1, KBEG ), LDA,
|
||||
$ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL CGERC( M, IXFRM, -CMPLX( FACTOR ), X( 2*NXFRM+1 ), 1,
|
||||
$ X( KBEG ), 1, A( 1, KBEG ), LDA )
|
||||
*
|
||||
END IF
|
||||
60 CONTINUE
|
||||
*
|
||||
X( 1 ) = CLARND( 3, ISEED )
|
||||
XABS = ABS( X( 1 ) )
|
||||
IF( XABS.NE.ZERO ) THEN
|
||||
CSIGN = X( 1 ) / XABS
|
||||
ELSE
|
||||
CSIGN = CONE
|
||||
END IF
|
||||
X( 2*NXFRM ) = CSIGN
|
||||
*
|
||||
* Scale the matrix A by D.
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
|
||||
DO 70 IROW = 1, M
|
||||
CALL CSCAL( N, CONJG( X( NXFRM+IROW ) ), A( IROW, 1 ), LDA )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 80 JCOL = 1, N
|
||||
CALL CSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.4 ) THEN
|
||||
DO 90 JCOL = 1, N
|
||||
CALL CSCAL( M, CONJG( X( NXFRM+JCOL ) ), A( 1, JCOL ), 1 )
|
||||
90 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CLAROR
|
||||
*
|
||||
END
|
||||
338
lapack-netlib/TESTING/MATGEN/clarot.f
Normal file
338
lapack-netlib/TESTING/MATGEN/clarot.f
Normal file
@@ -0,0 +1,338 @@
|
||||
*> \brief \b CLAROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
* XRIGHT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* LOGICAL LLEFT, LRIGHT, LROWS
|
||||
* INTEGER LDA, NL
|
||||
* COMPLEX C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLAROT applies a (Givens) rotation to two adjacent rows or
|
||||
*> columns, where one element of the first and/or last column/row
|
||||
*> for use on matrices stored in some format other than GE, so
|
||||
*> that elements of the matrix may be used or modified for which
|
||||
*> no array element is provided.
|
||||
*>
|
||||
*> One example is a symmetric matrix in SB format (bandwidth=4), for
|
||||
*> which UPLO='L': Two adjacent rows will have the format:
|
||||
*>
|
||||
*> row j: C> C> C> C> C> . . . .
|
||||
*> row j+1: C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> '*' indicates elements for which storage is provided,
|
||||
*> '.' indicates elements for which no storage is provided, but
|
||||
*> are not necessarily zero; their values are determined by
|
||||
*> symmetry. ' ' indicates elements which are necessarily zero,
|
||||
*> and have no storage provided.
|
||||
*>
|
||||
*> Those columns which have two '*'s can be handled by SROT.
|
||||
*> Those columns which have no '*'s can be ignored, since as long
|
||||
*> as the Givens rotations are carefully applied to preserve
|
||||
*> symmetry, their values are determined.
|
||||
*> Those columns which have one '*' have to be handled separately,
|
||||
*> by using separate variables "p" and "q":
|
||||
*>
|
||||
*> row j: C> C> C> C> C> p . . .
|
||||
*> row j+1: q C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> The element p would have to be set correctly, then that column
|
||||
*> is rotated, setting p to its new value. The next call to
|
||||
*> CLAROT would rotate columns j and j+1, using p, and restore
|
||||
*> symmetry. The element q would start out being zero, and be
|
||||
*> made non-zero by the rotation. Later, rotations would presumably
|
||||
*> be chosen to zero q out.
|
||||
*>
|
||||
*> Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
|
||||
*> ------- ------- ---------
|
||||
*>
|
||||
*> General dense matrix:
|
||||
*>
|
||||
*> CALL CLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
|
||||
*> A(i,1),LDA, DUMMY, DUMMY)
|
||||
*>
|
||||
*> General banded matrix in GB format:
|
||||
*>
|
||||
*> j = MAX(1, i-KL )
|
||||
*> NL = MIN( N, i+KU+1 ) + 1-j
|
||||
*> CALL CLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
|
||||
*> A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,KL+1) ]
|
||||
*>
|
||||
*> Symmetric banded matrix in SY format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> j = MAX(1, i-K )
|
||||
*> NL = MIN( K+1, i ) + 1
|
||||
*> CALL CLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
|
||||
*> A(i,j), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*>
|
||||
*> NL = MIN( K+1, N-i ) + 1
|
||||
*> CALL CLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
|
||||
*> A(i,i), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Symmetric banded matrix in SB format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> [ same as for SY, except:]
|
||||
*> . . . .
|
||||
*> A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,K+1) ]
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*> . . .
|
||||
*> A(K+1,i), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Rotating columns is just the transpose of rotating rows, except
|
||||
*> for GB and SB: (rotating columns i and i+1)
|
||||
*>
|
||||
*> GB:
|
||||
*> j = MAX(1, i-KU )
|
||||
*> NL = MIN( N, i+KL+1 ) + 1-j
|
||||
*> CALL CLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
|
||||
*> A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> [note that KU+j+1-i is just MAX(1,KU+2-i)]
|
||||
*>
|
||||
*> SB: (upper triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> SB: (lower triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(1,i),LDA-1, XTOP, XBOTTM )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> LROWS - LOGICAL
|
||||
*> If .TRUE., then CLAROT will rotate two rows. If .FALSE.,
|
||||
*> then it will rotate two columns.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LLEFT - LOGICAL
|
||||
*> If .TRUE., then XLEFT will be used instead of the
|
||||
*> corresponding element of A for the first element in the
|
||||
*> second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
|
||||
*> If .FALSE., then the corresponding element of A will be
|
||||
*> used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LRIGHT - LOGICAL
|
||||
*> If .TRUE., then XRIGHT will be used instead of the
|
||||
*> corresponding element of A for the last element in the
|
||||
*> first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
|
||||
*> .FALSE., then the corresponding element of A will be used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> NL - INTEGER
|
||||
*> The length of the rows (if LROWS=.TRUE.) or columns (if
|
||||
*> LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
|
||||
*> used, the columns/rows they are in should be included in
|
||||
*> NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
|
||||
*> least 2. The number of rows/columns to be rotated
|
||||
*> exclusive of those involving XLEFT and/or XRIGHT may
|
||||
*> not be negative, i.e., NL minus how many of LLEFT and
|
||||
*> LRIGHT are .TRUE. must be at least zero; if not, XERBLA
|
||||
*> will be called.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> C, S - COMPLEX
|
||||
*> Specify the Givens rotation to be applied. If LROWS is
|
||||
*> true, then the matrix ( c s )
|
||||
*> ( _ _ )
|
||||
*> (-s c ) is applied from the left;
|
||||
*> if false, then the transpose (not conjugated) thereof is
|
||||
*> applied from the right. Note that in contrast to the
|
||||
*> output of CROTG or to most versions of CROT, both C and S
|
||||
*> are complex. For a Givens rotation, |C|**2 + |S|**2 should
|
||||
*> be 1, but this is not checked.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> A - COMPLEX array.
|
||||
*> The array containing the rows/columns to be rotated. The
|
||||
*> first element of A should be the upper left element to
|
||||
*> be rotated.
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> LDA - INTEGER
|
||||
*> The "effective" leading dimension of A. If A contains
|
||||
*> a matrix stored in GE, HE, or SY format, then this is just
|
||||
*> the leading dimension of A as dimensioned in the calling
|
||||
*> routine. If A contains a matrix stored in band (GB, HB, or
|
||||
*> SB) format, then this should be *one less* than the leading
|
||||
*> dimension used in the calling routine. Thus, if A were
|
||||
*> dimensioned A(LDA,*) in CLAROT, then A(1,j) would be the
|
||||
*> j-th element in the first of the two rows to be rotated,
|
||||
*> and A(2,j) would be the j-th in the second, regardless of
|
||||
*> how the array may be stored in the calling routine. [A
|
||||
*> cannot, however, actually be dimensioned thus, since for
|
||||
*> band format, the row number may exceed LDA, which is not
|
||||
*> legal FORTRAN.]
|
||||
*> If LROWS=.TRUE., then LDA must be at least 1, otherwise
|
||||
*> it must be at least NL minus the number of .TRUE. values
|
||||
*> in XLEFT and XRIGHT.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> XLEFT - COMPLEX
|
||||
*> If LLEFT is .TRUE., then XLEFT will be used and modified
|
||||
*> instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> XRIGHT - COMPLEX
|
||||
*> If LRIGHT is .TRUE., then XRIGHT will be used and modified
|
||||
*> instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
$ XRIGHT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
LOGICAL LLEFT, LRIGHT, LROWS
|
||||
INTEGER LDA, NL
|
||||
COMPLEX C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER IINC, INEXT, IX, IY, IYT, J, NT
|
||||
COMPLEX TEMPX
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
COMPLEX XT( 2 ), YT( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Set up indices, arrays for ends
|
||||
*
|
||||
IF( LROWS ) THEN
|
||||
IINC = LDA
|
||||
INEXT = 1
|
||||
ELSE
|
||||
IINC = 1
|
||||
INEXT = LDA
|
||||
END IF
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
NT = 1
|
||||
IX = 1 + IINC
|
||||
IY = 2 + LDA
|
||||
XT( 1 ) = A( 1 )
|
||||
YT( 1 ) = XLEFT
|
||||
ELSE
|
||||
NT = 0
|
||||
IX = 1
|
||||
IY = 1 + INEXT
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
IYT = 1 + INEXT + ( NL-1 )*IINC
|
||||
NT = NT + 1
|
||||
XT( NT ) = XRIGHT
|
||||
YT( NT ) = A( IYT )
|
||||
END IF
|
||||
*
|
||||
* Check for errors
|
||||
*
|
||||
IF( NL.LT.NT ) THEN
|
||||
CALL XERBLA( 'CLAROT', 4 )
|
||||
RETURN
|
||||
END IF
|
||||
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
|
||||
CALL XERBLA( 'CLAROT', 8 )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Rotate
|
||||
*
|
||||
* CROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S
|
||||
*
|
||||
DO 10 J = 0, NL - NT - 1
|
||||
TEMPX = C*A( IX+J*IINC ) + S*A( IY+J*IINC )
|
||||
A( IY+J*IINC ) = -CONJG( S )*A( IX+J*IINC ) +
|
||||
$ CONJG( C )*A( IY+J*IINC )
|
||||
A( IX+J*IINC ) = TEMPX
|
||||
10 CONTINUE
|
||||
*
|
||||
* CROT( NT, XT,1, YT,1, C, S ) with complex C, S
|
||||
*
|
||||
DO 20 J = 1, NT
|
||||
TEMPX = C*XT( J ) + S*YT( J )
|
||||
YT( J ) = -CONJG( S )*XT( J ) + CONJG( C )*YT( J )
|
||||
XT( J ) = TEMPX
|
||||
20 CONTINUE
|
||||
*
|
||||
* Stuff values back into XLEFT, XRIGHT, etc.
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
A( 1 ) = XT( 1 )
|
||||
XLEFT = YT( 1 )
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
XRIGHT = XT( NT )
|
||||
A( IYT ) = YT( NT )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLAROT
|
||||
*
|
||||
END
|
||||
300
lapack-netlib/TESTING/MATGEN/clatm1.f
Normal file
300
lapack-netlib/TESTING/MATGEN/clatm1.f
Normal file
@@ -0,0 +1,300 @@
|
||||
*> \brief \b CLATM1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
* REAL COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX D( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATM1 computes the entries of D(1..N) as specified by
|
||||
*> MODE, COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. CLATM1 is called by CLATMR to generate
|
||||
*> random test matrices for LAPACK programs.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is REAL
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IRSIGN
|
||||
*> \verbatim
|
||||
*> IRSIGN is INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by random complex number
|
||||
*> uniformly distributed with absolute value 1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to CLATM1
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
REAL COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX D( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
REAL ALPHA, TEMP
|
||||
COMPLEX CTEMP
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLARAN
|
||||
COMPLEX CLARND
|
||||
EXTERNAL SLARAN, CLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CLARNV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, EXP, LOG, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.4 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'CLATM1', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
10 CONTINUE
|
||||
DO 20 I = 1, N
|
||||
D( I ) = ONE / COND
|
||||
20 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 120
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
30 CONTINUE
|
||||
DO 40 I = 1, N
|
||||
D( I ) = ONE
|
||||
40 CONTINUE
|
||||
D( N ) = ONE / COND
|
||||
GO TO 120
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
50 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / REAL( N-1 ) )
|
||||
DO 60 I = 2, N
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
70 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / REAL( N-1 )
|
||||
DO 80 I = 2, N
|
||||
D( I ) = REAL( N-I )*ALPHA + TEMP
|
||||
80 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
90 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 100 I = 1, N
|
||||
D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
|
||||
100 CONTINUE
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
110 CONTINUE
|
||||
CALL CLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
120 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 130 I = 1, N
|
||||
CTEMP = CLARND( 3, ISEED )
|
||||
D( I ) = D( I )*( CTEMP / ABS( CTEMP ) )
|
||||
130 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 140 I = 1, N / 2
|
||||
CTEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = CTEMP
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLATM1
|
||||
*
|
||||
END
|
||||
329
lapack-netlib/TESTING/MATGEN/clatm2.f
Normal file
329
lapack-netlib/TESTING/MATGEN/clatm2.f
Normal file
@@ -0,0 +1,329 @@
|
||||
*> \brief \b CLATM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D,
|
||||
* IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
* REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* COMPLEX D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATM2 returns the (I,J) entry of a random matrix of dimension
|
||||
*> (M, N) described by the other paramters. It is called by the
|
||||
*> CLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by CLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of CLATM2 differs from CLATM3 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With CLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With CLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, CLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. CLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*>
|
||||
*> The matrix whose (I,J) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If I is outside (1..M) or J is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0 , 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( CONJG(DL) )
|
||||
*> 6 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is COMPLEX array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is COMPLEX array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) in position K was originally in
|
||||
*> position IWORK( K ).
|
||||
*> This differs from IWORK for CLATM3. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is REAL
|
||||
*> Value between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D,
|
||||
$ IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
COMPLEX D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
COMPLEX CZERO
|
||||
PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) )
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
INTEGER ISUB, JSUB
|
||||
COMPLEX CTEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
REAL SLARAN
|
||||
COMPLEX CLARND
|
||||
EXTERNAL SLARAN, CLARND
|
||||
* ..
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
*
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
CLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
|
||||
CLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
CLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( ISUB.EQ.JSUB ) THEN
|
||||
CTEMP = D( ISUB )
|
||||
ELSE
|
||||
CTEMP = CLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
CTEMP = CTEMP*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB ) / DL( JSUB )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*CONJG( DL( JSUB ) )
|
||||
ELSE IF( IGRADE.EQ.6 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*DL( JSUB )
|
||||
END IF
|
||||
CLATM2 = CTEMP
|
||||
RETURN
|
||||
*
|
||||
* End of CLATM2
|
||||
*
|
||||
END
|
||||
348
lapack-netlib/TESTING/MATGEN/clatm3.f
Normal file
348
lapack-netlib/TESTING/MATGEN/clatm3.f
Normal file
@@ -0,0 +1,348 @@
|
||||
*> \brief \b CLATM3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
|
||||
* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
* SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
* $ KU, M, N
|
||||
* REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* COMPLEX D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATM3 returns the (ISUB,JSUB) entry of a random matrix of
|
||||
*> dimension (M, N) described by the other paramters. (ISUB,JSUB)
|
||||
*> is the final position of the (I,J) entry after pivoting
|
||||
*> according to IPVTNG and IWORK. CLATM3 is called by the
|
||||
*> CLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by CLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of CLATM3 differs from CLATM2 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With CLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With CLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, CLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. CLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*> in different orders for different pivot orders).
|
||||
*>
|
||||
*> The matrix whose (ISUB,JSUB) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISUB
|
||||
*> \verbatim
|
||||
*> ISUB is INTEGER
|
||||
*> Row of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] JSUB
|
||||
*> \verbatim
|
||||
*> JSUB is INTEGER
|
||||
*> Column of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0 , 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( CONJG(DL) )
|
||||
*> 6 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is COMPLEX array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is COMPLEX array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) originally in position K is in
|
||||
*> position IWORK( K ) after pivoting.
|
||||
*> This differs from IWORK for CLATM2. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is REAL between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
|
||||
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
$ SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
$ KU, M, N
|
||||
REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
COMPLEX D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
COMPLEX CZERO
|
||||
PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
COMPLEX CTEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
REAL SLARAN
|
||||
COMPLEX CLARND
|
||||
EXTERNAL SLARAN, CLARND
|
||||
* ..
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
*
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
CLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
|
||||
CLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
CLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
CTEMP = D( I )
|
||||
ELSE
|
||||
CTEMP = CLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
CTEMP = CTEMP*DL( I )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
CTEMP = CTEMP*DR( J )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*DR( J )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
|
||||
CTEMP = CTEMP*DL( I ) / DL( J )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*CONJG( DL( J ) )
|
||||
ELSE IF( IGRADE.EQ.6 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*DL( J )
|
||||
END IF
|
||||
CLATM3 = CTEMP
|
||||
RETURN
|
||||
*
|
||||
* End of CLATM3
|
||||
*
|
||||
END
|
||||
504
lapack-netlib/TESTING/MATGEN/clatm5.f
Normal file
504
lapack-netlib/TESTING/MATGEN/clatm5.f
Normal file
@@ -0,0 +1,504 @@
|
||||
*> \brief \b CLATM5
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
* QBLCKB )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
* $ PRTYPE, QBLCKA, QBLCKB
|
||||
* REAL ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
* $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
* $ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATM5 generates matrices involved in the Generalized Sylvester
|
||||
*> equation:
|
||||
*>
|
||||
*> A * R - L * B = C
|
||||
*> D * R - L * E = F
|
||||
*>
|
||||
*> They also satisfy (the diagonalization condition)
|
||||
*>
|
||||
*> [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
|
||||
*> [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] PRTYPE
|
||||
*> \verbatim
|
||||
*> PRTYPE is INTEGER
|
||||
*> "Points" to a certian type of the matrices to generate
|
||||
*> (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Specifies the order of A and D and the number of rows in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Specifies the order of B and E and the number of columns in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA, M).
|
||||
*> On exit A M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array, dimension (LDB, N).
|
||||
*> On exit B N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array, dimension (LDC, N).
|
||||
*> On exit C M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX array, dimension (LDD, M).
|
||||
*> On exit D M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDD
|
||||
*> \verbatim
|
||||
*> LDD is INTEGER
|
||||
*> The leading dimension of D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is COMPLEX array, dimension (LDE, N).
|
||||
*> On exit E N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDE
|
||||
*> \verbatim
|
||||
*> LDE is INTEGER
|
||||
*> The leading dimension of E.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] F
|
||||
*> \verbatim
|
||||
*> F is COMPLEX array, dimension (LDF, N).
|
||||
*> On exit F M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDF
|
||||
*> \verbatim
|
||||
*> LDF is INTEGER
|
||||
*> The leading dimension of F.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] R
|
||||
*> \verbatim
|
||||
*> R is COMPLEX array, dimension (LDR, N).
|
||||
*> On exit R M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDR
|
||||
*> \verbatim
|
||||
*> LDR is INTEGER
|
||||
*> The leading dimension of R.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] L
|
||||
*> \verbatim
|
||||
*> L is COMPLEX array, dimension (LDL, N).
|
||||
*> On exit L M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDL
|
||||
*> \verbatim
|
||||
*> LDL is INTEGER
|
||||
*> The leading dimension of L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> Parameter used in generating PRTYPE = 1 and 5 matrices.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKA
|
||||
*> \verbatim
|
||||
*> QBLCKA is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in A. Otherwise, QBLCKA is not
|
||||
*> referenced. QBLCKA > 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKB
|
||||
*> \verbatim
|
||||
*> QBLCKB is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in B. Otherwise, QBLCKB is not
|
||||
*> referenced. QBLCKB > 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
|
||||
*>
|
||||
*> A : if (i == j) then A(i, j) = 1.0
|
||||
*> if (j == i + 1) then A(i, j) = -1.0
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> B : if (i == j) then B(i, j) = 1.0 - ALPHA
|
||||
*> if (j == i + 1) then B(i, j) = 1.0
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> D : if (i == j) then D(i, j) = 1.0
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> E : if (i == j) then E(i, j) = 1.0
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L = R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
|
||||
*>
|
||||
*> A : if (i <= j) then A(i, j) = [-1...1]
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> A(k + 1, k + 1) = A(k, k)
|
||||
*> A(k + 1, k) = [-1...1]
|
||||
*> sign(A(k, k + 1) = -(sin(A(k + 1, k))
|
||||
*> k = 1, M - 1, QBLCKA
|
||||
*>
|
||||
*> B : if (i <= j) then B(i, j) = [-1...1]
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> B(k + 1, k + 1) = B(k, k)
|
||||
*> B(k + 1, k) = [-1...1]
|
||||
*> sign(B(k, k + 1) = -(sign(B(k + 1, k))
|
||||
*> k = 1, N - 1, QBLCKB
|
||||
*>
|
||||
*> D : if (i <= j) then D(i, j) = [-1...1].
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*>
|
||||
*> E : if (i <= j) then D(i, j) = [-1...1]
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L, R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 4 Full
|
||||
*> A(i, j) = [-10...10]
|
||||
*> D(i, j) = [-1...1] i,j = 1...M
|
||||
*> B(i, j) = [-10...10]
|
||||
*> E(i, j) = [-1...1] i,j = 1...N
|
||||
*> R(i, j) = [-10...10]
|
||||
*> L(i, j) = [-1...1] i = 1..M ,j = 1...N
|
||||
*>
|
||||
*> L, R specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 5 special case common and/or close eigs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
$ QBLCKB )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
$ PRTYPE, QBLCKA, QBLCKB
|
||||
REAL ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
$ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE, TWO, ZERO, HALF, TWENTY
|
||||
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
|
||||
$ TWO = ( 2.0E+0, 0.0E+0 ),
|
||||
$ ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ HALF = ( 0.5E+0, 0.0E+0 ),
|
||||
$ TWENTY = ( 2.0E+1, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, K
|
||||
COMPLEX IMEPS, REEPS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CMPLX, MOD, SIN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( PRTYPE.EQ.1 ) THEN
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, J ) = ONE
|
||||
D( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
A( I, J ) = -ONE
|
||||
D( I, J ) = ZERO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, N
|
||||
DO 30 J = 1, N
|
||||
IF( I.EQ.J ) THEN
|
||||
B( I, J ) = ONE - ALPHA
|
||||
E( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
B( I, J ) = ONE
|
||||
E( I, J ) = ZERO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
DO 50 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( CMPLX( I / J ) ) )*TWENTY
|
||||
L( I, J ) = R( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
|
||||
DO 80 I = 1, M
|
||||
DO 70 J = 1, M
|
||||
IF( I.LE.J ) THEN
|
||||
A( I, J ) = ( HALF-SIN( CMPLX( I ) ) )*TWO
|
||||
D( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*TWO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
DO 100 I = 1, N
|
||||
DO 90 J = 1, N
|
||||
IF( I.LE.J ) THEN
|
||||
B( I, J ) = ( HALF-SIN( CMPLX( I+J ) ) )*TWO
|
||||
E( I, J ) = ( HALF-SIN( CMPLX( J ) ) )*TWO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
DO 120 I = 1, M
|
||||
DO 110 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( CMPLX( I+J ) ) )*TWENTY
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
*
|
||||
IF( PRTYPE.EQ.3 ) THEN
|
||||
IF( QBLCKA.LE.1 )
|
||||
$ QBLCKA = 2
|
||||
DO 130 K = 1, M - 1, QBLCKA
|
||||
A( K+1, K+1 ) = A( K, K )
|
||||
A( K+1, K ) = -SIN( A( K, K+1 ) )
|
||||
130 CONTINUE
|
||||
*
|
||||
IF( QBLCKB.LE.1 )
|
||||
$ QBLCKB = 2
|
||||
DO 140 K = 1, N - 1, QBLCKB
|
||||
B( K+1, K+1 ) = B( K, K )
|
||||
B( K+1, K ) = -SIN( B( K, K+1 ) )
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.4 ) THEN
|
||||
DO 160 I = 1, M
|
||||
DO 150 J = 1, M
|
||||
A( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*TWENTY
|
||||
D( I, J ) = ( HALF-SIN( CMPLX( I+J ) ) )*TWO
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
*
|
||||
DO 180 I = 1, N
|
||||
DO 170 J = 1, N
|
||||
B( I, J ) = ( HALF-SIN( CMPLX( I+J ) ) )*TWENTY
|
||||
E( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*TWO
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
DO 200 I = 1, M
|
||||
DO 190 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( CMPLX( J / I ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*TWO
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.GE.5 ) THEN
|
||||
REEPS = HALF*TWO*TWENTY / ALPHA
|
||||
IMEPS = ( HALF-TWO ) / ALPHA
|
||||
DO 220 I = 1, M
|
||||
DO 210 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( CMPLX( I*J ) ) )*ALPHA / TWENTY
|
||||
L( I, J ) = ( HALF-SIN( CMPLX( I+J ) ) )*ALPHA / TWENTY
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
*
|
||||
DO 230 I = 1, M
|
||||
D( I, I ) = ONE
|
||||
230 CONTINUE
|
||||
*
|
||||
DO 240 I = 1, M
|
||||
IF( I.LE.4 ) THEN
|
||||
A( I, I ) = ONE
|
||||
IF( I.GT.2 )
|
||||
$ A( I, I ) = ONE + REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
A( I, I ) = REEPS
|
||||
ELSE
|
||||
A( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = ONE
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -ONE
|
||||
END IF
|
||||
ELSE
|
||||
A( I, I ) = ONE
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
240 CONTINUE
|
||||
*
|
||||
DO 250 I = 1, N
|
||||
E( I, I ) = ONE
|
||||
IF( I.LE.4 ) THEN
|
||||
B( I, I ) = -ONE
|
||||
IF( I.GT.2 )
|
||||
$ B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
B( I, I ) = REEPS
|
||||
ELSE
|
||||
B( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = ONE + IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -ONE - IMEPS
|
||||
END IF
|
||||
ELSE
|
||||
B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Compute rhs (C, F)
|
||||
*
|
||||
CALL CGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
|
||||
CALL CGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
|
||||
CALL CGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
|
||||
CALL CGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
|
||||
*
|
||||
* End of CLATM5
|
||||
*
|
||||
END
|
||||
300
lapack-netlib/TESTING/MATGEN/clatm6.f
Normal file
300
lapack-netlib/TESTING/MATGEN/clatm6.f
Normal file
@@ -0,0 +1,300 @@
|
||||
*> \brief \b CLATM6
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
* BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDX, LDY, N, TYPE
|
||||
* COMPLEX ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL DIF( * ), S( * )
|
||||
* COMPLEX A( LDA, * ), B( LDA, * ), X( LDX, * ),
|
||||
* $ Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATM6 generates test matrices for the generalized eigenvalue
|
||||
*> problem, their corresponding right and left eigenvector matrices,
|
||||
*> and also reciprocal condition numbers for all eigenvalues and
|
||||
*> the reciprocal condition numbers of eigenvectors corresponding to
|
||||
*> the 1th and 5th eigenvalues.
|
||||
*>
|
||||
*> Test Matrices
|
||||
*> =============
|
||||
*>
|
||||
*> Two kinds of test matrix pairs
|
||||
*> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
|
||||
*> are used in the tests:
|
||||
*>
|
||||
*> Type 1:
|
||||
*> Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 2+a 0 0 0 0 1 0 0 0
|
||||
*> 0 0 3+a 0 0 0 0 1 0 0
|
||||
*> 0 0 0 4+a 0 0 0 0 1 0
|
||||
*> 0 0 0 0 5+a , 0 0 0 0 1
|
||||
*> and Type 2:
|
||||
*> Da = 1+i 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 1-i 0 0 0 0 1 0 0 0
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0
|
||||
*> 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 .
|
||||
*>
|
||||
*> In both cases the same inverse(YH) and inverse(X) are used to compute
|
||||
*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
|
||||
*>
|
||||
*> YH: = 1 0 -y y -y X = 1 0 -x -x x
|
||||
*> 0 1 -y y -y 0 1 x -x -x
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1 0 0 0 0 1 0
|
||||
*> 0 0 0 0 1, 0 0 0 0 1 , where
|
||||
*>
|
||||
*> a, b, x and y will have all values independently of each other.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TYPE
|
||||
*> \verbatim
|
||||
*> TYPE is INTEGER
|
||||
*> Specifies the problem type (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of the matrices A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA, N).
|
||||
*> On exit A N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A and of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array, dimension (LDA, N).
|
||||
*> On exit B N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension (LDX, N).
|
||||
*> On exit X is the N-by-N matrix of right eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array, dimension (LDY, N).
|
||||
*> On exit Y is the N-by-N matrix of left eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDY
|
||||
*> \verbatim
|
||||
*> LDY is INTEGER
|
||||
*> The leading dimension of Y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*>
|
||||
*> Weighting constants for matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WX
|
||||
*> \verbatim
|
||||
*> WX is COMPLEX
|
||||
*> Constant for right eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WY
|
||||
*> \verbatim
|
||||
*> WY is COMPLEX
|
||||
*> Constant for left eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] S
|
||||
*> \verbatim
|
||||
*> S is REAL array, dimension (N)
|
||||
*> S(i) is the reciprocal condition number for eigenvalue i.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] DIF
|
||||
*> \verbatim
|
||||
*> DIF is REAL array, dimension (N)
|
||||
*> DIF(i) is the reciprocal condition number for eigenvector i.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
$ BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDX, LDY, N, TYPE
|
||||
COMPLEX ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL DIF( * ), S( * )
|
||||
COMPLEX A( LDA, * ), B( LDA, * ), X( LDX, * ),
|
||||
$ Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL RONE, TWO, THREE
|
||||
PARAMETER ( RONE = 1.0E+0, TWO = 2.0E+0, THREE = 3.0E+0 )
|
||||
COMPLEX ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
|
||||
$ ONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, INFO, J
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL RWORK( 50 )
|
||||
COMPLEX WORK( 26 ), Z( 8, 8 )
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CABS, CMPLX, CONJG, REAL, SQRT
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGESVD, CLACPY, CLAKF2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate test problem ...
|
||||
* (Da, Db) ...
|
||||
*
|
||||
DO 20 I = 1, N
|
||||
DO 10 J = 1, N
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, I ) = CMPLX( I ) + ALPHA
|
||||
B( I, I ) = ONE
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
B( I, J ) = ZERO
|
||||
END IF
|
||||
*
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
IF( TYPE.EQ.2 ) THEN
|
||||
A( 1, 1 ) = CMPLX( RONE, RONE )
|
||||
A( 2, 2 ) = CONJG( A( 1, 1 ) )
|
||||
A( 3, 3 ) = ONE
|
||||
A( 4, 4 ) = CMPLX( REAL( ONE+ALPHA ), REAL( ONE+BETA ) )
|
||||
A( 5, 5 ) = CONJG( A( 4, 4 ) )
|
||||
END IF
|
||||
*
|
||||
* Form X and Y
|
||||
*
|
||||
CALL CLACPY( 'F', N, N, B, LDA, Y, LDY )
|
||||
Y( 3, 1 ) = -CONJG( WY )
|
||||
Y( 4, 1 ) = CONJG( WY )
|
||||
Y( 5, 1 ) = -CONJG( WY )
|
||||
Y( 3, 2 ) = -CONJG( WY )
|
||||
Y( 4, 2 ) = CONJG( WY )
|
||||
Y( 5, 2 ) = -CONJG( WY )
|
||||
*
|
||||
CALL CLACPY( 'F', N, N, B, LDA, X, LDX )
|
||||
X( 1, 3 ) = -WX
|
||||
X( 1, 4 ) = -WX
|
||||
X( 1, 5 ) = WX
|
||||
X( 2, 3 ) = WX
|
||||
X( 2, 4 ) = -WX
|
||||
X( 2, 5 ) = -WX
|
||||
*
|
||||
* Form (A, B)
|
||||
*
|
||||
B( 1, 3 ) = WX + WY
|
||||
B( 2, 3 ) = -WX + WY
|
||||
B( 1, 4 ) = WX - WY
|
||||
B( 2, 4 ) = WX - WY
|
||||
B( 1, 5 ) = -WX + WY
|
||||
B( 2, 5 ) = WX + WY
|
||||
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
|
||||
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
|
||||
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
|
||||
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
|
||||
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
|
||||
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
|
||||
*
|
||||
* Compute condition numbers
|
||||
*
|
||||
S( 1 ) = RONE / SQRT( ( RONE+THREE*CABS( WY )*CABS( WY ) ) /
|
||||
$ ( RONE+CABS( A( 1, 1 ) )*CABS( A( 1, 1 ) ) ) )
|
||||
S( 2 ) = RONE / SQRT( ( RONE+THREE*CABS( WY )*CABS( WY ) ) /
|
||||
$ ( RONE+CABS( A( 2, 2 ) )*CABS( A( 2, 2 ) ) ) )
|
||||
S( 3 ) = RONE / SQRT( ( RONE+TWO*CABS( WX )*CABS( WX ) ) /
|
||||
$ ( RONE+CABS( A( 3, 3 ) )*CABS( A( 3, 3 ) ) ) )
|
||||
S( 4 ) = RONE / SQRT( ( RONE+TWO*CABS( WX )*CABS( WX ) ) /
|
||||
$ ( RONE+CABS( A( 4, 4 ) )*CABS( A( 4, 4 ) ) ) )
|
||||
S( 5 ) = RONE / SQRT( ( RONE+TWO*CABS( WX )*CABS( WX ) ) /
|
||||
$ ( RONE+CABS( A( 5, 5 ) )*CABS( A( 5, 5 ) ) ) )
|
||||
*
|
||||
CALL CLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 8 )
|
||||
CALL CGESVD( 'N', 'N', 8, 8, Z, 8, RWORK, WORK, 1, WORK( 2 ), 1,
|
||||
$ WORK( 3 ), 24, RWORK( 9 ), INFO )
|
||||
DIF( 1 ) = RWORK( 8 )
|
||||
*
|
||||
CALL CLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 8 )
|
||||
CALL CGESVD( 'N', 'N', 8, 8, Z, 8, RWORK, WORK, 1, WORK( 2 ), 1,
|
||||
$ WORK( 3 ), 24, RWORK( 9 ), INFO )
|
||||
DIF( 5 ) = RWORK( 8 )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLATM6
|
||||
*
|
||||
END
|
||||
642
lapack-netlib/TESTING/MATGEN/clatme.f
Normal file
642
lapack-netlib/TESTING/MATGEN/clatme.f
Normal file
@@ -0,0 +1,642 @@
|
||||
*> \brief \b CLATME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
|
||||
* RSIGN,
|
||||
* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
* A,
|
||||
* LDA, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
* INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
* REAL ANORM, COND, CONDS
|
||||
* COMPLEX DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL DS( * )
|
||||
* COMPLEX A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLATME generates random non-symmetric square matrices with
|
||||
*> specified eigenvalues for testing LAPACK programs.
|
||||
*>
|
||||
*> CLATME operates by applying the following sequence of
|
||||
*> operations:
|
||||
*>
|
||||
*> 1. Set the diagonal to D, where D may be input or
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN
|
||||
*> as described below.
|
||||
*>
|
||||
*> 2. If UPPER='T', the upper triangle of A is set to random values
|
||||
*> out of distribution DIST.
|
||||
*>
|
||||
*> 3. If SIM='T', A is multiplied on the left by a random matrix
|
||||
*> X, whose singular values are specified by DS, MODES, and
|
||||
*> CONDS, and on the right by X inverse.
|
||||
*>
|
||||
*> 4. If KL < N-1, the lower bandwidth is reduced to KL using
|
||||
*> Householder transformations. If KU < N-1, the upper
|
||||
*> bandwidth is reduced to KU.
|
||||
*>
|
||||
*> 5. If ANORM is not negative, the matrix is scaled to have
|
||||
*> maximum-element-norm ANORM.
|
||||
*>
|
||||
*> (Note: since the matrix cannot be reduced beyond Hessenberg form,
|
||||
*> no packing options are available.)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns (or rows) of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIST
|
||||
*> \verbatim
|
||||
*> DIST is CHARACTER*1
|
||||
*> On entry, DIST specifies the type of distribution to be used
|
||||
*> to generate the random eigen-/singular values, and on the
|
||||
*> upper triangle (see UPPER).
|
||||
*> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
|
||||
*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
|
||||
*> 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
|
||||
*> 'D' => uniform on the complex disc |z| < 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. They should lie between 0 and 4095 inclusive,
|
||||
*> and ISEED(4) should be odd. The random number generator
|
||||
*> uses a linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to CLATME
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX array, dimension ( N )
|
||||
*> This array is used to specify the eigenvalues of A. If
|
||||
*> MODE=0, then D is assumed to contain the eigenvalues
|
||||
*> otherwise they will be computed according to MODE, COND,
|
||||
*> DMAX, and RSIGN and placed in D.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry this describes how the eigenvalues are to
|
||||
*> be specified:
|
||||
*> MODE = 0 means use D as input
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is between 1 and 4, D has entries ranging
|
||||
*> from 1 to 1/COND, if between -1 and -4, D has entries
|
||||
*> ranging from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is REAL
|
||||
*> On entry, this is used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DMAX
|
||||
*> \verbatim
|
||||
*> DMAX is COMPLEX
|
||||
*> If MODE is neither -6, 0 nor 6, the contents of D, as
|
||||
*> computed according to MODE and COND, will be scaled by
|
||||
*> DMAX / max(abs(D(i))). Note that DMAX need not be
|
||||
*> positive or real: if DMAX is negative or complex (or zero),
|
||||
*> D will be scaled by a negative or complex number (or zero).
|
||||
*> If RSIGN='F' then the largest (absolute) eigenvalue will be
|
||||
*> equal to DMAX.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] RSIGN
|
||||
*> \verbatim
|
||||
*> RSIGN is CHARACTER*1
|
||||
*> If MODE is not 0, 6, or -6, and RSIGN='T', then the
|
||||
*> elements of D, as computed according to MODE and COND, will
|
||||
*> be multiplied by a random complex number from the unit
|
||||
*> circle |z| = 1. If RSIGN='F', they will not be. RSIGN may
|
||||
*> only have the values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPPER
|
||||
*> \verbatim
|
||||
*> UPPER is CHARACTER*1
|
||||
*> If UPPER='T', then the elements of A above the diagonal
|
||||
*> will be set to random numbers out of DIST. If UPPER='F',
|
||||
*> they will not. UPPER may only have the values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SIM
|
||||
*> \verbatim
|
||||
*> SIM is CHARACTER*1
|
||||
*> If SIM='T', then A will be operated on by a "similarity
|
||||
*> transform", i.e., multiplied on the left by a matrix X and
|
||||
*> on the right by X inverse. X = U S V, where U and V are
|
||||
*> random unitary matrices and S is a (diagonal) matrix of
|
||||
*> singular values specified by DS, MODES, and CONDS. If
|
||||
*> SIM='F', then A will not be transformed.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DS
|
||||
*> \verbatim
|
||||
*> DS is REAL array, dimension ( N )
|
||||
*> This array is used to specify the singular values of X,
|
||||
*> in the same way that D specifies the eigenvalues of A.
|
||||
*> If MODE=0, the DS contains the singular values, which
|
||||
*> may not be zero.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODES
|
||||
*> \verbatim
|
||||
*> MODES is INTEGER
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CONDS
|
||||
*> \verbatim
|
||||
*> CONDS is REAL
|
||||
*> Similar to MODE and COND, but for specifying the diagonal
|
||||
*> of S. MODES=-6 and +6 are not allowed (since they would
|
||||
*> result in randomly ill-conditioned eigenvalues.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> This specifies the lower bandwidth of the matrix. KL=1
|
||||
*> specifies upper Hessenberg form. If KL is at least N-1,
|
||||
*> then A will have full lower bandwidth.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> This specifies the upper bandwidth of the matrix. KU=1
|
||||
*> specifies lower Hessenberg form. If KU is at least N-1,
|
||||
*> then A will have full upper bandwidth; if KU and KL
|
||||
*> are both at least N-1, then A will be dense. Only one of
|
||||
*> KU and KL may be less than N-1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ANORM
|
||||
*> \verbatim
|
||||
*> ANORM is REAL
|
||||
*> If ANORM is not negative, then A will be scaled by a non-
|
||||
*> negative real number to make the maximum-element-norm of A
|
||||
*> to be ANORM.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension ( LDA, N )
|
||||
*> On exit A is the desired test matrix.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> LDA specifies the first dimension of A as declared in the
|
||||
*> calling program. LDA must be at least M.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension ( 3*N )
|
||||
*> Workspace.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> Error code. On exit, INFO will be set to one of the
|
||||
*> following values:
|
||||
*> 0 => normal return
|
||||
*> -1 => N negative
|
||||
*> -2 => DIST illegal string
|
||||
*> -5 => MODE not in range -6 to 6
|
||||
*> -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
|
||||
*> -9 => RSIGN is not 'T' or 'F'
|
||||
*> -10 => UPPER is not 'T' or 'F'
|
||||
*> -11 => SIM is not 'T' or 'F'
|
||||
*> -12 => MODES=0 and DS has a zero singular value.
|
||||
*> -13 => MODES is not in the range -5 to 5.
|
||||
*> -14 => MODES is nonzero and CONDS is less than 1.
|
||||
*> -15 => KL is less than 1.
|
||||
*> -16 => KU is less than 1, or KL and KU are both less than
|
||||
*> N-1.
|
||||
*> -19 => LDA is less than M.
|
||||
*> 1 => Error return from CLATM1 (computing D)
|
||||
*> 2 => Cannot scale to DMAX (max. eigenvalue is 0)
|
||||
*> 3 => Error return from SLATM1 (computing DS)
|
||||
*> 4 => Error return from CLARGE
|
||||
*> 5 => Zero singular value from SLATM1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
|
||||
$ RSIGN,
|
||||
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
$ A,
|
||||
$ LDA, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
REAL ANORM, COND, CONDS
|
||||
COMPLEX DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL DS( * )
|
||||
COMPLEX A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E+0 )
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E+0 )
|
||||
COMPLEX CZERO
|
||||
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
|
||||
COMPLEX CONE
|
||||
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BADS
|
||||
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
|
||||
$ ISIM, IUPPER, J, JC, JCR
|
||||
REAL RALPHA, TEMP
|
||||
COMPLEX ALPHA, TAU, XNORMS
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL TEMPA( 1 )
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
REAL CLANGE
|
||||
COMPLEX CLARND
|
||||
EXTERNAL LSAME, CLANGE, CLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CCOPY, CGEMV, CGERC, CLACGV, CLARFG, CLARGE,
|
||||
$ CLARNV, CLATM1, CLASET, CSCAL, CSSCAL, SLATM1,
|
||||
$ XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, CONJG, MAX, MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 1) Decode and Test the input parameters.
|
||||
* Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Decode DIST
|
||||
*
|
||||
IF( LSAME( DIST, 'U' ) ) THEN
|
||||
IDIST = 1
|
||||
ELSE IF( LSAME( DIST, 'S' ) ) THEN
|
||||
IDIST = 2
|
||||
ELSE IF( LSAME( DIST, 'N' ) ) THEN
|
||||
IDIST = 3
|
||||
ELSE IF( LSAME( DIST, 'D' ) ) THEN
|
||||
IDIST = 4
|
||||
ELSE
|
||||
IDIST = -1
|
||||
END IF
|
||||
*
|
||||
* Decode RSIGN
|
||||
*
|
||||
IF( LSAME( RSIGN, 'T' ) ) THEN
|
||||
IRSIGN = 1
|
||||
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
|
||||
IRSIGN = 0
|
||||
ELSE
|
||||
IRSIGN = -1
|
||||
END IF
|
||||
*
|
||||
* Decode UPPER
|
||||
*
|
||||
IF( LSAME( UPPER, 'T' ) ) THEN
|
||||
IUPPER = 1
|
||||
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
|
||||
IUPPER = 0
|
||||
ELSE
|
||||
IUPPER = -1
|
||||
END IF
|
||||
*
|
||||
* Decode SIM
|
||||
*
|
||||
IF( LSAME( SIM, 'T' ) ) THEN
|
||||
ISIM = 1
|
||||
ELSE IF( LSAME( SIM, 'F' ) ) THEN
|
||||
ISIM = 0
|
||||
ELSE
|
||||
ISIM = -1
|
||||
END IF
|
||||
*
|
||||
* Check DS, if MODES=0 and ISIM=1
|
||||
*
|
||||
BADS = .FALSE.
|
||||
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
|
||||
DO 10 J = 1, N
|
||||
IF( DS( J ).EQ.ZERO )
|
||||
$ BADS = .TRUE.
|
||||
10 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( IDIST.EQ.-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ABS( MODE ).GT.6 ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
|
||||
$ THEN
|
||||
INFO = -6
|
||||
ELSE IF( IRSIGN.EQ.-1 ) THEN
|
||||
INFO = -9
|
||||
ELSE IF( IUPPER.EQ.-1 ) THEN
|
||||
INFO = -10
|
||||
ELSE IF( ISIM.EQ.-1 ) THEN
|
||||
INFO = -11
|
||||
ELSE IF( BADS ) THEN
|
||||
INFO = -12
|
||||
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
|
||||
INFO = -13
|
||||
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
|
||||
INFO = -14
|
||||
ELSE IF( KL.LT.1 ) THEN
|
||||
INFO = -15
|
||||
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
|
||||
INFO = -16
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -19
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'CLATME', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Initialize random number generator
|
||||
*
|
||||
DO 20 I = 1, 4
|
||||
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
|
||||
20 CONTINUE
|
||||
*
|
||||
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
|
||||
$ ISEED( 4 ) = ISEED( 4 ) + 1
|
||||
*
|
||||
* 2) Set up diagonal of A
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
CALL CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 1
|
||||
RETURN
|
||||
END IF
|
||||
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
|
||||
*
|
||||
* Scale by DMAX
|
||||
*
|
||||
TEMP = ABS( D( 1 ) )
|
||||
DO 30 I = 2, N
|
||||
TEMP = MAX( TEMP, ABS( D( I ) ) )
|
||||
30 CONTINUE
|
||||
*
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = DMAX / TEMP
|
||||
ELSE
|
||||
INFO = 2
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
CALL CSCAL( N, ALPHA, D, 1 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
|
||||
CALL CCOPY( N, D, 1, A, LDA+1 )
|
||||
*
|
||||
* 3) If UPPER='T', set upper triangle of A to random numbers.
|
||||
*
|
||||
IF( IUPPER.NE.0 ) THEN
|
||||
DO 40 JC = 2, N
|
||||
CALL CLARNV( IDIST, ISEED, JC-1, A( 1, JC ) )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 4) If SIM='T', apply similarity transformation.
|
||||
*
|
||||
* -1
|
||||
* Transform is X A X , where X = U S V, thus
|
||||
*
|
||||
* it is U S V A V' (1/S) U'
|
||||
*
|
||||
IF( ISIM.NE.0 ) THEN
|
||||
*
|
||||
* Compute S (singular values of the eigenvector matrix)
|
||||
* according to CONDS and MODES
|
||||
*
|
||||
CALL SLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 3
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by V and V'
|
||||
*
|
||||
CALL CLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by S and (1/S)
|
||||
*
|
||||
DO 50 J = 1, N
|
||||
CALL CSSCAL( N, DS( J ), A( J, 1 ), LDA )
|
||||
IF( DS( J ).NE.ZERO ) THEN
|
||||
CALL CSSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
|
||||
ELSE
|
||||
INFO = 5
|
||||
RETURN
|
||||
END IF
|
||||
50 CONTINUE
|
||||
*
|
||||
* Multiply by U and U'
|
||||
*
|
||||
CALL CLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* 5) Reduce the bandwidth.
|
||||
*
|
||||
IF( KL.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce bandwidth -- kill column
|
||||
*
|
||||
DO 60 JCR = KL + 1, N - 1
|
||||
IC = JCR - KL
|
||||
IROWS = N + 1 - JCR
|
||||
ICOLS = N + KL - JCR
|
||||
*
|
||||
CALL CCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL CLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
TAU = CONJG( TAU )
|
||||
WORK( 1 ) = CONE
|
||||
ALPHA = CLARND( 5, ISEED )
|
||||
*
|
||||
CALL CGEMV( 'C', IROWS, ICOLS, CONE, A( JCR, IC+1 ), LDA,
|
||||
$ WORK, 1, CZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL CGERC( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
|
||||
$ A( JCR, IC+1 ), LDA )
|
||||
*
|
||||
CALL CGEMV( 'N', N, IROWS, CONE, A( 1, JCR ), LDA, WORK, 1,
|
||||
$ CZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL CGERC( N, IROWS, -CONJG( TAU ), WORK( IROWS+1 ), 1,
|
||||
$ WORK, 1, A( 1, JCR ), LDA )
|
||||
*
|
||||
A( JCR, IC ) = XNORMS
|
||||
CALL CLASET( 'Full', IROWS-1, 1, CZERO, CZERO,
|
||||
$ A( JCR+1, IC ), LDA )
|
||||
*
|
||||
CALL CSCAL( ICOLS+1, ALPHA, A( JCR, IC ), LDA )
|
||||
CALL CSCAL( N, CONJG( ALPHA ), A( 1, JCR ), 1 )
|
||||
60 CONTINUE
|
||||
ELSE IF( KU.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce upper bandwidth -- kill a row at a time.
|
||||
*
|
||||
DO 70 JCR = KU + 1, N - 1
|
||||
IR = JCR - KU
|
||||
IROWS = N + KU - JCR
|
||||
ICOLS = N + 1 - JCR
|
||||
*
|
||||
CALL CCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL CLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
TAU = CONJG( TAU )
|
||||
WORK( 1 ) = CONE
|
||||
CALL CLACGV( ICOLS-1, WORK( 2 ), 1 )
|
||||
ALPHA = CLARND( 5, ISEED )
|
||||
*
|
||||
CALL CGEMV( 'N', IROWS, ICOLS, CONE, A( IR+1, JCR ), LDA,
|
||||
$ WORK, 1, CZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL CGERC( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
|
||||
$ A( IR+1, JCR ), LDA )
|
||||
*
|
||||
CALL CGEMV( 'C', ICOLS, N, CONE, A( JCR, 1 ), LDA, WORK, 1,
|
||||
$ CZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL CGERC( ICOLS, N, -CONJG( TAU ), WORK, 1,
|
||||
$ WORK( ICOLS+1 ), 1, A( JCR, 1 ), LDA )
|
||||
*
|
||||
A( IR, JCR ) = XNORMS
|
||||
CALL CLASET( 'Full', 1, ICOLS-1, CZERO, CZERO,
|
||||
$ A( IR, JCR+1 ), LDA )
|
||||
*
|
||||
CALL CSCAL( IROWS+1, ALPHA, A( IR, JCR ), 1 )
|
||||
CALL CSCAL( N, CONJG( ALPHA ), A( JCR, 1 ), LDA )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Scale the matrix to have norm ANORM
|
||||
*
|
||||
IF( ANORM.GE.ZERO ) THEN
|
||||
TEMP = CLANGE( 'M', N, N, A, LDA, TEMPA )
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
RALPHA = ANORM / TEMP
|
||||
DO 80 J = 1, N
|
||||
CALL CSSCAL( N, RALPHA, A( 1, J ), 1 )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLATME
|
||||
*
|
||||
END
|
||||
1342
lapack-netlib/TESTING/MATGEN/clatmr.f
Normal file
1342
lapack-netlib/TESTING/MATGEN/clatmr.f
Normal file
File diff suppressed because it is too large
Load Diff
1256
lapack-netlib/TESTING/MATGEN/clatms.f
Normal file
1256
lapack-netlib/TESTING/MATGEN/clatms.f
Normal file
File diff suppressed because it is too large
Load Diff
1265
lapack-netlib/TESTING/MATGEN/clatmt.f
Normal file
1265
lapack-netlib/TESTING/MATGEN/clatmt.f
Normal file
File diff suppressed because it is too large
Load Diff
357
lapack-netlib/TESTING/MATGEN/dlagge.f
Normal file
357
lapack-netlib/TESTING/MATGEN/dlagge.f
Normal file
@@ -0,0 +1,357 @@
|
||||
*> \brief \b DLAGGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAGGE generates a real general m by n matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with random orthogonal matrices:
|
||||
*> A = U*D*V. The lower and upper bandwidths may then be reduced to
|
||||
*> kl and ku by additional orthogonal transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= KL <= M-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The number of nonzero superdiagonals within the band of A.
|
||||
*> 0 <= KU <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (min(M,N))
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> The generated m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= M.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (M+N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
DOUBLE PRECISION TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN, SIGN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DNRM2
|
||||
EXTERNAL DNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'DLAGGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, MIN( M, N )
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* pre- and post-multiply A by random orthogonal matrices
|
||||
*
|
||||
DO 40 I = MIN( M, N ), 1, -1
|
||||
IF( I.LT.M ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL DLARNV( 3, ISEED, M-I+1, WORK )
|
||||
WN = DNRM2( M-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL DSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the left
|
||||
*
|
||||
CALL DGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( M+1 ), 1 )
|
||||
CALL DGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL DLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the right
|
||||
*
|
||||
CALL DGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL DGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to KL and number of superdiagonals
|
||||
* to KU
|
||||
*
|
||||
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
|
||||
IF( KL.LE.KU ) THEN
|
||||
*
|
||||
* annihilate subdiagonal elements first (necessary if KL = 0)
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = SIGN( WN, A( KL+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
|
||||
$ A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = SIGN( WN, A( I, KU+I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* annihilate superdiagonal elements first (necessary if
|
||||
* KU = 0)
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = SIGN( WN, A( I, KU+I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = SIGN( WN, A( KL+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
|
||||
$ A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
DO 50 J = KL + I + 1, M
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
*
|
||||
DO 60 J = KU + I + 1, N
|
||||
A( I, J ) = ZERO
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of DLAGGE
|
||||
*
|
||||
END
|
||||
261
lapack-netlib/TESTING/MATGEN/dlagsy.f
Normal file
261
lapack-netlib/TESTING/MATGEN/dlagsy.f
Normal file
@@ -0,0 +1,261 @@
|
||||
*> \brief \b DLAGSY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAGSY generates a real symmetric matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random orthogonal matrix:
|
||||
*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
|
||||
*> orthogonal transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> The generated n by n symmetric matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
DOUBLE PRECISION ALPHA, TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DAXPY, DGEMV, DGER, DLARNV, DSCAL, DSYMV,
|
||||
$ DSYR2, XERBLA
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DDOT, DNRM2
|
||||
EXTERNAL DDOT, DNRM2
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SIGN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'DLAGSY', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of symmetric matrix
|
||||
*
|
||||
DO 40 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL DLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL DSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 )
|
||||
CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
CALL DSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 60 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = DNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = SIGN( WN, A( K+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL DSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
|
||||
CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
CALL DSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, K+I ), LDA )
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 50 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Store full symmetric matrix
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
DO 70 I = J + 1, N
|
||||
A( J, I ) = A( I, J )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of DLAGSY
|
||||
*
|
||||
END
|
||||
225
lapack-netlib/TESTING/MATGEN/dlahilb.f
Normal file
225
lapack-netlib/TESTING/MATGEN/dlahilb.f
Normal file
@@ -0,0 +1,225 @@
|
||||
C> \brief \b DLAHILB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAHILB generates an N by N scaled Hilbert matrix in A along with
|
||||
*> NRHS right-hand sides in B and solutions in X such that A*X=B.
|
||||
*>
|
||||
*> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
|
||||
*> entries are integers. The right-hand sides are the first NRHS
|
||||
*> columns of M * the identity matrix, and the solutions are the
|
||||
*> first NRHS columns of the inverse Hilbert matrix.
|
||||
*>
|
||||
*> The condition number of the Hilbert matrix grows exponentially with
|
||||
*> its size, roughly as O(e ** (3.5*N)). Additionally, the inverse
|
||||
*> Hilbert matrices beyond a relatively small dimension cannot be
|
||||
*> generated exactly without extra precision. Precision is exhausted
|
||||
*> when the largest entry in the inverse Hilbert matrix is greater than
|
||||
*> 2 to the power of the number of bits in the fraction of the data type
|
||||
*> used plus one, which is 24 for single precision.
|
||||
*>
|
||||
*> In single, the generated solution is exact for N <= 6 and has
|
||||
*> small componentwise error for 7 <= N <= 11.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The dimension of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NRHS
|
||||
*> \verbatim
|
||||
*> NRHS is INTEGER
|
||||
*> The requested number of right-hand sides.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, N)
|
||||
*> The generated scaled Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array, dimension (LDX, NRHS)
|
||||
*> The generated exact solutions. Currently, the first NRHS
|
||||
*> columns of the inverse Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of the array X. LDX >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension (LDB, NRHS)
|
||||
*> The generated right-hand sides. Currently, the first NRHS
|
||||
*> columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> = 1: N is too large; the data is still generated but may not
|
||||
*> be not exact.
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO)
|
||||
*
|
||||
* -- LAPACK test routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
* .. Local Scalars ..
|
||||
INTEGER TM, TI, R
|
||||
INTEGER M
|
||||
INTEGER I, J
|
||||
COMPLEX*16 TMP
|
||||
|
||||
* .. Parameters ..
|
||||
* NMAX_EXACT the largest dimension where the generated data is
|
||||
* exact.
|
||||
* NMAX_APPROX the largest dimension where the generated data has
|
||||
* a small componentwise relative error.
|
||||
INTEGER NMAX_EXACT, NMAX_APPROX
|
||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11)
|
||||
|
||||
* ..
|
||||
* .. External Functions
|
||||
EXTERNAL DLASET
|
||||
INTRINSIC DBLE
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN
|
||||
INFO = -1
|
||||
ELSE IF (NRHS .LT. 0) THEN
|
||||
INFO = -2
|
||||
ELSE IF (LDA .LT. N) THEN
|
||||
INFO = -4
|
||||
ELSE IF (LDX .LT. N) THEN
|
||||
INFO = -6
|
||||
ELSE IF (LDB .LT. N) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF (INFO .LT. 0) THEN
|
||||
CALL XERBLA('DLAHILB', -INFO)
|
||||
RETURN
|
||||
END IF
|
||||
IF (N .GT. NMAX_EXACT) THEN
|
||||
INFO = 1
|
||||
END IF
|
||||
|
||||
* Compute M = the LCM of the integers [1, 2*N-1]. The largest
|
||||
* reasonable N is small enough that integers suffice (up to N = 11).
|
||||
M = 1
|
||||
DO I = 2, (2*N-1)
|
||||
TM = M
|
||||
TI = I
|
||||
R = MOD(TM, TI)
|
||||
DO WHILE (R .NE. 0)
|
||||
TM = TI
|
||||
TI = R
|
||||
R = MOD(TM, TI)
|
||||
END DO
|
||||
M = (M / TI) * I
|
||||
END DO
|
||||
|
||||
* Generate the scaled Hilbert matrix in A
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = DBLE(M) / (I + J - 1)
|
||||
END DO
|
||||
END DO
|
||||
|
||||
* Generate matrix B as simply the first NRHS columns of M * the
|
||||
* identity.
|
||||
TMP = DBLE(M)
|
||||
CALL DLASET('Full', N, NRHS, 0.0D+0, TMP, B, LDB)
|
||||
|
||||
* Generate the true solutions in X. Because B = the first NRHS
|
||||
* columns of M*I, the true solutions are just the first NRHS columns
|
||||
* of the inverse Hilbert matrix.
|
||||
WORK(1) = N
|
||||
DO J = 2, N
|
||||
WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) )
|
||||
$ * (N +J -1)
|
||||
END DO
|
||||
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1)
|
||||
END DO
|
||||
END DO
|
||||
|
||||
END
|
||||
|
||||
191
lapack-netlib/TESTING/MATGEN/dlakf2.f
Normal file
191
lapack-netlib/TESTING/MATGEN/dlakf2.f
Normal file
@@ -0,0 +1,191 @@
|
||||
*> \brief \b DLAKF2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
* $ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Form the 2*M*N by 2*M*N matrix
|
||||
*>
|
||||
*> Z = [ kron(In, A) -kron(B', Im) ]
|
||||
*> [ kron(In, D) -kron(E', Im) ],
|
||||
*>
|
||||
*> where In is the identity matrix of size n and X' is the transpose
|
||||
*> of X. kron(X, Y) is the Kronecker product between the matrices X
|
||||
*> and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION, dimension ( LDA, M )
|
||||
*> The matrix A in the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A, B, D, and E. ( LDA >= M+N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION, dimension ( LDA, N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION, dimension ( LDA, M )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION, dimension ( LDA, N )
|
||||
*>
|
||||
*> The matrices used in forming the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Z
|
||||
*> \verbatim
|
||||
*> Z is DOUBLE PRECISION, dimension ( LDZ, 2*M*N )
|
||||
*> The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDZ
|
||||
*> \verbatim
|
||||
*> LDZ is INTEGER
|
||||
*> The leading dimension of Z. ( LDZ >= 2*M*N )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
$ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
* ====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IK, J, JK, L, MN, MN2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLASET
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Initialize Z
|
||||
*
|
||||
MN = M*N
|
||||
MN2 = 2*MN
|
||||
CALL DLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
|
||||
*
|
||||
IK = 1
|
||||
DO 50 L = 1, N
|
||||
*
|
||||
* form kron(In, A)
|
||||
*
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
Z( IK+I-1, IK+J-1 ) = A( I, J )
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* form kron(In, D)
|
||||
*
|
||||
DO 40 I = 1, M
|
||||
DO 30 J = 1, M
|
||||
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
50 CONTINUE
|
||||
*
|
||||
IK = 1
|
||||
DO 90 L = 1, N
|
||||
JK = MN + 1
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
*
|
||||
* form -kron(B', Im)
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
Z( IK+I-1, JK+I-1 ) = -B( J, L )
|
||||
60 CONTINUE
|
||||
*
|
||||
* form -kron(E', Im)
|
||||
*
|
||||
DO 70 I = 1, M
|
||||
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
|
||||
70 CONTINUE
|
||||
*
|
||||
JK = JK + M
|
||||
80 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
90 CONTINUE
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLAKF2
|
||||
*
|
||||
END
|
||||
146
lapack-netlib/TESTING/MATGEN/dlaran.f
Normal file
146
lapack-netlib/TESTING/MATGEN/dlaran.f
Normal file
@@ -0,0 +1,146 @@
|
||||
*> \brief \b DLARAN
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLARAN( ISEED )
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARAN returns a random real number from a uniform (0,1)
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup list_temp
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine uses a multiplicative congruential method with modulus
|
||||
*> 2**48 and multiplier 33952834046453 (see G.S.Fishman,
|
||||
*> 'Multiplicative congruential random number generators with modulus
|
||||
*> 2**b: an exhaustive analysis for b = 32 and a partial analysis for
|
||||
*> b = 48', Math. Comp. 189, pp 331-344, 1990).
|
||||
*>
|
||||
*> 48-bit integers are stored in 4 integer array elements with 12 bits
|
||||
*> per element. Hence the routine is portable across machines with
|
||||
*> integers of 32 bits or more.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLARAN( ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
INTEGER M1, M2, M3, M4
|
||||
PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
INTEGER IPW2
|
||||
DOUBLE PRECISION R
|
||||
PARAMETER ( IPW2 = 4096, R = ONE / IPW2 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IT1, IT2, IT3, IT4
|
||||
DOUBLE PRECISION RNDOUT
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
10 CONTINUE
|
||||
*
|
||||
* multiply the seed by the multiplier modulo 2**48
|
||||
*
|
||||
IT4 = ISEED( 4 )*M4
|
||||
IT3 = IT4 / IPW2
|
||||
IT4 = IT4 - IPW2*IT3
|
||||
IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
|
||||
IT2 = IT3 / IPW2
|
||||
IT3 = IT3 - IPW2*IT2
|
||||
IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
|
||||
IT1 = IT2 / IPW2
|
||||
IT2 = IT2 - IPW2*IT1
|
||||
IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
|
||||
$ ISEED( 4 )*M1
|
||||
IT1 = MOD( IT1, IPW2 )
|
||||
*
|
||||
* return updated seed
|
||||
*
|
||||
ISEED( 1 ) = IT1
|
||||
ISEED( 2 ) = IT2
|
||||
ISEED( 3 ) = IT3
|
||||
ISEED( 4 ) = IT4
|
||||
*
|
||||
* convert 48-bit integer to a real number in the interval (0,1)
|
||||
*
|
||||
RNDOUT = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
|
||||
$ ( DBLE( IT4 ) ) ) ) )
|
||||
*
|
||||
IF (RNDOUT.EQ.1.0D+0) THEN
|
||||
* If a real number has n bits of precision, and the first
|
||||
* n bits of the 48-bit integer above happen to be all 1 (which
|
||||
* will occur about once every 2**n calls), then DLARAN will
|
||||
* be rounded to exactly 1.0.
|
||||
* Since DLARAN is not supposed to return exactly 0.0 or 1.0
|
||||
* (and some callers of DLARAN, such as CLARND, depend on that),
|
||||
* the statistically correct thing to do in this situation is
|
||||
* simply to iterate again.
|
||||
* N.B. the case DLARAN = 0.0 should not be possible.
|
||||
*
|
||||
GOTO 10
|
||||
END IF
|
||||
*
|
||||
DLARAN = RNDOUT
|
||||
RETURN
|
||||
*
|
||||
* End of DLARAN
|
||||
*
|
||||
END
|
||||
174
lapack-netlib/TESTING/MATGEN/dlarge.f
Normal file
174
lapack-netlib/TESTING/MATGEN/dlarge.f
Normal file
@@ -0,0 +1,174 @@
|
||||
*> \brief \b DLARGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARGE pre- and post-multiplies a real general n by n matrix A
|
||||
*> with a random orthogonal matrix: A = U*D*U'.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> On entry, the original n by n matrix A.
|
||||
*> On exit, A is overwritten by U*A*U' for some random
|
||||
*> orthogonal matrix U.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
DOUBLE PRECISION TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SIGN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DNRM2
|
||||
EXTERNAL DNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -3
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'DLARGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* pre- and post-multiply A by random orthogonal matrix
|
||||
*
|
||||
DO 10 I = N, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL DLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:n,1:n) by random reflection from the left
|
||||
*
|
||||
CALL DGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK,
|
||||
$ 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL DGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
|
||||
$ LDA )
|
||||
*
|
||||
* multiply A(1:n,i:n) by random reflection from the right
|
||||
*
|
||||
CALL DGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL DGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
|
||||
$ LDA )
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of DLARGE
|
||||
*
|
||||
END
|
||||
133
lapack-netlib/TESTING/MATGEN/dlarnd.f
Normal file
133
lapack-netlib/TESTING/MATGEN/dlarnd.f
Normal file
@@ -0,0 +1,133 @@
|
||||
*> \brief \b DLARND
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARND returns a random real number from a uniform or normal
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> Specifies the distribution of the random numbers:
|
||||
*> = 1: uniform (0,1)
|
||||
*> = 2: uniform (-1,1)
|
||||
*> = 3: normal (0,1)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine calls the auxiliary routine DLARAN to generate a random
|
||||
*> real number from a uniform (0,1) distribution. The Box-Muller method
|
||||
*> is used to transform numbers from a uniform to a normal distribution.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, TWO
|
||||
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
|
||||
DOUBLE PRECISION TWOPI
|
||||
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION T1, T2
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLARAN
|
||||
EXTERNAL DLARAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC COS, LOG, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate a real random number from a uniform (0,1) distribution
|
||||
*
|
||||
T1 = DLARAN( ISEED )
|
||||
*
|
||||
IF( IDIST.EQ.1 ) THEN
|
||||
*
|
||||
* uniform (0,1)
|
||||
*
|
||||
DLARND = T1
|
||||
ELSE IF( IDIST.EQ.2 ) THEN
|
||||
*
|
||||
* uniform (-1,1)
|
||||
*
|
||||
DLARND = TWO*T1 - ONE
|
||||
ELSE IF( IDIST.EQ.3 ) THEN
|
||||
*
|
||||
* normal (0,1)
|
||||
*
|
||||
T2 = DLARAN( ISEED )
|
||||
DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLARND
|
||||
*
|
||||
END
|
||||
304
lapack-netlib/TESTING/MATGEN/dlaror.f
Normal file
304
lapack-netlib/TESTING/MATGEN/dlaror.f
Normal file
@@ -0,0 +1,304 @@
|
||||
*> \brief \b DLAROR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER INIT, SIDE
|
||||
* INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAROR pre- or post-multiplies an M by N matrix A by a random
|
||||
*> orthogonal matrix U, overwriting A. A may optionally be initialized
|
||||
*> to the identity matrix before multiplying by U. U is generated using
|
||||
*> the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> Specifies whether A is multiplied on the left or right by U.
|
||||
*> = 'L': Multiply A on the left (premultiply) by U
|
||||
*> = 'R': Multiply A on the right (postmultiply) by U'
|
||||
*> = 'C' or 'T': Multiply A on the left by U and the right
|
||||
*> by U' (Here, U' means U-transpose.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INIT
|
||||
*> \verbatim
|
||||
*> INIT is CHARACTER*1
|
||||
*> Specifies whether or not A should be initialized to the
|
||||
*> identity matrix.
|
||||
*> = 'I': Initialize A to (a section of) the identity matrix
|
||||
*> before applying U.
|
||||
*> = 'N': No initialization. Apply U to the input matrix A.
|
||||
*>
|
||||
*> INIT = 'I' may be used to generate square or rectangular
|
||||
*> orthogonal matrices:
|
||||
*>
|
||||
*> For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
|
||||
*> to each other, as will the columns.
|
||||
*>
|
||||
*> If M < N, SIDE = 'R' produces a dense matrix whose rows are
|
||||
*> orthogonal and whose columns are not, while SIDE = 'L'
|
||||
*> produces a matrix whose rows are orthogonal, and whose first
|
||||
*> M columns are orthogonal, and whose remaining columns are
|
||||
*> zero.
|
||||
*>
|
||||
*> If M > N, SIDE = 'L' produces a dense matrix whose columns
|
||||
*> are orthogonal and whose rows are not, while SIDE = 'R'
|
||||
*> produces a matrix whose columns are orthogonal, and whose
|
||||
*> first M rows are orthogonal, and whose remaining rows are
|
||||
*> zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, N)
|
||||
*> On entry, the array A.
|
||||
*> On exit, overwritten by U A ( if SIDE = 'L' ),
|
||||
*> or by A U ( if SIDE = 'R' ),
|
||||
*> or by U A U' ( if SIDE = 'C' or 'T').
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The array elements should be between 0 and 4095;
|
||||
*> if not they will be reduced mod 4096. Also, ISEED(4) must
|
||||
*> be odd. The random number generator uses a linear
|
||||
*> congruential sequence limited to small integers, and so
|
||||
*> should produce machine independent random numbers. The
|
||||
*> values of ISEED are changed on exit, and can be used in the
|
||||
*> next call to DLAROR to continue the same random number
|
||||
*> sequence.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array, dimension (3*MAX( M, N ))
|
||||
*> Workspace of length
|
||||
*> 2*M + N if SIDE = 'L',
|
||||
*> 2*N + M if SIDE = 'R',
|
||||
*> 3*N if SIDE = 'C' or 'T'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> An error flag. It is set to:
|
||||
*> = 0: normal return
|
||||
*> < 0: if INFO = -k, the k-th argument had an illegal value
|
||||
*> = 1: if the random numbers generated by DLARND are bad.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER INIT, SIDE
|
||||
INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, TOOSML
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
|
||||
$ TOOSML = 1.0D-20 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
|
||||
DOUBLE PRECISION FACTOR, XNORM, XNORMS
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
DOUBLE PRECISION DLARND, DNRM2
|
||||
EXTERNAL LSAME, DLARND, DNRM2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMV, DGER, DLASET, DSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, SIGN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.EQ.0 .OR. M.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
ITYPE = 0
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
ITYPE = 1
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
ITYPE = 2
|
||||
ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN
|
||||
ITYPE = 3
|
||||
END IF
|
||||
*
|
||||
* Check for argument errors.
|
||||
*
|
||||
IF( ITYPE.EQ.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.M ) THEN
|
||||
INFO = -6
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DLAROR', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.1 ) THEN
|
||||
NXFRM = M
|
||||
ELSE
|
||||
NXFRM = N
|
||||
END IF
|
||||
*
|
||||
* Initialize A to the identity matrix if desired
|
||||
*
|
||||
IF( LSAME( INIT, 'I' ) )
|
||||
$ CALL DLASET( 'Full', M, N, ZERO, ONE, A, LDA )
|
||||
*
|
||||
* If no rotation possible, multiply by random +/-1
|
||||
*
|
||||
* Compute rotation by computing Householder transformations
|
||||
* H(2), H(3), ..., H(nhouse)
|
||||
*
|
||||
DO 10 J = 1, NXFRM
|
||||
X( J ) = ZERO
|
||||
10 CONTINUE
|
||||
*
|
||||
DO 30 IXFRM = 2, NXFRM
|
||||
KBEG = NXFRM - IXFRM + 1
|
||||
*
|
||||
* Generate independent normal( 0, 1 ) random numbers
|
||||
*
|
||||
DO 20 J = KBEG, NXFRM
|
||||
X( J ) = DLARND( 3, ISEED )
|
||||
20 CONTINUE
|
||||
*
|
||||
* Generate a Householder transformation from the random vector X
|
||||
*
|
||||
XNORM = DNRM2( IXFRM, X( KBEG ), 1 )
|
||||
XNORMS = SIGN( XNORM, X( KBEG ) )
|
||||
X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) )
|
||||
FACTOR = XNORMS*( XNORMS+X( KBEG ) )
|
||||
IF( ABS( FACTOR ).LT.TOOSML ) THEN
|
||||
INFO = 1
|
||||
CALL XERBLA( 'DLAROR', INFO )
|
||||
RETURN
|
||||
ELSE
|
||||
FACTOR = ONE / FACTOR
|
||||
END IF
|
||||
X( KBEG ) = X( KBEG ) + XNORMS
|
||||
*
|
||||
* Apply Householder transformation to A
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* Apply H(k) from the left.
|
||||
*
|
||||
CALL DGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA,
|
||||
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL DGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ),
|
||||
$ 1, A( KBEG, 1 ), LDA )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* Apply H(k) from the right.
|
||||
*
|
||||
CALL DGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA,
|
||||
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL DGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ),
|
||||
$ 1, A( 1, KBEG ), LDA )
|
||||
*
|
||||
END IF
|
||||
30 CONTINUE
|
||||
*
|
||||
X( 2*NXFRM ) = SIGN( ONE, DLARND( 3, ISEED ) )
|
||||
*
|
||||
* Scale the matrix A by D.
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 40 IROW = 1, M
|
||||
CALL DSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 50 JCOL = 1, N
|
||||
CALL DSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLAROR
|
||||
*
|
||||
END
|
||||
317
lapack-netlib/TESTING/MATGEN/dlarot.f
Normal file
317
lapack-netlib/TESTING/MATGEN/dlarot.f
Normal file
@@ -0,0 +1,317 @@
|
||||
*> \brief \b DLAROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
* XRIGHT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* LOGICAL LLEFT, LRIGHT, LROWS
|
||||
* INTEGER LDA, NL
|
||||
* DOUBLE PRECISION C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAROT applies a (Givens) rotation to two adjacent rows or
|
||||
*> columns, where one element of the first and/or last column/row
|
||||
*> for use on matrices stored in some format other than GE, so
|
||||
*> that elements of the matrix may be used or modified for which
|
||||
*> no array element is provided.
|
||||
*>
|
||||
*> One example is a symmetric matrix in SB format (bandwidth=4), for
|
||||
*> which UPLO='L': Two adjacent rows will have the format:
|
||||
*>
|
||||
*> row j: C> C> C> C> C> . . . .
|
||||
*> row j+1: C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> '*' indicates elements for which storage is provided,
|
||||
*> '.' indicates elements for which no storage is provided, but
|
||||
*> are not necessarily zero; their values are determined by
|
||||
*> symmetry. ' ' indicates elements which are necessarily zero,
|
||||
*> and have no storage provided.
|
||||
*>
|
||||
*> Those columns which have two '*'s can be handled by DROT.
|
||||
*> Those columns which have no '*'s can be ignored, since as long
|
||||
*> as the Givens rotations are carefully applied to preserve
|
||||
*> symmetry, their values are determined.
|
||||
*> Those columns which have one '*' have to be handled separately,
|
||||
*> by using separate variables "p" and "q":
|
||||
*>
|
||||
*> row j: C> C> C> C> C> p . . .
|
||||
*> row j+1: q C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> The element p would have to be set correctly, then that column
|
||||
*> is rotated, setting p to its new value. The next call to
|
||||
*> DLAROT would rotate columns j and j+1, using p, and restore
|
||||
*> symmetry. The element q would start out being zero, and be
|
||||
*> made non-zero by the rotation. Later, rotations would presumably
|
||||
*> be chosen to zero q out.
|
||||
*>
|
||||
*> Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
|
||||
*> ------- ------- ---------
|
||||
*>
|
||||
*> General dense matrix:
|
||||
*>
|
||||
*> CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
|
||||
*> A(i,1),LDA, DUMMY, DUMMY)
|
||||
*>
|
||||
*> General banded matrix in GB format:
|
||||
*>
|
||||
*> j = MAX(1, i-KL )
|
||||
*> NL = MIN( N, i+KU+1 ) + 1-j
|
||||
*> CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
|
||||
*> A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,KL+1) ]
|
||||
*>
|
||||
*> Symmetric banded matrix in SY format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> j = MAX(1, i-K )
|
||||
*> NL = MIN( K+1, i ) + 1
|
||||
*> CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
|
||||
*> A(i,j), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*>
|
||||
*> NL = MIN( K+1, N-i ) + 1
|
||||
*> CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
|
||||
*> A(i,i), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Symmetric banded matrix in SB format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> [ same as for SY, except:]
|
||||
*> . . . .
|
||||
*> A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,K+1) ]
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*> . . .
|
||||
*> A(K+1,i), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Rotating columns is just the transpose of rotating rows, except
|
||||
*> for GB and SB: (rotating columns i and i+1)
|
||||
*>
|
||||
*> GB:
|
||||
*> j = MAX(1, i-KU )
|
||||
*> NL = MIN( N, i+KL+1 ) + 1-j
|
||||
*> CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
|
||||
*> A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> [note that KU+j+1-i is just MAX(1,KU+2-i)]
|
||||
*>
|
||||
*> SB: (upper triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> SB: (lower triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(1,i),LDA-1, XTOP, XBOTTM )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> LROWS - LOGICAL
|
||||
*> If .TRUE., then DLAROT will rotate two rows. If .FALSE.,
|
||||
*> then it will rotate two columns.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LLEFT - LOGICAL
|
||||
*> If .TRUE., then XLEFT will be used instead of the
|
||||
*> corresponding element of A for the first element in the
|
||||
*> second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
|
||||
*> If .FALSE., then the corresponding element of A will be
|
||||
*> used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LRIGHT - LOGICAL
|
||||
*> If .TRUE., then XRIGHT will be used instead of the
|
||||
*> corresponding element of A for the last element in the
|
||||
*> first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
|
||||
*> .FALSE., then the corresponding element of A will be used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> NL - INTEGER
|
||||
*> The length of the rows (if LROWS=.TRUE.) or columns (if
|
||||
*> LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
|
||||
*> used, the columns/rows they are in should be included in
|
||||
*> NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
|
||||
*> least 2. The number of rows/columns to be rotated
|
||||
*> exclusive of those involving XLEFT and/or XRIGHT may
|
||||
*> not be negative, i.e., NL minus how many of LLEFT and
|
||||
*> LRIGHT are .TRUE. must be at least zero; if not, XERBLA
|
||||
*> will be called.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> C, S - DOUBLE PRECISION
|
||||
*> Specify the Givens rotation to be applied. If LROWS is
|
||||
*> true, then the matrix ( c s )
|
||||
*> (-s c ) is applied from the left;
|
||||
*> if false, then the transpose thereof is applied from the
|
||||
*> right. For a Givens rotation, C**2 + S**2 should be 1,
|
||||
*> but this is not checked.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> A - DOUBLE PRECISION array.
|
||||
*> The array containing the rows/columns to be rotated. The
|
||||
*> first element of A should be the upper left element to
|
||||
*> be rotated.
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> LDA - INTEGER
|
||||
*> The "effective" leading dimension of A. If A contains
|
||||
*> a matrix stored in GE or SY format, then this is just
|
||||
*> the leading dimension of A as dimensioned in the calling
|
||||
*> routine. If A contains a matrix stored in band (GB or SB)
|
||||
*> format, then this should be *one less* than the leading
|
||||
*> dimension used in the calling routine. Thus, if
|
||||
*> A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would
|
||||
*> be the j-th element in the first of the two rows
|
||||
*> to be rotated, and A(2,j) would be the j-th in the second,
|
||||
*> regardless of how the array may be stored in the calling
|
||||
*> routine. [A cannot, however, actually be dimensioned thus,
|
||||
*> since for band format, the row number may exceed LDA, which
|
||||
*> is not legal FORTRAN.]
|
||||
*> If LROWS=.TRUE., then LDA must be at least 1, otherwise
|
||||
*> it must be at least NL minus the number of .TRUE. values
|
||||
*> in XLEFT and XRIGHT.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> XLEFT - DOUBLE PRECISION
|
||||
*> If LLEFT is .TRUE., then XLEFT will be used and modified
|
||||
*> instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> XRIGHT - DOUBLE PRECISION
|
||||
*> If LRIGHT is .TRUE., then XRIGHT will be used and modified
|
||||
*> instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
$ XRIGHT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
LOGICAL LLEFT, LRIGHT, LROWS
|
||||
INTEGER LDA, NL
|
||||
DOUBLE PRECISION C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER IINC, INEXT, IX, IY, IYT, NT
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION XT( 2 ), YT( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DROT, XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Set up indices, arrays for ends
|
||||
*
|
||||
IF( LROWS ) THEN
|
||||
IINC = LDA
|
||||
INEXT = 1
|
||||
ELSE
|
||||
IINC = 1
|
||||
INEXT = LDA
|
||||
END IF
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
NT = 1
|
||||
IX = 1 + IINC
|
||||
IY = 2 + LDA
|
||||
XT( 1 ) = A( 1 )
|
||||
YT( 1 ) = XLEFT
|
||||
ELSE
|
||||
NT = 0
|
||||
IX = 1
|
||||
IY = 1 + INEXT
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
IYT = 1 + INEXT + ( NL-1 )*IINC
|
||||
NT = NT + 1
|
||||
XT( NT ) = XRIGHT
|
||||
YT( NT ) = A( IYT )
|
||||
END IF
|
||||
*
|
||||
* Check for errors
|
||||
*
|
||||
IF( NL.LT.NT ) THEN
|
||||
CALL XERBLA( 'DLAROT', 4 )
|
||||
RETURN
|
||||
END IF
|
||||
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
|
||||
CALL XERBLA( 'DLAROT', 8 )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Rotate
|
||||
*
|
||||
CALL DROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S )
|
||||
CALL DROT( NT, XT, 1, YT, 1, C, S )
|
||||
*
|
||||
* Stuff values back into XLEFT, XRIGHT, etc.
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
A( 1 ) = XT( 1 )
|
||||
XLEFT = YT( 1 )
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
XRIGHT = XT( NT )
|
||||
A( IYT ) = YT( NT )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLAROT
|
||||
*
|
||||
END
|
||||
299
lapack-netlib/TESTING/MATGEN/dlatm1.f
Normal file
299
lapack-netlib/TESTING/MATGEN/dlatm1.f
Normal file
@@ -0,0 +1,299 @@
|
||||
*> \brief \b DLATM1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
* DOUBLE PRECISION COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION D( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM1 computes the entries of D(1..N) as specified by
|
||||
*> MODE, COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. DLATM1 is called by SLATMR to generate
|
||||
*> random test matrices for LAPACK programs.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is DOUBLE PRECISION
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IRSIGN
|
||||
*> \verbatim
|
||||
*> IRSIGN is INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by 1 or -1 with probability .5
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to DLATM1
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
DOUBLE PRECISION COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION D( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D0 )
|
||||
DOUBLE PRECISION HALF
|
||||
PARAMETER ( HALF = 0.5D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
DOUBLE PRECISION ALPHA, TEMP
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLARAN
|
||||
EXTERNAL DLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLARNV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, EXP, LOG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DLATM1', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
10 CONTINUE
|
||||
DO 20 I = 1, N
|
||||
D( I ) = ONE / COND
|
||||
20 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 120
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
30 CONTINUE
|
||||
DO 40 I = 1, N
|
||||
D( I ) = ONE
|
||||
40 CONTINUE
|
||||
D( N ) = ONE / COND
|
||||
GO TO 120
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
50 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / DBLE( N-1 ) )
|
||||
DO 60 I = 2, N
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
70 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / DBLE( N-1 )
|
||||
DO 80 I = 2, N
|
||||
D( I ) = DBLE( N-I )*ALPHA + TEMP
|
||||
80 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
90 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 100 I = 1, N
|
||||
D( I ) = EXP( ALPHA*DLARAN( ISEED ) )
|
||||
100 CONTINUE
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
110 CONTINUE
|
||||
CALL DLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
120 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 130 I = 1, N
|
||||
TEMP = DLARAN( ISEED )
|
||||
IF( TEMP.GT.HALF )
|
||||
$ D( I ) = -D( I )
|
||||
130 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 140 I = 1, N / 2
|
||||
TEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = TEMP
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLATM1
|
||||
*
|
||||
END
|
||||
315
lapack-netlib/TESTING/MATGEN/dlatm2.f
Normal file
315
lapack-netlib/TESTING/MATGEN/dlatm2.f
Normal file
@@ -0,0 +1,315 @@
|
||||
*> \brief \b DLATM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
* DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* DOUBLE PRECISION D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM2 returns the (I,J) entry of a random matrix of dimension
|
||||
*> (M, N) described by the other paramters. It is called by the
|
||||
*> DLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by DLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of DLATM2 differs from SLATM3 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With DLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With DLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, DLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. DLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*>
|
||||
*> The matrix whose (I,J) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If I is outside (1..M) or J is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is DOUBLE PRECISION array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is DOUBLE PRECISION array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) in position K was originally in
|
||||
*> position IWORK( K ).
|
||||
*> This differs from IWORK for DLATM3. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is DOUBLE PRECISION between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
DOUBLE PRECISION D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
INTEGER ISUB, JSUB
|
||||
DOUBLE PRECISION TEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
DOUBLE PRECISION DLARAN, DLARND
|
||||
EXTERNAL DLARAN, DLARND
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
DLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
|
||||
DLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
DLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( ISUB.EQ.JSUB ) THEN
|
||||
TEMP = D( ISUB )
|
||||
ELSE
|
||||
TEMP = DLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
TEMP = TEMP*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
|
||||
TEMP = TEMP*DL( ISUB ) / DL( JSUB )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )*DL( JSUB )
|
||||
END IF
|
||||
DLATM2 = TEMP
|
||||
RETURN
|
||||
*
|
||||
* End of DLATM2
|
||||
*
|
||||
END
|
||||
335
lapack-netlib/TESTING/MATGEN/dlatm3.f
Normal file
335
lapack-netlib/TESTING/MATGEN/dlatm3.f
Normal file
@@ -0,0 +1,335 @@
|
||||
*> \brief \b DLATM3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
* SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
* $ KU, M, N
|
||||
* DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* DOUBLE PRECISION D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM3 returns the (ISUB,JSUB) entry of a random matrix of
|
||||
*> dimension (M, N) described by the other paramters. (ISUB,JSUB)
|
||||
*> is the final position of the (I,J) entry after pivoting
|
||||
*> according to IPVTNG and IWORK. DLATM3 is called by the
|
||||
*> DLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by DLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of DLATM3 differs from SLATM2 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With DLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With DLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, DLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. DLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*> in different orders for different pivot orders).
|
||||
*>
|
||||
*> The matrix whose (ISUB,JSUB) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISUB
|
||||
*> \verbatim
|
||||
*> ISUB is INTEGER
|
||||
*> Row of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] JSUB
|
||||
*> \verbatim
|
||||
*> JSUB is INTEGER
|
||||
*> Column of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is DOUBLE PRECISION array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is DOUBLE PRECISION array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) originally in position K is in
|
||||
*> position IWORK( K ) after pivoting.
|
||||
*> This differs from IWORK for DLATM2. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is DOUBLE PRECISION between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
$ SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
$ KU, M, N
|
||||
DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
DOUBLE PRECISION D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
DOUBLE PRECISION TEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
DOUBLE PRECISION DLARAN, DLARND
|
||||
EXTERNAL DLARAN, DLARND
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
DLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
|
||||
DLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
DLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
TEMP = D( I )
|
||||
ELSE
|
||||
TEMP = DLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
TEMP = TEMP*DL( I )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
TEMP = TEMP*DR( J )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
TEMP = TEMP*DL( I )*DR( J )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
|
||||
TEMP = TEMP*DL( I ) / DL( J )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
TEMP = TEMP*DL( I )*DL( J )
|
||||
END IF
|
||||
DLATM3 = TEMP
|
||||
RETURN
|
||||
*
|
||||
* End of DLATM3
|
||||
*
|
||||
END
|
||||
501
lapack-netlib/TESTING/MATGEN/dlatm5.f
Normal file
501
lapack-netlib/TESTING/MATGEN/dlatm5.f
Normal file
@@ -0,0 +1,501 @@
|
||||
*> \brief \b DLATM5
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
* QBLCKB )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
* $ PRTYPE, QBLCKA, QBLCKB
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
* $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
* $ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM5 generates matrices involved in the Generalized Sylvester
|
||||
*> equation:
|
||||
*>
|
||||
*> A * R - L * B = C
|
||||
*> D * R - L * E = F
|
||||
*>
|
||||
*> They also satisfy (the diagonalization condition)
|
||||
*>
|
||||
*> [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
|
||||
*> [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] PRTYPE
|
||||
*> \verbatim
|
||||
*> PRTYPE is INTEGER
|
||||
*> "Points" to a certian type of the matrices to generate
|
||||
*> (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Specifies the order of A and D and the number of rows in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Specifies the order of B and E and the number of columns in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, M).
|
||||
*> On exit A M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension (LDB, N).
|
||||
*> On exit B N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array, dimension (LDC, N).
|
||||
*> On exit C M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (LDD, M).
|
||||
*> On exit D M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDD
|
||||
*> \verbatim
|
||||
*> LDD is INTEGER
|
||||
*> The leading dimension of D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION array, dimension (LDE, N).
|
||||
*> On exit E N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDE
|
||||
*> \verbatim
|
||||
*> LDE is INTEGER
|
||||
*> The leading dimension of E.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] F
|
||||
*> \verbatim
|
||||
*> F is DOUBLE PRECISION array, dimension (LDF, N).
|
||||
*> On exit F M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDF
|
||||
*> \verbatim
|
||||
*> LDF is INTEGER
|
||||
*> The leading dimension of F.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] R
|
||||
*> \verbatim
|
||||
*> R is DOUBLE PRECISION array, dimension (LDR, N).
|
||||
*> On exit R M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDR
|
||||
*> \verbatim
|
||||
*> LDR is INTEGER
|
||||
*> The leading dimension of R.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] L
|
||||
*> \verbatim
|
||||
*> L is DOUBLE PRECISION array, dimension (LDL, N).
|
||||
*> On exit L M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDL
|
||||
*> \verbatim
|
||||
*> LDL is INTEGER
|
||||
*> The leading dimension of L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION
|
||||
*> Parameter used in generating PRTYPE = 1 and 5 matrices.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKA
|
||||
*> \verbatim
|
||||
*> QBLCKA is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in A. Otherwise, QBLCKA is not
|
||||
*> referenced. QBLCKA > 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKB
|
||||
*> \verbatim
|
||||
*> QBLCKB is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in B. Otherwise, QBLCKB is not
|
||||
*> referenced. QBLCKB > 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
|
||||
*>
|
||||
*> A : if (i == j) then A(i, j) = 1.0
|
||||
*> if (j == i + 1) then A(i, j) = -1.0
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> B : if (i == j) then B(i, j) = 1.0 - ALPHA
|
||||
*> if (j == i + 1) then B(i, j) = 1.0
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> D : if (i == j) then D(i, j) = 1.0
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> E : if (i == j) then E(i, j) = 1.0
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L = R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
|
||||
*>
|
||||
*> A : if (i <= j) then A(i, j) = [-1...1]
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> A(k + 1, k + 1) = A(k, k)
|
||||
*> A(k + 1, k) = [-1...1]
|
||||
*> sign(A(k, k + 1) = -(sin(A(k + 1, k))
|
||||
*> k = 1, M - 1, QBLCKA
|
||||
*>
|
||||
*> B : if (i <= j) then B(i, j) = [-1...1]
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> B(k + 1, k + 1) = B(k, k)
|
||||
*> B(k + 1, k) = [-1...1]
|
||||
*> sign(B(k, k + 1) = -(sign(B(k + 1, k))
|
||||
*> k = 1, N - 1, QBLCKB
|
||||
*>
|
||||
*> D : if (i <= j) then D(i, j) = [-1...1].
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*>
|
||||
*> E : if (i <= j) then D(i, j) = [-1...1]
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L, R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 4 Full
|
||||
*> A(i, j) = [-10...10]
|
||||
*> D(i, j) = [-1...1] i,j = 1...M
|
||||
*> B(i, j) = [-10...10]
|
||||
*> E(i, j) = [-1...1] i,j = 1...N
|
||||
*> R(i, j) = [-10...10]
|
||||
*> L(i, j) = [-1...1] i = 1..M ,j = 1...N
|
||||
*>
|
||||
*> L, R specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 5 special case common and/or close eigs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
$ QBLCKB )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
$ PRTYPE, QBLCKA, QBLCKB
|
||||
DOUBLE PRECISION ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
$ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO, TWENTY, HALF, TWO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, TWENTY = 2.0D+1,
|
||||
$ HALF = 0.5D+0, TWO = 2.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, K
|
||||
DOUBLE PRECISION IMEPS, REEPS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, MOD, SIN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( PRTYPE.EQ.1 ) THEN
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, J ) = ONE
|
||||
D( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
A( I, J ) = -ONE
|
||||
D( I, J ) = ZERO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, N
|
||||
DO 30 J = 1, N
|
||||
IF( I.EQ.J ) THEN
|
||||
B( I, J ) = ONE - ALPHA
|
||||
E( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
B( I, J ) = ONE
|
||||
E( I, J ) = ZERO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
DO 50 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DBLE( I / J ) ) )*TWENTY
|
||||
L( I, J ) = R( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
|
||||
DO 80 I = 1, M
|
||||
DO 70 J = 1, M
|
||||
IF( I.LE.J ) THEN
|
||||
A( I, J ) = ( HALF-SIN( DBLE( I ) ) )*TWO
|
||||
D( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
DO 100 I = 1, N
|
||||
DO 90 J = 1, N
|
||||
IF( I.LE.J ) THEN
|
||||
B( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWO
|
||||
E( I, J ) = ( HALF-SIN( DBLE( J ) ) )*TWO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
DO 120 I = 1, M
|
||||
DO 110 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWENTY
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
*
|
||||
IF( PRTYPE.EQ.3 ) THEN
|
||||
IF( QBLCKA.LE.1 )
|
||||
$ QBLCKA = 2
|
||||
DO 130 K = 1, M - 1, QBLCKA
|
||||
A( K+1, K+1 ) = A( K, K )
|
||||
A( K+1, K ) = -SIN( A( K, K+1 ) )
|
||||
130 CONTINUE
|
||||
*
|
||||
IF( QBLCKB.LE.1 )
|
||||
$ QBLCKB = 2
|
||||
DO 140 K = 1, N - 1, QBLCKB
|
||||
B( K+1, K+1 ) = B( K, K )
|
||||
B( K+1, K ) = -SIN( B( K, K+1 ) )
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.4 ) THEN
|
||||
DO 160 I = 1, M
|
||||
DO 150 J = 1, M
|
||||
A( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWENTY
|
||||
D( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWO
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
*
|
||||
DO 180 I = 1, N
|
||||
DO 170 J = 1, N
|
||||
B( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWENTY
|
||||
E( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
DO 200 I = 1, M
|
||||
DO 190 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DBLE( J / I ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.GE.5 ) THEN
|
||||
REEPS = HALF*TWO*TWENTY / ALPHA
|
||||
IMEPS = ( HALF-TWO ) / ALPHA
|
||||
DO 220 I = 1, M
|
||||
DO 210 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*ALPHA / TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*ALPHA / TWENTY
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
*
|
||||
DO 230 I = 1, M
|
||||
D( I, I ) = ONE
|
||||
230 CONTINUE
|
||||
*
|
||||
DO 240 I = 1, M
|
||||
IF( I.LE.4 ) THEN
|
||||
A( I, I ) = ONE
|
||||
IF( I.GT.2 )
|
||||
$ A( I, I ) = ONE + REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
A( I, I ) = REEPS
|
||||
ELSE
|
||||
A( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = ONE
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -ONE
|
||||
END IF
|
||||
ELSE
|
||||
A( I, I ) = ONE
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
240 CONTINUE
|
||||
*
|
||||
DO 250 I = 1, N
|
||||
E( I, I ) = ONE
|
||||
IF( I.LE.4 ) THEN
|
||||
B( I, I ) = -ONE
|
||||
IF( I.GT.2 )
|
||||
$ B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
B( I, I ) = REEPS
|
||||
ELSE
|
||||
B( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = ONE + IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -ONE - IMEPS
|
||||
END IF
|
||||
ELSE
|
||||
B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Compute rhs (C, F)
|
||||
*
|
||||
CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
|
||||
CALL DGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
|
||||
CALL DGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
|
||||
CALL DGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
|
||||
*
|
||||
* End of DLATM5
|
||||
*
|
||||
END
|
||||
333
lapack-netlib/TESTING/MATGEN/dlatm6.f
Normal file
333
lapack-netlib/TESTING/MATGEN/dlatm6.f
Normal file
@@ -0,0 +1,333 @@
|
||||
*> \brief \b DLATM6
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
* BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDX, LDY, N, TYPE
|
||||
* DOUBLE PRECISION ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
|
||||
* $ X( LDX, * ), Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM6 generates test matrices for the generalized eigenvalue
|
||||
*> problem, their corresponding right and left eigenvector matrices,
|
||||
*> and also reciprocal condition numbers for all eigenvalues and
|
||||
*> the reciprocal condition numbers of eigenvectors corresponding to
|
||||
*> the 1th and 5th eigenvalues.
|
||||
*>
|
||||
*> Test Matrices
|
||||
*> =============
|
||||
*>
|
||||
*> Two kinds of test matrix pairs
|
||||
*>
|
||||
*> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
|
||||
*>
|
||||
*> are used in the tests:
|
||||
*>
|
||||
*> Type 1:
|
||||
*> Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 2+a 0 0 0 0 1 0 0 0
|
||||
*> 0 0 3+a 0 0 0 0 1 0 0
|
||||
*> 0 0 0 4+a 0 0 0 0 1 0
|
||||
*> 0 0 0 0 5+a , 0 0 0 0 1 , and
|
||||
*>
|
||||
*> Type 2:
|
||||
*> Da = 1 -1 0 0 0 Db = 1 0 0 0 0
|
||||
*> 1 1 0 0 0 0 1 0 0 0
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1+a 1+b 0 0 0 1 0
|
||||
*> 0 0 0 -1-b 1+a , 0 0 0 0 1 .
|
||||
*>
|
||||
*> In both cases the same inverse(YH) and inverse(X) are used to compute
|
||||
*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
|
||||
*>
|
||||
*> YH: = 1 0 -y y -y X = 1 0 -x -x x
|
||||
*> 0 1 -y y -y 0 1 x -x -x
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1 0 0 0 0 1 0
|
||||
*> 0 0 0 0 1, 0 0 0 0 1 ,
|
||||
*>
|
||||
*> where a, b, x and y will have all values independently of each other.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TYPE
|
||||
*> \verbatim
|
||||
*> TYPE is INTEGER
|
||||
*> Specifies the problem type (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of the matrices A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, N).
|
||||
*> On exit A N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A and of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension (LDA, N).
|
||||
*> On exit B N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array, dimension (LDX, N).
|
||||
*> On exit X is the N-by-N matrix of right eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array, dimension (LDY, N).
|
||||
*> On exit Y is the N-by-N matrix of left eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDY
|
||||
*> \verbatim
|
||||
*> LDY is INTEGER
|
||||
*> The leading dimension of Y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION
|
||||
*>
|
||||
*> Weighting constants for matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WX
|
||||
*> \verbatim
|
||||
*> WX is DOUBLE PRECISION
|
||||
*> Constant for right eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WY
|
||||
*> \verbatim
|
||||
*> WY is DOUBLE PRECISION
|
||||
*> Constant for left eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] S
|
||||
*> \verbatim
|
||||
*> S is DOUBLE PRECISION array, dimension (N)
|
||||
*> S(i) is the reciprocal condition number for eigenvalue i.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] DIF
|
||||
*> \verbatim
|
||||
*> DIF is DOUBLE PRECISION array, dimension (N)
|
||||
*> DIF(i) is the reciprocal condition number for eigenvector i.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
$ BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDX, LDY, N, TYPE
|
||||
DOUBLE PRECISION ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
|
||||
$ X( LDX, * ), Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, TWO, THREE
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
|
||||
$ THREE = 3.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, INFO, J
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION WORK( 100 ), Z( 12, 12 )
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, SQRT
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGESVD, DLACPY, DLAKF2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate test problem ...
|
||||
* (Da, Db) ...
|
||||
*
|
||||
DO 20 I = 1, N
|
||||
DO 10 J = 1, N
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, I ) = DBLE( I ) + ALPHA
|
||||
B( I, I ) = ONE
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
B( I, J ) = ZERO
|
||||
END IF
|
||||
*
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* Form X and Y
|
||||
*
|
||||
CALL DLACPY( 'F', N, N, B, LDA, Y, LDY )
|
||||
Y( 3, 1 ) = -WY
|
||||
Y( 4, 1 ) = WY
|
||||
Y( 5, 1 ) = -WY
|
||||
Y( 3, 2 ) = -WY
|
||||
Y( 4, 2 ) = WY
|
||||
Y( 5, 2 ) = -WY
|
||||
*
|
||||
CALL DLACPY( 'F', N, N, B, LDA, X, LDX )
|
||||
X( 1, 3 ) = -WX
|
||||
X( 1, 4 ) = -WX
|
||||
X( 1, 5 ) = WX
|
||||
X( 2, 3 ) = WX
|
||||
X( 2, 4 ) = -WX
|
||||
X( 2, 5 ) = -WX
|
||||
*
|
||||
* Form (A, B)
|
||||
*
|
||||
B( 1, 3 ) = WX + WY
|
||||
B( 2, 3 ) = -WX + WY
|
||||
B( 1, 4 ) = WX - WY
|
||||
B( 2, 4 ) = WX - WY
|
||||
B( 1, 5 ) = -WX + WY
|
||||
B( 2, 5 ) = WX + WY
|
||||
IF( TYPE.EQ.1 ) THEN
|
||||
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
|
||||
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
|
||||
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
|
||||
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
|
||||
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
|
||||
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
|
||||
ELSE IF( TYPE.EQ.2 ) THEN
|
||||
A( 1, 3 ) = TWO*WX + WY
|
||||
A( 2, 3 ) = WY
|
||||
A( 1, 4 ) = -WY*( TWO+ALPHA+BETA )
|
||||
A( 2, 4 ) = TWO*WX - WY*( TWO+ALPHA+BETA )
|
||||
A( 1, 5 ) = -TWO*WX + WY*( ALPHA-BETA )
|
||||
A( 2, 5 ) = WY*( ALPHA-BETA )
|
||||
A( 1, 1 ) = ONE
|
||||
A( 1, 2 ) = -ONE
|
||||
A( 2, 1 ) = ONE
|
||||
A( 2, 2 ) = A( 1, 1 )
|
||||
A( 3, 3 ) = ONE
|
||||
A( 4, 4 ) = ONE + ALPHA
|
||||
A( 4, 5 ) = ONE + BETA
|
||||
A( 5, 4 ) = -A( 4, 5 )
|
||||
A( 5, 5 ) = A( 4, 4 )
|
||||
END IF
|
||||
*
|
||||
* Compute condition numbers
|
||||
*
|
||||
IF( TYPE.EQ.1 ) THEN
|
||||
*
|
||||
S( 1 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
|
||||
$ ( ONE+A( 1, 1 )*A( 1, 1 ) ) )
|
||||
S( 2 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
|
||||
$ ( ONE+A( 2, 2 )*A( 2, 2 ) ) )
|
||||
S( 3 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 3, 3 )*A( 3, 3 ) ) )
|
||||
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 4, 4 )*A( 4, 4 ) ) )
|
||||
S( 5 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 5, 5 )*A( 5, 5 ) ) )
|
||||
*
|
||||
CALL DLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 12 )
|
||||
CALL DGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
|
||||
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
|
||||
DIF( 1 ) = WORK( 8 )
|
||||
*
|
||||
CALL DLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 12 )
|
||||
CALL DGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
|
||||
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
|
||||
DIF( 5 ) = WORK( 8 )
|
||||
*
|
||||
ELSE IF( TYPE.EQ.2 ) THEN
|
||||
*
|
||||
S( 1 ) = ONE / SQRT( ONE / THREE+WY*WY )
|
||||
S( 2 ) = S( 1 )
|
||||
S( 3 ) = ONE / SQRT( ONE / TWO+WX*WX )
|
||||
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+( ONE+ALPHA )*( ONE+ALPHA )+( ONE+BETA )*( ONE+
|
||||
$ BETA ) ) )
|
||||
S( 5 ) = S( 4 )
|
||||
*
|
||||
CALL DLAKF2( 2, 3, A, LDA, A( 3, 3 ), B, B( 3, 3 ), Z, 12 )
|
||||
CALL DGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
|
||||
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
|
||||
DIF( 1 ) = WORK( 12 )
|
||||
*
|
||||
CALL DLAKF2( 3, 2, A, LDA, A( 4, 4 ), B, B( 4, 4 ), Z, 12 )
|
||||
CALL DGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
|
||||
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
|
||||
DIF( 5 ) = WORK( 12 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLATM6
|
||||
*
|
||||
END
|
||||
297
lapack-netlib/TESTING/MATGEN/dlatm7.f
Normal file
297
lapack-netlib/TESTING/MATGEN/dlatm7.f
Normal file
@@ -0,0 +1,297 @@
|
||||
*> \brief \b DLATM7
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
|
||||
* RANK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION COND
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION D( * )
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATM7 computes the entries of D as specified by MODE
|
||||
*> COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. DLATM7 is called by DLATMT to generate
|
||||
*> random test matrices.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> MODE - INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*>
|
||||
*> MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND
|
||||
*> MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK
|
||||
*>
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*>
|
||||
*> COND - DOUBLE PRECISION
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*>
|
||||
*> IRSIGN - INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by 1 or -1 with probability .5
|
||||
*>
|
||||
*> IDIST - CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*>
|
||||
*> ISEED - INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to DLATM7
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*>
|
||||
*> D - DOUBLE PRECISION array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*>
|
||||
*> N - INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*>
|
||||
*> RANK - INTEGER
|
||||
*> The rank of matrix to be generated for modes 1,2,3 only.
|
||||
*> D( RANK+1:N ) = 0.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> INFO - INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
|
||||
$ RANK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION COND
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION D( * )
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D0 )
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
DOUBLE PRECISION HALF
|
||||
PARAMETER ( HALF = 0.5D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ALPHA, TEMP
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLARAN
|
||||
EXTERNAL DLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLARNV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, EXP, LOG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DLATM7', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 100, 130, 160, 190, 210, 230 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
100 CONTINUE
|
||||
DO 110 I = 2, RANK
|
||||
D( I ) = ONE / COND
|
||||
110 CONTINUE
|
||||
DO 120 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
120 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 240
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
130 CONTINUE
|
||||
DO 140 I = 1, RANK - 1
|
||||
D( I ) = ONE
|
||||
140 CONTINUE
|
||||
DO 150 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
150 CONTINUE
|
||||
D( RANK ) = ONE / COND
|
||||
GO TO 240
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
160 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 .AND. RANK.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / DBLE( RANK-1 ) )
|
||||
DO 170 I = 2, RANK
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
170 CONTINUE
|
||||
DO 180 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
180 CONTINUE
|
||||
END IF
|
||||
GO TO 240
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
190 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / DBLE( N-1 )
|
||||
DO 200 I = 2, N
|
||||
D( I ) = DBLE( N-I )*ALPHA + TEMP
|
||||
200 CONTINUE
|
||||
END IF
|
||||
GO TO 240
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
210 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 220 I = 1, N
|
||||
D( I ) = EXP( ALPHA*DLARAN( ISEED ) )
|
||||
220 CONTINUE
|
||||
GO TO 240
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
230 CONTINUE
|
||||
CALL DLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
240 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 250 I = 1, N
|
||||
TEMP = DLARAN( ISEED )
|
||||
IF( TEMP.GT.HALF )
|
||||
$ D( I ) = -D( I )
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 260 I = 1, N / 2
|
||||
TEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = TEMP
|
||||
260 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLATM7
|
||||
*
|
||||
END
|
||||
710
lapack-netlib/TESTING/MATGEN/dlatme.f
Normal file
710
lapack-netlib/TESTING/MATGEN/dlatme.f
Normal file
@@ -0,0 +1,710 @@
|
||||
*> \brief \b DLATME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
|
||||
* RSIGN,
|
||||
* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
* A,
|
||||
* LDA, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
* INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
* DOUBLE PRECISION ANORM, COND, CONDS, DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* CHARACTER EI( * )
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLATME generates random non-symmetric square matrices with
|
||||
*> specified eigenvalues for testing LAPACK programs.
|
||||
*>
|
||||
*> DLATME operates by applying the following sequence of
|
||||
*> operations:
|
||||
*>
|
||||
*> 1. Set the diagonal to D, where D may be input or
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN
|
||||
*> as described below.
|
||||
*>
|
||||
*> 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
|
||||
*> or MODE=5), certain pairs of adjacent elements of D are
|
||||
*> interpreted as the real and complex parts of a complex
|
||||
*> conjugate pair; A thus becomes block diagonal, with 1x1
|
||||
*> and 2x2 blocks.
|
||||
*>
|
||||
*> 3. If UPPER='T', the upper triangle of A is set to random values
|
||||
*> out of distribution DIST.
|
||||
*>
|
||||
*> 4. If SIM='T', A is multiplied on the left by a random matrix
|
||||
*> X, whose singular values are specified by DS, MODES, and
|
||||
*> CONDS, and on the right by X inverse.
|
||||
*>
|
||||
*> 5. If KL < N-1, the lower bandwidth is reduced to KL using
|
||||
*> Householder transformations. If KU < N-1, the upper
|
||||
*> bandwidth is reduced to KU.
|
||||
*>
|
||||
*> 6. If ANORM is not negative, the matrix is scaled to have
|
||||
*> maximum-element-norm ANORM.
|
||||
*>
|
||||
*> (Note: since the matrix cannot be reduced beyond Hessenberg form,
|
||||
*> no packing options are available.)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns (or rows) of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIST
|
||||
*> \verbatim
|
||||
*> DIST is CHARACTER*1
|
||||
*> On entry, DIST specifies the type of distribution to be used
|
||||
*> to generate the random eigen-/singular values, and for the
|
||||
*> upper triangle (see UPPER).
|
||||
*> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
|
||||
*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
|
||||
*> 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. They should lie between 0 and 4095 inclusive,
|
||||
*> and ISEED(4) should be odd. The random number generator
|
||||
*> uses a linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to DLATME
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension ( N )
|
||||
*> This array is used to specify the eigenvalues of A. If
|
||||
*> MODE=0, then D is assumed to contain the eigenvalues (but
|
||||
*> see the description of EI), otherwise they will be
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN and
|
||||
*> placed in D.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry this describes how the eigenvalues are to
|
||||
*> be specified:
|
||||
*> MODE = 0 means use D (with EI) as input
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed. Each odd-even pair
|
||||
*> of elements will be either used as two real
|
||||
*> eigenvalues or as the real and imaginary part
|
||||
*> of a complex conjugate pair of eigenvalues;
|
||||
*> the choice of which is done is random, with
|
||||
*> 50-50 probability, for each pair.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is between 1 and 4, D has entries ranging
|
||||
*> from 1 to 1/COND, if between -1 and -4, D has entries
|
||||
*> ranging from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is DOUBLE PRECISION
|
||||
*> On entry, this is used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DMAX
|
||||
*> \verbatim
|
||||
*> DMAX is DOUBLE PRECISION
|
||||
*> If MODE is neither -6, 0 nor 6, the contents of D, as
|
||||
*> computed according to MODE and COND, will be scaled by
|
||||
*> DMAX / max(abs(D(i))). Note that DMAX need not be
|
||||
*> positive: if DMAX is negative (or zero), D will be
|
||||
*> scaled by a negative number (or zero).
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] EI
|
||||
*> \verbatim
|
||||
*> EI is CHARACTER*1 array, dimension ( N )
|
||||
*> If MODE is 0, and EI(1) is not ' ' (space character),
|
||||
*> this array specifies which elements of D (on input) are
|
||||
*> real eigenvalues and which are the real and imaginary parts
|
||||
*> of a complex conjugate pair of eigenvalues. The elements
|
||||
*> of EI may then only have the values 'R' and 'I'. If
|
||||
*> EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
|
||||
*> CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
|
||||
*> conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th
|
||||
*> eigenvalue is D(j) (i.e., real). EI(1) may not be 'I',
|
||||
*> nor may two adjacent elements of EI both have the value 'I'.
|
||||
*> If MODE is not 0, then EI is ignored. If MODE is 0 and
|
||||
*> EI(1)=' ', then the eigenvalues will all be real.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] RSIGN
|
||||
*> \verbatim
|
||||
*> RSIGN is CHARACTER*1
|
||||
*> If MODE is not 0, 6, or -6, and RSIGN='T', then the
|
||||
*> elements of D, as computed according to MODE and COND, will
|
||||
*> be multiplied by a random sign (+1 or -1). If RSIGN='F',
|
||||
*> they will not be. RSIGN may only have the values 'T' or
|
||||
*> 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPPER
|
||||
*> \verbatim
|
||||
*> UPPER is CHARACTER*1
|
||||
*> If UPPER='T', then the elements of A above the diagonal
|
||||
*> (and above the 2x2 diagonal blocks, if A has complex
|
||||
*> eigenvalues) will be set to random numbers out of DIST.
|
||||
*> If UPPER='F', they will not. UPPER may only have the
|
||||
*> values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SIM
|
||||
*> \verbatim
|
||||
*> SIM is CHARACTER*1
|
||||
*> If SIM='T', then A will be operated on by a "similarity
|
||||
*> transform", i.e., multiplied on the left by a matrix X and
|
||||
*> on the right by X inverse. X = U S V, where U and V are
|
||||
*> random unitary matrices and S is a (diagonal) matrix of
|
||||
*> singular values specified by DS, MODES, and CONDS. If
|
||||
*> SIM='F', then A will not be transformed.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DS
|
||||
*> \verbatim
|
||||
*> DS is DOUBLE PRECISION array, dimension ( N )
|
||||
*> This array is used to specify the singular values of X,
|
||||
*> in the same way that D specifies the eigenvalues of A.
|
||||
*> If MODE=0, the DS contains the singular values, which
|
||||
*> may not be zero.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODES
|
||||
*> \verbatim
|
||||
*> MODES is INTEGER
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CONDS
|
||||
*> \verbatim
|
||||
*> CONDS is DOUBLE PRECISION
|
||||
*> Same as MODE and COND, but for specifying the diagonal
|
||||
*> of S. MODES=-6 and +6 are not allowed (since they would
|
||||
*> result in randomly ill-conditioned eigenvalues.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> This specifies the lower bandwidth of the matrix. KL=1
|
||||
*> specifies upper Hessenberg form. If KL is at least N-1,
|
||||
*> then A will have full lower bandwidth. KL must be at
|
||||
*> least 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> This specifies the upper bandwidth of the matrix. KU=1
|
||||
*> specifies lower Hessenberg form. If KU is at least N-1,
|
||||
*> then A will have full upper bandwidth; if KU and KL
|
||||
*> are both at least N-1, then A will be dense. Only one of
|
||||
*> KU and KL may be less than N-1. KU must be at least 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ANORM
|
||||
*> \verbatim
|
||||
*> ANORM is DOUBLE PRECISION
|
||||
*> If ANORM is not negative, then A will be scaled by a non-
|
||||
*> negative real number to make the maximum-element-norm of A
|
||||
*> to be ANORM.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension ( LDA, N )
|
||||
*> On exit A is the desired test matrix.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> LDA specifies the first dimension of A as declared in the
|
||||
*> calling program. LDA must be at least N.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension ( 3*N )
|
||||
*> Workspace.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> Error code. On exit, INFO will be set to one of the
|
||||
*> following values:
|
||||
*> 0 => normal return
|
||||
*> -1 => N negative
|
||||
*> -2 => DIST illegal string
|
||||
*> -5 => MODE not in range -6 to 6
|
||||
*> -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
|
||||
*> -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
|
||||
*> two adjacent elements of EI are 'I'.
|
||||
*> -9 => RSIGN is not 'T' or 'F'
|
||||
*> -10 => UPPER is not 'T' or 'F'
|
||||
*> -11 => SIM is not 'T' or 'F'
|
||||
*> -12 => MODES=0 and DS has a zero singular value.
|
||||
*> -13 => MODES is not in the range -5 to 5.
|
||||
*> -14 => MODES is nonzero and CONDS is less than 1.
|
||||
*> -15 => KL is less than 1.
|
||||
*> -16 => KU is less than 1, or KL and KU are both less than
|
||||
*> N-1.
|
||||
*> -19 => LDA is less than N.
|
||||
*> 1 => Error return from DLATM1 (computing D)
|
||||
*> 2 => Cannot scale to DMAX (max. eigenvalue is 0)
|
||||
*> 3 => Error return from DLATM1 (computing DS)
|
||||
*> 4 => Error return from DLARGE
|
||||
*> 5 => Zero singular value from DLATM1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
|
||||
$ RSIGN,
|
||||
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
$ A,
|
||||
$ LDA, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
DOUBLE PRECISION ANORM, COND, CONDS, DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
CHARACTER EI( * )
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D0 )
|
||||
DOUBLE PRECISION HALF
|
||||
PARAMETER ( HALF = 1.0D0 / 2.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BADEI, BADS, USEEI
|
||||
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
|
||||
$ ISIM, IUPPER, J, JC, JCR, JR
|
||||
DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION TEMPA( 1 )
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
DOUBLE PRECISION DLANGE, DLARAN
|
||||
EXTERNAL LSAME, DLANGE, DLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DCOPY, DGEMV, DGER, DLARFG, DLARGE, DLARNV,
|
||||
$ DLASET, DLATM1, DSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 1) Decode and Test the input parameters.
|
||||
* Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Decode DIST
|
||||
*
|
||||
IF( LSAME( DIST, 'U' ) ) THEN
|
||||
IDIST = 1
|
||||
ELSE IF( LSAME( DIST, 'S' ) ) THEN
|
||||
IDIST = 2
|
||||
ELSE IF( LSAME( DIST, 'N' ) ) THEN
|
||||
IDIST = 3
|
||||
ELSE
|
||||
IDIST = -1
|
||||
END IF
|
||||
*
|
||||
* Check EI
|
||||
*
|
||||
USEEI = .TRUE.
|
||||
BADEI = .FALSE.
|
||||
IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN
|
||||
USEEI = .FALSE.
|
||||
ELSE
|
||||
IF( LSAME( EI( 1 ), 'R' ) ) THEN
|
||||
DO 10 J = 2, N
|
||||
IF( LSAME( EI( J ), 'I' ) ) THEN
|
||||
IF( LSAME( EI( J-1 ), 'I' ) )
|
||||
$ BADEI = .TRUE.
|
||||
ELSE
|
||||
IF( .NOT.LSAME( EI( J ), 'R' ) )
|
||||
$ BADEI = .TRUE.
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
BADEI = .TRUE.
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Decode RSIGN
|
||||
*
|
||||
IF( LSAME( RSIGN, 'T' ) ) THEN
|
||||
IRSIGN = 1
|
||||
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
|
||||
IRSIGN = 0
|
||||
ELSE
|
||||
IRSIGN = -1
|
||||
END IF
|
||||
*
|
||||
* Decode UPPER
|
||||
*
|
||||
IF( LSAME( UPPER, 'T' ) ) THEN
|
||||
IUPPER = 1
|
||||
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
|
||||
IUPPER = 0
|
||||
ELSE
|
||||
IUPPER = -1
|
||||
END IF
|
||||
*
|
||||
* Decode SIM
|
||||
*
|
||||
IF( LSAME( SIM, 'T' ) ) THEN
|
||||
ISIM = 1
|
||||
ELSE IF( LSAME( SIM, 'F' ) ) THEN
|
||||
ISIM = 0
|
||||
ELSE
|
||||
ISIM = -1
|
||||
END IF
|
||||
*
|
||||
* Check DS, if MODES=0 and ISIM=1
|
||||
*
|
||||
BADS = .FALSE.
|
||||
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
|
||||
DO 20 J = 1, N
|
||||
IF( DS( J ).EQ.ZERO )
|
||||
$ BADS = .TRUE.
|
||||
20 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( IDIST.EQ.-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ABS( MODE ).GT.6 ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
|
||||
$ THEN
|
||||
INFO = -6
|
||||
ELSE IF( BADEI ) THEN
|
||||
INFO = -8
|
||||
ELSE IF( IRSIGN.EQ.-1 ) THEN
|
||||
INFO = -9
|
||||
ELSE IF( IUPPER.EQ.-1 ) THEN
|
||||
INFO = -10
|
||||
ELSE IF( ISIM.EQ.-1 ) THEN
|
||||
INFO = -11
|
||||
ELSE IF( BADS ) THEN
|
||||
INFO = -12
|
||||
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
|
||||
INFO = -13
|
||||
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
|
||||
INFO = -14
|
||||
ELSE IF( KL.LT.1 ) THEN
|
||||
INFO = -15
|
||||
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
|
||||
INFO = -16
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -19
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DLATME', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Initialize random number generator
|
||||
*
|
||||
DO 30 I = 1, 4
|
||||
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
|
||||
30 CONTINUE
|
||||
*
|
||||
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
|
||||
$ ISEED( 4 ) = ISEED( 4 ) + 1
|
||||
*
|
||||
* 2) Set up diagonal of A
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 1
|
||||
RETURN
|
||||
END IF
|
||||
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
|
||||
*
|
||||
* Scale by DMAX
|
||||
*
|
||||
TEMP = ABS( D( 1 ) )
|
||||
DO 40 I = 2, N
|
||||
TEMP = MAX( TEMP, ABS( D( I ) ) )
|
||||
40 CONTINUE
|
||||
*
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = DMAX / TEMP
|
||||
ELSE IF( DMAX.NE.ZERO ) THEN
|
||||
INFO = 2
|
||||
RETURN
|
||||
ELSE
|
||||
ALPHA = ZERO
|
||||
END IF
|
||||
*
|
||||
CALL DSCAL( N, ALPHA, D, 1 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
|
||||
CALL DCOPY( N, D, 1, A, LDA+1 )
|
||||
*
|
||||
* Set up complex conjugate pairs
|
||||
*
|
||||
IF( MODE.EQ.0 ) THEN
|
||||
IF( USEEI ) THEN
|
||||
DO 50 J = 2, N
|
||||
IF( LSAME( EI( J ), 'I' ) ) THEN
|
||||
A( J-1, J ) = A( J, J )
|
||||
A( J, J-1 ) = -A( J, J )
|
||||
A( J, J ) = A( J-1, J-1 )
|
||||
END IF
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( ABS( MODE ).EQ.5 ) THEN
|
||||
*
|
||||
DO 60 J = 2, N, 2
|
||||
IF( DLARAN( ISEED ).GT.HALF ) THEN
|
||||
A( J-1, J ) = A( J, J )
|
||||
A( J, J-1 ) = -A( J, J )
|
||||
A( J, J ) = A( J-1, J-1 )
|
||||
END IF
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 3) If UPPER='T', set upper triangle of A to random numbers.
|
||||
* (but don't modify the corners of 2x2 blocks.)
|
||||
*
|
||||
IF( IUPPER.NE.0 ) THEN
|
||||
DO 70 JC = 2, N
|
||||
IF( A( JC-1, JC ).NE.ZERO ) THEN
|
||||
JR = JC - 2
|
||||
ELSE
|
||||
JR = JC - 1
|
||||
END IF
|
||||
CALL DLARNV( IDIST, ISEED, JR, A( 1, JC ) )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 4) If SIM='T', apply similarity transformation.
|
||||
*
|
||||
* -1
|
||||
* Transform is X A X , where X = U S V, thus
|
||||
*
|
||||
* it is U S V A V' (1/S) U'
|
||||
*
|
||||
IF( ISIM.NE.0 ) THEN
|
||||
*
|
||||
* Compute S (singular values of the eigenvector matrix)
|
||||
* according to CONDS and MODES
|
||||
*
|
||||
CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 3
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by V and V'
|
||||
*
|
||||
CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by S and (1/S)
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
CALL DSCAL( N, DS( J ), A( J, 1 ), LDA )
|
||||
IF( DS( J ).NE.ZERO ) THEN
|
||||
CALL DSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
|
||||
ELSE
|
||||
INFO = 5
|
||||
RETURN
|
||||
END IF
|
||||
80 CONTINUE
|
||||
*
|
||||
* Multiply by U and U'
|
||||
*
|
||||
CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* 5) Reduce the bandwidth.
|
||||
*
|
||||
IF( KL.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce bandwidth -- kill column
|
||||
*
|
||||
DO 90 JCR = KL + 1, N - 1
|
||||
IC = JCR - KL
|
||||
IROWS = N + 1 - JCR
|
||||
ICOLS = N + KL - JCR
|
||||
*
|
||||
CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
WORK( 1 ) = ONE
|
||||
*
|
||||
CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
|
||||
$ A( JCR, IC+1 ), LDA )
|
||||
*
|
||||
CALL DGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1,
|
||||
$ ZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL DGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1,
|
||||
$ A( 1, JCR ), LDA )
|
||||
*
|
||||
A( JCR, IC ) = XNORMS
|
||||
CALL DLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ),
|
||||
$ LDA )
|
||||
90 CONTINUE
|
||||
ELSE IF( KU.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce upper bandwidth -- kill a row at a time.
|
||||
*
|
||||
DO 100 JCR = KU + 1, N - 1
|
||||
IR = JCR - KU
|
||||
IROWS = N + KU - JCR
|
||||
ICOLS = N + 1 - JCR
|
||||
*
|
||||
CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
WORK( 1 ) = ONE
|
||||
*
|
||||
CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
|
||||
$ A( IR+1, JCR ), LDA )
|
||||
*
|
||||
CALL DGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1,
|
||||
$ ZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL DGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1,
|
||||
$ A( JCR, 1 ), LDA )
|
||||
*
|
||||
A( IR, JCR ) = XNORMS
|
||||
CALL DLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ),
|
||||
$ LDA )
|
||||
100 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Scale the matrix to have norm ANORM
|
||||
*
|
||||
IF( ANORM.GE.ZERO ) THEN
|
||||
TEMP = DLANGE( 'M', N, N, A, LDA, TEMPA )
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = ANORM / TEMP
|
||||
DO 110 J = 1, N
|
||||
CALL DSCAL( N, ALPHA, A( 1, J ), 1 )
|
||||
110 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLATME
|
||||
*
|
||||
END
|
||||
1227
lapack-netlib/TESTING/MATGEN/dlatmr.f
Normal file
1227
lapack-netlib/TESTING/MATGEN/dlatmr.f
Normal file
File diff suppressed because it is too large
Load Diff
1128
lapack-netlib/TESTING/MATGEN/dlatms.f
Normal file
1128
lapack-netlib/TESTING/MATGEN/dlatms.f
Normal file
File diff suppressed because it is too large
Load Diff
1139
lapack-netlib/TESTING/MATGEN/dlatmt.f
Normal file
1139
lapack-netlib/TESTING/MATGEN/dlatmt.f
Normal file
File diff suppressed because it is too large
Load Diff
357
lapack-netlib/TESTING/MATGEN/slagge.f
Normal file
357
lapack-netlib/TESTING/MATGEN/slagge.f
Normal file
@@ -0,0 +1,357 @@
|
||||
*> \brief \b SLAGGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAGGE generates a real general m by n matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with random orthogonal matrices:
|
||||
*> A = U*D*V. The lower and upper bandwidths may then be reduced to
|
||||
*> kl and ku by additional orthogonal transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= KL <= M-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The number of nonzero superdiagonals within the band of A.
|
||||
*> 0 <= KU <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (min(M,N))
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA,N)
|
||||
*> The generated m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= M.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (M+N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
REAL TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN, SIGN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SNRM2
|
||||
EXTERNAL SNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'SLAGGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, MIN( M, N )
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* pre- and post-multiply A by random orthogonal matrices
|
||||
*
|
||||
DO 40 I = MIN( M, N ), 1, -1
|
||||
IF( I.LT.M ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL SLARNV( 3, ISEED, M-I+1, WORK )
|
||||
WN = SNRM2( M-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL SSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the left
|
||||
*
|
||||
CALL SGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( M+1 ), 1 )
|
||||
CALL SGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL SLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the right
|
||||
*
|
||||
CALL SGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL SGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to KL and number of superdiagonals
|
||||
* to KU
|
||||
*
|
||||
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
|
||||
IF( KL.LE.KU ) THEN
|
||||
*
|
||||
* annihilate subdiagonal elements first (necessary if KL = 0)
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = SIGN( WN, A( KL+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
|
||||
$ A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = SIGN( WN, A( I, KU+I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* annihilate superdiagonal elements first (necessary if
|
||||
* KU = 0)
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = SIGN( WN, A( I, KU+I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = SIGN( WN, A( KL+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
|
||||
$ A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
DO 50 J = KL + I + 1, M
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
*
|
||||
DO 60 J = KU + I + 1, N
|
||||
A( I, J ) = ZERO
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of SLAGGE
|
||||
*
|
||||
END
|
||||
261
lapack-netlib/TESTING/MATGEN/slagsy.f
Normal file
261
lapack-netlib/TESTING/MATGEN/slagsy.f
Normal file
@@ -0,0 +1,261 @@
|
||||
*> \brief \b SLAGSY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAGSY generates a real symmetric matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random orthogonal matrix:
|
||||
*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
|
||||
*> orthogonal transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA,N)
|
||||
*> The generated n by n symmetric matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
REAL ALPHA, TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SAXPY, SGEMV, SGER, SLARNV, SSCAL, SSYMV,
|
||||
$ SSYR2, XERBLA
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SDOT, SNRM2
|
||||
EXTERNAL SDOT, SNRM2
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SIGN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'SLAGSY', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of symmetric matrix
|
||||
*
|
||||
DO 40 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL SLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL SSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*SDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 )
|
||||
CALL SAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
CALL SSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 60 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = SNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = SIGN( WN, A( K+I, I ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL SSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL SGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL SGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL SSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*SDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
|
||||
CALL SAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
CALL SSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, K+I ), LDA )
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 50 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Store full symmetric matrix
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
DO 70 I = J + 1, N
|
||||
A( J, I ) = A( I, J )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of SLAGSY
|
||||
*
|
||||
END
|
||||
223
lapack-netlib/TESTING/MATGEN/slahilb.f
Normal file
223
lapack-netlib/TESTING/MATGEN/slahilb.f
Normal file
@@ -0,0 +1,223 @@
|
||||
*> \brief \b SLAHILB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAHILB generates an N by N scaled Hilbert matrix in A along with
|
||||
*> NRHS right-hand sides in B and solutions in X such that A*X=B.
|
||||
*>
|
||||
*> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
|
||||
*> entries are integers. The right-hand sides are the first NRHS
|
||||
*> columns of M * the identity matrix, and the solutions are the
|
||||
*> first NRHS columns of the inverse Hilbert matrix.
|
||||
*>
|
||||
*> The condition number of the Hilbert matrix grows exponentially with
|
||||
*> its size, roughly as O(e ** (3.5*N)). Additionally, the inverse
|
||||
*> Hilbert matrices beyond a relatively small dimension cannot be
|
||||
*> generated exactly without extra precision. Precision is exhausted
|
||||
*> when the largest entry in the inverse Hilbert matrix is greater than
|
||||
*> 2 to the power of the number of bits in the fraction of the data type
|
||||
*> used plus one, which is 24 for single precision.
|
||||
*>
|
||||
*> In single, the generated solution is exact for N <= 6 and has
|
||||
*> small componentwise error for 7 <= N <= 11.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The dimension of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NRHS
|
||||
*> \verbatim
|
||||
*> NRHS is INTEGER
|
||||
*> The requested number of right-hand sides.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA, N)
|
||||
*> The generated scaled Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is REAL array, dimension (LDX, NRHS)
|
||||
*> The generated exact solutions. Currently, the first NRHS
|
||||
*> columns of the inverse Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of the array X. LDX >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is REAL array, dimension (LDB, NRHS)
|
||||
*> The generated right-hand sides. Currently, the first NRHS
|
||||
*> columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> = 1: N is too large; the data is still generated but may not
|
||||
*> be not exact.
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO)
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
* .. Local Scalars ..
|
||||
INTEGER TM, TI, R
|
||||
INTEGER M
|
||||
INTEGER I, J
|
||||
|
||||
* .. Parameters ..
|
||||
* NMAX_EXACT the largest dimension where the generated data is
|
||||
* exact.
|
||||
* NMAX_APPROX the largest dimension where the generated data has
|
||||
* a small componentwise relative error.
|
||||
INTEGER NMAX_EXACT, NMAX_APPROX
|
||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11)
|
||||
|
||||
* ..
|
||||
* .. External Functions
|
||||
EXTERNAL SLASET
|
||||
INTRINSIC REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN
|
||||
INFO = -1
|
||||
ELSE IF (NRHS .LT. 0) THEN
|
||||
INFO = -2
|
||||
ELSE IF (LDA .LT. N) THEN
|
||||
INFO = -4
|
||||
ELSE IF (LDX .LT. N) THEN
|
||||
INFO = -6
|
||||
ELSE IF (LDB .LT. N) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF (INFO .LT. 0) THEN
|
||||
CALL XERBLA('SLAHILB', -INFO)
|
||||
RETURN
|
||||
END IF
|
||||
IF (N .GT. NMAX_EXACT) THEN
|
||||
INFO = 1
|
||||
END IF
|
||||
|
||||
* Compute M = the LCM of the integers [1, 2*N-1]. The largest
|
||||
* reasonable N is small enough that integers suffice (up to N = 11).
|
||||
M = 1
|
||||
DO I = 2, (2*N-1)
|
||||
TM = M
|
||||
TI = I
|
||||
R = MOD(TM, TI)
|
||||
DO WHILE (R .NE. 0)
|
||||
TM = TI
|
||||
TI = R
|
||||
R = MOD(TM, TI)
|
||||
END DO
|
||||
M = (M / TI) * I
|
||||
END DO
|
||||
|
||||
* Generate the scaled Hilbert matrix in A
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = REAL(M) / (I + J - 1)
|
||||
END DO
|
||||
END DO
|
||||
|
||||
* Generate matrix B as simply the first NRHS columns of M * the
|
||||
* identity.
|
||||
CALL SLASET('Full', N, NRHS, 0.0, REAL(M), B, LDB)
|
||||
|
||||
* Generate the true solutions in X. Because B = the first NRHS
|
||||
* columns of M*I, the true solutions are just the first NRHS columns
|
||||
* of the inverse Hilbert matrix.
|
||||
WORK(1) = N
|
||||
DO J = 2, N
|
||||
WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) )
|
||||
$ * (N +J -1)
|
||||
END DO
|
||||
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1)
|
||||
END DO
|
||||
END DO
|
||||
|
||||
END
|
||||
|
||||
191
lapack-netlib/TESTING/MATGEN/slakf2.f
Normal file
191
lapack-netlib/TESTING/MATGEN/slakf2.f
Normal file
@@ -0,0 +1,191 @@
|
||||
*> \brief \b SLAKF2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
* $ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Form the 2*M*N by 2*M*N matrix
|
||||
*>
|
||||
*> Z = [ kron(In, A) -kron(B', Im) ]
|
||||
*> [ kron(In, D) -kron(E', Im) ],
|
||||
*>
|
||||
*> where In is the identity matrix of size n and X' is the transpose
|
||||
*> of X. kron(X, Y) is the Kronecker product between the matrices X
|
||||
*> and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL, dimension ( LDA, M )
|
||||
*> The matrix A in the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A, B, D, and E. ( LDA >= M+N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is REAL, dimension ( LDA, N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL, dimension ( LDA, M )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] E
|
||||
*> \verbatim
|
||||
*> E is REAL, dimension ( LDA, N )
|
||||
*>
|
||||
*> The matrices used in forming the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Z
|
||||
*> \verbatim
|
||||
*> Z is REAL, dimension ( LDZ, 2*M*N )
|
||||
*> The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDZ
|
||||
*> \verbatim
|
||||
*> LDZ is INTEGER
|
||||
*> The leading dimension of Z. ( LDZ >= 2*M*N )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
$ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
* ====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IK, J, JK, L, MN, MN2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SLASET
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Initialize Z
|
||||
*
|
||||
MN = M*N
|
||||
MN2 = 2*MN
|
||||
CALL SLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
|
||||
*
|
||||
IK = 1
|
||||
DO 50 L = 1, N
|
||||
*
|
||||
* form kron(In, A)
|
||||
*
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
Z( IK+I-1, IK+J-1 ) = A( I, J )
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* form kron(In, D)
|
||||
*
|
||||
DO 40 I = 1, M
|
||||
DO 30 J = 1, M
|
||||
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
50 CONTINUE
|
||||
*
|
||||
IK = 1
|
||||
DO 90 L = 1, N
|
||||
JK = MN + 1
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
*
|
||||
* form -kron(B', Im)
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
Z( IK+I-1, JK+I-1 ) = -B( J, L )
|
||||
60 CONTINUE
|
||||
*
|
||||
* form -kron(E', Im)
|
||||
*
|
||||
DO 70 I = 1, M
|
||||
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
|
||||
70 CONTINUE
|
||||
*
|
||||
JK = JK + M
|
||||
80 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
90 CONTINUE
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLAKF2
|
||||
*
|
||||
END
|
||||
147
lapack-netlib/TESTING/MATGEN/slaran.f
Normal file
147
lapack-netlib/TESTING/MATGEN/slaran.f
Normal file
@@ -0,0 +1,147 @@
|
||||
*> \brief \b SLARAN
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLARAN( ISEED )
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARAN returns a random real number from a uniform (0,1)
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine uses a multiplicative congruential method with modulus
|
||||
*> 2**48 and multiplier 33952834046453 (see G.S.Fishman,
|
||||
*> 'Multiplicative congruential random number generators with modulus
|
||||
*> 2**b: an exhaustive analysis for b = 32 and a partial analysis for
|
||||
*> b = 48', Math. Comp. 189, pp 331-344, 1990).
|
||||
*>
|
||||
*> 48-bit integers are stored in 4 integer array elements with 12 bits
|
||||
*> per element. Hence the routine is portable across machines with
|
||||
*> integers of 32 bits or more.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLARAN( ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
INTEGER M1, M2, M3, M4
|
||||
PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E+0 )
|
||||
INTEGER IPW2
|
||||
REAL R
|
||||
PARAMETER ( IPW2 = 4096, R = ONE / IPW2 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IT1, IT2, IT3, IT4
|
||||
REAL RNDOUT
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
10 CONTINUE
|
||||
*
|
||||
* multiply the seed by the multiplier modulo 2**48
|
||||
*
|
||||
IT4 = ISEED( 4 )*M4
|
||||
IT3 = IT4 / IPW2
|
||||
IT4 = IT4 - IPW2*IT3
|
||||
IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
|
||||
IT2 = IT3 / IPW2
|
||||
IT3 = IT3 - IPW2*IT2
|
||||
IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
|
||||
IT1 = IT2 / IPW2
|
||||
IT2 = IT2 - IPW2*IT1
|
||||
IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
|
||||
$ ISEED( 4 )*M1
|
||||
IT1 = MOD( IT1, IPW2 )
|
||||
*
|
||||
* return updated seed
|
||||
*
|
||||
ISEED( 1 ) = IT1
|
||||
ISEED( 2 ) = IT2
|
||||
ISEED( 3 ) = IT3
|
||||
ISEED( 4 ) = IT4
|
||||
*
|
||||
* convert 48-bit integer to a real number in the interval (0,1)
|
||||
*
|
||||
RNDOUT = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
|
||||
$ ( REAL( IT4 ) ) ) ) )
|
||||
*
|
||||
IF (RNDOUT.EQ.1.0) THEN
|
||||
* If a real number has n bits of precision, and the first
|
||||
* n bits of the 48-bit integer above happen to be all 1 (which
|
||||
* will occur about once every 2**n calls), then SLARAN will
|
||||
* be rounded to exactly 1.0. In IEEE single precision arithmetic,
|
||||
* this will happen relatively often since n = 24.
|
||||
* Since SLARAN is not supposed to return exactly 0.0 or 1.0
|
||||
* (and some callers of SLARAN, such as CLARND, depend on that),
|
||||
* the statistically correct thing to do in this situation is
|
||||
* simply to iterate again.
|
||||
* N.B. the case SLARAN = 0.0 should not be possible.
|
||||
*
|
||||
GOTO 10
|
||||
END IF
|
||||
*
|
||||
SLARAN = RNDOUT
|
||||
RETURN
|
||||
*
|
||||
* End of SLARAN
|
||||
*
|
||||
END
|
||||
174
lapack-netlib/TESTING/MATGEN/slarge.f
Normal file
174
lapack-netlib/TESTING/MATGEN/slarge.f
Normal file
@@ -0,0 +1,174 @@
|
||||
*> \brief \b SLARGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARGE pre- and post-multiplies a real general n by n matrix A
|
||||
*> with a random orthogonal matrix: A = U*D*U'.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA,N)
|
||||
*> On entry, the original n by n matrix A.
|
||||
*> On exit, A is overwritten by U*A*U' for some random
|
||||
*> orthogonal matrix U.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
REAL TAU, WA, WB, WN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SIGN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SNRM2
|
||||
EXTERNAL SNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -3
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'SLARGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* pre- and post-multiply A by random orthogonal matrix
|
||||
*
|
||||
DO 10 I = N, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL SLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = SNRM2( N-I+1, WORK, 1 )
|
||||
WA = SIGN( WN, WORK( 1 ) )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = WB / WA
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:n,1:n) by random reflection from the left
|
||||
*
|
||||
CALL SGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK,
|
||||
$ 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL SGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
|
||||
$ LDA )
|
||||
*
|
||||
* multiply A(1:n,i:n) by random reflection from the right
|
||||
*
|
||||
CALL SGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL SGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
|
||||
$ LDA )
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of SLARGE
|
||||
*
|
||||
END
|
||||
133
lapack-netlib/TESTING/MATGEN/slarnd.f
Normal file
133
lapack-netlib/TESTING/MATGEN/slarnd.f
Normal file
@@ -0,0 +1,133 @@
|
||||
*> \brief \b SLARND
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLARND( IDIST, ISEED )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARND returns a random real number from a uniform or normal
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> Specifies the distribution of the random numbers:
|
||||
*> = 1: uniform (0,1)
|
||||
*> = 2: uniform (-1,1)
|
||||
*> = 3: normal (0,1)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine calls the auxiliary routine SLARAN to generate a random
|
||||
*> real number from a uniform (0,1) distribution. The Box-Muller method
|
||||
*> is used to transform numbers from a uniform to a normal distribution.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLARND( IDIST, ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, TWO
|
||||
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
|
||||
REAL TWOPI
|
||||
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL T1, T2
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLARAN
|
||||
EXTERNAL SLARAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC COS, LOG, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate a real random number from a uniform (0,1) distribution
|
||||
*
|
||||
T1 = SLARAN( ISEED )
|
||||
*
|
||||
IF( IDIST.EQ.1 ) THEN
|
||||
*
|
||||
* uniform (0,1)
|
||||
*
|
||||
SLARND = T1
|
||||
ELSE IF( IDIST.EQ.2 ) THEN
|
||||
*
|
||||
* uniform (-1,1)
|
||||
*
|
||||
SLARND = TWO*T1 - ONE
|
||||
ELSE IF( IDIST.EQ.3 ) THEN
|
||||
*
|
||||
* normal (0,1)
|
||||
*
|
||||
T2 = SLARAN( ISEED )
|
||||
SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLARND
|
||||
*
|
||||
END
|
||||
304
lapack-netlib/TESTING/MATGEN/slaror.f
Normal file
304
lapack-netlib/TESTING/MATGEN/slaror.f
Normal file
@@ -0,0 +1,304 @@
|
||||
*> \brief \b SLAROR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER INIT, SIDE
|
||||
* INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAROR pre- or post-multiplies an M by N matrix A by a random
|
||||
*> orthogonal matrix U, overwriting A. A may optionally be initialized
|
||||
*> to the identity matrix before multiplying by U. U is generated using
|
||||
*> the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> Specifies whether A is multiplied on the left or right by U.
|
||||
*> = 'L': Multiply A on the left (premultiply) by U
|
||||
*> = 'R': Multiply A on the right (postmultiply) by U'
|
||||
*> = 'C' or 'T': Multiply A on the left by U and the right
|
||||
*> by U' (Here, U' means U-transpose.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INIT
|
||||
*> \verbatim
|
||||
*> INIT is CHARACTER*1
|
||||
*> Specifies whether or not A should be initialized to the
|
||||
*> identity matrix.
|
||||
*> = 'I': Initialize A to (a section of) the identity matrix
|
||||
*> before applying U.
|
||||
*> = 'N': No initialization. Apply U to the input matrix A.
|
||||
*>
|
||||
*> INIT = 'I' may be used to generate square or rectangular
|
||||
*> orthogonal matrices:
|
||||
*>
|
||||
*> For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
|
||||
*> to each other, as will the columns.
|
||||
*>
|
||||
*> If M < N, SIDE = 'R' produces a dense matrix whose rows are
|
||||
*> orthogonal and whose columns are not, while SIDE = 'L'
|
||||
*> produces a matrix whose rows are orthogonal, and whose first
|
||||
*> M columns are orthogonal, and whose remaining columns are
|
||||
*> zero.
|
||||
*>
|
||||
*> If M > N, SIDE = 'L' produces a dense matrix whose columns
|
||||
*> are orthogonal and whose rows are not, while SIDE = 'R'
|
||||
*> produces a matrix whose columns are orthogonal, and whose
|
||||
*> first M rows are orthogonal, and whose remaining rows are
|
||||
*> zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA, N)
|
||||
*> On entry, the array A.
|
||||
*> On exit, overwritten by U A ( if SIDE = 'L' ),
|
||||
*> or by A U ( if SIDE = 'R' ),
|
||||
*> or by U A U' ( if SIDE = 'C' or 'T').
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The array elements should be between 0 and 4095;
|
||||
*> if not they will be reduced mod 4096. Also, ISEED(4) must
|
||||
*> be odd. The random number generator uses a linear
|
||||
*> congruential sequence limited to small integers, and so
|
||||
*> should produce machine independent random numbers. The
|
||||
*> values of ISEED are changed on exit, and can be used in the
|
||||
*> next call to SLAROR to continue the same random number
|
||||
*> sequence.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is REAL array, dimension (3*MAX( M, N ))
|
||||
*> Workspace of length
|
||||
*> 2*M + N if SIDE = 'L',
|
||||
*> 2*N + M if SIDE = 'R',
|
||||
*> 3*N if SIDE = 'C' or 'T'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> An error flag. It is set to:
|
||||
*> = 0: normal return
|
||||
*> < 0: if INFO = -k, the k-th argument had an illegal value
|
||||
*> = 1: if the random numbers generated by SLARND are bad.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER INIT, SIDE
|
||||
INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE, TOOSML
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
|
||||
$ TOOSML = 1.0E-20 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
|
||||
REAL FACTOR, XNORM, XNORMS
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
REAL SLARND, SNRM2
|
||||
EXTERNAL LSAME, SLARND, SNRM2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMV, SGER, SLASET, SSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, SIGN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.EQ.0 .OR. M.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
ITYPE = 0
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
ITYPE = 1
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
ITYPE = 2
|
||||
ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN
|
||||
ITYPE = 3
|
||||
END IF
|
||||
*
|
||||
* Check for argument errors.
|
||||
*
|
||||
IF( ITYPE.EQ.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.M ) THEN
|
||||
INFO = -6
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'SLAROR', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.1 ) THEN
|
||||
NXFRM = M
|
||||
ELSE
|
||||
NXFRM = N
|
||||
END IF
|
||||
*
|
||||
* Initialize A to the identity matrix if desired
|
||||
*
|
||||
IF( LSAME( INIT, 'I' ) )
|
||||
$ CALL SLASET( 'Full', M, N, ZERO, ONE, A, LDA )
|
||||
*
|
||||
* If no rotation possible, multiply by random +/-1
|
||||
*
|
||||
* Compute rotation by computing Householder transformations
|
||||
* H(2), H(3), ..., H(nhouse)
|
||||
*
|
||||
DO 10 J = 1, NXFRM
|
||||
X( J ) = ZERO
|
||||
10 CONTINUE
|
||||
*
|
||||
DO 30 IXFRM = 2, NXFRM
|
||||
KBEG = NXFRM - IXFRM + 1
|
||||
*
|
||||
* Generate independent normal( 0, 1 ) random numbers
|
||||
*
|
||||
DO 20 J = KBEG, NXFRM
|
||||
X( J ) = SLARND( 3, ISEED )
|
||||
20 CONTINUE
|
||||
*
|
||||
* Generate a Householder transformation from the random vector X
|
||||
*
|
||||
XNORM = SNRM2( IXFRM, X( KBEG ), 1 )
|
||||
XNORMS = SIGN( XNORM, X( KBEG ) )
|
||||
X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) )
|
||||
FACTOR = XNORMS*( XNORMS+X( KBEG ) )
|
||||
IF( ABS( FACTOR ).LT.TOOSML ) THEN
|
||||
INFO = 1
|
||||
CALL XERBLA( 'SLAROR', INFO )
|
||||
RETURN
|
||||
ELSE
|
||||
FACTOR = ONE / FACTOR
|
||||
END IF
|
||||
X( KBEG ) = X( KBEG ) + XNORMS
|
||||
*
|
||||
* Apply Householder transformation to A
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* Apply H(k) from the left.
|
||||
*
|
||||
CALL SGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA,
|
||||
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL SGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ),
|
||||
$ 1, A( KBEG, 1 ), LDA )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* Apply H(k) from the right.
|
||||
*
|
||||
CALL SGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA,
|
||||
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL SGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ),
|
||||
$ 1, A( 1, KBEG ), LDA )
|
||||
*
|
||||
END IF
|
||||
30 CONTINUE
|
||||
*
|
||||
X( 2*NXFRM ) = SIGN( ONE, SLARND( 3, ISEED ) )
|
||||
*
|
||||
* Scale the matrix A by D.
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 40 IROW = 1, M
|
||||
CALL SSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 50 JCOL = 1, N
|
||||
CALL SSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLAROR
|
||||
*
|
||||
END
|
||||
317
lapack-netlib/TESTING/MATGEN/slarot.f
Normal file
317
lapack-netlib/TESTING/MATGEN/slarot.f
Normal file
@@ -0,0 +1,317 @@
|
||||
*> \brief \b SLAROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
* XRIGHT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* LOGICAL LLEFT, LRIGHT, LROWS
|
||||
* INTEGER LDA, NL
|
||||
* REAL C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAROT applies a (Givens) rotation to two adjacent rows or
|
||||
*> columns, where one element of the first and/or last column/row
|
||||
*> for use on matrices stored in some format other than GE, so
|
||||
*> that elements of the matrix may be used or modified for which
|
||||
*> no array element is provided.
|
||||
*>
|
||||
*> One example is a symmetric matrix in SB format (bandwidth=4), for
|
||||
*> which UPLO='L': Two adjacent rows will have the format:
|
||||
*>
|
||||
*> row j: C> C> C> C> C> . . . .
|
||||
*> row j+1: C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> '*' indicates elements for which storage is provided,
|
||||
*> '.' indicates elements for which no storage is provided, but
|
||||
*> are not necessarily zero; their values are determined by
|
||||
*> symmetry. ' ' indicates elements which are necessarily zero,
|
||||
*> and have no storage provided.
|
||||
*>
|
||||
*> Those columns which have two '*'s can be handled by SROT.
|
||||
*> Those columns which have no '*'s can be ignored, since as long
|
||||
*> as the Givens rotations are carefully applied to preserve
|
||||
*> symmetry, their values are determined.
|
||||
*> Those columns which have one '*' have to be handled separately,
|
||||
*> by using separate variables "p" and "q":
|
||||
*>
|
||||
*> row j: C> C> C> C> C> p . . .
|
||||
*> row j+1: q C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> The element p would have to be set correctly, then that column
|
||||
*> is rotated, setting p to its new value. The next call to
|
||||
*> SLAROT would rotate columns j and j+1, using p, and restore
|
||||
*> symmetry. The element q would start out being zero, and be
|
||||
*> made non-zero by the rotation. Later, rotations would presumably
|
||||
*> be chosen to zero q out.
|
||||
*>
|
||||
*> Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
|
||||
*> ------- ------- ---------
|
||||
*>
|
||||
*> General dense matrix:
|
||||
*>
|
||||
*> CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
|
||||
*> A(i,1),LDA, DUMMY, DUMMY)
|
||||
*>
|
||||
*> General banded matrix in GB format:
|
||||
*>
|
||||
*> j = MAX(1, i-KL )
|
||||
*> NL = MIN( N, i+KU+1 ) + 1-j
|
||||
*> CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
|
||||
*> A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,KL+1) ]
|
||||
*>
|
||||
*> Symmetric banded matrix in SY format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> j = MAX(1, i-K )
|
||||
*> NL = MIN( K+1, i ) + 1
|
||||
*> CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
|
||||
*> A(i,j), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*>
|
||||
*> NL = MIN( K+1, N-i ) + 1
|
||||
*> CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
|
||||
*> A(i,i), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Symmetric banded matrix in SB format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> [ same as for SY, except:]
|
||||
*> . . . .
|
||||
*> A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,K+1) ]
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*> . . .
|
||||
*> A(K+1,i), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Rotating columns is just the transpose of rotating rows, except
|
||||
*> for GB and SB: (rotating columns i and i+1)
|
||||
*>
|
||||
*> GB:
|
||||
*> j = MAX(1, i-KU )
|
||||
*> NL = MIN( N, i+KL+1 ) + 1-j
|
||||
*> CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
|
||||
*> A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> [note that KU+j+1-i is just MAX(1,KU+2-i)]
|
||||
*>
|
||||
*> SB: (upper triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> SB: (lower triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(1,i),LDA-1, XTOP, XBOTTM )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> LROWS - LOGICAL
|
||||
*> If .TRUE., then SLAROT will rotate two rows. If .FALSE.,
|
||||
*> then it will rotate two columns.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LLEFT - LOGICAL
|
||||
*> If .TRUE., then XLEFT will be used instead of the
|
||||
*> corresponding element of A for the first element in the
|
||||
*> second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
|
||||
*> If .FALSE., then the corresponding element of A will be
|
||||
*> used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LRIGHT - LOGICAL
|
||||
*> If .TRUE., then XRIGHT will be used instead of the
|
||||
*> corresponding element of A for the last element in the
|
||||
*> first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
|
||||
*> .FALSE., then the corresponding element of A will be used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> NL - INTEGER
|
||||
*> The length of the rows (if LROWS=.TRUE.) or columns (if
|
||||
*> LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
|
||||
*> used, the columns/rows they are in should be included in
|
||||
*> NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
|
||||
*> least 2. The number of rows/columns to be rotated
|
||||
*> exclusive of those involving XLEFT and/or XRIGHT may
|
||||
*> not be negative, i.e., NL minus how many of LLEFT and
|
||||
*> LRIGHT are .TRUE. must be at least zero; if not, XERBLA
|
||||
*> will be called.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> C, S - REAL
|
||||
*> Specify the Givens rotation to be applied. If LROWS is
|
||||
*> true, then the matrix ( c s )
|
||||
*> (-s c ) is applied from the left;
|
||||
*> if false, then the transpose thereof is applied from the
|
||||
*> right. For a Givens rotation, C**2 + S**2 should be 1,
|
||||
*> but this is not checked.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> A - REAL array.
|
||||
*> The array containing the rows/columns to be rotated. The
|
||||
*> first element of A should be the upper left element to
|
||||
*> be rotated.
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> LDA - INTEGER
|
||||
*> The "effective" leading dimension of A. If A contains
|
||||
*> a matrix stored in GE or SY format, then this is just
|
||||
*> the leading dimension of A as dimensioned in the calling
|
||||
*> routine. If A contains a matrix stored in band (GB or SB)
|
||||
*> format, then this should be *one less* than the leading
|
||||
*> dimension used in the calling routine. Thus, if
|
||||
*> A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would
|
||||
*> be the j-th element in the first of the two rows
|
||||
*> to be rotated, and A(2,j) would be the j-th in the second,
|
||||
*> regardless of how the array may be stored in the calling
|
||||
*> routine. [A cannot, however, actually be dimensioned thus,
|
||||
*> since for band format, the row number may exceed LDA, which
|
||||
*> is not legal FORTRAN.]
|
||||
*> If LROWS=.TRUE., then LDA must be at least 1, otherwise
|
||||
*> it must be at least NL minus the number of .TRUE. values
|
||||
*> in XLEFT and XRIGHT.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> XLEFT - REAL
|
||||
*> If LLEFT is .TRUE., then XLEFT will be used and modified
|
||||
*> instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> XRIGHT - REAL
|
||||
*> If LRIGHT is .TRUE., then XRIGHT will be used and modified
|
||||
*> instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
$ XRIGHT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
LOGICAL LLEFT, LRIGHT, LROWS
|
||||
INTEGER LDA, NL
|
||||
REAL C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER IINC, INEXT, IX, IY, IYT, NT
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL XT( 2 ), YT( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SROT, XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Set up indices, arrays for ends
|
||||
*
|
||||
IF( LROWS ) THEN
|
||||
IINC = LDA
|
||||
INEXT = 1
|
||||
ELSE
|
||||
IINC = 1
|
||||
INEXT = LDA
|
||||
END IF
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
NT = 1
|
||||
IX = 1 + IINC
|
||||
IY = 2 + LDA
|
||||
XT( 1 ) = A( 1 )
|
||||
YT( 1 ) = XLEFT
|
||||
ELSE
|
||||
NT = 0
|
||||
IX = 1
|
||||
IY = 1 + INEXT
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
IYT = 1 + INEXT + ( NL-1 )*IINC
|
||||
NT = NT + 1
|
||||
XT( NT ) = XRIGHT
|
||||
YT( NT ) = A( IYT )
|
||||
END IF
|
||||
*
|
||||
* Check for errors
|
||||
*
|
||||
IF( NL.LT.NT ) THEN
|
||||
CALL XERBLA( 'SLAROT', 4 )
|
||||
RETURN
|
||||
END IF
|
||||
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
|
||||
CALL XERBLA( 'SLAROT', 8 )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Rotate
|
||||
*
|
||||
CALL SROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S )
|
||||
CALL SROT( NT, XT, 1, YT, 1, C, S )
|
||||
*
|
||||
* Stuff values back into XLEFT, XRIGHT, etc.
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
A( 1 ) = XT( 1 )
|
||||
XLEFT = YT( 1 )
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
XRIGHT = XT( NT )
|
||||
A( IYT ) = YT( NT )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLAROT
|
||||
*
|
||||
END
|
||||
299
lapack-netlib/TESTING/MATGEN/slatm1.f
Normal file
299
lapack-netlib/TESTING/MATGEN/slatm1.f
Normal file
@@ -0,0 +1,299 @@
|
||||
*> \brief \b SLATM1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
* REAL COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL D( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM1 computes the entries of D(1..N) as specified by
|
||||
*> MODE, COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. SLATM1 is called by SLATMR to generate
|
||||
*> random test matrices for LAPACK programs.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is REAL
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IRSIGN
|
||||
*> \verbatim
|
||||
*> IRSIGN is INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by 1 or -1 with probability .5
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to SLATM1
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
REAL COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
REAL D( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E0 )
|
||||
REAL HALF
|
||||
PARAMETER ( HALF = 0.5E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
REAL ALPHA, TEMP
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLARAN
|
||||
EXTERNAL SLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SLARNV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, EXP, LOG, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'SLATM1', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
10 CONTINUE
|
||||
DO 20 I = 1, N
|
||||
D( I ) = ONE / COND
|
||||
20 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 120
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
30 CONTINUE
|
||||
DO 40 I = 1, N
|
||||
D( I ) = ONE
|
||||
40 CONTINUE
|
||||
D( N ) = ONE / COND
|
||||
GO TO 120
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
50 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / REAL( N-1 ) )
|
||||
DO 60 I = 2, N
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
70 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / REAL( N-1 )
|
||||
DO 80 I = 2, N
|
||||
D( I ) = REAL( N-I )*ALPHA + TEMP
|
||||
80 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
90 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 100 I = 1, N
|
||||
D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
|
||||
100 CONTINUE
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
110 CONTINUE
|
||||
CALL SLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
120 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 130 I = 1, N
|
||||
TEMP = SLARAN( ISEED )
|
||||
IF( TEMP.GT.HALF )
|
||||
$ D( I ) = -D( I )
|
||||
130 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 140 I = 1, N / 2
|
||||
TEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = TEMP
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLATM1
|
||||
*
|
||||
END
|
||||
315
lapack-netlib/TESTING/MATGEN/slatm2.f
Normal file
315
lapack-netlib/TESTING/MATGEN/slatm2.f
Normal file
@@ -0,0 +1,315 @@
|
||||
*> \brief \b SLATM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
* REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* REAL D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM2 returns the (I,J) entry of a random matrix of dimension
|
||||
*> (M, N) described by the other paramters. It is called by the
|
||||
*> SLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by SLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of SLATM2 differs from SLATM3 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With SLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With SLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, SLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. SLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*>
|
||||
*> The matrix whose (I,J) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If I is outside (1..M) or J is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is REAL array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is REAL array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) in position K was originally in
|
||||
*> position IWORK( K ).
|
||||
*> This differs from IWORK for SLATM3. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is REAL between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
REAL D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
INTEGER ISUB, JSUB
|
||||
REAL TEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
REAL SLARAN, SLARND
|
||||
EXTERNAL SLARAN, SLARND
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
SLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
|
||||
SLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
SLATM2 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( ISUB.EQ.JSUB ) THEN
|
||||
TEMP = D( ISUB )
|
||||
ELSE
|
||||
TEMP = SLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
TEMP = TEMP*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
|
||||
TEMP = TEMP*DL( ISUB ) / DL( JSUB )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
TEMP = TEMP*DL( ISUB )*DL( JSUB )
|
||||
END IF
|
||||
SLATM2 = TEMP
|
||||
RETURN
|
||||
*
|
||||
* End of SLATM2
|
||||
*
|
||||
END
|
||||
335
lapack-netlib/TESTING/MATGEN/slatm3.f
Normal file
335
lapack-netlib/TESTING/MATGEN/slatm3.f
Normal file
@@ -0,0 +1,335 @@
|
||||
*> \brief \b SLATM3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
* SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
* $ KU, M, N
|
||||
* REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* REAL D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM3 returns the (ISUB,JSUB) entry of a random matrix of
|
||||
*> dimension (M, N) described by the other paramters. (ISUB,JSUB)
|
||||
*> is the final position of the (I,J) entry after pivoting
|
||||
*> according to IPVTNG and IWORK. SLATM3 is called by the
|
||||
*> SLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by SLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of SLATM3 differs from SLATM2 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With SLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With SLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, SLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. SLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*> in different orders for different pivot orders).
|
||||
*>
|
||||
*> The matrix whose (ISUB,JSUB) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISUB
|
||||
*> \verbatim
|
||||
*> ISUB is INTEGER
|
||||
*> Row of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] JSUB
|
||||
*> \verbatim
|
||||
*> JSUB is INTEGER
|
||||
*> Column of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is REAL array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is REAL array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) originally in position K is in
|
||||
*> position IWORK( K ) after pivoting.
|
||||
*> This differs from IWORK for SLATM2. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is REAL between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
$ SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
$ KU, M, N
|
||||
REAL SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
REAL D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
REAL TEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
REAL SLARAN, SLARND
|
||||
EXTERNAL SLARAN, SLARND
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
SLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
|
||||
SLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
SLATM3 = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
TEMP = D( I )
|
||||
ELSE
|
||||
TEMP = SLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
TEMP = TEMP*DL( I )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
TEMP = TEMP*DR( J )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
TEMP = TEMP*DL( I )*DR( J )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
|
||||
TEMP = TEMP*DL( I ) / DL( J )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
TEMP = TEMP*DL( I )*DL( J )
|
||||
END IF
|
||||
SLATM3 = TEMP
|
||||
RETURN
|
||||
*
|
||||
* End of SLATM3
|
||||
*
|
||||
END
|
||||
501
lapack-netlib/TESTING/MATGEN/slatm5.f
Normal file
501
lapack-netlib/TESTING/MATGEN/slatm5.f
Normal file
@@ -0,0 +1,501 @@
|
||||
*> \brief \b SLATM5
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
* QBLCKB )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
* $ PRTYPE, QBLCKA, QBLCKB
|
||||
* REAL ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
* $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
* $ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM5 generates matrices involved in the Generalized Sylvester
|
||||
*> equation:
|
||||
*>
|
||||
*> A * R - L * B = C
|
||||
*> D * R - L * E = F
|
||||
*>
|
||||
*> They also satisfy (the diagonalization condition)
|
||||
*>
|
||||
*> [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
|
||||
*> [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] PRTYPE
|
||||
*> \verbatim
|
||||
*> PRTYPE is INTEGER
|
||||
*> "Points" to a certian type of the matrices to generate
|
||||
*> (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Specifies the order of A and D and the number of rows in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Specifies the order of B and E and the number of columns in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA, M).
|
||||
*> On exit A M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is REAL array, dimension (LDB, N).
|
||||
*> On exit B N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] C
|
||||
*> \verbatim
|
||||
*> C is REAL array, dimension (LDC, N).
|
||||
*> On exit C M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (LDD, M).
|
||||
*> On exit D M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDD
|
||||
*> \verbatim
|
||||
*> LDD is INTEGER
|
||||
*> The leading dimension of D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is REAL array, dimension (LDE, N).
|
||||
*> On exit E N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDE
|
||||
*> \verbatim
|
||||
*> LDE is INTEGER
|
||||
*> The leading dimension of E.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] F
|
||||
*> \verbatim
|
||||
*> F is REAL array, dimension (LDF, N).
|
||||
*> On exit F M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDF
|
||||
*> \verbatim
|
||||
*> LDF is INTEGER
|
||||
*> The leading dimension of F.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] R
|
||||
*> \verbatim
|
||||
*> R is REAL array, dimension (LDR, N).
|
||||
*> On exit R M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDR
|
||||
*> \verbatim
|
||||
*> LDR is INTEGER
|
||||
*> The leading dimension of R.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] L
|
||||
*> \verbatim
|
||||
*> L is REAL array, dimension (LDL, N).
|
||||
*> On exit L M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDL
|
||||
*> \verbatim
|
||||
*> LDL is INTEGER
|
||||
*> The leading dimension of L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> Parameter used in generating PRTYPE = 1 and 5 matrices.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKA
|
||||
*> \verbatim
|
||||
*> QBLCKA is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in A. Otherwise, QBLCKA is not
|
||||
*> referenced. QBLCKA > 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKB
|
||||
*> \verbatim
|
||||
*> QBLCKB is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in B. Otherwise, QBLCKB is not
|
||||
*> referenced. QBLCKB > 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
|
||||
*>
|
||||
*> A : if (i == j) then A(i, j) = 1.0
|
||||
*> if (j == i + 1) then A(i, j) = -1.0
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> B : if (i == j) then B(i, j) = 1.0 - ALPHA
|
||||
*> if (j == i + 1) then B(i, j) = 1.0
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> D : if (i == j) then D(i, j) = 1.0
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> E : if (i == j) then E(i, j) = 1.0
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L = R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
|
||||
*>
|
||||
*> A : if (i <= j) then A(i, j) = [-1...1]
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> A(k + 1, k + 1) = A(k, k)
|
||||
*> A(k + 1, k) = [-1...1]
|
||||
*> sign(A(k, k + 1) = -(sin(A(k + 1, k))
|
||||
*> k = 1, M - 1, QBLCKA
|
||||
*>
|
||||
*> B : if (i <= j) then B(i, j) = [-1...1]
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> B(k + 1, k + 1) = B(k, k)
|
||||
*> B(k + 1, k) = [-1...1]
|
||||
*> sign(B(k, k + 1) = -(sign(B(k + 1, k))
|
||||
*> k = 1, N - 1, QBLCKB
|
||||
*>
|
||||
*> D : if (i <= j) then D(i, j) = [-1...1].
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*>
|
||||
*> E : if (i <= j) then D(i, j) = [-1...1]
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L, R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 4 Full
|
||||
*> A(i, j) = [-10...10]
|
||||
*> D(i, j) = [-1...1] i,j = 1...M
|
||||
*> B(i, j) = [-10...10]
|
||||
*> E(i, j) = [-1...1] i,j = 1...N
|
||||
*> R(i, j) = [-10...10]
|
||||
*> L(i, j) = [-1...1] i = 1..M ,j = 1...N
|
||||
*>
|
||||
*> L, R specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 5 special case common and/or close eigs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
$ QBLCKB )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
$ PRTYPE, QBLCKA, QBLCKB
|
||||
REAL ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
$ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO, TWENTY, HALF, TWO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, TWENTY = 2.0E+1,
|
||||
$ HALF = 0.5E+0, TWO = 2.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, K
|
||||
REAL IMEPS, REEPS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD, REAL, SIN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( PRTYPE.EQ.1 ) THEN
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, J ) = ONE
|
||||
D( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
A( I, J ) = -ONE
|
||||
D( I, J ) = ZERO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, N
|
||||
DO 30 J = 1, N
|
||||
IF( I.EQ.J ) THEN
|
||||
B( I, J ) = ONE - ALPHA
|
||||
E( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
B( I, J ) = ONE
|
||||
E( I, J ) = ZERO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
DO 50 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( REAL( I / J ) ) )*TWENTY
|
||||
L( I, J ) = R( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
|
||||
DO 80 I = 1, M
|
||||
DO 70 J = 1, M
|
||||
IF( I.LE.J ) THEN
|
||||
A( I, J ) = ( HALF-SIN( REAL( I ) ) )*TWO
|
||||
D( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
DO 100 I = 1, N
|
||||
DO 90 J = 1, N
|
||||
IF( I.LE.J ) THEN
|
||||
B( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWO
|
||||
E( I, J ) = ( HALF-SIN( REAL( J ) ) )*TWO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
DO 120 I = 1, M
|
||||
DO 110 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWENTY
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
*
|
||||
IF( PRTYPE.EQ.3 ) THEN
|
||||
IF( QBLCKA.LE.1 )
|
||||
$ QBLCKA = 2
|
||||
DO 130 K = 1, M - 1, QBLCKA
|
||||
A( K+1, K+1 ) = A( K, K )
|
||||
A( K+1, K ) = -SIN( A( K, K+1 ) )
|
||||
130 CONTINUE
|
||||
*
|
||||
IF( QBLCKB.LE.1 )
|
||||
$ QBLCKB = 2
|
||||
DO 140 K = 1, N - 1, QBLCKB
|
||||
B( K+1, K+1 ) = B( K, K )
|
||||
B( K+1, K ) = -SIN( B( K, K+1 ) )
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.4 ) THEN
|
||||
DO 160 I = 1, M
|
||||
DO 150 J = 1, M
|
||||
A( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWENTY
|
||||
D( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWO
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
*
|
||||
DO 180 I = 1, N
|
||||
DO 170 J = 1, N
|
||||
B( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWENTY
|
||||
E( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
DO 200 I = 1, M
|
||||
DO 190 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( REAL( J / I ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.GE.5 ) THEN
|
||||
REEPS = HALF*TWO*TWENTY / ALPHA
|
||||
IMEPS = ( HALF-TWO ) / ALPHA
|
||||
DO 220 I = 1, M
|
||||
DO 210 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*ALPHA / TWENTY
|
||||
L( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*ALPHA / TWENTY
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
*
|
||||
DO 230 I = 1, M
|
||||
D( I, I ) = ONE
|
||||
230 CONTINUE
|
||||
*
|
||||
DO 240 I = 1, M
|
||||
IF( I.LE.4 ) THEN
|
||||
A( I, I ) = ONE
|
||||
IF( I.GT.2 )
|
||||
$ A( I, I ) = ONE + REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
A( I, I ) = REEPS
|
||||
ELSE
|
||||
A( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = ONE
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -ONE
|
||||
END IF
|
||||
ELSE
|
||||
A( I, I ) = ONE
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
240 CONTINUE
|
||||
*
|
||||
DO 250 I = 1, N
|
||||
E( I, I ) = ONE
|
||||
IF( I.LE.4 ) THEN
|
||||
B( I, I ) = -ONE
|
||||
IF( I.GT.2 )
|
||||
$ B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
B( I, I ) = REEPS
|
||||
ELSE
|
||||
B( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = ONE + IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -ONE - IMEPS
|
||||
END IF
|
||||
ELSE
|
||||
B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Compute rhs (C, F)
|
||||
*
|
||||
CALL SGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
|
||||
CALL SGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
|
||||
CALL SGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
|
||||
CALL SGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
|
||||
*
|
||||
* End of SLATM5
|
||||
*
|
||||
END
|
||||
333
lapack-netlib/TESTING/MATGEN/slatm6.f
Normal file
333
lapack-netlib/TESTING/MATGEN/slatm6.f
Normal file
@@ -0,0 +1,333 @@
|
||||
*> \brief \b SLATM6
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
* BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDX, LDY, N, TYPE
|
||||
* REAL ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
|
||||
* $ X( LDX, * ), Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM6 generates test matrices for the generalized eigenvalue
|
||||
*> problem, their corresponding right and left eigenvector matrices,
|
||||
*> and also reciprocal condition numbers for all eigenvalues and
|
||||
*> the reciprocal condition numbers of eigenvectors corresponding to
|
||||
*> the 1th and 5th eigenvalues.
|
||||
*>
|
||||
*> Test Matrices
|
||||
*> =============
|
||||
*>
|
||||
*> Two kinds of test matrix pairs
|
||||
*>
|
||||
*> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
|
||||
*>
|
||||
*> are used in the tests:
|
||||
*>
|
||||
*> Type 1:
|
||||
*> Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 2+a 0 0 0 0 1 0 0 0
|
||||
*> 0 0 3+a 0 0 0 0 1 0 0
|
||||
*> 0 0 0 4+a 0 0 0 0 1 0
|
||||
*> 0 0 0 0 5+a , 0 0 0 0 1 , and
|
||||
*>
|
||||
*> Type 2:
|
||||
*> Da = 1 -1 0 0 0 Db = 1 0 0 0 0
|
||||
*> 1 1 0 0 0 0 1 0 0 0
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1+a 1+b 0 0 0 1 0
|
||||
*> 0 0 0 -1-b 1+a , 0 0 0 0 1 .
|
||||
*>
|
||||
*> In both cases the same inverse(YH) and inverse(X) are used to compute
|
||||
*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
|
||||
*>
|
||||
*> YH: = 1 0 -y y -y X = 1 0 -x -x x
|
||||
*> 0 1 -y y -y 0 1 x -x -x
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1 0 0 0 0 1 0
|
||||
*> 0 0 0 0 1, 0 0 0 0 1 ,
|
||||
*>
|
||||
*> where a, b, x and y will have all values independently of each other.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TYPE
|
||||
*> \verbatim
|
||||
*> TYPE is INTEGER
|
||||
*> Specifies the problem type (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of the matrices A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA, N).
|
||||
*> On exit A N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A and of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is REAL array, dimension (LDA, N).
|
||||
*> On exit B N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is REAL array, dimension (LDX, N).
|
||||
*> On exit X is the N-by-N matrix of right eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array, dimension (LDY, N).
|
||||
*> On exit Y is the N-by-N matrix of left eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDY
|
||||
*> \verbatim
|
||||
*> LDY is INTEGER
|
||||
*> The leading dimension of Y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*>
|
||||
*> Weighting constants for matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WX
|
||||
*> \verbatim
|
||||
*> WX is REAL
|
||||
*> Constant for right eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WY
|
||||
*> \verbatim
|
||||
*> WY is REAL
|
||||
*> Constant for left eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] S
|
||||
*> \verbatim
|
||||
*> S is REAL array, dimension (N)
|
||||
*> S(i) is the reciprocal condition number for eigenvalue i.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] DIF
|
||||
*> \verbatim
|
||||
*> DIF is REAL array, dimension (N)
|
||||
*> DIF(i) is the reciprocal condition number for eigenvector i.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
$ BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDX, LDY, N, TYPE
|
||||
REAL ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
|
||||
$ X( LDX, * ), Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO, ONE, TWO, THREE
|
||||
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
|
||||
$ THREE = 3.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, INFO, J
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL WORK( 100 ), Z( 12, 12 )
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC REAL, SQRT
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGESVD, SLACPY, SLAKF2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate test problem ...
|
||||
* (Da, Db) ...
|
||||
*
|
||||
DO 20 I = 1, N
|
||||
DO 10 J = 1, N
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, I ) = REAL( I ) + ALPHA
|
||||
B( I, I ) = ONE
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
B( I, J ) = ZERO
|
||||
END IF
|
||||
*
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* Form X and Y
|
||||
*
|
||||
CALL SLACPY( 'F', N, N, B, LDA, Y, LDY )
|
||||
Y( 3, 1 ) = -WY
|
||||
Y( 4, 1 ) = WY
|
||||
Y( 5, 1 ) = -WY
|
||||
Y( 3, 2 ) = -WY
|
||||
Y( 4, 2 ) = WY
|
||||
Y( 5, 2 ) = -WY
|
||||
*
|
||||
CALL SLACPY( 'F', N, N, B, LDA, X, LDX )
|
||||
X( 1, 3 ) = -WX
|
||||
X( 1, 4 ) = -WX
|
||||
X( 1, 5 ) = WX
|
||||
X( 2, 3 ) = WX
|
||||
X( 2, 4 ) = -WX
|
||||
X( 2, 5 ) = -WX
|
||||
*
|
||||
* Form (A, B)
|
||||
*
|
||||
B( 1, 3 ) = WX + WY
|
||||
B( 2, 3 ) = -WX + WY
|
||||
B( 1, 4 ) = WX - WY
|
||||
B( 2, 4 ) = WX - WY
|
||||
B( 1, 5 ) = -WX + WY
|
||||
B( 2, 5 ) = WX + WY
|
||||
IF( TYPE.EQ.1 ) THEN
|
||||
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
|
||||
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
|
||||
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
|
||||
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
|
||||
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
|
||||
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
|
||||
ELSE IF( TYPE.EQ.2 ) THEN
|
||||
A( 1, 3 ) = TWO*WX + WY
|
||||
A( 2, 3 ) = WY
|
||||
A( 1, 4 ) = -WY*( TWO+ALPHA+BETA )
|
||||
A( 2, 4 ) = TWO*WX - WY*( TWO+ALPHA+BETA )
|
||||
A( 1, 5 ) = -TWO*WX + WY*( ALPHA-BETA )
|
||||
A( 2, 5 ) = WY*( ALPHA-BETA )
|
||||
A( 1, 1 ) = ONE
|
||||
A( 1, 2 ) = -ONE
|
||||
A( 2, 1 ) = ONE
|
||||
A( 2, 2 ) = A( 1, 1 )
|
||||
A( 3, 3 ) = ONE
|
||||
A( 4, 4 ) = ONE + ALPHA
|
||||
A( 4, 5 ) = ONE + BETA
|
||||
A( 5, 4 ) = -A( 4, 5 )
|
||||
A( 5, 5 ) = A( 4, 4 )
|
||||
END IF
|
||||
*
|
||||
* Compute condition numbers
|
||||
*
|
||||
IF( TYPE.EQ.1 ) THEN
|
||||
*
|
||||
S( 1 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
|
||||
$ ( ONE+A( 1, 1 )*A( 1, 1 ) ) )
|
||||
S( 2 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
|
||||
$ ( ONE+A( 2, 2 )*A( 2, 2 ) ) )
|
||||
S( 3 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 3, 3 )*A( 3, 3 ) ) )
|
||||
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 4, 4 )*A( 4, 4 ) ) )
|
||||
S( 5 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+A( 5, 5 )*A( 5, 5 ) ) )
|
||||
*
|
||||
CALL SLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 12 )
|
||||
CALL SGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
|
||||
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
|
||||
DIF( 1 ) = WORK( 8 )
|
||||
*
|
||||
CALL SLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 12 )
|
||||
CALL SGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
|
||||
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
|
||||
DIF( 5 ) = WORK( 8 )
|
||||
*
|
||||
ELSE IF( TYPE.EQ.2 ) THEN
|
||||
*
|
||||
S( 1 ) = ONE / SQRT( ONE / THREE+WY*WY )
|
||||
S( 2 ) = S( 1 )
|
||||
S( 3 ) = ONE / SQRT( ONE / TWO+WX*WX )
|
||||
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
|
||||
$ ( ONE+( ONE+ALPHA )*( ONE+ALPHA )+( ONE+BETA )*( ONE+
|
||||
$ BETA ) ) )
|
||||
S( 5 ) = S( 4 )
|
||||
*
|
||||
CALL SLAKF2( 2, 3, A, LDA, A( 3, 3 ), B, B( 3, 3 ), Z, 12 )
|
||||
CALL SGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
|
||||
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
|
||||
DIF( 1 ) = WORK( 12 )
|
||||
*
|
||||
CALL SLAKF2( 3, 2, A, LDA, A( 4, 4 ), B, B( 4, 4 ), Z, 12 )
|
||||
CALL SGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
|
||||
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
|
||||
DIF( 5 ) = WORK( 12 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLATM6
|
||||
*
|
||||
END
|
||||
297
lapack-netlib/TESTING/MATGEN/slatm7.f
Normal file
297
lapack-netlib/TESTING/MATGEN/slatm7.f
Normal file
@@ -0,0 +1,297 @@
|
||||
*> \brief \b SLATM7
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
|
||||
* RANK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL COND
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL D( * )
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATM7 computes the entries of D as specified by MODE
|
||||
*> COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. SLATM7 is called by SLATMT to generate
|
||||
*> random test matrices.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> MODE - INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*>
|
||||
*> MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND
|
||||
*> MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK
|
||||
*>
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*>
|
||||
*> COND - REAL
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*>
|
||||
*> IRSIGN - INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by 1 or -1 with probability .5
|
||||
*>
|
||||
*> IDIST - CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => UNIFORM( 0, 1 )
|
||||
*> 2 => UNIFORM( -1, 1 )
|
||||
*> 3 => NORMAL( 0, 1 )
|
||||
*> Not modified.
|
||||
*>
|
||||
*> ISEED - INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to SLATM7
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*>
|
||||
*> D - REAL array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*>
|
||||
*> N - INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*>
|
||||
*> RANK - INTEGER
|
||||
*> The rank of matrix to be generated for modes 1,2,3 only.
|
||||
*> D( RANK+1:N ) = 0.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> INFO - INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
|
||||
$ RANK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.2) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* September 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL COND
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL D( * )
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E0 )
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
REAL HALF
|
||||
PARAMETER ( HALF = 0.5E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL ALPHA, TEMP
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLARAN
|
||||
EXTERNAL SLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SLARNV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, EXP, LOG, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'SLATM7', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 100, 130, 160, 190, 210, 230 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
100 CONTINUE
|
||||
DO 110 I = 2, RANK
|
||||
D( I ) = ONE / COND
|
||||
110 CONTINUE
|
||||
DO 120 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
120 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 240
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
130 CONTINUE
|
||||
DO 140 I = 1, RANK - 1
|
||||
D( I ) = ONE
|
||||
140 CONTINUE
|
||||
DO 150 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
150 CONTINUE
|
||||
D( RANK ) = ONE / COND
|
||||
GO TO 240
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
160 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 .AND. RANK.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / REAL( RANK-1 ) )
|
||||
DO 170 I = 2, RANK
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
170 CONTINUE
|
||||
DO 180 I = RANK + 1, N
|
||||
D( I ) = ZERO
|
||||
180 CONTINUE
|
||||
END IF
|
||||
GO TO 240
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
190 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / REAL( N-1 )
|
||||
DO 200 I = 2, N
|
||||
D( I ) = REAL( N-I )*ALPHA + TEMP
|
||||
200 CONTINUE
|
||||
END IF
|
||||
GO TO 240
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
210 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 220 I = 1, N
|
||||
D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
|
||||
220 CONTINUE
|
||||
GO TO 240
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
230 CONTINUE
|
||||
CALL SLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
240 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 250 I = 1, N
|
||||
TEMP = SLARAN( ISEED )
|
||||
IF( TEMP.GT.HALF )
|
||||
$ D( I ) = -D( I )
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 260 I = 1, N / 2
|
||||
TEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = TEMP
|
||||
260 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLATM7
|
||||
*
|
||||
END
|
||||
710
lapack-netlib/TESTING/MATGEN/slatme.f
Normal file
710
lapack-netlib/TESTING/MATGEN/slatme.f
Normal file
@@ -0,0 +1,710 @@
|
||||
*> \brief \b SLATME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
|
||||
* RSIGN,
|
||||
* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
* A,
|
||||
* LDA, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
* INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
* REAL ANORM, COND, CONDS, DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* CHARACTER EI( * )
|
||||
* INTEGER ISEED( 4 )
|
||||
* REAL A( LDA, * ), D( * ), DS( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLATME generates random non-symmetric square matrices with
|
||||
*> specified eigenvalues for testing LAPACK programs.
|
||||
*>
|
||||
*> SLATME operates by applying the following sequence of
|
||||
*> operations:
|
||||
*>
|
||||
*> 1. Set the diagonal to D, where D may be input or
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN
|
||||
*> as described below.
|
||||
*>
|
||||
*> 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
|
||||
*> or MODE=5), certain pairs of adjacent elements of D are
|
||||
*> interpreted as the real and complex parts of a complex
|
||||
*> conjugate pair; A thus becomes block diagonal, with 1x1
|
||||
*> and 2x2 blocks.
|
||||
*>
|
||||
*> 3. If UPPER='T', the upper triangle of A is set to random values
|
||||
*> out of distribution DIST.
|
||||
*>
|
||||
*> 4. If SIM='T', A is multiplied on the left by a random matrix
|
||||
*> X, whose singular values are specified by DS, MODES, and
|
||||
*> CONDS, and on the right by X inverse.
|
||||
*>
|
||||
*> 5. If KL < N-1, the lower bandwidth is reduced to KL using
|
||||
*> Householder transformations. If KU < N-1, the upper
|
||||
*> bandwidth is reduced to KU.
|
||||
*>
|
||||
*> 6. If ANORM is not negative, the matrix is scaled to have
|
||||
*> maximum-element-norm ANORM.
|
||||
*>
|
||||
*> (Note: since the matrix cannot be reduced beyond Hessenberg form,
|
||||
*> no packing options are available.)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns (or rows) of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIST
|
||||
*> \verbatim
|
||||
*> DIST is CHARACTER*1
|
||||
*> On entry, DIST specifies the type of distribution to be used
|
||||
*> to generate the random eigen-/singular values, and for the
|
||||
*> upper triangle (see UPPER).
|
||||
*> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
|
||||
*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
|
||||
*> 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. They should lie between 0 and 4095 inclusive,
|
||||
*> and ISEED(4) should be odd. The random number generator
|
||||
*> uses a linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to SLATME
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension ( N )
|
||||
*> This array is used to specify the eigenvalues of A. If
|
||||
*> MODE=0, then D is assumed to contain the eigenvalues (but
|
||||
*> see the description of EI), otherwise they will be
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN and
|
||||
*> placed in D.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry this describes how the eigenvalues are to
|
||||
*> be specified:
|
||||
*> MODE = 0 means use D (with EI) as input
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed. Each odd-even pair
|
||||
*> of elements will be either used as two real
|
||||
*> eigenvalues or as the real and imaginary part
|
||||
*> of a complex conjugate pair of eigenvalues;
|
||||
*> the choice of which is done is random, with
|
||||
*> 50-50 probability, for each pair.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is between 1 and 4, D has entries ranging
|
||||
*> from 1 to 1/COND, if between -1 and -4, D has entries
|
||||
*> ranging from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is REAL
|
||||
*> On entry, this is used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DMAX
|
||||
*> \verbatim
|
||||
*> DMAX is REAL
|
||||
*> If MODE is neither -6, 0 nor 6, the contents of D, as
|
||||
*> computed according to MODE and COND, will be scaled by
|
||||
*> DMAX / max(abs(D(i))). Note that DMAX need not be
|
||||
*> positive: if DMAX is negative (or zero), D will be
|
||||
*> scaled by a negative number (or zero).
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] EI
|
||||
*> \verbatim
|
||||
*> EI is CHARACTER*1 array, dimension ( N )
|
||||
*> If MODE is 0, and EI(1) is not ' ' (space character),
|
||||
*> this array specifies which elements of D (on input) are
|
||||
*> real eigenvalues and which are the real and imaginary parts
|
||||
*> of a complex conjugate pair of eigenvalues. The elements
|
||||
*> of EI may then only have the values 'R' and 'I'. If
|
||||
*> EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
|
||||
*> CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
|
||||
*> conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th
|
||||
*> eigenvalue is D(j) (i.e., real). EI(1) may not be 'I',
|
||||
*> nor may two adjacent elements of EI both have the value 'I'.
|
||||
*> If MODE is not 0, then EI is ignored. If MODE is 0 and
|
||||
*> EI(1)=' ', then the eigenvalues will all be real.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] RSIGN
|
||||
*> \verbatim
|
||||
*> RSIGN is CHARACTER*1
|
||||
*> If MODE is not 0, 6, or -6, and RSIGN='T', then the
|
||||
*> elements of D, as computed according to MODE and COND, will
|
||||
*> be multiplied by a random sign (+1 or -1). If RSIGN='F',
|
||||
*> they will not be. RSIGN may only have the values 'T' or
|
||||
*> 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPPER
|
||||
*> \verbatim
|
||||
*> UPPER is CHARACTER*1
|
||||
*> If UPPER='T', then the elements of A above the diagonal
|
||||
*> (and above the 2x2 diagonal blocks, if A has complex
|
||||
*> eigenvalues) will be set to random numbers out of DIST.
|
||||
*> If UPPER='F', they will not. UPPER may only have the
|
||||
*> values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SIM
|
||||
*> \verbatim
|
||||
*> SIM is CHARACTER*1
|
||||
*> If SIM='T', then A will be operated on by a "similarity
|
||||
*> transform", i.e., multiplied on the left by a matrix X and
|
||||
*> on the right by X inverse. X = U S V, where U and V are
|
||||
*> random unitary matrices and S is a (diagonal) matrix of
|
||||
*> singular values specified by DS, MODES, and CONDS. If
|
||||
*> SIM='F', then A will not be transformed.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DS
|
||||
*> \verbatim
|
||||
*> DS is REAL array, dimension ( N )
|
||||
*> This array is used to specify the singular values of X,
|
||||
*> in the same way that D specifies the eigenvalues of A.
|
||||
*> If MODE=0, the DS contains the singular values, which
|
||||
*> may not be zero.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODES
|
||||
*> \verbatim
|
||||
*> MODES is INTEGER
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CONDS
|
||||
*> \verbatim
|
||||
*> CONDS is REAL
|
||||
*> Same as MODE and COND, but for specifying the diagonal
|
||||
*> of S. MODES=-6 and +6 are not allowed (since they would
|
||||
*> result in randomly ill-conditioned eigenvalues.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> This specifies the lower bandwidth of the matrix. KL=1
|
||||
*> specifies upper Hessenberg form. If KL is at least N-1,
|
||||
*> then A will have full lower bandwidth. KL must be at
|
||||
*> least 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> This specifies the upper bandwidth of the matrix. KU=1
|
||||
*> specifies lower Hessenberg form. If KU is at least N-1,
|
||||
*> then A will have full upper bandwidth; if KU and KL
|
||||
*> are both at least N-1, then A will be dense. Only one of
|
||||
*> KU and KL may be less than N-1. KU must be at least 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ANORM
|
||||
*> \verbatim
|
||||
*> ANORM is REAL
|
||||
*> If ANORM is not negative, then A will be scaled by a non-
|
||||
*> negative real number to make the maximum-element-norm of A
|
||||
*> to be ANORM.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension ( LDA, N )
|
||||
*> On exit A is the desired test matrix.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> LDA specifies the first dimension of A as declared in the
|
||||
*> calling program. LDA must be at least N.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension ( 3*N )
|
||||
*> Workspace.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> Error code. On exit, INFO will be set to one of the
|
||||
*> following values:
|
||||
*> 0 => normal return
|
||||
*> -1 => N negative
|
||||
*> -2 => DIST illegal string
|
||||
*> -5 => MODE not in range -6 to 6
|
||||
*> -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
|
||||
*> -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
|
||||
*> two adjacent elements of EI are 'I'.
|
||||
*> -9 => RSIGN is not 'T' or 'F'
|
||||
*> -10 => UPPER is not 'T' or 'F'
|
||||
*> -11 => SIM is not 'T' or 'F'
|
||||
*> -12 => MODES=0 and DS has a zero singular value.
|
||||
*> -13 => MODES is not in the range -5 to 5.
|
||||
*> -14 => MODES is nonzero and CONDS is less than 1.
|
||||
*> -15 => KL is less than 1.
|
||||
*> -16 => KU is less than 1, or KL and KU are both less than
|
||||
*> N-1.
|
||||
*> -19 => LDA is less than N.
|
||||
*> 1 => Error return from SLATM1 (computing D)
|
||||
*> 2 => Cannot scale to DMAX (max. eigenvalue is 0)
|
||||
*> 3 => Error return from SLATM1 (computing DS)
|
||||
*> 4 => Error return from SLARGE
|
||||
*> 5 => Zero singular value from SLATM1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup real_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
|
||||
$ RSIGN,
|
||||
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
$ A,
|
||||
$ LDA, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
REAL ANORM, COND, CONDS, DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
CHARACTER EI( * )
|
||||
INTEGER ISEED( 4 )
|
||||
REAL A( LDA, * ), D( * ), DS( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E0 )
|
||||
REAL HALF
|
||||
PARAMETER ( HALF = 1.0E0 / 2.0E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BADEI, BADS, USEEI
|
||||
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
|
||||
$ ISIM, IUPPER, J, JC, JCR, JR
|
||||
REAL ALPHA, TAU, TEMP, XNORMS
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
REAL TEMPA( 1 )
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
REAL SLANGE, SLARAN
|
||||
EXTERNAL LSAME, SLANGE, SLARAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SCOPY, SGEMV, SGER, SLARFG, SLARGE, SLARNV,
|
||||
$ SLATM1, SLASET, SSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 1) Decode and Test the input parameters.
|
||||
* Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Decode DIST
|
||||
*
|
||||
IF( LSAME( DIST, 'U' ) ) THEN
|
||||
IDIST = 1
|
||||
ELSE IF( LSAME( DIST, 'S' ) ) THEN
|
||||
IDIST = 2
|
||||
ELSE IF( LSAME( DIST, 'N' ) ) THEN
|
||||
IDIST = 3
|
||||
ELSE
|
||||
IDIST = -1
|
||||
END IF
|
||||
*
|
||||
* Check EI
|
||||
*
|
||||
USEEI = .TRUE.
|
||||
BADEI = .FALSE.
|
||||
IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN
|
||||
USEEI = .FALSE.
|
||||
ELSE
|
||||
IF( LSAME( EI( 1 ), 'R' ) ) THEN
|
||||
DO 10 J = 2, N
|
||||
IF( LSAME( EI( J ), 'I' ) ) THEN
|
||||
IF( LSAME( EI( J-1 ), 'I' ) )
|
||||
$ BADEI = .TRUE.
|
||||
ELSE
|
||||
IF( .NOT.LSAME( EI( J ), 'R' ) )
|
||||
$ BADEI = .TRUE.
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
BADEI = .TRUE.
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Decode RSIGN
|
||||
*
|
||||
IF( LSAME( RSIGN, 'T' ) ) THEN
|
||||
IRSIGN = 1
|
||||
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
|
||||
IRSIGN = 0
|
||||
ELSE
|
||||
IRSIGN = -1
|
||||
END IF
|
||||
*
|
||||
* Decode UPPER
|
||||
*
|
||||
IF( LSAME( UPPER, 'T' ) ) THEN
|
||||
IUPPER = 1
|
||||
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
|
||||
IUPPER = 0
|
||||
ELSE
|
||||
IUPPER = -1
|
||||
END IF
|
||||
*
|
||||
* Decode SIM
|
||||
*
|
||||
IF( LSAME( SIM, 'T' ) ) THEN
|
||||
ISIM = 1
|
||||
ELSE IF( LSAME( SIM, 'F' ) ) THEN
|
||||
ISIM = 0
|
||||
ELSE
|
||||
ISIM = -1
|
||||
END IF
|
||||
*
|
||||
* Check DS, if MODES=0 and ISIM=1
|
||||
*
|
||||
BADS = .FALSE.
|
||||
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
|
||||
DO 20 J = 1, N
|
||||
IF( DS( J ).EQ.ZERO )
|
||||
$ BADS = .TRUE.
|
||||
20 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( IDIST.EQ.-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ABS( MODE ).GT.6 ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
|
||||
$ THEN
|
||||
INFO = -6
|
||||
ELSE IF( BADEI ) THEN
|
||||
INFO = -8
|
||||
ELSE IF( IRSIGN.EQ.-1 ) THEN
|
||||
INFO = -9
|
||||
ELSE IF( IUPPER.EQ.-1 ) THEN
|
||||
INFO = -10
|
||||
ELSE IF( ISIM.EQ.-1 ) THEN
|
||||
INFO = -11
|
||||
ELSE IF( BADS ) THEN
|
||||
INFO = -12
|
||||
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
|
||||
INFO = -13
|
||||
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
|
||||
INFO = -14
|
||||
ELSE IF( KL.LT.1 ) THEN
|
||||
INFO = -15
|
||||
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
|
||||
INFO = -16
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -19
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'SLATME', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Initialize random number generator
|
||||
*
|
||||
DO 30 I = 1, 4
|
||||
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
|
||||
30 CONTINUE
|
||||
*
|
||||
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
|
||||
$ ISEED( 4 ) = ISEED( 4 ) + 1
|
||||
*
|
||||
* 2) Set up diagonal of A
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 1
|
||||
RETURN
|
||||
END IF
|
||||
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
|
||||
*
|
||||
* Scale by DMAX
|
||||
*
|
||||
TEMP = ABS( D( 1 ) )
|
||||
DO 40 I = 2, N
|
||||
TEMP = MAX( TEMP, ABS( D( I ) ) )
|
||||
40 CONTINUE
|
||||
*
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = DMAX / TEMP
|
||||
ELSE IF( DMAX.NE.ZERO ) THEN
|
||||
INFO = 2
|
||||
RETURN
|
||||
ELSE
|
||||
ALPHA = ZERO
|
||||
END IF
|
||||
*
|
||||
CALL SSCAL( N, ALPHA, D, 1 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
|
||||
CALL SCOPY( N, D, 1, A, LDA+1 )
|
||||
*
|
||||
* Set up complex conjugate pairs
|
||||
*
|
||||
IF( MODE.EQ.0 ) THEN
|
||||
IF( USEEI ) THEN
|
||||
DO 50 J = 2, N
|
||||
IF( LSAME( EI( J ), 'I' ) ) THEN
|
||||
A( J-1, J ) = A( J, J )
|
||||
A( J, J-1 ) = -A( J, J )
|
||||
A( J, J ) = A( J-1, J-1 )
|
||||
END IF
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( ABS( MODE ).EQ.5 ) THEN
|
||||
*
|
||||
DO 60 J = 2, N, 2
|
||||
IF( SLARAN( ISEED ).GT.HALF ) THEN
|
||||
A( J-1, J ) = A( J, J )
|
||||
A( J, J-1 ) = -A( J, J )
|
||||
A( J, J ) = A( J-1, J-1 )
|
||||
END IF
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 3) If UPPER='T', set upper triangle of A to random numbers.
|
||||
* (but don't modify the corners of 2x2 blocks.)
|
||||
*
|
||||
IF( IUPPER.NE.0 ) THEN
|
||||
DO 70 JC = 2, N
|
||||
IF( A( JC-1, JC ).NE.ZERO ) THEN
|
||||
JR = JC - 2
|
||||
ELSE
|
||||
JR = JC - 1
|
||||
END IF
|
||||
CALL SLARNV( IDIST, ISEED, JR, A( 1, JC ) )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 4) If SIM='T', apply similarity transformation.
|
||||
*
|
||||
* -1
|
||||
* Transform is X A X , where X = U S V, thus
|
||||
*
|
||||
* it is U S V A V' (1/S) U'
|
||||
*
|
||||
IF( ISIM.NE.0 ) THEN
|
||||
*
|
||||
* Compute S (singular values of the eigenvector matrix)
|
||||
* according to CONDS and MODES
|
||||
*
|
||||
CALL SLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 3
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by V and V'
|
||||
*
|
||||
CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by S and (1/S)
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
CALL SSCAL( N, DS( J ), A( J, 1 ), LDA )
|
||||
IF( DS( J ).NE.ZERO ) THEN
|
||||
CALL SSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
|
||||
ELSE
|
||||
INFO = 5
|
||||
RETURN
|
||||
END IF
|
||||
80 CONTINUE
|
||||
*
|
||||
* Multiply by U and U'
|
||||
*
|
||||
CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* 5) Reduce the bandwidth.
|
||||
*
|
||||
IF( KL.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce bandwidth -- kill column
|
||||
*
|
||||
DO 90 JCR = KL + 1, N - 1
|
||||
IC = JCR - KL
|
||||
IROWS = N + 1 - JCR
|
||||
ICOLS = N + KL - JCR
|
||||
*
|
||||
CALL SCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL SLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
WORK( 1 ) = ONE
|
||||
*
|
||||
CALL SGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL SGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
|
||||
$ A( JCR, IC+1 ), LDA )
|
||||
*
|
||||
CALL SGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1,
|
||||
$ ZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL SGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1,
|
||||
$ A( 1, JCR ), LDA )
|
||||
*
|
||||
A( JCR, IC ) = XNORMS
|
||||
CALL SLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ),
|
||||
$ LDA )
|
||||
90 CONTINUE
|
||||
ELSE IF( KU.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce upper bandwidth -- kill a row at a time.
|
||||
*
|
||||
DO 100 JCR = KU + 1, N - 1
|
||||
IR = JCR - KU
|
||||
IROWS = N + KU - JCR
|
||||
ICOLS = N + 1 - JCR
|
||||
*
|
||||
CALL SCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL SLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
WORK( 1 ) = ONE
|
||||
*
|
||||
CALL SGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL SGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
|
||||
$ A( IR+1, JCR ), LDA )
|
||||
*
|
||||
CALL SGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1,
|
||||
$ ZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL SGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1,
|
||||
$ A( JCR, 1 ), LDA )
|
||||
*
|
||||
A( IR, JCR ) = XNORMS
|
||||
CALL SLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ),
|
||||
$ LDA )
|
||||
100 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Scale the matrix to have norm ANORM
|
||||
*
|
||||
IF( ANORM.GE.ZERO ) THEN
|
||||
TEMP = SLANGE( 'M', N, N, A, LDA, TEMPA )
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = ANORM / TEMP
|
||||
DO 110 J = 1, N
|
||||
CALL SSCAL( N, ALPHA, A( 1, J ), 1 )
|
||||
110 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLATME
|
||||
*
|
||||
END
|
||||
1227
lapack-netlib/TESTING/MATGEN/slatmr.f
Normal file
1227
lapack-netlib/TESTING/MATGEN/slatmr.f
Normal file
File diff suppressed because it is too large
Load Diff
1128
lapack-netlib/TESTING/MATGEN/slatms.f
Normal file
1128
lapack-netlib/TESTING/MATGEN/slatms.f
Normal file
File diff suppressed because it is too large
Load Diff
1139
lapack-netlib/TESTING/MATGEN/slatmt.f
Normal file
1139
lapack-netlib/TESTING/MATGEN/slatmt.f
Normal file
File diff suppressed because it is too large
Load Diff
363
lapack-netlib/TESTING/MATGEN/zlagge.f
Normal file
363
lapack-netlib/TESTING/MATGEN/zlagge.f
Normal file
@@ -0,0 +1,363 @@
|
||||
*> \brief \b ZLAGGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION D( * )
|
||||
* COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAGGE generates a complex general m by n matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with random unitary matrices:
|
||||
*> A = U*D*V. The lower and upper bandwidths may then be reduced to
|
||||
*> kl and ku by additional unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= KL <= M-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The number of nonzero superdiagonals within the band of A.
|
||||
*> 0 <= KU <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (min(M,N))
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The generated m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= M.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (M+N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, KL, KU, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION D( * )
|
||||
COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
DOUBLE PRECISION WN
|
||||
COMPLEX*16 TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZGEMV, ZGERC, ZLACGV, ZLARNV, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, MAX, MIN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DZNRM2
|
||||
EXTERNAL DZNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'ZLAGGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, MIN( M, N )
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* pre- and post-multiply A by random unitary matrices
|
||||
*
|
||||
DO 40 I = MIN( M, N ), 1, -1
|
||||
IF( I.LT.M ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL ZLARNV( 3, ISEED, M-I+1, WORK )
|
||||
WN = DZNRM2( M-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL ZSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I+1, ONE,
|
||||
$ A( I, I ), LDA, WORK, 1, ZERO, WORK( M+1 ), 1 )
|
||||
CALL ZGERC( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL ZLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DZNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:m,i:n) by random reflection from the right
|
||||
*
|
||||
CALL ZGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL ZGERC( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
|
||||
$ A( I, I ), LDA )
|
||||
END IF
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to KL and number of superdiagonals
|
||||
* to KU
|
||||
*
|
||||
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
|
||||
IF( KL.LE.KU ) THEN
|
||||
*
|
||||
* annihilate subdiagonal elements first (necessary if KL = 0)
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = DZNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL ZSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL ZGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK,
|
||||
$ 1, A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = DZNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL ZSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL ZLACGV( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
CALL ZGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL ZGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* annihilate superdiagonal elements first (necessary if
|
||||
* KU = 0)
|
||||
*
|
||||
IF( I.LE.MIN( N-1-KU, M ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(i,ku+i+1:n)
|
||||
*
|
||||
WN = DZNRM2( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( I, KU+I ) + WA
|
||||
CALL ZSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
|
||||
A( I, KU+I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(i+1:m,ku+i:n) from the right
|
||||
*
|
||||
CALL ZLACGV( N-KU-I+1, A( I, KU+I ), LDA )
|
||||
CALL ZGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
|
||||
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL ZGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
|
||||
$ LDA, A( I+1, KU+I ), LDA )
|
||||
A( I, KU+I ) = -WA
|
||||
END IF
|
||||
*
|
||||
IF( I.LE.MIN( M-1-KL, N ) ) THEN
|
||||
*
|
||||
* generate reflection to annihilate A(kl+i+1:m,i)
|
||||
*
|
||||
WN = DZNRM2( M-KL-I+1, A( KL+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( KL+I, I ) + WA
|
||||
CALL ZSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
|
||||
A( KL+I, I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(kl+i:m,i+1:n) from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE,
|
||||
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
|
||||
$ WORK, 1 )
|
||||
CALL ZGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK,
|
||||
$ 1, A( KL+I, I+1 ), LDA )
|
||||
A( KL+I, I ) = -WA
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
DO 50 J = KL + I + 1, M
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
*
|
||||
DO 60 J = KU + I + 1, N
|
||||
A( I, J ) = ZERO
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAGGE
|
||||
*
|
||||
END
|
||||
267
lapack-netlib/TESTING/MATGEN/zlaghe.f
Normal file
267
lapack-netlib/TESTING/MATGEN/zlaghe.f
Normal file
@@ -0,0 +1,267 @@
|
||||
*> \brief \b ZLAGHE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION D( * )
|
||||
* COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAGHE generates a complex hermitian matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random unitary matrix:
|
||||
*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
|
||||
*> unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The generated n by n hermitian matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION D( * )
|
||||
COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ HALF = ( 0.5D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
DOUBLE PRECISION WN
|
||||
COMPLEX*16 ALPHA, TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZHEMV, ZHER2,
|
||||
$ ZLARNV, ZSCAL
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DZNRM2
|
||||
COMPLEX*16 ZDOTC
|
||||
EXTERNAL DZNRM2, ZDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, DCONJG, MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'ZLAGHE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of hermitian matrix
|
||||
*
|
||||
DO 40 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL ZLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DZNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL ZHEMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 )
|
||||
CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
CALL ZHER2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
$ A( I, I ), LDA )
|
||||
40 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 60 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = DZNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL ZSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE,
|
||||
$ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL ZGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * u
|
||||
*
|
||||
CALL ZHEMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( y, u ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
|
||||
CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply hermitian rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
CALL ZHER2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, K+I ), LDA )
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 50 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Store full hermitian matrix
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
DO 70 I = J + 1, N
|
||||
A( J, I ) = DCONJG( A( I, J ) )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAGHE
|
||||
*
|
||||
END
|
||||
286
lapack-netlib/TESTING/MATGEN/zlagsy.f
Normal file
286
lapack-netlib/TESTING/MATGEN/zlagsy.f
Normal file
@@ -0,0 +1,286 @@
|
||||
*> \brief \b ZLAGSY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION D( * )
|
||||
* COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAGSY generates a complex symmetric matrix A, by pre- and post-
|
||||
*> multiplying a real diagonal matrix D with a random unitary matrix:
|
||||
*> A = U*D*U**T. The semi-bandwidth may then be reduced to k by
|
||||
*> additional unitary transformations.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of nonzero subdiagonals within the band of A.
|
||||
*> 0 <= K <= N-1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> The diagonal elements of the diagonal matrix D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The generated n by n symmetric matrix A (the full matrix is
|
||||
*> stored).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION D( * )
|
||||
COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ HALF = ( 0.5D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, II, J, JJ
|
||||
DOUBLE PRECISION WN
|
||||
COMPLEX*16 ALPHA, TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZLACGV, ZLARNV,
|
||||
$ ZSCAL, ZSYMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DZNRM2
|
||||
COMPLEX*16 ZDOTC
|
||||
EXTERNAL DZNRM2, ZDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'ZLAGSY', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* initialize lower triangle of A to diagonal matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = J + 1, N
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N
|
||||
A( I, I ) = D( I )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Generate lower triangle of symmetric matrix
|
||||
*
|
||||
DO 60 I = N - 1, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL ZLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DZNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply random reflection to A(i:n,i:n) from the left
|
||||
* and the right
|
||||
*
|
||||
* compute y := tau * A * conjg(u)
|
||||
*
|
||||
CALL ZLACGV( N-I+1, WORK, 1 )
|
||||
CALL ZSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
|
||||
$ WORK( N+1 ), 1 )
|
||||
CALL ZLACGV( N-I+1, WORK, 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( u, y ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 )
|
||||
CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
|
||||
*
|
||||
* apply the transformation as a rank-2 update to A(i:n,i:n)
|
||||
*
|
||||
* CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
|
||||
* $ A( I, I ), LDA )
|
||||
*
|
||||
DO 50 JJ = I, N
|
||||
DO 40 II = JJ, N
|
||||
A( II, JJ ) = A( II, JJ ) -
|
||||
$ WORK( II-I+1 )*WORK( N+JJ-I+1 ) -
|
||||
$ WORK( N+II-I+1 )*WORK( JJ-I+1 )
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
* Reduce number of subdiagonals to K
|
||||
*
|
||||
DO 100 I = 1, N - 1 - K
|
||||
*
|
||||
* generate reflection to annihilate A(k+i+1:n,i)
|
||||
*
|
||||
WN = DZNRM2( N-K-I+1, A( K+I, I ), 1 )
|
||||
WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = A( K+I, I ) + WA
|
||||
CALL ZSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
|
||||
A( K+I, I ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE,
|
||||
$ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL ZGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
|
||||
$ A( K+I, I+1 ), LDA )
|
||||
*
|
||||
* apply reflection to A(k+i:n,k+i:n) from the left and the right
|
||||
*
|
||||
* compute y := tau * A * conjg(u)
|
||||
*
|
||||
CALL ZLACGV( N-K-I+1, A( K+I, I ), 1 )
|
||||
CALL ZSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
|
||||
$ A( K+I, I ), 1, ZERO, WORK, 1 )
|
||||
CALL ZLACGV( N-K-I+1, A( K+I, I ), 1 )
|
||||
*
|
||||
* compute v := y - 1/2 * tau * ( u, y ) * u
|
||||
*
|
||||
ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 )
|
||||
CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
|
||||
*
|
||||
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
|
||||
*
|
||||
* CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
|
||||
* $ A( K+I, K+I ), LDA )
|
||||
*
|
||||
DO 80 JJ = K + I, N
|
||||
DO 70 II = JJ, N
|
||||
A( II, JJ ) = A( II, JJ ) - A( II, I )*WORK( JJ-K-I+1 ) -
|
||||
$ WORK( II-K-I+1 )*A( JJ, I )
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
A( K+I, I ) = -WA
|
||||
DO 90 J = K + I + 1, N
|
||||
A( J, I ) = ZERO
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
* Store full symmetric matrix
|
||||
*
|
||||
DO 120 J = 1, N
|
||||
DO 110 I = J + 1, N
|
||||
A( J, I ) = A( I, J )
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAGSY
|
||||
*
|
||||
END
|
||||
274
lapack-netlib/TESTING/MATGEN/zlahilb.f
Normal file
274
lapack-netlib/TESTING/MATGEN/zlahilb.f
Normal file
@@ -0,0 +1,274 @@
|
||||
*> \brief \b ZLAHILB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK,
|
||||
* INFO, PATH)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION WORK(N)
|
||||
* COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
|
||||
* CHARACTER*3 PATH
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAHILB generates an N by N scaled Hilbert matrix in A along with
|
||||
*> NRHS right-hand sides in B and solutions in X such that A*X=B.
|
||||
*>
|
||||
*> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
|
||||
*> entries are integers. The right-hand sides are the first NRHS
|
||||
*> columns of M * the identity matrix, and the solutions are the
|
||||
*> first NRHS columns of the inverse Hilbert matrix.
|
||||
*>
|
||||
*> The condition number of the Hilbert matrix grows exponentially with
|
||||
*> its size, roughly as O(e ** (3.5*N)). Additionally, the inverse
|
||||
*> Hilbert matrices beyond a relatively small dimension cannot be
|
||||
*> generated exactly without extra precision. Precision is exhausted
|
||||
*> when the largest entry in the inverse Hilbert matrix is greater than
|
||||
*> 2 to the power of the number of bits in the fraction of the data type
|
||||
*> used plus one, which is 24 for single precision.
|
||||
*>
|
||||
*> In single, the generated solution is exact for N <= 6 and has
|
||||
*> small componentwise error for 7 <= N <= 11.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The dimension of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NRHS
|
||||
*> \verbatim
|
||||
*> NRHS is INTEGER
|
||||
*> The requested number of right-hand sides.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA, N)
|
||||
*> The generated scaled Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension (LDX, NRHS)
|
||||
*> The generated exact solutions. Currently, the first NRHS
|
||||
*> columns of the inverse Hilbert matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of the array X. LDX >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is REAL array, dimension (LDB, NRHS)
|
||||
*> The generated right-hand sides. Currently, the first NRHS
|
||||
*> columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> = 1: N is too large; the data is still generated but may not
|
||||
*> be not exact.
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] PATH
|
||||
*> \verbatim
|
||||
*> PATH is CHARACTER*3
|
||||
*> The LAPACK path name.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK,
|
||||
$ INFO, PATH)
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER N, NRHS, LDA, LDX, LDB, INFO
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION WORK(N)
|
||||
COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
|
||||
CHARACTER*3 PATH
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
* .. Local Scalars ..
|
||||
INTEGER TM, TI, R
|
||||
INTEGER M
|
||||
INTEGER I, J
|
||||
COMPLEX*16 TMP
|
||||
CHARACTER*2 C2
|
||||
|
||||
* .. Parameters ..
|
||||
* NMAX_EXACT the largest dimension where the generated data is
|
||||
* exact.
|
||||
* NMAX_APPROX the largest dimension where the generated data has
|
||||
* a small componentwise relative error.
|
||||
* ??? complex uses how many bits ???
|
||||
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8)
|
||||
|
||||
* d's are generated from random permuation of those eight elements.
|
||||
COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8)
|
||||
DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
|
||||
DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
|
||||
|
||||
DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
|
||||
$ (-.5,-.5),(.5,-.5),(.5,.5)/
|
||||
DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
|
||||
$ (-.5,.5),(.5,.5),(.5,-.5)/
|
||||
* ..
|
||||
* .. External Functions
|
||||
EXTERNAL ZLASET, LSAMEN
|
||||
INTRINSIC DBLE
|
||||
LOGICAL LSAMEN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
C2 = PATH( 2: 3 )
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN
|
||||
INFO = -1
|
||||
ELSE IF (NRHS .LT. 0) THEN
|
||||
INFO = -2
|
||||
ELSE IF (LDA .LT. N) THEN
|
||||
INFO = -4
|
||||
ELSE IF (LDX .LT. N) THEN
|
||||
INFO = -6
|
||||
ELSE IF (LDB .LT. N) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF (INFO .LT. 0) THEN
|
||||
CALL XERBLA('ZLAHILB', -INFO)
|
||||
RETURN
|
||||
END IF
|
||||
IF (N .GT. NMAX_EXACT) THEN
|
||||
INFO = 1
|
||||
END IF
|
||||
|
||||
* Compute M = the LCM of the integers [1, 2*N-1]. The largest
|
||||
* reasonable N is small enough that integers suffice (up to N = 11).
|
||||
M = 1
|
||||
DO I = 2, (2*N-1)
|
||||
TM = M
|
||||
TI = I
|
||||
R = MOD(TM, TI)
|
||||
DO WHILE (R .NE. 0)
|
||||
TM = TI
|
||||
TI = R
|
||||
R = MOD(TM, TI)
|
||||
END DO
|
||||
M = (M / TI) * I
|
||||
END DO
|
||||
|
||||
* Generate the scaled Hilbert matrix in A
|
||||
* If we are testing SY routines,
|
||||
* take D1_i = D2_i, else, D1_i = D2_i*
|
||||
IF ( LSAMEN( 2, C2, 'SY' ) ) THEN
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = D1(MOD(J,SIZE_D)+1) * (DBLE(M) / (I + J - 1))
|
||||
$ * D1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
ELSE
|
||||
DO J = 1, N
|
||||
DO I = 1, N
|
||||
A(I, J) = D1(MOD(J,SIZE_D)+1) * (DBLE(M) / (I + J - 1))
|
||||
$ * D2(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
|
||||
* Generate matrix B as simply the first NRHS columns of M * the
|
||||
* identity.
|
||||
TMP = DBLE(M)
|
||||
CALL ZLASET('Full', N, NRHS, (0.0D+0,0.0D+0), TMP, B, LDB)
|
||||
|
||||
* Generate the true solutions in X. Because B = the first NRHS
|
||||
* columns of M*I, the true solutions are just the first NRHS columns
|
||||
* of the inverse Hilbert matrix.
|
||||
WORK(1) = N
|
||||
DO J = 2, N
|
||||
WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) )
|
||||
$ * (N +J -1)
|
||||
END DO
|
||||
|
||||
* If we are testing SY routines,
|
||||
* take D1_i = D2_i, else, D1_i = D2_i*
|
||||
IF ( LSAMEN( 2, C2, 'SY' ) ) THEN
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) = INVD1(MOD(J,SIZE_D)+1) *
|
||||
$ ((WORK(I)*WORK(J)) / (I + J - 1))
|
||||
$ * INVD1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
ELSE
|
||||
DO J = 1, NRHS
|
||||
DO I = 1, N
|
||||
X(I, J) = INVD2(MOD(J,SIZE_D)+1) *
|
||||
$ ((WORK(I)*WORK(J)) / (I + J - 1))
|
||||
$ * INVD1(MOD(I,SIZE_D)+1)
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
END
|
||||
191
lapack-netlib/TESTING/MATGEN/zlakf2.f
Normal file
191
lapack-netlib/TESTING/MATGEN/zlakf2.f
Normal file
@@ -0,0 +1,191 @@
|
||||
*> \brief \b ZLAKF2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
* $ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Form the 2*M*N by 2*M*N matrix
|
||||
*>
|
||||
*> Z = [ kron(In, A) -kron(B', Im) ]
|
||||
*> [ kron(In, D) -kron(E', Im) ],
|
||||
*>
|
||||
*> where In is the identity matrix of size n and X' is the transpose
|
||||
*> of X. kron(X, Y) is the Kronecker product between the matrices X
|
||||
*> and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of matrix, must be >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16, dimension ( LDA, M )
|
||||
*> The matrix A in the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A, B, D, and E. ( LDA >= M+N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX*16, dimension ( LDA, N )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16, dimension ( LDA, M )
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] E
|
||||
*> \verbatim
|
||||
*> E is COMPLEX*16, dimension ( LDA, N )
|
||||
*>
|
||||
*> The matrices used in forming the output matrix Z.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Z
|
||||
*> \verbatim
|
||||
*> Z is COMPLEX*16, dimension ( LDZ, 2*M*N )
|
||||
*> The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDZ
|
||||
*> \verbatim
|
||||
*> LDZ is INTEGER
|
||||
*> The leading dimension of Z. ( LDZ >= 2*M*N )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDZ, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), B( LDA, * ), D( LDA, * ),
|
||||
$ E( LDA, * ), Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
* ====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IK, J, JK, L, MN, MN2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZLASET
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Initialize Z
|
||||
*
|
||||
MN = M*N
|
||||
MN2 = 2*MN
|
||||
CALL ZLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
|
||||
*
|
||||
IK = 1
|
||||
DO 50 L = 1, N
|
||||
*
|
||||
* form kron(In, A)
|
||||
*
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
Z( IK+I-1, IK+J-1 ) = A( I, J )
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* form kron(In, D)
|
||||
*
|
||||
DO 40 I = 1, M
|
||||
DO 30 J = 1, M
|
||||
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
50 CONTINUE
|
||||
*
|
||||
IK = 1
|
||||
DO 90 L = 1, N
|
||||
JK = MN + 1
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
*
|
||||
* form -kron(B', Im)
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
Z( IK+I-1, JK+I-1 ) = -B( J, L )
|
||||
60 CONTINUE
|
||||
*
|
||||
* form -kron(E', Im)
|
||||
*
|
||||
DO 70 I = 1, M
|
||||
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
|
||||
70 CONTINUE
|
||||
*
|
||||
JK = JK + M
|
||||
80 CONTINUE
|
||||
*
|
||||
IK = IK + M
|
||||
90 CONTINUE
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAKF2
|
||||
*
|
||||
END
|
||||
176
lapack-netlib/TESTING/MATGEN/zlarge.f
Normal file
176
lapack-netlib/TESTING/MATGEN/zlarge.f
Normal file
@@ -0,0 +1,176 @@
|
||||
*> \brief \b ZLARGE
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARGE pre- and post-multiplies a complex general n by n matrix A
|
||||
*> with a random unitary matrix: A = U*D*U'.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the original n by n matrix A.
|
||||
*> On exit, A is overwritten by U*A*U' for some random
|
||||
*> unitary matrix U.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (2*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
DOUBLE PRECISION WN
|
||||
COMPLEX*16 TAU, WA, WB
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZGEMV, ZGERC, ZLARNV, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, MAX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DZNRM2
|
||||
EXTERNAL DZNRM2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -3
|
||||
END IF
|
||||
IF( INFO.LT.0 ) THEN
|
||||
CALL XERBLA( 'ZLARGE', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* pre- and post-multiply A by random unitary matrix
|
||||
*
|
||||
DO 10 I = N, 1, -1
|
||||
*
|
||||
* generate random reflection
|
||||
*
|
||||
CALL ZLARNV( 3, ISEED, N-I+1, WORK )
|
||||
WN = DZNRM2( N-I+1, WORK, 1 )
|
||||
WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 )
|
||||
IF( WN.EQ.ZERO ) THEN
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
WB = WORK( 1 ) + WA
|
||||
CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
|
||||
WORK( 1 ) = ONE
|
||||
TAU = DBLE( WB / WA )
|
||||
END IF
|
||||
*
|
||||
* multiply A(i:n,1:n) by random reflection from the left
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', N-I+1, N, ONE, A( I, 1 ),
|
||||
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL ZGERC( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
|
||||
$ LDA )
|
||||
*
|
||||
* multiply A(1:n,i:n) by random reflection from the right
|
||||
*
|
||||
CALL ZGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
|
||||
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
|
||||
CALL ZGERC( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
|
||||
$ LDA )
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARGE
|
||||
*
|
||||
END
|
||||
146
lapack-netlib/TESTING/MATGEN/zlarnd.f
Normal file
146
lapack-netlib/TESTING/MATGEN/zlarnd.f
Normal file
@@ -0,0 +1,146 @@
|
||||
*> \brief \b ZLARND
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX*16 FUNCTION ZLARND( IDIST, ISEED )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARND returns a random complex number from a uniform or normal
|
||||
*> distribution.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> Specifies the distribution of the random numbers:
|
||||
*> = 1: real and imaginary parts each uniform (0,1)
|
||||
*> = 2: real and imaginary parts each uniform (-1,1)
|
||||
*> = 3: real and imaginary parts each normal (0,1)
|
||||
*> = 4: uniformly distributed on the disc abs(z) <= 1
|
||||
*> = 5: uniformly distributed on the circle abs(z) = 1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension (4)
|
||||
*> On entry, the seed of the random number generator; the array
|
||||
*> elements must be between 0 and 4095, and ISEED(4) must be
|
||||
*> odd.
|
||||
*> On exit, the seed is updated.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> This routine calls the auxiliary routine DLARAN to generate a random
|
||||
*> real number from a uniform (0,1) distribution. The Box-Muller method
|
||||
*> is used to transform numbers from a uniform to a normal distribution.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
COMPLEX*16 FUNCTION ZLARND( IDIST, ISEED )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, TWO
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
|
||||
DOUBLE PRECISION TWOPI
|
||||
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION T1, T2
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLARAN
|
||||
EXTERNAL DLARAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCMPLX, EXP, LOG, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate a pair of real random numbers from a uniform (0,1)
|
||||
* distribution
|
||||
*
|
||||
T1 = DLARAN( ISEED )
|
||||
T2 = DLARAN( ISEED )
|
||||
*
|
||||
IF( IDIST.EQ.1 ) THEN
|
||||
*
|
||||
* real and imaginary parts each uniform (0,1)
|
||||
*
|
||||
ZLARND = DCMPLX( T1, T2 )
|
||||
ELSE IF( IDIST.EQ.2 ) THEN
|
||||
*
|
||||
* real and imaginary parts each uniform (-1,1)
|
||||
*
|
||||
ZLARND = DCMPLX( TWO*T1-ONE, TWO*T2-ONE )
|
||||
ELSE IF( IDIST.EQ.3 ) THEN
|
||||
*
|
||||
* real and imaginary parts each normal (0,1)
|
||||
*
|
||||
ZLARND = SQRT( -TWO*LOG( T1 ) )*EXP( DCMPLX( ZERO, TWOPI*T2 ) )
|
||||
ELSE IF( IDIST.EQ.4 ) THEN
|
||||
*
|
||||
* uniform distribution on the unit disc abs(z) <= 1
|
||||
*
|
||||
ZLARND = SQRT( T1 )*EXP( DCMPLX( ZERO, TWOPI*T2 ) )
|
||||
ELSE IF( IDIST.EQ.5 ) THEN
|
||||
*
|
||||
* uniform distribution on the unit circle abs(z) = 1
|
||||
*
|
||||
ZLARND = EXP( DCMPLX( ZERO, TWOPI*T2 ) )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARND
|
||||
*
|
||||
END
|
||||
349
lapack-netlib/TESTING/MATGEN/zlaror.f
Normal file
349
lapack-netlib/TESTING/MATGEN/zlaror.f
Normal file
@@ -0,0 +1,349 @@
|
||||
*> \brief \b ZLAROR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER INIT, SIDE
|
||||
* INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX*16 A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAROR pre- or post-multiplies an M by N matrix A by a random
|
||||
*> unitary matrix U, overwriting A. A may optionally be
|
||||
*> initialized to the identity matrix before multiplying by U.
|
||||
*> U is generated using the method of G.W. Stewart
|
||||
*> ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
|
||||
*> (BLAS-2 version)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> SIDE specifies whether A is multiplied on the left or right
|
||||
*> by U.
|
||||
*> SIDE = 'L' Multiply A on the left (premultiply) by U
|
||||
*> SIDE = 'R' Multiply A on the right (postmultiply) by UC> SIDE = 'C' Multiply A on the left by U and the right by UC> SIDE = 'T' Multiply A on the left by U and the right by U'
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INIT
|
||||
*> \verbatim
|
||||
*> INIT is CHARACTER*1
|
||||
*> INIT specifies whether or not A should be initialized to
|
||||
*> the identity matrix.
|
||||
*> INIT = 'I' Initialize A to (a section of) the
|
||||
*> identity matrix before applying U.
|
||||
*> INIT = 'N' No initialization. Apply U to the
|
||||
*> input matrix A.
|
||||
*>
|
||||
*> INIT = 'I' may be used to generate square (i.e., unitary)
|
||||
*> or rectangular orthogonal matrices (orthogonality being
|
||||
*> in the sense of ZDOTC):
|
||||
*>
|
||||
*> For square matrices, M=N, and SIDE many be either 'L' or
|
||||
*> 'R'; the rows will be orthogonal to each other, as will the
|
||||
*> columns.
|
||||
*> For rectangular matrices where M < N, SIDE = 'R' will
|
||||
*> produce a dense matrix whose rows will be orthogonal and
|
||||
*> whose columns will not, while SIDE = 'L' will produce a
|
||||
*> matrix whose rows will be orthogonal, and whose first M
|
||||
*> columns will be orthogonal, the remaining columns being
|
||||
*> zero.
|
||||
*> For matrices where M > N, just use the previous
|
||||
*> explanation, interchanging 'L' and 'R' and "rows" and
|
||||
*> "columns".
|
||||
*>
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension ( LDA, N )
|
||||
*> Input and output array. Overwritten by U A ( if SIDE = 'L' )
|
||||
*> or by A U ( if SIDE = 'R' )
|
||||
*> or by U A U* ( if SIDE = 'C')
|
||||
*> or by U A U' ( if SIDE = 'T') on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> Leading dimension of A. Must be at least MAX ( 1, M ).
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The array elements should be between 0 and 4095;
|
||||
*> if not they will be reduced mod 4096. Also, ISEED(4) must
|
||||
*> be odd. The random number generator uses a linear
|
||||
*> congruential sequence limited to small integers, and so
|
||||
*> should produce machine independent random numbers. The
|
||||
*> values of ISEED are changed on exit, and can be used in the
|
||||
*> next call to ZLAROR to continue the same random number
|
||||
*> sequence.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
|
||||
*> Workspace. Of length:
|
||||
*> 2*M + N if SIDE = 'L',
|
||||
*> 2*N + M if SIDE = 'R',
|
||||
*> 3*N if SIDE = 'C' or 'T'.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> An error flag. It is set to:
|
||||
*> 0 if no error.
|
||||
*> 1 if ZLARND returned a bad random number (installation
|
||||
*> problem)
|
||||
*> -1 if SIDE is not L, R, C, or T.
|
||||
*> -3 if M is negative.
|
||||
*> -4 if N is negative or if SIDE is C or T and N is not equal
|
||||
*> to M.
|
||||
*> -6 if LDA is less than M.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER INIT, SIDE
|
||||
INTEGER INFO, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX*16 A( LDA, * ), X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, TOOSML
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
|
||||
$ TOOSML = 1.0D-20 )
|
||||
COMPLEX*16 CZERO, CONE
|
||||
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ CONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
|
||||
DOUBLE PRECISION FACTOR, XABS, XNORM
|
||||
COMPLEX*16 CSIGN, XNORMS
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
DOUBLE PRECISION DZNRM2
|
||||
COMPLEX*16 ZLARND
|
||||
EXTERNAL LSAME, DZNRM2, ZLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZGEMV, ZGERC, ZLACGV, ZLASET, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DCMPLX, DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.EQ.0 .OR. M.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
ITYPE = 0
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
ITYPE = 1
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
ITYPE = 2
|
||||
ELSE IF( LSAME( SIDE, 'C' ) ) THEN
|
||||
ITYPE = 3
|
||||
ELSE IF( LSAME( SIDE, 'T' ) ) THEN
|
||||
ITYPE = 4
|
||||
END IF
|
||||
*
|
||||
* Check for argument errors.
|
||||
*
|
||||
IF( ITYPE.EQ.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.M ) THEN
|
||||
INFO = -6
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZLAROR', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.1 ) THEN
|
||||
NXFRM = M
|
||||
ELSE
|
||||
NXFRM = N
|
||||
END IF
|
||||
*
|
||||
* Initialize A to the identity matrix if desired
|
||||
*
|
||||
IF( LSAME( INIT, 'I' ) )
|
||||
$ CALL ZLASET( 'Full', M, N, CZERO, CONE, A, LDA )
|
||||
*
|
||||
* If no rotation possible, still multiply by
|
||||
* a random complex number from the circle |x| = 1
|
||||
*
|
||||
* 2) Compute Rotation by computing Householder
|
||||
* Transformations H(2), H(3), ..., H(n). Note that the
|
||||
* order in which they are computed is irrelevant.
|
||||
*
|
||||
DO 10 J = 1, NXFRM
|
||||
X( J ) = CZERO
|
||||
10 CONTINUE
|
||||
*
|
||||
DO 30 IXFRM = 2, NXFRM
|
||||
KBEG = NXFRM - IXFRM + 1
|
||||
*
|
||||
* Generate independent normal( 0, 1 ) random numbers
|
||||
*
|
||||
DO 20 J = KBEG, NXFRM
|
||||
X( J ) = ZLARND( 3, ISEED )
|
||||
20 CONTINUE
|
||||
*
|
||||
* Generate a Householder transformation from the random vector X
|
||||
*
|
||||
XNORM = DZNRM2( IXFRM, X( KBEG ), 1 )
|
||||
XABS = ABS( X( KBEG ) )
|
||||
IF( XABS.NE.CZERO ) THEN
|
||||
CSIGN = X( KBEG ) / XABS
|
||||
ELSE
|
||||
CSIGN = CONE
|
||||
END IF
|
||||
XNORMS = CSIGN*XNORM
|
||||
X( NXFRM+KBEG ) = -CSIGN
|
||||
FACTOR = XNORM*( XNORM+XABS )
|
||||
IF( ABS( FACTOR ).LT.TOOSML ) THEN
|
||||
INFO = 1
|
||||
CALL XERBLA( 'ZLAROR', -INFO )
|
||||
RETURN
|
||||
ELSE
|
||||
FACTOR = ONE / FACTOR
|
||||
END IF
|
||||
X( KBEG ) = X( KBEG ) + XNORMS
|
||||
*
|
||||
* Apply Householder transformation to A
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
|
||||
*
|
||||
* Apply H(k) on the left of A
|
||||
*
|
||||
CALL ZGEMV( 'C', IXFRM, N, CONE, A( KBEG, 1 ), LDA,
|
||||
$ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL ZGERC( IXFRM, N, -DCMPLX( FACTOR ), X( KBEG ), 1,
|
||||
$ X( 2*NXFRM+1 ), 1, A( KBEG, 1 ), LDA )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.GE.2 .AND. ITYPE.LE.4 ) THEN
|
||||
*
|
||||
* Apply H(k)* (or H(k)') on the right of A
|
||||
*
|
||||
IF( ITYPE.EQ.4 ) THEN
|
||||
CALL ZLACGV( IXFRM, X( KBEG ), 1 )
|
||||
END IF
|
||||
*
|
||||
CALL ZGEMV( 'N', M, IXFRM, CONE, A( 1, KBEG ), LDA,
|
||||
$ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
|
||||
CALL ZGERC( M, IXFRM, -DCMPLX( FACTOR ), X( 2*NXFRM+1 ), 1,
|
||||
$ X( KBEG ), 1, A( 1, KBEG ), LDA )
|
||||
*
|
||||
END IF
|
||||
30 CONTINUE
|
||||
*
|
||||
X( 1 ) = ZLARND( 3, ISEED )
|
||||
XABS = ABS( X( 1 ) )
|
||||
IF( XABS.NE.ZERO ) THEN
|
||||
CSIGN = X( 1 ) / XABS
|
||||
ELSE
|
||||
CSIGN = CONE
|
||||
END IF
|
||||
X( 2*NXFRM ) = CSIGN
|
||||
*
|
||||
* Scale the matrix A by D.
|
||||
*
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
|
||||
DO 40 IROW = 1, M
|
||||
CALL ZSCAL( N, DCONJG( X( NXFRM+IROW ) ), A( IROW, 1 ),
|
||||
$ LDA )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
|
||||
DO 50 JCOL = 1, N
|
||||
CALL ZSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.4 ) THEN
|
||||
DO 60 JCOL = 1, N
|
||||
CALL ZSCAL( M, DCONJG( X( NXFRM+JCOL ) ), A( 1, JCOL ), 1 )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAROR
|
||||
*
|
||||
END
|
||||
338
lapack-netlib/TESTING/MATGEN/zlarot.f
Normal file
338
lapack-netlib/TESTING/MATGEN/zlarot.f
Normal file
@@ -0,0 +1,338 @@
|
||||
*> \brief \b ZLAROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
* XRIGHT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* LOGICAL LLEFT, LRIGHT, LROWS
|
||||
* INTEGER LDA, NL
|
||||
* COMPLEX*16 C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLAROT applies a (Givens) rotation to two adjacent rows or
|
||||
*> columns, where one element of the first and/or last column/row
|
||||
*> for use on matrices stored in some format other than GE, so
|
||||
*> that elements of the matrix may be used or modified for which
|
||||
*> no array element is provided.
|
||||
*>
|
||||
*> One example is a symmetric matrix in SB format (bandwidth=4), for
|
||||
*> which UPLO='L': Two adjacent rows will have the format:
|
||||
*>
|
||||
*> row j: C> C> C> C> C> . . . .
|
||||
*> row j+1: C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> '*' indicates elements for which storage is provided,
|
||||
*> '.' indicates elements for which no storage is provided, but
|
||||
*> are not necessarily zero; their values are determined by
|
||||
*> symmetry. ' ' indicates elements which are necessarily zero,
|
||||
*> and have no storage provided.
|
||||
*>
|
||||
*> Those columns which have two '*'s can be handled by DROT.
|
||||
*> Those columns which have no '*'s can be ignored, since as long
|
||||
*> as the Givens rotations are carefully applied to preserve
|
||||
*> symmetry, their values are determined.
|
||||
*> Those columns which have one '*' have to be handled separately,
|
||||
*> by using separate variables "p" and "q":
|
||||
*>
|
||||
*> row j: C> C> C> C> C> p . . .
|
||||
*> row j+1: q C> C> C> C> C> . . . .
|
||||
*>
|
||||
*> The element p would have to be set correctly, then that column
|
||||
*> is rotated, setting p to its new value. The next call to
|
||||
*> ZLAROT would rotate columns j and j+1, using p, and restore
|
||||
*> symmetry. The element q would start out being zero, and be
|
||||
*> made non-zero by the rotation. Later, rotations would presumably
|
||||
*> be chosen to zero q out.
|
||||
*>
|
||||
*> Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
|
||||
*> ------- ------- ---------
|
||||
*>
|
||||
*> General dense matrix:
|
||||
*>
|
||||
*> CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
|
||||
*> A(i,1),LDA, DUMMY, DUMMY)
|
||||
*>
|
||||
*> General banded matrix in GB format:
|
||||
*>
|
||||
*> j = MAX(1, i-KL )
|
||||
*> NL = MIN( N, i+KU+1 ) + 1-j
|
||||
*> CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
|
||||
*> A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,KL+1) ]
|
||||
*>
|
||||
*> Symmetric banded matrix in SY format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> j = MAX(1, i-K )
|
||||
*> NL = MIN( K+1, i ) + 1
|
||||
*> CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
|
||||
*> A(i,j), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*>
|
||||
*> NL = MIN( K+1, N-i ) + 1
|
||||
*> CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
|
||||
*> A(i,i), LDA, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Symmetric banded matrix in SB format, bandwidth K,
|
||||
*> lower triangle only:
|
||||
*>
|
||||
*> [ same as for SY, except:]
|
||||
*> . . . .
|
||||
*> A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> [ note that i+1-j is just MIN(i,K+1) ]
|
||||
*>
|
||||
*> Same, but upper triangle only:
|
||||
*> . . .
|
||||
*> A(K+1,i), LDA-1, XLEFT, XRIGHT )
|
||||
*>
|
||||
*> Rotating columns is just the transpose of rotating rows, except
|
||||
*> for GB and SB: (rotating columns i and i+1)
|
||||
*>
|
||||
*> GB:
|
||||
*> j = MAX(1, i-KU )
|
||||
*> NL = MIN( N, i+KL+1 ) + 1-j
|
||||
*> CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
|
||||
*> A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> [note that KU+j+1-i is just MAX(1,KU+2-i)]
|
||||
*>
|
||||
*> SB: (upper triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
|
||||
*>
|
||||
*> SB: (lower triangle)
|
||||
*>
|
||||
*> . . . . . .
|
||||
*> A(1,i),LDA-1, XTOP, XBOTTM )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \verbatim
|
||||
*> LROWS - LOGICAL
|
||||
*> If .TRUE., then ZLAROT will rotate two rows. If .FALSE.,
|
||||
*> then it will rotate two columns.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LLEFT - LOGICAL
|
||||
*> If .TRUE., then XLEFT will be used instead of the
|
||||
*> corresponding element of A for the first element in the
|
||||
*> second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
|
||||
*> If .FALSE., then the corresponding element of A will be
|
||||
*> used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> LRIGHT - LOGICAL
|
||||
*> If .TRUE., then XRIGHT will be used instead of the
|
||||
*> corresponding element of A for the last element in the
|
||||
*> first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
|
||||
*> .FALSE., then the corresponding element of A will be used.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> NL - INTEGER
|
||||
*> The length of the rows (if LROWS=.TRUE.) or columns (if
|
||||
*> LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
|
||||
*> used, the columns/rows they are in should be included in
|
||||
*> NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
|
||||
*> least 2. The number of rows/columns to be rotated
|
||||
*> exclusive of those involving XLEFT and/or XRIGHT may
|
||||
*> not be negative, i.e., NL minus how many of LLEFT and
|
||||
*> LRIGHT are .TRUE. must be at least zero; if not, XERBLA
|
||||
*> will be called.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> C, S - COMPLEX*16
|
||||
*> Specify the Givens rotation to be applied. If LROWS is
|
||||
*> true, then the matrix ( c s )
|
||||
*> ( _ _ )
|
||||
*> (-s c ) is applied from the left;
|
||||
*> if false, then the transpose (not conjugated) thereof is
|
||||
*> applied from the right. Note that in contrast to the
|
||||
*> output of ZROTG or to most versions of ZROT, both C and S
|
||||
*> are complex. For a Givens rotation, |C|**2 + |S|**2 should
|
||||
*> be 1, but this is not checked.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> A - COMPLEX*16 array.
|
||||
*> The array containing the rows/columns to be rotated. The
|
||||
*> first element of A should be the upper left element to
|
||||
*> be rotated.
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> LDA - INTEGER
|
||||
*> The "effective" leading dimension of A. If A contains
|
||||
*> a matrix stored in GE, HE, or SY format, then this is just
|
||||
*> the leading dimension of A as dimensioned in the calling
|
||||
*> routine. If A contains a matrix stored in band (GB, HB, or
|
||||
*> SB) format, then this should be *one less* than the leading
|
||||
*> dimension used in the calling routine. Thus, if A were
|
||||
*> dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the
|
||||
*> j-th element in the first of the two rows to be rotated,
|
||||
*> and A(2,j) would be the j-th in the second, regardless of
|
||||
*> how the array may be stored in the calling routine. [A
|
||||
*> cannot, however, actually be dimensioned thus, since for
|
||||
*> band format, the row number may exceed LDA, which is not
|
||||
*> legal FORTRAN.]
|
||||
*> If LROWS=.TRUE., then LDA must be at least 1, otherwise
|
||||
*> it must be at least NL minus the number of .TRUE. values
|
||||
*> in XLEFT and XRIGHT.
|
||||
*> Not modified.
|
||||
*>
|
||||
*> XLEFT - COMPLEX*16
|
||||
*> If LLEFT is .TRUE., then XLEFT will be used and modified
|
||||
*> instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*>
|
||||
*> XRIGHT - COMPLEX*16
|
||||
*> If LRIGHT is .TRUE., then XRIGHT will be used and modified
|
||||
*> instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
|
||||
*> (if LROWS=.FALSE.).
|
||||
*> Read and modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
|
||||
$ XRIGHT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
LOGICAL LLEFT, LRIGHT, LROWS
|
||||
INTEGER LDA, NL
|
||||
COMPLEX*16 C, S, XLEFT, XRIGHT
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER IINC, INEXT, IX, IY, IYT, J, NT
|
||||
COMPLEX*16 TEMPX
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
COMPLEX*16 XT( 2 ), YT( 2 )
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Set up indices, arrays for ends
|
||||
*
|
||||
IF( LROWS ) THEN
|
||||
IINC = LDA
|
||||
INEXT = 1
|
||||
ELSE
|
||||
IINC = 1
|
||||
INEXT = LDA
|
||||
END IF
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
NT = 1
|
||||
IX = 1 + IINC
|
||||
IY = 2 + LDA
|
||||
XT( 1 ) = A( 1 )
|
||||
YT( 1 ) = XLEFT
|
||||
ELSE
|
||||
NT = 0
|
||||
IX = 1
|
||||
IY = 1 + INEXT
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
IYT = 1 + INEXT + ( NL-1 )*IINC
|
||||
NT = NT + 1
|
||||
XT( NT ) = XRIGHT
|
||||
YT( NT ) = A( IYT )
|
||||
END IF
|
||||
*
|
||||
* Check for errors
|
||||
*
|
||||
IF( NL.LT.NT ) THEN
|
||||
CALL XERBLA( 'ZLAROT', 4 )
|
||||
RETURN
|
||||
END IF
|
||||
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
|
||||
CALL XERBLA( 'ZLAROT', 8 )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Rotate
|
||||
*
|
||||
* ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S
|
||||
*
|
||||
DO 10 J = 0, NL - NT - 1
|
||||
TEMPX = C*A( IX+J*IINC ) + S*A( IY+J*IINC )
|
||||
A( IY+J*IINC ) = -DCONJG( S )*A( IX+J*IINC ) +
|
||||
$ DCONJG( C )*A( IY+J*IINC )
|
||||
A( IX+J*IINC ) = TEMPX
|
||||
10 CONTINUE
|
||||
*
|
||||
* ZROT( NT, XT,1, YT,1, C, S ) with complex C, S
|
||||
*
|
||||
DO 20 J = 1, NT
|
||||
TEMPX = C*XT( J ) + S*YT( J )
|
||||
YT( J ) = -DCONJG( S )*XT( J ) + DCONJG( C )*YT( J )
|
||||
XT( J ) = TEMPX
|
||||
20 CONTINUE
|
||||
*
|
||||
* Stuff values back into XLEFT, XRIGHT, etc.
|
||||
*
|
||||
IF( LLEFT ) THEN
|
||||
A( 1 ) = XT( 1 )
|
||||
XLEFT = YT( 1 )
|
||||
END IF
|
||||
*
|
||||
IF( LRIGHT ) THEN
|
||||
XRIGHT = XT( NT )
|
||||
A( IYT ) = YT( NT )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLAROT
|
||||
*
|
||||
END
|
||||
300
lapack-netlib/TESTING/MATGEN/zlatm1.f
Normal file
300
lapack-netlib/TESTING/MATGEN/zlatm1.f
Normal file
@@ -0,0 +1,300 @@
|
||||
*> \brief \b ZLATM1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
* DOUBLE PRECISION COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* COMPLEX*16 D( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATM1 computes the entries of D(1..N) as specified by
|
||||
*> MODE, COND and IRSIGN. IDIST and ISEED determine the generation
|
||||
*> of random numbers. ZLATM1 is called by CLATMR to generate
|
||||
*> random test matrices for LAPACK programs.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry describes how D is to be computed:
|
||||
*> MODE = 0 means do not change D.
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is positive, D has entries ranging from
|
||||
*> 1 to 1/COND, if negative, from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is DOUBLE PRECISION
|
||||
*> On entry, used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IRSIGN
|
||||
*> \verbatim
|
||||
*> IRSIGN is INTEGER
|
||||
*> On entry, if MODE neither -6, 0 nor 6, determines sign of
|
||||
*> entries of D
|
||||
*> 0 => leave entries of D unchanged
|
||||
*> 1 => multiply each entry of D by random complex number
|
||||
*> uniformly distributed with absolute value 1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is CHARACTER*1
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0, 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. The random number generator uses a
|
||||
*> linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to ZLATM1
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16 array, dimension ( MIN( M , N ) )
|
||||
*> Array to be computed according to MODE, COND and IRSIGN.
|
||||
*> May be changed on exit if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of entries of D. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> 0 => normal termination
|
||||
*> -1 => if MODE not in range -6 to 6
|
||||
*> -2 => if MODE neither -6, 0 nor 6, and
|
||||
*> IRSIGN neither 0 nor 1
|
||||
*> -3 => if MODE neither -6, 0 nor 6 and COND less than 1
|
||||
*> -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4
|
||||
*> -7 => if N negative
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER IDIST, INFO, IRSIGN, MODE, N
|
||||
DOUBLE PRECISION COND
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
COMPLEX*16 D( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
DOUBLE PRECISION ALPHA, TEMP
|
||||
COMPLEX*16 CTEMP
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLARAN
|
||||
COMPLEX*16 ZLARND
|
||||
EXTERNAL DLARAN, ZLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLARNV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, EXP, LOG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Decode and Test the input parameters. Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ COND.LT.ONE ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
|
||||
$ ( IDIST.LT.1 .OR. IDIST.GT.4 ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZLATM1', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
IF( MODE.NE.0 ) THEN
|
||||
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
|
||||
*
|
||||
* One large D value:
|
||||
*
|
||||
10 CONTINUE
|
||||
DO 20 I = 1, N
|
||||
D( I ) = ONE / COND
|
||||
20 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
GO TO 120
|
||||
*
|
||||
* One small D value:
|
||||
*
|
||||
30 CONTINUE
|
||||
DO 40 I = 1, N
|
||||
D( I ) = ONE
|
||||
40 CONTINUE
|
||||
D( N ) = ONE / COND
|
||||
GO TO 120
|
||||
*
|
||||
* Exponentially distributed D values:
|
||||
*
|
||||
50 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
ALPHA = COND**( -ONE / DBLE( N-1 ) )
|
||||
DO 60 I = 2, N
|
||||
D( I ) = ALPHA**( I-1 )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Arithmetically distributed D values:
|
||||
*
|
||||
70 CONTINUE
|
||||
D( 1 ) = ONE
|
||||
IF( N.GT.1 ) THEN
|
||||
TEMP = ONE / COND
|
||||
ALPHA = ( ONE-TEMP ) / DBLE( N-1 )
|
||||
DO 80 I = 2, N
|
||||
D( I ) = DBLE( N-I )*ALPHA + TEMP
|
||||
80 CONTINUE
|
||||
END IF
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values on ( 1/COND , 1):
|
||||
*
|
||||
90 CONTINUE
|
||||
ALPHA = LOG( ONE / COND )
|
||||
DO 100 I = 1, N
|
||||
D( I ) = EXP( ALPHA*DLARAN( ISEED ) )
|
||||
100 CONTINUE
|
||||
GO TO 120
|
||||
*
|
||||
* Randomly distributed D values from IDIST
|
||||
*
|
||||
110 CONTINUE
|
||||
CALL ZLARNV( IDIST, ISEED, N, D )
|
||||
*
|
||||
120 CONTINUE
|
||||
*
|
||||
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
|
||||
* random signs to D
|
||||
*
|
||||
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
|
||||
$ IRSIGN.EQ.1 ) THEN
|
||||
DO 130 I = 1, N
|
||||
CTEMP = ZLARND( 3, ISEED )
|
||||
D( I ) = D( I )*( CTEMP / ABS( CTEMP ) )
|
||||
130 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Reverse if MODE < 0
|
||||
*
|
||||
IF( MODE.LT.0 ) THEN
|
||||
DO 140 I = 1, N / 2
|
||||
CTEMP = D( I )
|
||||
D( I ) = D( N+1-I )
|
||||
D( N+1-I ) = CTEMP
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATM1
|
||||
*
|
||||
END
|
||||
328
lapack-netlib/TESTING/MATGEN/zlatm2.f
Normal file
328
lapack-netlib/TESTING/MATGEN/zlatm2.f
Normal file
@@ -0,0 +1,328 @@
|
||||
*> \brief \b ZLATM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX*16 FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
* DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* COMPLEX*16 D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATM2 returns the (I,J) entry of a random matrix of dimension
|
||||
*> (M, N) described by the other paramters. It is called by the
|
||||
*> ZLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by ZLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of ZLATM2 differs from CLATM3 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With ZLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With ZLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, ZLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. ZLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*>
|
||||
*> The matrix whose (I,J) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If I is outside (1..M) or J is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0 , 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16 array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( CONJG(DL) )
|
||||
*> 6 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is COMPLEX*16 array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is COMPLEX*16 array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) in position K was originally in
|
||||
*> position IWORK( K ).
|
||||
*> This differs from IWORK for ZLATM3. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is DOUBLE PRECISION between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX*16 FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST,
|
||||
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
|
||||
DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
COMPLEX*16 D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
COMPLEX*16 CZERO
|
||||
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) )
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
INTEGER ISUB, JSUB
|
||||
COMPLEX*16 CTEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
DOUBLE PRECISION DLARAN
|
||||
COMPLEX*16 ZLARND
|
||||
EXTERNAL DLARAN, ZLARND
|
||||
* ..
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
*
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
ZLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
|
||||
ZLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
ZLATM2 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( ISUB.EQ.JSUB ) THEN
|
||||
CTEMP = D( ISUB )
|
||||
ELSE
|
||||
CTEMP = ZLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
CTEMP = CTEMP*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*DR( JSUB )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB ) / DL( JSUB )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*DCONJG( DL( JSUB ) )
|
||||
ELSE IF( IGRADE.EQ.6 ) THEN
|
||||
CTEMP = CTEMP*DL( ISUB )*DL( JSUB )
|
||||
END IF
|
||||
ZLATM2 = CTEMP
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATM2
|
||||
*
|
||||
END
|
||||
348
lapack-netlib/TESTING/MATGEN/zlatm3.f
Normal file
348
lapack-netlib/TESTING/MATGEN/zlatm3.f
Normal file
@@ -0,0 +1,348 @@
|
||||
*> \brief \b ZLATM3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX*16 FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
* SPARSE )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
* $ KU, M, N
|
||||
* DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
* INTEGER ISEED( 4 ), IWORK( * )
|
||||
* COMPLEX*16 D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of
|
||||
*> dimension (M, N) described by the other paramters. (ISUB,JSUB)
|
||||
*> is the final position of the (I,J) entry after pivoting
|
||||
*> according to IPVTNG and IWORK. ZLATM3 is called by the
|
||||
*> ZLATMR routine in order to build random test matrices. No error
|
||||
*> checking on parameters is done, because this routine is called in
|
||||
*> a tight loop by ZLATMR which has already checked the parameters.
|
||||
*>
|
||||
*> Use of ZLATM3 differs from CLATM2 in the order in which the random
|
||||
*> number generator is called to fill in random matrix entries.
|
||||
*> With ZLATM2, the generator is called to fill in the pivoted matrix
|
||||
*> columnwise. With ZLATM3, the generator is called to fill in the
|
||||
*> matrix columnwise, after which it is pivoted. Thus, ZLATM3 can
|
||||
*> be used to construct random matrices which differ only in their
|
||||
*> order of rows and/or columns. ZLATM2 is used to construct band
|
||||
*> matrices while avoiding calling the random number generator for
|
||||
*> entries outside the band (and therefore generating random numbers
|
||||
*> in different orders for different pivot orders).
|
||||
*>
|
||||
*> The matrix whose (ISUB,JSUB) entry is returned is constructed as
|
||||
*> follows (this routine only computes one entry):
|
||||
*>
|
||||
*> If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
|
||||
*> (this is convenient for generating matrices in band format).
|
||||
*>
|
||||
*> Generate a matrix A with random entries of distribution IDIST.
|
||||
*>
|
||||
*> Set the diagonal to D.
|
||||
*>
|
||||
*> Grade the matrix, if desired, from the left (by DL) and/or
|
||||
*> from the right (by DR or DL) as specified by IGRADE.
|
||||
*>
|
||||
*> Permute, if desired, the rows and/or columns as specified by
|
||||
*> IPVTNG and IWORK.
|
||||
*>
|
||||
*> Band the matrix to have lower bandwidth KL and upper
|
||||
*> bandwidth KU.
|
||||
*>
|
||||
*> Set random entries to zero as specified by SPARSE.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Number of rows of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Number of columns of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] I
|
||||
*> \verbatim
|
||||
*> I is INTEGER
|
||||
*> Row of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] J
|
||||
*> \verbatim
|
||||
*> J is INTEGER
|
||||
*> Column of unpivoted entry to be returned. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISUB
|
||||
*> \verbatim
|
||||
*> ISUB is INTEGER
|
||||
*> Row of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] JSUB
|
||||
*> \verbatim
|
||||
*> JSUB is INTEGER
|
||||
*> Column of pivoted entry to be returned. Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> Lower bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> Upper bandwidth. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IDIST
|
||||
*> \verbatim
|
||||
*> IDIST is INTEGER
|
||||
*> On entry, IDIST specifies the type of distribution to be
|
||||
*> used to generate a random matrix .
|
||||
*> 1 => real and imaginary parts each UNIFORM( 0, 1 )
|
||||
*> 2 => real and imaginary parts each UNIFORM( -1, 1 )
|
||||
*> 3 => real and imaginary parts each NORMAL( 0, 1 )
|
||||
*> 4 => complex number uniform in DISK( 0 , 1 )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array of dimension ( 4 )
|
||||
*> Seed for random number generator.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16 array of dimension ( MIN( I , J ) )
|
||||
*> Diagonal entries of matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IGRADE
|
||||
*> \verbatim
|
||||
*> IGRADE is INTEGER
|
||||
*> Specifies grading of matrix as follows:
|
||||
*> 0 => no grading
|
||||
*> 1 => matrix premultiplied by diag( DL )
|
||||
*> 2 => matrix postmultiplied by diag( DR )
|
||||
*> 3 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DR )
|
||||
*> 4 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by inv( diag( DL ) )
|
||||
*> 5 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( CONJG(DL) )
|
||||
*> 6 => matrix premultiplied by diag( DL ) and
|
||||
*> postmultiplied by diag( DL )
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DL
|
||||
*> \verbatim
|
||||
*> DL is COMPLEX*16 array ( I or J, as appropriate )
|
||||
*> Left scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DR
|
||||
*> \verbatim
|
||||
*> DR is COMPLEX*16 array ( I or J, as appropriate )
|
||||
*> Right scale factors for grading matrix. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPVTNG
|
||||
*> \verbatim
|
||||
*> IPVTNG is INTEGER
|
||||
*> On entry specifies pivoting permutations as follows:
|
||||
*> 0 => none.
|
||||
*> 1 => row pivoting.
|
||||
*> 2 => column pivoting.
|
||||
*> 3 => full pivoting, i.e., on both sides.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array ( I or J, as appropriate )
|
||||
*> This array specifies the permutation used. The
|
||||
*> row (or column) originally in position K is in
|
||||
*> position IWORK( K ) after pivoting.
|
||||
*> This differs from IWORK for ZLATM2. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SPARSE
|
||||
*> \verbatim
|
||||
*> SPARSE is DOUBLE PRECISION between 0. and 1.
|
||||
*> On entry specifies the sparsity of the matrix
|
||||
*> if sparse matix is to be generated.
|
||||
*> SPARSE should lie between 0 and 1.
|
||||
*> A uniform ( 0, 1 ) random number x is generated and
|
||||
*> compared to SPARSE; if x is larger the matrix entry
|
||||
*> is unchanged and if x is smaller the entry is set
|
||||
*> to zero. Thus on the average a fraction SPARSE of the
|
||||
*> entries will be set to zero.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX*16 FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
|
||||
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
|
||||
$ SPARSE )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
*
|
||||
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
|
||||
$ KU, M, N
|
||||
DOUBLE PRECISION SPARSE
|
||||
* ..
|
||||
*
|
||||
* .. Array Arguments ..
|
||||
*
|
||||
INTEGER ISEED( 4 ), IWORK( * )
|
||||
COMPLEX*16 D( * ), DL( * ), DR( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
COMPLEX*16 CZERO
|
||||
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) )
|
||||
* ..
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
*
|
||||
COMPLEX*16 CTEMP
|
||||
* ..
|
||||
*
|
||||
* .. External Functions ..
|
||||
*
|
||||
DOUBLE PRECISION DLARAN
|
||||
COMPLEX*16 ZLARND
|
||||
EXTERNAL DLARAN, ZLARND
|
||||
* ..
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
*
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Check for I and J in range
|
||||
*
|
||||
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ZLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute subscripts depending on IPVTNG
|
||||
*
|
||||
IF( IPVTNG.EQ.0 ) THEN
|
||||
ISUB = I
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.1 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = J
|
||||
ELSE IF( IPVTNG.EQ.2 ) THEN
|
||||
ISUB = I
|
||||
JSUB = IWORK( J )
|
||||
ELSE IF( IPVTNG.EQ.3 ) THEN
|
||||
ISUB = IWORK( I )
|
||||
JSUB = IWORK( J )
|
||||
END IF
|
||||
*
|
||||
* Check for banding
|
||||
*
|
||||
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
|
||||
ZLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Check for sparsity
|
||||
*
|
||||
IF( SPARSE.GT.ZERO ) THEN
|
||||
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
|
||||
ZLATM3 = CZERO
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* Compute entry and grade it according to IGRADE
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
CTEMP = D( I )
|
||||
ELSE
|
||||
CTEMP = ZLARND( IDIST, ISEED )
|
||||
END IF
|
||||
IF( IGRADE.EQ.1 ) THEN
|
||||
CTEMP = CTEMP*DL( I )
|
||||
ELSE IF( IGRADE.EQ.2 ) THEN
|
||||
CTEMP = CTEMP*DR( J )
|
||||
ELSE IF( IGRADE.EQ.3 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*DR( J )
|
||||
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
|
||||
CTEMP = CTEMP*DL( I ) / DL( J )
|
||||
ELSE IF( IGRADE.EQ.5 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*DCONJG( DL( J ) )
|
||||
ELSE IF( IGRADE.EQ.6 ) THEN
|
||||
CTEMP = CTEMP*DL( I )*DL( J )
|
||||
END IF
|
||||
ZLATM3 = CTEMP
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATM3
|
||||
*
|
||||
END
|
||||
504
lapack-netlib/TESTING/MATGEN/zlatm5.f
Normal file
504
lapack-netlib/TESTING/MATGEN/zlatm5.f
Normal file
@@ -0,0 +1,504 @@
|
||||
*> \brief \b ZLATM5
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
* QBLCKB )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
* $ PRTYPE, QBLCKA, QBLCKB
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
* $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
* $ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATM5 generates matrices involved in the Generalized Sylvester
|
||||
*> equation:
|
||||
*>
|
||||
*> A * R - L * B = C
|
||||
*> D * R - L * E = F
|
||||
*>
|
||||
*> They also satisfy (the diagonalization condition)
|
||||
*>
|
||||
*> [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
|
||||
*> [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] PRTYPE
|
||||
*> \verbatim
|
||||
*> PRTYPE is INTEGER
|
||||
*> "Points" to a certian type of the matrices to generate
|
||||
*> (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> Specifies the order of A and D and the number of rows in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Specifies the order of B and E and the number of columns in
|
||||
*> C, F, R and L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA, M).
|
||||
*> On exit A M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX*16 array, dimension (LDB, N).
|
||||
*> On exit B N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX*16 array, dimension (LDC, N).
|
||||
*> On exit C M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16 array, dimension (LDD, M).
|
||||
*> On exit D M-by-M is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDD
|
||||
*> \verbatim
|
||||
*> LDD is INTEGER
|
||||
*> The leading dimension of D.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is COMPLEX*16 array, dimension (LDE, N).
|
||||
*> On exit E N-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDE
|
||||
*> \verbatim
|
||||
*> LDE is INTEGER
|
||||
*> The leading dimension of E.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] F
|
||||
*> \verbatim
|
||||
*> F is COMPLEX*16 array, dimension (LDF, N).
|
||||
*> On exit F M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDF
|
||||
*> \verbatim
|
||||
*> LDF is INTEGER
|
||||
*> The leading dimension of F.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] R
|
||||
*> \verbatim
|
||||
*> R is COMPLEX*16 array, dimension (LDR, N).
|
||||
*> On exit R M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDR
|
||||
*> \verbatim
|
||||
*> LDR is INTEGER
|
||||
*> The leading dimension of R.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] L
|
||||
*> \verbatim
|
||||
*> L is COMPLEX*16 array, dimension (LDL, N).
|
||||
*> On exit L M-by-N is initialized according to PRTYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDL
|
||||
*> \verbatim
|
||||
*> LDL is INTEGER
|
||||
*> The leading dimension of L.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION
|
||||
*> Parameter used in generating PRTYPE = 1 and 5 matrices.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKA
|
||||
*> \verbatim
|
||||
*> QBLCKA is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in A. Otherwise, QBLCKA is not
|
||||
*> referenced. QBLCKA > 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] QBLCKB
|
||||
*> \verbatim
|
||||
*> QBLCKB is INTEGER
|
||||
*> When PRTYPE = 3, specifies the distance between 2-by-2
|
||||
*> blocks on the diagonal in B. Otherwise, QBLCKB is not
|
||||
*> referenced. QBLCKB > 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
|
||||
*>
|
||||
*> A : if (i == j) then A(i, j) = 1.0
|
||||
*> if (j == i + 1) then A(i, j) = -1.0
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> B : if (i == j) then B(i, j) = 1.0 - ALPHA
|
||||
*> if (j == i + 1) then B(i, j) = 1.0
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> D : if (i == j) then D(i, j) = 1.0
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> E : if (i == j) then E(i, j) = 1.0
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L = R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
|
||||
*>
|
||||
*> A : if (i <= j) then A(i, j) = [-1...1]
|
||||
*> else A(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> A(k + 1, k + 1) = A(k, k)
|
||||
*> A(k + 1, k) = [-1...1]
|
||||
*> sign(A(k, k + 1) = -(sin(A(k + 1, k))
|
||||
*> k = 1, M - 1, QBLCKA
|
||||
*>
|
||||
*> B : if (i <= j) then B(i, j) = [-1...1]
|
||||
*> else B(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> if (PRTYPE = 3) then
|
||||
*> B(k + 1, k + 1) = B(k, k)
|
||||
*> B(k + 1, k) = [-1...1]
|
||||
*> sign(B(k, k + 1) = -(sign(B(k + 1, k))
|
||||
*> k = 1, N - 1, QBLCKB
|
||||
*>
|
||||
*> D : if (i <= j) then D(i, j) = [-1...1].
|
||||
*> else D(i, j) = 0.0, i, j = 1...M
|
||||
*>
|
||||
*>
|
||||
*> E : if (i <= j) then D(i, j) = [-1...1]
|
||||
*> else E(i, j) = 0.0, i, j = 1...N
|
||||
*>
|
||||
*> L, R are chosen from [-10...10],
|
||||
*> which specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 4 Full
|
||||
*> A(i, j) = [-10...10]
|
||||
*> D(i, j) = [-1...1] i,j = 1...M
|
||||
*> B(i, j) = [-10...10]
|
||||
*> E(i, j) = [-1...1] i,j = 1...N
|
||||
*> R(i, j) = [-10...10]
|
||||
*> L(i, j) = [-1...1] i = 1..M ,j = 1...N
|
||||
*>
|
||||
*> L, R specifies the right hand sides (C, F).
|
||||
*>
|
||||
*> PRTYPE = 5 special case common and/or close eigs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
|
||||
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
|
||||
$ QBLCKB )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
|
||||
$ PRTYPE, QBLCKA, QBLCKB
|
||||
DOUBLE PRECISION ALPHA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
|
||||
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
|
||||
$ L( LDL, * ), R( LDR, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, TWO, ZERO, HALF, TWENTY
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ TWO = ( 2.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ HALF = ( 0.5D+0, 0.0D+0 ),
|
||||
$ TWENTY = ( 2.0D+1, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, K
|
||||
COMPLEX*16 IMEPS, REEPS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCMPLX, MOD, SIN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGEMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( PRTYPE.EQ.1 ) THEN
|
||||
DO 20 I = 1, M
|
||||
DO 10 J = 1, M
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, J ) = ONE
|
||||
D( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
A( I, J ) = -ONE
|
||||
D( I, J ) = ZERO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, N
|
||||
DO 30 J = 1, N
|
||||
IF( I.EQ.J ) THEN
|
||||
B( I, J ) = ONE - ALPHA
|
||||
E( I, J ) = ONE
|
||||
ELSE IF( I.EQ.J-1 ) THEN
|
||||
B( I, J ) = ONE
|
||||
E( I, J ) = ZERO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
DO 60 I = 1, M
|
||||
DO 50 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DCMPLX( I / J ) ) )*TWENTY
|
||||
L( I, J ) = R( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
|
||||
DO 80 I = 1, M
|
||||
DO 70 J = 1, M
|
||||
IF( I.LE.J ) THEN
|
||||
A( I, J ) = ( HALF-SIN( DCMPLX( I ) ) )*TWO
|
||||
D( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*TWO
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
D( I, J ) = ZERO
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
*
|
||||
DO 100 I = 1, N
|
||||
DO 90 J = 1, N
|
||||
IF( I.LE.J ) THEN
|
||||
B( I, J ) = ( HALF-SIN( DCMPLX( I+J ) ) )*TWO
|
||||
E( I, J ) = ( HALF-SIN( DCMPLX( J ) ) )*TWO
|
||||
ELSE
|
||||
B( I, J ) = ZERO
|
||||
E( I, J ) = ZERO
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
*
|
||||
DO 120 I = 1, M
|
||||
DO 110 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DCMPLX( I+J ) ) )*TWENTY
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
*
|
||||
IF( PRTYPE.EQ.3 ) THEN
|
||||
IF( QBLCKA.LE.1 )
|
||||
$ QBLCKA = 2
|
||||
DO 130 K = 1, M - 1, QBLCKA
|
||||
A( K+1, K+1 ) = A( K, K )
|
||||
A( K+1, K ) = -SIN( A( K, K+1 ) )
|
||||
130 CONTINUE
|
||||
*
|
||||
IF( QBLCKB.LE.1 )
|
||||
$ QBLCKB = 2
|
||||
DO 140 K = 1, N - 1, QBLCKB
|
||||
B( K+1, K+1 ) = B( K, K )
|
||||
B( K+1, K ) = -SIN( B( K, K+1 ) )
|
||||
140 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE IF( PRTYPE.EQ.4 ) THEN
|
||||
DO 160 I = 1, M
|
||||
DO 150 J = 1, M
|
||||
A( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*TWENTY
|
||||
D( I, J ) = ( HALF-SIN( DCMPLX( I+J ) ) )*TWO
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
*
|
||||
DO 180 I = 1, N
|
||||
DO 170 J = 1, N
|
||||
B( I, J ) = ( HALF-SIN( DCMPLX( I+J ) ) )*TWENTY
|
||||
E( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*TWO
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
DO 200 I = 1, M
|
||||
DO 190 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DCMPLX( J / I ) ) )*TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*TWO
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
*
|
||||
ELSE IF( PRTYPE.GE.5 ) THEN
|
||||
REEPS = HALF*TWO*TWENTY / ALPHA
|
||||
IMEPS = ( HALF-TWO ) / ALPHA
|
||||
DO 220 I = 1, M
|
||||
DO 210 J = 1, N
|
||||
R( I, J ) = ( HALF-SIN( DCMPLX( I*J ) ) )*ALPHA / TWENTY
|
||||
L( I, J ) = ( HALF-SIN( DCMPLX( I+J ) ) )*ALPHA / TWENTY
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
*
|
||||
DO 230 I = 1, M
|
||||
D( I, I ) = ONE
|
||||
230 CONTINUE
|
||||
*
|
||||
DO 240 I = 1, M
|
||||
IF( I.LE.4 ) THEN
|
||||
A( I, I ) = ONE
|
||||
IF( I.GT.2 )
|
||||
$ A( I, I ) = ONE + REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
A( I, I ) = REEPS
|
||||
ELSE
|
||||
A( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = ONE
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -ONE
|
||||
END IF
|
||||
ELSE
|
||||
A( I, I ) = ONE
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
|
||||
A( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
A( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
240 CONTINUE
|
||||
*
|
||||
DO 250 I = 1, N
|
||||
E( I, I ) = ONE
|
||||
IF( I.LE.4 ) THEN
|
||||
B( I, I ) = -ONE
|
||||
IF( I.GT.2 )
|
||||
$ B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS
|
||||
END IF
|
||||
ELSE IF( I.LE.8 ) THEN
|
||||
IF( I.LE.6 ) THEN
|
||||
B( I, I ) = REEPS
|
||||
ELSE
|
||||
B( I, I ) = -REEPS
|
||||
END IF
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = ONE + IMEPS
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -ONE - IMEPS
|
||||
END IF
|
||||
ELSE
|
||||
B( I, I ) = ONE - REEPS
|
||||
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
|
||||
B( I, I+1 ) = IMEPS*2
|
||||
ELSE IF( I.GT.1 ) THEN
|
||||
B( I, I-1 ) = -IMEPS*2
|
||||
END IF
|
||||
END IF
|
||||
250 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Compute rhs (C, F)
|
||||
*
|
||||
CALL ZGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
|
||||
CALL ZGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
|
||||
CALL ZGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
|
||||
CALL ZGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
|
||||
*
|
||||
* End of ZLATM5
|
||||
*
|
||||
END
|
||||
300
lapack-netlib/TESTING/MATGEN/zlatm6.f
Normal file
300
lapack-netlib/TESTING/MATGEN/zlatm6.f
Normal file
@@ -0,0 +1,300 @@
|
||||
*> \brief \b ZLATM6
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
* BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER LDA, LDX, LDY, N, TYPE
|
||||
* COMPLEX*16 ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DIF( * ), S( * )
|
||||
* COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ),
|
||||
* $ Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATM6 generates test matrices for the generalized eigenvalue
|
||||
*> problem, their corresponding right and left eigenvector matrices,
|
||||
*> and also reciprocal condition numbers for all eigenvalues and
|
||||
*> the reciprocal condition numbers of eigenvectors corresponding to
|
||||
*> the 1th and 5th eigenvalues.
|
||||
*>
|
||||
*> Test Matrices
|
||||
*> =============
|
||||
*>
|
||||
*> Two kinds of test matrix pairs
|
||||
*> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
|
||||
*> are used in the tests:
|
||||
*>
|
||||
*> Type 1:
|
||||
*> Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 2+a 0 0 0 0 1 0 0 0
|
||||
*> 0 0 3+a 0 0 0 0 1 0 0
|
||||
*> 0 0 0 4+a 0 0 0 0 1 0
|
||||
*> 0 0 0 0 5+a , 0 0 0 0 1
|
||||
*> and Type 2:
|
||||
*> Da = 1+i 0 0 0 0 Db = 1 0 0 0 0
|
||||
*> 0 1-i 0 0 0 0 1 0 0 0
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0
|
||||
*> 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 .
|
||||
*>
|
||||
*> In both cases the same inverse(YH) and inverse(X) are used to compute
|
||||
*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
|
||||
*>
|
||||
*> YH: = 1 0 -y y -y X = 1 0 -x -x x
|
||||
*> 0 1 -y y -y 0 1 x -x -x
|
||||
*> 0 0 1 0 0 0 0 1 0 0
|
||||
*> 0 0 0 1 0 0 0 0 1 0
|
||||
*> 0 0 0 0 1, 0 0 0 0 1 , where
|
||||
*>
|
||||
*> a, b, x and y will have all values independently of each other.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TYPE
|
||||
*> \verbatim
|
||||
*> TYPE is INTEGER
|
||||
*> Specifies the problem type (see futher details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> Size of the matrices A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA, N).
|
||||
*> On exit A N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of A and of B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX*16 array, dimension (LDA, N).
|
||||
*> On exit B N-by-N is initialized according to TYPE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension (LDX, N).
|
||||
*> On exit X is the N-by-N matrix of right eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDX
|
||||
*> \verbatim
|
||||
*> LDX is INTEGER
|
||||
*> The leading dimension of X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16 array, dimension (LDY, N).
|
||||
*> On exit Y is the N-by-N matrix of left eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDY
|
||||
*> \verbatim
|
||||
*> LDY is INTEGER
|
||||
*> The leading dimension of Y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX*16
|
||||
*> \verbatim
|
||||
*> Weighting constants for matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WX
|
||||
*> \verbatim
|
||||
*> WX is COMPLEX*16
|
||||
*> Constant for right eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] WY
|
||||
*> \verbatim
|
||||
*> WY is COMPLEX*16
|
||||
*> Constant for left eigenvector matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] S
|
||||
*> \verbatim
|
||||
*> S is DOUBLE PRECISION array, dimension (N)
|
||||
*> S(i) is the reciprocal condition number for eigenvalue i.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] DIF
|
||||
*> \verbatim
|
||||
*> DIF is DOUBLE PRECISION array, dimension (N)
|
||||
*> DIF(i) is the reciprocal condition number for eigenvector i.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
|
||||
$ BETA, WX, WY, S, DIF )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER LDA, LDX, LDY, N, TYPE
|
||||
COMPLEX*16 ALPHA, BETA, WX, WY
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DIF( * ), S( * )
|
||||
COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ),
|
||||
$ Y( LDY, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION RONE, TWO, THREE
|
||||
PARAMETER ( RONE = 1.0D+0, TWO = 2.0D+0, THREE = 3.0D+0 )
|
||||
COMPLEX*16 ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, INFO, J
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION RWORK( 50 )
|
||||
COMPLEX*16 WORK( 26 ), Z( 8, 8 )
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CDABS, DBLE, DCMPLX, DCONJG, SQRT
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGESVD, ZLACPY, ZLAKF2
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Generate test problem ...
|
||||
* (Da, Db) ...
|
||||
*
|
||||
DO 20 I = 1, N
|
||||
DO 10 J = 1, N
|
||||
*
|
||||
IF( I.EQ.J ) THEN
|
||||
A( I, I ) = DCMPLX( I ) + ALPHA
|
||||
B( I, I ) = ONE
|
||||
ELSE
|
||||
A( I, J ) = ZERO
|
||||
B( I, J ) = ZERO
|
||||
END IF
|
||||
*
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
IF( TYPE.EQ.2 ) THEN
|
||||
A( 1, 1 ) = DCMPLX( RONE, RONE )
|
||||
A( 2, 2 ) = DCONJG( A( 1, 1 ) )
|
||||
A( 3, 3 ) = ONE
|
||||
A( 4, 4 ) = DCMPLX( DBLE( ONE+ALPHA ), DBLE( ONE+BETA ) )
|
||||
A( 5, 5 ) = DCONJG( A( 4, 4 ) )
|
||||
END IF
|
||||
*
|
||||
* Form X and Y
|
||||
*
|
||||
CALL ZLACPY( 'F', N, N, B, LDA, Y, LDY )
|
||||
Y( 3, 1 ) = -DCONJG( WY )
|
||||
Y( 4, 1 ) = DCONJG( WY )
|
||||
Y( 5, 1 ) = -DCONJG( WY )
|
||||
Y( 3, 2 ) = -DCONJG( WY )
|
||||
Y( 4, 2 ) = DCONJG( WY )
|
||||
Y( 5, 2 ) = -DCONJG( WY )
|
||||
*
|
||||
CALL ZLACPY( 'F', N, N, B, LDA, X, LDX )
|
||||
X( 1, 3 ) = -WX
|
||||
X( 1, 4 ) = -WX
|
||||
X( 1, 5 ) = WX
|
||||
X( 2, 3 ) = WX
|
||||
X( 2, 4 ) = -WX
|
||||
X( 2, 5 ) = -WX
|
||||
*
|
||||
* Form (A, B)
|
||||
*
|
||||
B( 1, 3 ) = WX + WY
|
||||
B( 2, 3 ) = -WX + WY
|
||||
B( 1, 4 ) = WX - WY
|
||||
B( 2, 4 ) = WX - WY
|
||||
B( 1, 5 ) = -WX + WY
|
||||
B( 2, 5 ) = WX + WY
|
||||
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
|
||||
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
|
||||
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
|
||||
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
|
||||
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
|
||||
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
|
||||
*
|
||||
* Compute condition numbers
|
||||
*
|
||||
S( 1 ) = RONE / SQRT( ( RONE+THREE*CDABS( WY )*CDABS( WY ) ) /
|
||||
$ ( RONE+CDABS( A( 1, 1 ) )*CDABS( A( 1, 1 ) ) ) )
|
||||
S( 2 ) = RONE / SQRT( ( RONE+THREE*CDABS( WY )*CDABS( WY ) ) /
|
||||
$ ( RONE+CDABS( A( 2, 2 ) )*CDABS( A( 2, 2 ) ) ) )
|
||||
S( 3 ) = RONE / SQRT( ( RONE+TWO*CDABS( WX )*CDABS( WX ) ) /
|
||||
$ ( RONE+CDABS( A( 3, 3 ) )*CDABS( A( 3, 3 ) ) ) )
|
||||
S( 4 ) = RONE / SQRT( ( RONE+TWO*CDABS( WX )*CDABS( WX ) ) /
|
||||
$ ( RONE+CDABS( A( 4, 4 ) )*CDABS( A( 4, 4 ) ) ) )
|
||||
S( 5 ) = RONE / SQRT( ( RONE+TWO*CDABS( WX )*CDABS( WX ) ) /
|
||||
$ ( RONE+CDABS( A( 5, 5 ) )*CDABS( A( 5, 5 ) ) ) )
|
||||
*
|
||||
CALL ZLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 8 )
|
||||
CALL ZGESVD( 'N', 'N', 8, 8, Z, 8, RWORK, WORK, 1, WORK( 2 ), 1,
|
||||
$ WORK( 3 ), 24, RWORK( 9 ), INFO )
|
||||
DIF( 1 ) = RWORK( 8 )
|
||||
*
|
||||
CALL ZLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 8 )
|
||||
CALL ZGESVD( 'N', 'N', 8, 8, Z, 8, RWORK, WORK, 1, WORK( 2 ), 1,
|
||||
$ WORK( 3 ), 24, RWORK( 9 ), INFO )
|
||||
DIF( 5 ) = RWORK( 8 )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATM6
|
||||
*
|
||||
END
|
||||
642
lapack-netlib/TESTING/MATGEN/zlatme.f
Normal file
642
lapack-netlib/TESTING/MATGEN/zlatme.f
Normal file
@@ -0,0 +1,642 @@
|
||||
*> \brief \b ZLATME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
|
||||
* RSIGN,
|
||||
* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
* A,
|
||||
* LDA, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
* INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
* DOUBLE PRECISION ANORM, COND, CONDS
|
||||
* COMPLEX*16 DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER ISEED( 4 )
|
||||
* DOUBLE PRECISION DS( * )
|
||||
* COMPLEX*16 A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATME generates random non-symmetric square matrices with
|
||||
*> specified eigenvalues for testing LAPACK programs.
|
||||
*>
|
||||
*> ZLATME operates by applying the following sequence of
|
||||
*> operations:
|
||||
*>
|
||||
*> 1. Set the diagonal to D, where D may be input or
|
||||
*> computed according to MODE, COND, DMAX, and RSIGN
|
||||
*> as described below.
|
||||
*>
|
||||
*> 2. If UPPER='T', the upper triangle of A is set to random values
|
||||
*> out of distribution DIST.
|
||||
*>
|
||||
*> 3. If SIM='T', A is multiplied on the left by a random matrix
|
||||
*> X, whose singular values are specified by DS, MODES, and
|
||||
*> CONDS, and on the right by X inverse.
|
||||
*>
|
||||
*> 4. If KL < N-1, the lower bandwidth is reduced to KL using
|
||||
*> Householder transformations. If KU < N-1, the upper
|
||||
*> bandwidth is reduced to KU.
|
||||
*>
|
||||
*> 5. If ANORM is not negative, the matrix is scaled to have
|
||||
*> maximum-element-norm ANORM.
|
||||
*>
|
||||
*> (Note: since the matrix cannot be reduced beyond Hessenberg form,
|
||||
*> no packing options are available.)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns (or rows) of A. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIST
|
||||
*> \verbatim
|
||||
*> DIST is CHARACTER*1
|
||||
*> On entry, DIST specifies the type of distribution to be used
|
||||
*> to generate the random eigen-/singular values, and on the
|
||||
*> upper triangle (see UPPER).
|
||||
*> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
|
||||
*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
|
||||
*> 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
|
||||
*> 'D' => uniform on the complex disc |z| < 1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ISEED
|
||||
*> \verbatim
|
||||
*> ISEED is INTEGER array, dimension ( 4 )
|
||||
*> On entry ISEED specifies the seed of the random number
|
||||
*> generator. They should lie between 0 and 4095 inclusive,
|
||||
*> and ISEED(4) should be odd. The random number generator
|
||||
*> uses a linear congruential sequence limited to small
|
||||
*> integers, and so should produce machine independent
|
||||
*> random numbers. The values of ISEED are changed on
|
||||
*> exit, and can be used in the next call to ZLATME
|
||||
*> to continue the same random number sequence.
|
||||
*> Changed on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is COMPLEX*16 array, dimension ( N )
|
||||
*> This array is used to specify the eigenvalues of A. If
|
||||
*> MODE=0, then D is assumed to contain the eigenvalues
|
||||
*> otherwise they will be computed according to MODE, COND,
|
||||
*> DMAX, and RSIGN and placed in D.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODE
|
||||
*> \verbatim
|
||||
*> MODE is INTEGER
|
||||
*> On entry this describes how the eigenvalues are to
|
||||
*> be specified:
|
||||
*> MODE = 0 means use D as input
|
||||
*> MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
|
||||
*> MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
|
||||
*> MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
|
||||
*> MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
|
||||
*> MODE = 5 sets D to random numbers in the range
|
||||
*> ( 1/COND , 1 ) such that their logarithms
|
||||
*> are uniformly distributed.
|
||||
*> MODE = 6 set D to random numbers from same distribution
|
||||
*> as the rest of the matrix.
|
||||
*> MODE < 0 has the same meaning as ABS(MODE), except that
|
||||
*> the order of the elements of D is reversed.
|
||||
*> Thus if MODE is between 1 and 4, D has entries ranging
|
||||
*> from 1 to 1/COND, if between -1 and -4, D has entries
|
||||
*> ranging from 1/COND to 1,
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] COND
|
||||
*> \verbatim
|
||||
*> COND is DOUBLE PRECISION
|
||||
*> On entry, this is used as described under MODE above.
|
||||
*> If used, it must be >= 1. Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DMAX
|
||||
*> \verbatim
|
||||
*> DMAX is COMPLEX*16
|
||||
*> If MODE is neither -6, 0 nor 6, the contents of D, as
|
||||
*> computed according to MODE and COND, will be scaled by
|
||||
*> DMAX / max(abs(D(i))). Note that DMAX need not be
|
||||
*> positive or real: if DMAX is negative or complex (or zero),
|
||||
*> D will be scaled by a negative or complex number (or zero).
|
||||
*> If RSIGN='F' then the largest (absolute) eigenvalue will be
|
||||
*> equal to DMAX.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] RSIGN
|
||||
*> \verbatim
|
||||
*> RSIGN is CHARACTER*1
|
||||
*> If MODE is not 0, 6, or -6, and RSIGN='T', then the
|
||||
*> elements of D, as computed according to MODE and COND, will
|
||||
*> be multiplied by a random complex number from the unit
|
||||
*> circle |z| = 1. If RSIGN='F', they will not be. RSIGN may
|
||||
*> only have the values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPPER
|
||||
*> \verbatim
|
||||
*> UPPER is CHARACTER*1
|
||||
*> If UPPER='T', then the elements of A above the diagonal
|
||||
*> will be set to random numbers out of DIST. If UPPER='F',
|
||||
*> they will not. UPPER may only have the values 'T' or 'F'.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SIM
|
||||
*> \verbatim
|
||||
*> SIM is CHARACTER*1
|
||||
*> If SIM='T', then A will be operated on by a "similarity
|
||||
*> transform", i.e., multiplied on the left by a matrix X and
|
||||
*> on the right by X inverse. X = U S V, where U and V are
|
||||
*> random unitary matrices and S is a (diagonal) matrix of
|
||||
*> singular values specified by DS, MODES, and CONDS. If
|
||||
*> SIM='F', then A will not be transformed.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DS
|
||||
*> \verbatim
|
||||
*> DS is DOUBLE PRECISION array, dimension ( N )
|
||||
*> This array is used to specify the singular values of X,
|
||||
*> in the same way that D specifies the eigenvalues of A.
|
||||
*> If MODE=0, the DS contains the singular values, which
|
||||
*> may not be zero.
|
||||
*> Modified if MODE is nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] MODES
|
||||
*> \verbatim
|
||||
*> MODES is INTEGER
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CONDS
|
||||
*> \verbatim
|
||||
*> CONDS is DOUBLE PRECISION
|
||||
*> Similar to MODE and COND, but for specifying the diagonal
|
||||
*> of S. MODES=-6 and +6 are not allowed (since they would
|
||||
*> result in randomly ill-conditioned eigenvalues.)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> This specifies the lower bandwidth of the matrix. KL=1
|
||||
*> specifies upper Hessenberg form. If KL is at least N-1,
|
||||
*> then A will have full lower bandwidth.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> This specifies the upper bandwidth of the matrix. KU=1
|
||||
*> specifies lower Hessenberg form. If KU is at least N-1,
|
||||
*> then A will have full upper bandwidth; if KU and KL
|
||||
*> are both at least N-1, then A will be dense. Only one of
|
||||
*> KU and KL may be less than N-1.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ANORM
|
||||
*> \verbatim
|
||||
*> ANORM is DOUBLE PRECISION
|
||||
*> If ANORM is not negative, then A will be scaled by a non-
|
||||
*> negative real number to make the maximum-element-norm of A
|
||||
*> to be ANORM.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension ( LDA, N )
|
||||
*> On exit A is the desired test matrix.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> LDA specifies the first dimension of A as declared in the
|
||||
*> calling program. LDA must be at least M.
|
||||
*> Not modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension ( 3*N )
|
||||
*> Workspace.
|
||||
*> Modified.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> Error code. On exit, INFO will be set to one of the
|
||||
*> following values:
|
||||
*> 0 => normal return
|
||||
*> -1 => N negative
|
||||
*> -2 => DIST illegal string
|
||||
*> -5 => MODE not in range -6 to 6
|
||||
*> -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
|
||||
*> -9 => RSIGN is not 'T' or 'F'
|
||||
*> -10 => UPPER is not 'T' or 'F'
|
||||
*> -11 => SIM is not 'T' or 'F'
|
||||
*> -12 => MODES=0 and DS has a zero singular value.
|
||||
*> -13 => MODES is not in the range -5 to 5.
|
||||
*> -14 => MODES is nonzero and CONDS is less than 1.
|
||||
*> -15 => KL is less than 1.
|
||||
*> -16 => KU is less than 1, or KL and KU are both less than
|
||||
*> N-1.
|
||||
*> -19 => LDA is less than M.
|
||||
*> 1 => Error return from ZLATM1 (computing D)
|
||||
*> 2 => Cannot scale to DMAX (max. eigenvalue is 0)
|
||||
*> 3 => Error return from DLATM1 (computing DS)
|
||||
*> 4 => Error return from ZLARGE
|
||||
*> 5 => Zero singular value from DLATM1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_matgen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
|
||||
$ RSIGN,
|
||||
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
|
||||
$ A,
|
||||
$ LDA, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIST, RSIGN, SIM, UPPER
|
||||
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
|
||||
DOUBLE PRECISION ANORM, COND, CONDS
|
||||
COMPLEX*16 DMAX
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER ISEED( 4 )
|
||||
DOUBLE PRECISION DS( * )
|
||||
COMPLEX*16 A( LDA, * ), D( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
COMPLEX*16 CZERO
|
||||
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
COMPLEX*16 CONE
|
||||
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL BADS
|
||||
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
|
||||
$ ISIM, IUPPER, J, JC, JCR
|
||||
DOUBLE PRECISION RALPHA, TEMP
|
||||
COMPLEX*16 ALPHA, TAU, XNORMS
|
||||
* ..
|
||||
* .. Local Arrays ..
|
||||
DOUBLE PRECISION TEMPA( 1 )
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
DOUBLE PRECISION ZLANGE
|
||||
COMPLEX*16 ZLARND
|
||||
EXTERNAL LSAME, ZLANGE, ZLARND
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLATM1, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZGERC,
|
||||
$ ZLACGV, ZLARFG, ZLARGE, ZLARNV, ZLASET, ZLATM1,
|
||||
$ ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DCONJG, MAX, MOD
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* 1) Decode and Test the input parameters.
|
||||
* Initialize flags & seed.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Decode DIST
|
||||
*
|
||||
IF( LSAME( DIST, 'U' ) ) THEN
|
||||
IDIST = 1
|
||||
ELSE IF( LSAME( DIST, 'S' ) ) THEN
|
||||
IDIST = 2
|
||||
ELSE IF( LSAME( DIST, 'N' ) ) THEN
|
||||
IDIST = 3
|
||||
ELSE IF( LSAME( DIST, 'D' ) ) THEN
|
||||
IDIST = 4
|
||||
ELSE
|
||||
IDIST = -1
|
||||
END IF
|
||||
*
|
||||
* Decode RSIGN
|
||||
*
|
||||
IF( LSAME( RSIGN, 'T' ) ) THEN
|
||||
IRSIGN = 1
|
||||
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
|
||||
IRSIGN = 0
|
||||
ELSE
|
||||
IRSIGN = -1
|
||||
END IF
|
||||
*
|
||||
* Decode UPPER
|
||||
*
|
||||
IF( LSAME( UPPER, 'T' ) ) THEN
|
||||
IUPPER = 1
|
||||
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
|
||||
IUPPER = 0
|
||||
ELSE
|
||||
IUPPER = -1
|
||||
END IF
|
||||
*
|
||||
* Decode SIM
|
||||
*
|
||||
IF( LSAME( SIM, 'T' ) ) THEN
|
||||
ISIM = 1
|
||||
ELSE IF( LSAME( SIM, 'F' ) ) THEN
|
||||
ISIM = 0
|
||||
ELSE
|
||||
ISIM = -1
|
||||
END IF
|
||||
*
|
||||
* Check DS, if MODES=0 and ISIM=1
|
||||
*
|
||||
BADS = .FALSE.
|
||||
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
|
||||
DO 10 J = 1, N
|
||||
IF( DS( J ).EQ.ZERO )
|
||||
$ BADS = .TRUE.
|
||||
10 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Set INFO if an error
|
||||
*
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( IDIST.EQ.-1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ABS( MODE ).GT.6 ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
|
||||
$ THEN
|
||||
INFO = -6
|
||||
ELSE IF( IRSIGN.EQ.-1 ) THEN
|
||||
INFO = -9
|
||||
ELSE IF( IUPPER.EQ.-1 ) THEN
|
||||
INFO = -10
|
||||
ELSE IF( ISIM.EQ.-1 ) THEN
|
||||
INFO = -11
|
||||
ELSE IF( BADS ) THEN
|
||||
INFO = -12
|
||||
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
|
||||
INFO = -13
|
||||
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
|
||||
INFO = -14
|
||||
ELSE IF( KL.LT.1 ) THEN
|
||||
INFO = -15
|
||||
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
|
||||
INFO = -16
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -19
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZLATME', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Initialize random number generator
|
||||
*
|
||||
DO 20 I = 1, 4
|
||||
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
|
||||
20 CONTINUE
|
||||
*
|
||||
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
|
||||
$ ISEED( 4 ) = ISEED( 4 ) + 1
|
||||
*
|
||||
* 2) Set up diagonal of A
|
||||
*
|
||||
* Compute D according to COND and MODE
|
||||
*
|
||||
CALL ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 1
|
||||
RETURN
|
||||
END IF
|
||||
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
|
||||
*
|
||||
* Scale by DMAX
|
||||
*
|
||||
TEMP = ABS( D( 1 ) )
|
||||
DO 30 I = 2, N
|
||||
TEMP = MAX( TEMP, ABS( D( I ) ) )
|
||||
30 CONTINUE
|
||||
*
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
ALPHA = DMAX / TEMP
|
||||
ELSE
|
||||
INFO = 2
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
CALL ZSCAL( N, ALPHA, D, 1 )
|
||||
*
|
||||
END IF
|
||||
*
|
||||
CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
|
||||
CALL ZCOPY( N, D, 1, A, LDA+1 )
|
||||
*
|
||||
* 3) If UPPER='T', set upper triangle of A to random numbers.
|
||||
*
|
||||
IF( IUPPER.NE.0 ) THEN
|
||||
DO 40 JC = 2, N
|
||||
CALL ZLARNV( IDIST, ISEED, JC-1, A( 1, JC ) )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* 4) If SIM='T', apply similarity transformation.
|
||||
*
|
||||
* -1
|
||||
* Transform is X A X , where X = U S V, thus
|
||||
*
|
||||
* it is U S V A V' (1/S) U'
|
||||
*
|
||||
IF( ISIM.NE.0 ) THEN
|
||||
*
|
||||
* Compute S (singular values of the eigenvector matrix)
|
||||
* according to CONDS and MODES
|
||||
*
|
||||
CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 3
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by V and V'
|
||||
*
|
||||
CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Multiply by S and (1/S)
|
||||
*
|
||||
DO 50 J = 1, N
|
||||
CALL ZDSCAL( N, DS( J ), A( J, 1 ), LDA )
|
||||
IF( DS( J ).NE.ZERO ) THEN
|
||||
CALL ZDSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
|
||||
ELSE
|
||||
INFO = 5
|
||||
RETURN
|
||||
END IF
|
||||
50 CONTINUE
|
||||
*
|
||||
* Multiply by U and U'
|
||||
*
|
||||
CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO )
|
||||
IF( IINFO.NE.0 ) THEN
|
||||
INFO = 4
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
* 5) Reduce the bandwidth.
|
||||
*
|
||||
IF( KL.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce bandwidth -- kill column
|
||||
*
|
||||
DO 60 JCR = KL + 1, N - 1
|
||||
IC = JCR - KL
|
||||
IROWS = N + 1 - JCR
|
||||
ICOLS = N + KL - JCR
|
||||
*
|
||||
CALL ZCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL ZLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
TAU = DCONJG( TAU )
|
||||
WORK( 1 ) = CONE
|
||||
ALPHA = ZLARND( 5, ISEED )
|
||||
*
|
||||
CALL ZGEMV( 'C', IROWS, ICOLS, CONE, A( JCR, IC+1 ), LDA,
|
||||
$ WORK, 1, CZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL ZGERC( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
|
||||
$ A( JCR, IC+1 ), LDA )
|
||||
*
|
||||
CALL ZGEMV( 'N', N, IROWS, CONE, A( 1, JCR ), LDA, WORK, 1,
|
||||
$ CZERO, WORK( IROWS+1 ), 1 )
|
||||
CALL ZGERC( N, IROWS, -DCONJG( TAU ), WORK( IROWS+1 ), 1,
|
||||
$ WORK, 1, A( 1, JCR ), LDA )
|
||||
*
|
||||
A( JCR, IC ) = XNORMS
|
||||
CALL ZLASET( 'Full', IROWS-1, 1, CZERO, CZERO,
|
||||
$ A( JCR+1, IC ), LDA )
|
||||
*
|
||||
CALL ZSCAL( ICOLS+1, ALPHA, A( JCR, IC ), LDA )
|
||||
CALL ZSCAL( N, DCONJG( ALPHA ), A( 1, JCR ), 1 )
|
||||
60 CONTINUE
|
||||
ELSE IF( KU.LT.N-1 ) THEN
|
||||
*
|
||||
* Reduce upper bandwidth -- kill a row at a time.
|
||||
*
|
||||
DO 70 JCR = KU + 1, N - 1
|
||||
IR = JCR - KU
|
||||
IROWS = N + KU - JCR
|
||||
ICOLS = N + 1 - JCR
|
||||
*
|
||||
CALL ZCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
|
||||
XNORMS = WORK( 1 )
|
||||
CALL ZLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
|
||||
TAU = DCONJG( TAU )
|
||||
WORK( 1 ) = CONE
|
||||
CALL ZLACGV( ICOLS-1, WORK( 2 ), 1 )
|
||||
ALPHA = ZLARND( 5, ISEED )
|
||||
*
|
||||
CALL ZGEMV( 'N', IROWS, ICOLS, CONE, A( IR+1, JCR ), LDA,
|
||||
$ WORK, 1, CZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL ZGERC( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
|
||||
$ A( IR+1, JCR ), LDA )
|
||||
*
|
||||
CALL ZGEMV( 'C', ICOLS, N, CONE, A( JCR, 1 ), LDA, WORK, 1,
|
||||
$ CZERO, WORK( ICOLS+1 ), 1 )
|
||||
CALL ZGERC( ICOLS, N, -DCONJG( TAU ), WORK, 1,
|
||||
$ WORK( ICOLS+1 ), 1, A( JCR, 1 ), LDA )
|
||||
*
|
||||
A( IR, JCR ) = XNORMS
|
||||
CALL ZLASET( 'Full', 1, ICOLS-1, CZERO, CZERO,
|
||||
$ A( IR, JCR+1 ), LDA )
|
||||
*
|
||||
CALL ZSCAL( IROWS+1, ALPHA, A( IR, JCR ), 1 )
|
||||
CALL ZSCAL( N, DCONJG( ALPHA ), A( JCR, 1 ), LDA )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
*
|
||||
* Scale the matrix to have norm ANORM
|
||||
*
|
||||
IF( ANORM.GE.ZERO ) THEN
|
||||
TEMP = ZLANGE( 'M', N, N, A, LDA, TEMPA )
|
||||
IF( TEMP.GT.ZERO ) THEN
|
||||
RALPHA = ANORM / TEMP
|
||||
DO 80 J = 1, N
|
||||
CALL ZDSCAL( N, RALPHA, A( 1, J ), 1 )
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATME
|
||||
*
|
||||
END
|
||||
1342
lapack-netlib/TESTING/MATGEN/zlatmr.f
Normal file
1342
lapack-netlib/TESTING/MATGEN/zlatmr.f
Normal file
File diff suppressed because it is too large
Load Diff
1256
lapack-netlib/TESTING/MATGEN/zlatms.f
Normal file
1256
lapack-netlib/TESTING/MATGEN/zlatms.f
Normal file
File diff suppressed because it is too large
Load Diff
1265
lapack-netlib/TESTING/MATGEN/zlatmt.f
Normal file
1265
lapack-netlib/TESTING/MATGEN/zlatmt.f
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user