1*> \brief \b SGET51
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       SUBROUTINE SGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
12*                          RESULT )
13*
14*       .. Scalar Arguments ..
15*       INTEGER            ITYPE, LDA, LDB, LDU, LDV, N
16*       REAL               RESULT
17*       ..
18*       .. Array Arguments ..
19*       REAL               A( LDA, * ), B( LDB, * ), U( LDU, * ),
20*      $                   V( LDV, * ), WORK( * )
21*       ..
22*
23*
24*> \par Purpose:
25*  =============
26*>
27*> \verbatim
28*>
29*>      SGET51  generally checks a decomposition of the form
30*>
31*>              A = U B V'
32*>
33*>      where ' means transpose and U and V are orthogonal.
34*>
35*>      Specifically, if ITYPE=1
36*>
37*>              RESULT = | A - U B V' | / ( |A| n ulp )
38*>
39*>      If ITYPE=2, then:
40*>
41*>              RESULT = | A - B | / ( |A| n ulp )
42*>
43*>      If ITYPE=3, then:
44*>
45*>              RESULT = | I - UU' | / ( n ulp )
46*> \endverbatim
47*
48*  Arguments:
49*  ==========
50*
51*> \param[in] ITYPE
52*> \verbatim
53*>          ITYPE is INTEGER
54*>          Specifies the type of tests to be performed.
55*>          =1: RESULT = | A - U B V' | / ( |A| n ulp )
56*>          =2: RESULT = | A - B | / ( |A| n ulp )
57*>          =3: RESULT = | I - UU' | / ( n ulp )
58*> \endverbatim
59*>
60*> \param[in] N
61*> \verbatim
62*>          N is INTEGER
63*>          The size of the matrix.  If it is zero, SGET51 does nothing.
64*>          It must be at least zero.
65*> \endverbatim
66*>
67*> \param[in] A
68*> \verbatim
69*>          A is REAL array, dimension (LDA, N)
70*>          The original (unfactored) matrix.
71*> \endverbatim
72*>
73*> \param[in] LDA
74*> \verbatim
75*>          LDA is INTEGER
76*>          The leading dimension of A.  It must be at least 1
77*>          and at least N.
78*> \endverbatim
79*>
80*> \param[in] B
81*> \verbatim
82*>          B is REAL array, dimension (LDB, N)
83*>          The factored matrix.
84*> \endverbatim
85*>
86*> \param[in] LDB
87*> \verbatim
88*>          LDB is INTEGER
89*>          The leading dimension of B.  It must be at least 1
90*>          and at least N.
91*> \endverbatim
92*>
93*> \param[in] U
94*> \verbatim
95*>          U is REAL array, dimension (LDU, N)
96*>          The orthogonal matrix on the left-hand side in the
97*>          decomposition.
98*>          Not referenced if ITYPE=2
99*> \endverbatim
100*>
101*> \param[in] LDU
102*> \verbatim
103*>          LDU is INTEGER
104*>          The leading dimension of U.  LDU must be at least N and
105*>          at least 1.
106*> \endverbatim
107*>
108*> \param[in] V
109*> \verbatim
110*>          V is REAL array, dimension (LDV, N)
111*>          The orthogonal matrix on the left-hand side in the
112*>          decomposition.
113*>          Not referenced if ITYPE=2
114*> \endverbatim
115*>
116*> \param[in] LDV
117*> \verbatim
118*>          LDV is INTEGER
119*>          The leading dimension of V.  LDV must be at least N and
120*>          at least 1.
121*> \endverbatim
122*>
123*> \param[out] WORK
124*> \verbatim
125*>          WORK is REAL array, dimension (2*N**2)
126*> \endverbatim
127*>
128*> \param[out] RESULT
129*> \verbatim
130*>          RESULT is REAL
131*>          The values computed by the test specified by ITYPE.  The
132*>          value is currently limited to 1/ulp, to avoid overflow.
133*>          Errors are flagged by RESULT=10/ulp.
134*> \endverbatim
135*
136*  Authors:
137*  ========
138*
139*> \author Univ. of Tennessee
140*> \author Univ. of California Berkeley
141*> \author Univ. of Colorado Denver
142*> \author NAG Ltd.
143*
144*> \ingroup single_eig
145*
146*  =====================================================================
147      SUBROUTINE SGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
148     $                   RESULT )
149*
150*  -- LAPACK test routine --
151*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
152*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154*     .. Scalar Arguments ..
155      INTEGER            ITYPE, LDA, LDB, LDU, LDV, N
156      REAL               RESULT
157*     ..
158*     .. Array Arguments ..
159      REAL               A( LDA, * ), B( LDB, * ), U( LDU, * ),
160     $                   V( LDV, * ), WORK( * )
161*     ..
162*
163*  =====================================================================
164*
165*     .. Parameters ..
166      REAL               ZERO, ONE, TEN
167      PARAMETER          ( ZERO = 0.0, ONE = 1.0E0, TEN = 10.0E0 )
168*     ..
169*     .. Local Scalars ..
170      INTEGER            JCOL, JDIAG, JROW
171      REAL               ANORM, ULP, UNFL, WNORM
172*     ..
173*     .. External Functions ..
174      REAL               SLAMCH, SLANGE
175      EXTERNAL           SLAMCH, SLANGE
176*     ..
177*     .. External Subroutines ..
178      EXTERNAL           SGEMM, SLACPY
179*     ..
180*     .. Intrinsic Functions ..
181      INTRINSIC          MAX, MIN, REAL
182*     ..
183*     .. Executable Statements ..
184*
185      RESULT = ZERO
186      IF( N.LE.0 )
187     $   RETURN
188*
189*     Constants
190*
191      UNFL = SLAMCH( 'Safe minimum' )
192      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
193*
194*     Some Error Checks
195*
196      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
197         RESULT = TEN / ULP
198         RETURN
199      END IF
200*
201      IF( ITYPE.LE.2 ) THEN
202*
203*        Tests scaled by the norm(A)
204*
205         ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK ), UNFL )
206*
207         IF( ITYPE.EQ.1 ) THEN
208*
209*           ITYPE=1: Compute W = A - UBV'
210*
211            CALL SLACPY( ' ', N, N, A, LDA, WORK, N )
212            CALL SGEMM( 'N', 'N', N, N, N, ONE, U, LDU, B, LDB, ZERO,
213     $                  WORK( N**2+1 ), N )
214*
215            CALL SGEMM( 'N', 'C', N, N, N, -ONE, WORK( N**2+1 ), N, V,
216     $                  LDV, ONE, WORK, N )
217*
218         ELSE
219*
220*           ITYPE=2: Compute W = A - B
221*
222            CALL SLACPY( ' ', N, N, B, LDB, WORK, N )
223*
224            DO 20 JCOL = 1, N
225               DO 10 JROW = 1, N
226                  WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
227     $                - A( JROW, JCOL )
228   10          CONTINUE
229   20       CONTINUE
230         END IF
231*
232*        Compute norm(W)/ ( ulp*norm(A) )
233*
234         WNORM = SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
235*
236         IF( ANORM.GT.WNORM ) THEN
237            RESULT = ( WNORM / ANORM ) / ( N*ULP )
238         ELSE
239            IF( ANORM.LT.ONE ) THEN
240               RESULT = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
241            ELSE
242               RESULT = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
243            END IF
244         END IF
245*
246      ELSE
247*
248*        Tests not scaled by norm(A)
249*
250*        ITYPE=3: Compute  UU' - I
251*
252         CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
253     $               N )
254*
255         DO 30 JDIAG = 1, N
256            WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+
257     $         1 ) - ONE
258   30    CONTINUE
259*
260         RESULT = MIN( SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
261     $            REAL( N ) ) / ( N*ULP )
262      END IF
263*
264      RETURN
265*
266*     End of SGET51
267*
268      END
269