LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
cglmts.f
Go to the documentation of this file.
1 *> \brief \b CGLMTS
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 CGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF,
12 * X, U, WORK, LWORK, RWORK, RESULT )
13 *
14 * .. Scalar Arguments ..
15 * INTEGER LDA, LDB, LWORK, M, P, N
16 * REAL RESULT
17 * ..
18 * .. Array Arguments ..
19 * REAL RWORK( * )
20 * COMPLEX A( LDA, * ), AF( LDA, * ), B( LDB, * ),
21 * $ BF( LDB, * ), D( * ), DF( * ), U( * ),
22 * $ WORK( LWORK ), X( * )
23 *
24 *
25 *> \par Purpose:
26 * =============
27 *>
28 *> \verbatim
29 *>
30 *> CGLMTS tests CGGGLM - a subroutine for solving the generalized
31 *> linear model problem.
32 *> \endverbatim
33 *
34 * Arguments:
35 * ==========
36 *
37 *> \param[in] N
38 *> \verbatim
39 *> N is INTEGER
40 *> The number of rows of the matrices A and B. N >= 0.
41 *> \endverbatim
42 *>
43 *> \param[in] M
44 *> \verbatim
45 *> M is INTEGER
46 *> The number of columns of the matrix A. M >= 0.
47 *> \endverbatim
48 *>
49 *> \param[in] P
50 *> \verbatim
51 *> P is INTEGER
52 *> The number of columns of the matrix B. P >= 0.
53 *> \endverbatim
54 *>
55 *> \param[in] A
56 *> \verbatim
57 *> A is COMPLEX array, dimension (LDA,M)
58 *> The N-by-M matrix A.
59 *> \endverbatim
60 *>
61 *> \param[out] AF
62 *> \verbatim
63 *> AF is COMPLEX array, dimension (LDA,M)
64 *> \endverbatim
65 *>
66 *> \param[in] LDA
67 *> \verbatim
68 *> LDA is INTEGER
69 *> The leading dimension of the arrays A, AF. LDA >= max(M,N).
70 *> \endverbatim
71 *>
72 *> \param[in] B
73 *> \verbatim
74 *> B is COMPLEX array, dimension (LDB,P)
75 *> The N-by-P matrix A.
76 *> \endverbatim
77 *>
78 *> \param[out] BF
79 *> \verbatim
80 *> BF is COMPLEX array, dimension (LDB,P)
81 *> \endverbatim
82 *>
83 *> \param[in] LDB
84 *> \verbatim
85 *> LDB is INTEGER
86 *> The leading dimension of the arrays B, BF. LDB >= max(P,N).
87 *> \endverbatim
88 *>
89 *> \param[in] D
90 *> \verbatim
91 *> D is COMPLEX array, dimension( N )
92 *> On input, the left hand side of the GLM.
93 *> \endverbatim
94 *>
95 *> \param[out] DF
96 *> \verbatim
97 *> DF is COMPLEX array, dimension( N )
98 *> \endverbatim
99 *>
100 *> \param[out] X
101 *> \verbatim
102 *> X is COMPLEX array, dimension( M )
103 *> solution vector X in the GLM problem.
104 *> \endverbatim
105 *>
106 *> \param[out] U
107 *> \verbatim
108 *> U is COMPLEX array, dimension( P )
109 *> solution vector U in the GLM problem.
110 *> \endverbatim
111 *>
112 *> \param[out] WORK
113 *> \verbatim
114 *> WORK is COMPLEX array, dimension (LWORK)
115 *> \endverbatim
116 *>
117 *> \param[in] LWORK
118 *> \verbatim
119 *> LWORK is INTEGER
120 *> The dimension of the array WORK.
121 *> \endverbatim
122 *>
123 *> \param[out] RWORK
124 *> \verbatim
125 *> RWORK is REAL array, dimension (M)
126 *> \endverbatim
127 *>
128 *> \param[out] RESULT
129 *> \verbatim
130 *> RESULT is REAL
131 *> The test ratio:
132 *> norm( d - A*x - B*u )
133 *> RESULT = -----------------------------------------
134 *> (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
135 *> \endverbatim
136 *
137 * Authors:
138 * ========
139 *
140 *> \author Univ. of Tennessee
141 *> \author Univ. of California Berkeley
142 *> \author Univ. of Colorado Denver
143 *> \author NAG Ltd.
144 *
145 *> \date November 2011
146 *
147 *> \ingroup complex_eig
148 *
149 * =====================================================================
150  SUBROUTINE cglmts( N, M, P, A, AF, LDA, B, BF, LDB, D, DF,
151  $ x, u, work, lwork, rwork, result )
152 *
153 * -- LAPACK test routine (version 3.4.0) --
154 * -- LAPACK is a software package provided by Univ. of Tennessee, --
155 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156 * November 2011
157 *
158 * .. Scalar Arguments ..
159  INTEGER lda, ldb, lwork, m, p, n
160  REAL result
161 * ..
162 * .. Array Arguments ..
163  REAL rwork( * )
164  COMPLEX a( lda, * ), af( lda, * ), b( ldb, * ),
165  $ bf( ldb, * ), d( * ), df( * ), u( * ),
166  $ work( lwork ), x( * )
167 *
168 * ====================================================================
169 *
170 * .. Parameters ..
171  REAL zero
172  parameter( zero = 0.0e+0 )
173  COMPLEX cone
174  parameter( cone = 1.0e+0 )
175 * ..
176 * .. Local Scalars ..
177  INTEGER info
178  REAL anorm, bnorm, eps, xnorm, ynorm, dnorm, unfl
179 * ..
180 * .. External Functions ..
181  REAL scasum, slamch, clange
182  EXTERNAL scasum, slamch, clange
183 * ..
184 * .. External Subroutines ..
185  EXTERNAL clacpy
186 *
187 * .. Intrinsic Functions ..
188  INTRINSIC max
189 * ..
190 * .. Executable Statements ..
191 *
192  eps = slamch( 'Epsilon' )
193  unfl = slamch( 'Safe minimum' )
194  anorm = max( clange( '1', n, m, a, lda, rwork ), unfl )
195  bnorm = max( clange( '1', n, p, b, ldb, rwork ), unfl )
196 *
197 * Copy the matrices A and B to the arrays AF and BF,
198 * and the vector D the array DF.
199 *
200  CALL clacpy( 'Full', n, m, a, lda, af, lda )
201  CALL clacpy( 'Full', n, p, b, ldb, bf, ldb )
202  CALL ccopy( n, d, 1, df, 1 )
203 *
204 * Solve GLM problem
205 *
206  CALL cggglm( n, m, p, af, lda, bf, ldb, df, x, u, work, lwork,
207  $ info )
208 *
209 * Test the residual for the solution of LSE
210 *
211 * norm( d - A*x - B*u )
212 * RESULT = -----------------------------------------
213 * (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
214 *
215  CALL ccopy( n, d, 1, df, 1 )
216  CALL cgemv( 'No transpose', n, m, -cone, a, lda, x, 1, cone,
217  $ df, 1 )
218 *
219  CALL cgemv( 'No transpose', n, p, -cone, b, ldb, u, 1, cone,
220  $ df, 1 )
221 *
222  dnorm = scasum( n, df, 1 )
223  xnorm = scasum( m, x, 1 ) + scasum( p, u, 1 )
224  ynorm = anorm + bnorm
225 *
226  IF( xnorm.LE.zero ) THEN
227  result = zero
228  ELSE
229  result = ( ( dnorm / ynorm ) / xnorm ) /eps
230  END IF
231 *
232  RETURN
233 *
234 * End of CGLMTS
235 *
236  END