LAPACK  3.10.1 LAPACK: Linear Algebra PACKage
clatm5.f
Go to the documentation of this file.
1 *> \brief \b CLATM5
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 CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
12 * E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
13 * QBLCKB )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
17 * \$ PRTYPE, QBLCKA, QBLCKB
18 * REAL ALPHA
19 * ..
20 * .. Array Arguments ..
21 * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
22 * \$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
23 * \$ L( LDL, * ), R( LDR, * )
24 * ..
25 *
26 *
27 *> \par Purpose:
28 * =============
29 *>
30 *> \verbatim
31 *>
32 *> CLATM5 generates matrices involved in the Generalized Sylvester
33 *> equation:
34 *>
35 *> A * R - L * B = C
36 *> D * R - L * E = F
37 *>
38 *> They also satisfy (the diagonalization condition)
39 *>
40 *> [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
41 *> [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
42 *>
43 *> \endverbatim
44 *
45 * Arguments:
46 * ==========
47 *
48 *> \param[in] PRTYPE
49 *> \verbatim
50 *> PRTYPE is INTEGER
51 *> "Points" to a certain type of the matrices to generate
52 *> (see further details).
53 *> \endverbatim
54 *>
55 *> \param[in] M
56 *> \verbatim
57 *> M is INTEGER
58 *> Specifies the order of A and D and the number of rows in
59 *> C, F, R and L.
60 *> \endverbatim
61 *>
62 *> \param[in] N
63 *> \verbatim
64 *> N is INTEGER
65 *> Specifies the order of B and E and the number of columns in
66 *> C, F, R and L.
67 *> \endverbatim
68 *>
69 *> \param[out] A
70 *> \verbatim
71 *> A is COMPLEX array, dimension (LDA, M).
72 *> On exit A M-by-M is initialized according to PRTYPE.
73 *> \endverbatim
74 *>
75 *> \param[in] LDA
76 *> \verbatim
77 *> LDA is INTEGER
78 *> The leading dimension of A.
79 *> \endverbatim
80 *>
81 *> \param[out] B
82 *> \verbatim
83 *> B is COMPLEX array, dimension (LDB, N).
84 *> On exit B N-by-N is initialized according to PRTYPE.
85 *> \endverbatim
86 *>
87 *> \param[in] LDB
88 *> \verbatim
89 *> LDB is INTEGER
90 *> The leading dimension of B.
91 *> \endverbatim
92 *>
93 *> \param[out] C
94 *> \verbatim
95 *> C is COMPLEX array, dimension (LDC, N).
96 *> On exit C M-by-N is initialized according to PRTYPE.
97 *> \endverbatim
98 *>
99 *> \param[in] LDC
100 *> \verbatim
101 *> LDC is INTEGER
102 *> The leading dimension of C.
103 *> \endverbatim
104 *>
105 *> \param[out] D
106 *> \verbatim
107 *> D is COMPLEX array, dimension (LDD, M).
108 *> On exit D M-by-M is initialized according to PRTYPE.
109 *> \endverbatim
110 *>
111 *> \param[in] LDD
112 *> \verbatim
113 *> LDD is INTEGER
114 *> The leading dimension of D.
115 *> \endverbatim
116 *>
117 *> \param[out] E
118 *> \verbatim
119 *> E is COMPLEX array, dimension (LDE, N).
120 *> On exit E N-by-N is initialized according to PRTYPE.
121 *> \endverbatim
122 *>
123 *> \param[in] LDE
124 *> \verbatim
125 *> LDE is INTEGER
126 *> The leading dimension of E.
127 *> \endverbatim
128 *>
129 *> \param[out] F
130 *> \verbatim
131 *> F is COMPLEX array, dimension (LDF, N).
132 *> On exit F M-by-N is initialized according to PRTYPE.
133 *> \endverbatim
134 *>
135 *> \param[in] LDF
136 *> \verbatim
137 *> LDF is INTEGER
138 *> The leading dimension of F.
139 *> \endverbatim
140 *>
141 *> \param[out] R
142 *> \verbatim
143 *> R is COMPLEX array, dimension (LDR, N).
144 *> On exit R M-by-N is initialized according to PRTYPE.
145 *> \endverbatim
146 *>
147 *> \param[in] LDR
148 *> \verbatim
149 *> LDR is INTEGER
150 *> The leading dimension of R.
151 *> \endverbatim
152 *>
153 *> \param[out] L
154 *> \verbatim
155 *> L is COMPLEX array, dimension (LDL, N).
156 *> On exit L M-by-N is initialized according to PRTYPE.
157 *> \endverbatim
158 *>
159 *> \param[in] LDL
160 *> \verbatim
161 *> LDL is INTEGER
162 *> The leading dimension of L.
163 *> \endverbatim
164 *>
165 *> \param[in] ALPHA
166 *> \verbatim
167 *> ALPHA is REAL
168 *> Parameter used in generating PRTYPE = 1 and 5 matrices.
169 *> \endverbatim
170 *>
171 *> \param[in] QBLCKA
172 *> \verbatim
173 *> QBLCKA is INTEGER
174 *> When PRTYPE = 3, specifies the distance between 2-by-2
175 *> blocks on the diagonal in A. Otherwise, QBLCKA is not
176 *> referenced. QBLCKA > 1.
177 *> \endverbatim
178 *>
179 *> \param[in] QBLCKB
180 *> \verbatim
181 *> QBLCKB is INTEGER
182 *> When PRTYPE = 3, specifies the distance between 2-by-2
183 *> blocks on the diagonal in B. Otherwise, QBLCKB is not
184 *> referenced. QBLCKB > 1.
185 *> \endverbatim
186 *
187 * Authors:
188 * ========
189 *
190 *> \author Univ. of Tennessee
191 *> \author Univ. of California Berkeley
192 *> \author Univ. of Colorado Denver
193 *> \author NAG Ltd.
194 *
195 *> \ingroup complex_matgen
196 *
197 *> \par Further Details:
198 * =====================
199 *>
200 *> \verbatim
201 *>
202 *> PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
203 *>
204 *> A : if (i == j) then A(i, j) = 1.0
205 *> if (j == i + 1) then A(i, j) = -1.0
206 *> else A(i, j) = 0.0, i, j = 1...M
207 *>
208 *> B : if (i == j) then B(i, j) = 1.0 - ALPHA
209 *> if (j == i + 1) then B(i, j) = 1.0
210 *> else B(i, j) = 0.0, i, j = 1...N
211 *>
212 *> D : if (i == j) then D(i, j) = 1.0
213 *> else D(i, j) = 0.0, i, j = 1...M
214 *>
215 *> E : if (i == j) then E(i, j) = 1.0
216 *> else E(i, j) = 0.0, i, j = 1...N
217 *>
218 *> L = R are chosen from [-10...10],
219 *> which specifies the right hand sides (C, F).
220 *>
221 *> PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
222 *>
223 *> A : if (i <= j) then A(i, j) = [-1...1]
224 *> else A(i, j) = 0.0, i, j = 1...M
225 *>
226 *> if (PRTYPE = 3) then
227 *> A(k + 1, k + 1) = A(k, k)
228 *> A(k + 1, k) = [-1...1]
229 *> sign(A(k, k + 1) = -(sin(A(k + 1, k))
230 *> k = 1, M - 1, QBLCKA
231 *>
232 *> B : if (i <= j) then B(i, j) = [-1...1]
233 *> else B(i, j) = 0.0, i, j = 1...N
234 *>
235 *> if (PRTYPE = 3) then
236 *> B(k + 1, k + 1) = B(k, k)
237 *> B(k + 1, k) = [-1...1]
238 *> sign(B(k, k + 1) = -(sign(B(k + 1, k))
239 *> k = 1, N - 1, QBLCKB
240 *>
241 *> D : if (i <= j) then D(i, j) = [-1...1].
242 *> else D(i, j) = 0.0, i, j = 1...M
243 *>
244 *>
245 *> E : if (i <= j) then D(i, j) = [-1...1]
246 *> else E(i, j) = 0.0, i, j = 1...N
247 *>
248 *> L, R are chosen from [-10...10],
249 *> which specifies the right hand sides (C, F).
250 *>
251 *> PRTYPE = 4 Full
252 *> A(i, j) = [-10...10]
253 *> D(i, j) = [-1...1] i,j = 1...M
254 *> B(i, j) = [-10...10]
255 *> E(i, j) = [-1...1] i,j = 1...N
256 *> R(i, j) = [-10...10]
257 *> L(i, j) = [-1...1] i = 1..M ,j = 1...N
258 *>
259 *> L, R specifies the right hand sides (C, F).
260 *>
261 *> PRTYPE = 5 special case common and/or close eigs.
262 *> \endverbatim
263 *>
264 * =====================================================================
265  SUBROUTINE clatm5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
266  \$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
267  \$ QBLCKB )
268 *
269 * -- LAPACK computational routine --
270 * -- LAPACK is a software package provided by Univ. of Tennessee, --
271 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
272 *
273 * .. Scalar Arguments ..
274  INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
275  \$ PRTYPE, QBLCKA, QBLCKB
276  REAL ALPHA
277 * ..
278 * .. Array Arguments ..
279  COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
280  \$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
281  \$ l( ldl, * ), r( ldr, * )
282 * ..
283 *
284 * =====================================================================
285 *
286 * .. Parameters ..
287  COMPLEX ONE, TWO, ZERO, HALF, TWENTY
288  PARAMETER ( ONE = ( 1.0e+0, 0.0e+0 ),
289  \$ two = ( 2.0e+0, 0.0e+0 ),
290  \$ zero = ( 0.0e+0, 0.0e+0 ),
291  \$ half = ( 0.5e+0, 0.0e+0 ),
292  \$ twenty = ( 2.0e+1, 0.0e+0 ) )
293 * ..
294 * .. Local Scalars ..
295  INTEGER I, J, K
296  COMPLEX IMEPS, REEPS
297 * ..
298 * .. Intrinsic Functions ..
299  INTRINSIC cmplx, mod, sin
300 * ..
301 * .. External Subroutines ..
302  EXTERNAL cgemm
303 * ..
304 * .. Executable Statements ..
305 *
306  IF( prtype.EQ.1 ) THEN
307  DO 20 i = 1, m
308  DO 10 j = 1, m
309  IF( i.EQ.j ) THEN
310  a( i, j ) = one
311  d( i, j ) = one
312  ELSE IF( i.EQ.j-1 ) THEN
313  a( i, j ) = -one
314  d( i, j ) = zero
315  ELSE
316  a( i, j ) = zero
317  d( i, j ) = zero
318  END IF
319  10 CONTINUE
320  20 CONTINUE
321 *
322  DO 40 i = 1, n
323  DO 30 j = 1, n
324  IF( i.EQ.j ) THEN
325  b( i, j ) = one - alpha
326  e( i, j ) = one
327  ELSE IF( i.EQ.j-1 ) THEN
328  b( i, j ) = one
329  e( i, j ) = zero
330  ELSE
331  b( i, j ) = zero
332  e( i, j ) = zero
333  END IF
334  30 CONTINUE
335  40 CONTINUE
336 *
337  DO 60 i = 1, m
338  DO 50 j = 1, n
339  r( i, j ) = ( half-sin( cmplx( i / j ) ) )*twenty
340  l( i, j ) = r( i, j )
341  50 CONTINUE
342  60 CONTINUE
343 *
344  ELSE IF( prtype.EQ.2 .OR. prtype.EQ.3 ) THEN
345  DO 80 i = 1, m
346  DO 70 j = 1, m
347  IF( i.LE.j ) THEN
348  a( i, j ) = ( half-sin( cmplx( i ) ) )*two
349  d( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
350  ELSE
351  a( i, j ) = zero
352  d( i, j ) = zero
353  END IF
354  70 CONTINUE
355  80 CONTINUE
356 *
357  DO 100 i = 1, n
358  DO 90 j = 1, n
359  IF( i.LE.j ) THEN
360  b( i, j ) = ( half-sin( cmplx( i+j ) ) )*two
361  e( i, j ) = ( half-sin( cmplx( j ) ) )*two
362  ELSE
363  b( i, j ) = zero
364  e( i, j ) = zero
365  END IF
366  90 CONTINUE
367  100 CONTINUE
368 *
369  DO 120 i = 1, m
370  DO 110 j = 1, n
371  r( i, j ) = ( half-sin( cmplx( i*j ) ) )*twenty
372  l( i, j ) = ( half-sin( cmplx( i+j ) ) )*twenty
373  110 CONTINUE
374  120 CONTINUE
375 *
376  IF( prtype.EQ.3 ) THEN
377  IF( qblcka.LE.1 )
378  \$ qblcka = 2
379  DO 130 k = 1, m - 1, qblcka
380  a( k+1, k+1 ) = a( k, k )
381  a( k+1, k ) = -sin( a( k, k+1 ) )
382  130 CONTINUE
383 *
384  IF( qblckb.LE.1 )
385  \$ qblckb = 2
386  DO 140 k = 1, n - 1, qblckb
387  b( k+1, k+1 ) = b( k, k )
388  b( k+1, k ) = -sin( b( k, k+1 ) )
389  140 CONTINUE
390  END IF
391 *
392  ELSE IF( prtype.EQ.4 ) THEN
393  DO 160 i = 1, m
394  DO 150 j = 1, m
395  a( i, j ) = ( half-sin( cmplx( i*j ) ) )*twenty
396  d( i, j ) = ( half-sin( cmplx( i+j ) ) )*two
397  150 CONTINUE
398  160 CONTINUE
399 *
400  DO 180 i = 1, n
401  DO 170 j = 1, n
402  b( i, j ) = ( half-sin( cmplx( i+j ) ) )*twenty
403  e( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
404  170 CONTINUE
405  180 CONTINUE
406 *
407  DO 200 i = 1, m
408  DO 190 j = 1, n
409  r( i, j ) = ( half-sin( cmplx( j / i ) ) )*twenty
410  l( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
411  190 CONTINUE
412  200 CONTINUE
413 *
414  ELSE IF( prtype.GE.5 ) THEN
415  reeps = half*two*twenty / alpha
416  imeps = ( half-two ) / alpha
417  DO 220 i = 1, m
418  DO 210 j = 1, n
419  r( i, j ) = ( half-sin( cmplx( i*j ) ) )*alpha / twenty
420  l( i, j ) = ( half-sin( cmplx( i+j ) ) )*alpha / twenty
421  210 CONTINUE
422  220 CONTINUE
423 *
424  DO 230 i = 1, m
425  d( i, i ) = one
426  230 CONTINUE
427 *
428  DO 240 i = 1, m
429  IF( i.LE.4 ) THEN
430  a( i, i ) = one
431  IF( i.GT.2 )
432  \$ a( i, i ) = one + reeps
433  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
434  a( i, i+1 ) = imeps
435  ELSE IF( i.GT.1 ) THEN
436  a( i, i-1 ) = -imeps
437  END IF
438  ELSE IF( i.LE.8 ) THEN
439  IF( i.LE.6 ) THEN
440  a( i, i ) = reeps
441  ELSE
442  a( i, i ) = -reeps
443  END IF
444  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
445  a( i, i+1 ) = one
446  ELSE IF( i.GT.1 ) THEN
447  a( i, i-1 ) = -one
448  END IF
449  ELSE
450  a( i, i ) = one
451  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
452  a( i, i+1 ) = imeps*2
453  ELSE IF( i.GT.1 ) THEN
454  a( i, i-1 ) = -imeps*2
455  END IF
456  END IF
457  240 CONTINUE
458 *
459  DO 250 i = 1, n
460  e( i, i ) = one
461  IF( i.LE.4 ) THEN
462  b( i, i ) = -one
463  IF( i.GT.2 )
464  \$ b( i, i ) = one - reeps
465  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
466  b( i, i+1 ) = imeps
467  ELSE IF( i.GT.1 ) THEN
468  b( i, i-1 ) = -imeps
469  END IF
470  ELSE IF( i.LE.8 ) THEN
471  IF( i.LE.6 ) THEN
472  b( i, i ) = reeps
473  ELSE
474  b( i, i ) = -reeps
475  END IF
476  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
477  b( i, i+1 ) = one + imeps
478  ELSE IF( i.GT.1 ) THEN
479  b( i, i-1 ) = -one - imeps
480  END IF
481  ELSE
482  b( i, i ) = one - reeps
483  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
484  b( i, i+1 ) = imeps*2
485  ELSE IF( i.GT.1 ) THEN
486  b( i, i-1 ) = -imeps*2
487  END IF
488  END IF
489  250 CONTINUE
490  END IF
491 *
492 * Compute rhs (C, F)
493 *
494  CALL cgemm( 'N', 'N', m, n, m, one, a, lda, r, ldr, zero, c, ldc )
495  CALL cgemm( 'N', 'N', m, n, n, -one, l, ldl, b, ldb, one, c, ldc )
496  CALL cgemm( 'N', 'N', m, n, m, one, d, ldd, r, ldr, zero, f, ldf )
497  CALL cgemm( 'N', 'N', m, n, n, -one, l, ldl, e, lde, one, f, ldf )
498 *
499 * End of CLATM5
500 *
501  END
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:187
subroutine clatm5(PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, QBLCKB)
CLATM5
Definition: clatm5.f:268