165 lines
5.7 KiB
Fortran
165 lines
5.7 KiB
Fortran
DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2,
|
|
$ LDQ2, RES, LDRES )
|
|
C
|
|
C SLICOT RELEASE 5.0.
|
|
C
|
|
C Copyright (c) 2002-2009 NICONET e.V.
|
|
C
|
|
C This program is free software: you can redistribute it and/or
|
|
C modify it under the terms of the GNU General Public License as
|
|
C published by the Free Software Foundation, either version 2 of
|
|
C the License, or (at your option) any later version.
|
|
C
|
|
C This program is distributed in the hope that it will be useful,
|
|
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
C GNU General Public License for more details.
|
|
C
|
|
C You should have received a copy of the GNU General Public License
|
|
C along with this program. If not, see
|
|
C <http://www.gnu.org/licenses/>.
|
|
C
|
|
C PURPOSE
|
|
C
|
|
C To compute || Q^T Q - I ||_F for a matrix of the form
|
|
C
|
|
C [ op( Q1 ) op( Q2 ) ]
|
|
C Q = [ ],
|
|
C [ -op( Q2 ) op( Q1 ) ]
|
|
C
|
|
C where Q1 and Q2 are N-by-N matrices. This residual can be used to
|
|
C test wether Q is numerically an orthogonal symplectic matrix.
|
|
C
|
|
C FUNCTION VALUE
|
|
C
|
|
C MA02JD DOUBLE PRECISION
|
|
C The computed residual.
|
|
C
|
|
C ARGUMENTS
|
|
C
|
|
C Mode Parameters
|
|
C
|
|
C LTRAN1 LOGICAL
|
|
C Specifies the form of op( Q1 ) as follows:
|
|
C = .FALSE.: op( Q1 ) = Q1;
|
|
C = .TRUE. : op( Q1 ) = Q1'.
|
|
C
|
|
C LTRAN2 LOGICAL
|
|
C Specifies the form of op( Q2 ) as follows:
|
|
C = .FALSE.: op( Q2 ) = Q2;
|
|
C = .TRUE. : op( Q2 ) = Q2'.
|
|
C
|
|
C Input/Output Parameters
|
|
C
|
|
C N (input) INTEGER
|
|
C The order of the matrices Q1 and Q2. N >= 0.
|
|
C
|
|
C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N)
|
|
C On entry, the leading N-by-N part of this array must
|
|
C contain the matrix op( Q1 ).
|
|
C
|
|
C LDQ1 INTEGER
|
|
C The leading dimension of the array Q1. LDQ1 >= MAX(1,N).
|
|
C
|
|
C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N)
|
|
C On entry, the leading N-by-N part of this array must
|
|
C contain the matrix op( Q2 ).
|
|
C
|
|
C LDQ2 INTEGER
|
|
C The leading dimension of the array Q2. LDQ2 >= MAX(1,N).
|
|
C
|
|
C Workspace
|
|
C
|
|
C RES DOUBLE PRECISION array, dimension (LDRES,N)
|
|
C
|
|
C LDRES INTEGER
|
|
C The leading dimension of the array RES. LDRES >= MAX(1,N).
|
|
C
|
|
C METHOD
|
|
C
|
|
C The routine computes the residual by simple elementary operations.
|
|
C
|
|
C CONTRIBUTORS
|
|
C
|
|
C D. Kressner, Technical Univ. Berlin, Germany, and
|
|
C P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
|
|
C
|
|
C REVISIONS
|
|
C
|
|
C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS).
|
|
C
|
|
C KEYWORDS
|
|
C
|
|
C Elementary operations.
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C .. Parameters ..
|
|
DOUBLE PRECISION ZERO, ONE, TWO
|
|
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
|
|
C .. Scalar Arguments ..
|
|
LOGICAL LTRAN1, LTRAN2
|
|
INTEGER LDQ1, LDQ2, LDRES, N
|
|
C .. Array Arguments ..
|
|
DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*)
|
|
C .. Local Scalars ..
|
|
INTEGER I
|
|
DOUBLE PRECISION TEMP
|
|
C .. Local Arrays ..
|
|
DOUBLE PRECISION DUMMY(1)
|
|
C .. External Subroutines ..
|
|
EXTERNAL DGEMM
|
|
C .. External Functions ..
|
|
DOUBLE PRECISION DLANGE, DLAPY2
|
|
EXTERNAL DLANGE, DLAPY2
|
|
C .. Intrinsic Functions ..
|
|
INTRINSIC SQRT
|
|
C
|
|
C .. Executable Statements ..
|
|
C
|
|
IF ( LTRAN1 ) THEN
|
|
CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q1, LDQ1, ZERO, RES, LDRES )
|
|
ELSE
|
|
CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q1, LDQ1, ZERO, RES, LDRES )
|
|
END IF
|
|
IF ( LTRAN2 ) THEN
|
|
CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q2, LDQ2, ONE, RES, LDRES )
|
|
ELSE
|
|
CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q2, LDQ2, ONE, RES, LDRES )
|
|
END IF
|
|
DO 10 I = 1, N
|
|
RES(I,I) = RES(I,I) - ONE
|
|
10 CONTINUE
|
|
TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY )
|
|
IF ( LTRAN1 .AND. LTRAN2 ) THEN
|
|
CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
|
|
CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
|
|
ELSE IF ( LTRAN1 ) THEN
|
|
CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
|
|
CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
|
|
ELSE IF ( LTRAN2 ) THEN
|
|
CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
|
|
CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
|
|
ELSE
|
|
CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2,
|
|
$ LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
|
|
CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1,
|
|
$ LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
|
|
END IF
|
|
TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES,
|
|
$ DUMMY ) )
|
|
MA02JD = SQRT( TWO )*TEMP
|
|
RETURN
|
|
C *** Last line of MA02JD ***
|
|
END
|