LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine clatm5 ( integer  PRTYPE,
integer  M,
integer  N,
complex, dimension( lda, * )  A,
integer  LDA,
complex, dimension( ldb, * )  B,
integer  LDB,
complex, dimension( ldc, * )  C,
integer  LDC,
complex, dimension( ldd, * )  D,
integer  LDD,
complex, dimension( lde, * )  E,
integer  LDE,
complex, dimension( ldf, * )  F,
integer  LDF,
complex, dimension( ldr, * )  R,
integer  LDR,
complex, dimension( ldl, * )  L,
integer  LDL,
real  ALPHA,
integer  QBLCKA,
integer  QBLCKB 
)

CLATM5

Purpose: 
 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 ] )
Parameters
[in]PRTYPE
          PRTYPE is INTEGER
          "Points" to a certain type of the matrices to generate
          (see futher details).
[in]M
          M is INTEGER
          Specifies the order of A and D and the number of rows in
          C, F,  R and L.
[in]N
          N is INTEGER
          Specifies the order of B and E and the number of columns in
          C, F, R and L.
[out]A
          A is COMPLEX array, dimension (LDA, M).
          On exit A M-by-M is initialized according to PRTYPE.
[in]LDA
          LDA is INTEGER
          The leading dimension of A.
[out]B
          B is COMPLEX array, dimension (LDB, N).
          On exit B N-by-N is initialized according to PRTYPE.
[in]LDB
          LDB is INTEGER
          The leading dimension of B.
[out]C
          C is COMPLEX array, dimension (LDC, N).
          On exit C M-by-N is initialized according to PRTYPE.
[in]LDC
          LDC is INTEGER
          The leading dimension of C.
[out]D
          D is COMPLEX array, dimension (LDD, M).
          On exit D M-by-M is initialized according to PRTYPE.
[in]LDD
          LDD is INTEGER
          The leading dimension of D.
[out]E
          E is COMPLEX array, dimension (LDE, N).
          On exit E N-by-N is initialized according to PRTYPE.
[in]LDE
          LDE is INTEGER
          The leading dimension of E.
[out]F
          F is COMPLEX array, dimension (LDF, N).
          On exit F M-by-N is initialized according to PRTYPE.
[in]LDF
          LDF is INTEGER
          The leading dimension of F.
[out]R
          R is COMPLEX array, dimension (LDR, N).
          On exit R M-by-N is initialized according to PRTYPE.
[in]LDR
          LDR is INTEGER
          The leading dimension of R.
[out]L
          L is COMPLEX array, dimension (LDL, N).
          On exit L M-by-N is initialized according to PRTYPE.
[in]LDL
          LDL is INTEGER
          The leading dimension of L.
[in]ALPHA
          ALPHA is REAL
          Parameter used in generating PRTYPE = 1 and 5 matrices.
[in]QBLCKA
          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.
[in]QBLCKB
          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.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
June 2016
Further Details: 
  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.

Definition at line 270 of file clatm5.f.

270 *
271 * -- LAPACK computational routine (version 3.6.1) --
272 * -- LAPACK is a software package provided by Univ. of Tennessee, --
273 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
274 * June 2016
275 *
276 * .. Scalar Arguments ..
277  INTEGER lda, ldb, ldc, ldd, lde, ldf, ldl, ldr, m, n,
278  $ prtype, qblcka, qblckb
279  REAL alpha
280 * ..
281 * .. Array Arguments ..
282  COMPLEX a( lda, * ), b( ldb, * ), c( ldc, * ),
283  $ d( ldd, * ), e( lde, * ), f( ldf, * ),
284  $ l( ldl, * ), r( ldr, * )
285 * ..
286 *
287 * =====================================================================
288 *
289 * .. Parameters ..
290  COMPLEX one, two, zero, half, twenty
291  parameter ( one = ( 1.0e+0, 0.0e+0 ),
292  $ two = ( 2.0e+0, 0.0e+0 ),
293  $ zero = ( 0.0e+0, 0.0e+0 ),
294  $ half = ( 0.5e+0, 0.0e+0 ),
295  $ twenty = ( 2.0e+1, 0.0e+0 ) )
296 * ..
297 * .. Local Scalars ..
298  INTEGER i, j, k
299  COMPLEX imeps, reeps
300 * ..
301 * .. Intrinsic Functions ..
302  INTRINSIC cmplx, mod, sin
303 * ..
304 * .. External Subroutines ..
305  EXTERNAL cgemm
306 * ..
307 * .. Executable Statements ..
308 *
309  IF( prtype.EQ.1 ) THEN
310  DO 20 i = 1, m
311  DO 10 j = 1, m
312  IF( i.EQ.j ) THEN
313  a( i, j ) = one
314  d( i, j ) = one
315  ELSE IF( i.EQ.j-1 ) THEN
316  a( i, j ) = -one
317  d( i, j ) = zero
318  ELSE
319  a( i, j ) = zero
320  d( i, j ) = zero
321  END IF
322  10 CONTINUE
323  20 CONTINUE
324 *
325  DO 40 i = 1, n
326  DO 30 j = 1, n
327  IF( i.EQ.j ) THEN
328  b( i, j ) = one - alpha
329  e( i, j ) = one
330  ELSE IF( i.EQ.j-1 ) THEN
331  b( i, j ) = one
332  e( i, j ) = zero
333  ELSE
334  b( i, j ) = zero
335  e( i, j ) = zero
336  END IF
337  30 CONTINUE
338  40 CONTINUE
339 *
340  DO 60 i = 1, m
341  DO 50 j = 1, n
342  r( i, j ) = ( half-sin( cmplx( i / j ) ) )*twenty
343  l( i, j ) = r( i, j )
344  50 CONTINUE
345  60 CONTINUE
346 *
347  ELSE IF( prtype.EQ.2 .OR. prtype.EQ.3 ) THEN
348  DO 80 i = 1, m
349  DO 70 j = 1, m
350  IF( i.LE.j ) THEN
351  a( i, j ) = ( half-sin( cmplx( i ) ) )*two
352  d( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
353  ELSE
354  a( i, j ) = zero
355  d( i, j ) = zero
356  END IF
357  70 CONTINUE
358  80 CONTINUE
359 *
360  DO 100 i = 1, n
361  DO 90 j = 1, n
362  IF( i.LE.j ) THEN
363  b( i, j ) = ( half-sin( cmplx( i+j ) ) )*two
364  e( i, j ) = ( half-sin( cmplx( j ) ) )*two
365  ELSE
366  b( i, j ) = zero
367  e( i, j ) = zero
368  END IF
369  90 CONTINUE
370  100 CONTINUE
371 *
372  DO 120 i = 1, m
373  DO 110 j = 1, n
374  r( i, j ) = ( half-sin( cmplx( i*j ) ) )*twenty
375  l( i, j ) = ( half-sin( cmplx( i+j ) ) )*twenty
376  110 CONTINUE
377  120 CONTINUE
378 *
379  IF( prtype.EQ.3 ) THEN
380  IF( qblcka.LE.1 )
381  $ qblcka = 2
382  DO 130 k = 1, m - 1, qblcka
383  a( k+1, k+1 ) = a( k, k )
384  a( k+1, k ) = -sin( a( k, k+1 ) )
385  130 CONTINUE
386 *
387  IF( qblckb.LE.1 )
388  $ qblckb = 2
389  DO 140 k = 1, n - 1, qblckb
390  b( k+1, k+1 ) = b( k, k )
391  b( k+1, k ) = -sin( b( k, k+1 ) )
392  140 CONTINUE
393  END IF
394 *
395  ELSE IF( prtype.EQ.4 ) THEN
396  DO 160 i = 1, m
397  DO 150 j = 1, m
398  a( i, j ) = ( half-sin( cmplx( i*j ) ) )*twenty
399  d( i, j ) = ( half-sin( cmplx( i+j ) ) )*two
400  150 CONTINUE
401  160 CONTINUE
402 *
403  DO 180 i = 1, n
404  DO 170 j = 1, n
405  b( i, j ) = ( half-sin( cmplx( i+j ) ) )*twenty
406  e( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
407  170 CONTINUE
408  180 CONTINUE
409 *
410  DO 200 i = 1, m
411  DO 190 j = 1, n
412  r( i, j ) = ( half-sin( cmplx( j / i ) ) )*twenty
413  l( i, j ) = ( half-sin( cmplx( i*j ) ) )*two
414  190 CONTINUE
415  200 CONTINUE
416 *
417  ELSE IF( prtype.GE.5 ) THEN
418  reeps = half*two*twenty / alpha
419  imeps = ( half-two ) / alpha
420  DO 220 i = 1, m
421  DO 210 j = 1, n
422  r( i, j ) = ( half-sin( cmplx( i*j ) ) )*alpha / twenty
423  l( i, j ) = ( half-sin( cmplx( i+j ) ) )*alpha / twenty
424  210 CONTINUE
425  220 CONTINUE
426 *
427  DO 230 i = 1, m
428  d( i, i ) = one
429  230 CONTINUE
430 *
431  DO 240 i = 1, m
432  IF( i.LE.4 ) THEN
433  a( i, i ) = one
434  IF( i.GT.2 )
435  $ a( i, i ) = one + reeps
436  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
437  a( i, i+1 ) = imeps
438  ELSE IF( i.GT.1 ) THEN
439  a( i, i-1 ) = -imeps
440  END IF
441  ELSE IF( i.LE.8 ) THEN
442  IF( i.LE.6 ) THEN
443  a( i, i ) = reeps
444  ELSE
445  a( i, i ) = -reeps
446  END IF
447  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
448  a( i, i+1 ) = one
449  ELSE IF( i.GT.1 ) THEN
450  a( i, i-1 ) = -one
451  END IF
452  ELSE
453  a( i, i ) = one
454  IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
455  a( i, i+1 ) = imeps*2
456  ELSE IF( i.GT.1 ) THEN
457  a( i, i-1 ) = -imeps*2
458  END IF
459  END IF
460  240 CONTINUE
461 *
462  DO 250 i = 1, n
463  e( i, i ) = one
464  IF( i.LE.4 ) THEN
465  b( i, i ) = -one
466  IF( i.GT.2 )
467  $ b( i, i ) = one - reeps
468  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
469  b( i, i+1 ) = imeps
470  ELSE IF( i.GT.1 ) THEN
471  b( i, i-1 ) = -imeps
472  END IF
473  ELSE IF( i.LE.8 ) THEN
474  IF( i.LE.6 ) THEN
475  b( i, i ) = reeps
476  ELSE
477  b( i, i ) = -reeps
478  END IF
479  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
480  b( i, i+1 ) = one + imeps
481  ELSE IF( i.GT.1 ) THEN
482  b( i, i-1 ) = -one - imeps
483  END IF
484  ELSE
485  b( i, i ) = one - reeps
486  IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
487  b( i, i+1 ) = imeps*2
488  ELSE IF( i.GT.1 ) THEN
489  b( i, i-1 ) = -imeps*2
490  END IF
491  END IF
492  250 CONTINUE
493  END IF
494 *
495 * Compute rhs (C, F)
496 *
497  CALL cgemm( 'N', 'N', m, n, m, one, a, lda, r, ldr, zero, c, ldc )
498  CALL cgemm( 'N', 'N', m, n, n, -one, l, ldl, b, ldb, one, c, ldc )
499  CALL cgemm( 'N', 'N', m, n, m, one, d, ldd, r, ldr, zero, f, ldf )
500  CALL cgemm( 'N', 'N', m, n, n, -one, l, ldl, e, lde, one, f, ldf )
501 *
502 * End of CLATM5
503 *
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
cgemm
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:189

Here is the call graph for this function:

Here is the caller graph for this function: