ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pztrsm_.c
Go to the documentation of this file.
1 /* ---------------------------------------------------------------------
2 *
3 * -- PBLAS routine (version 2.0) --
4 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5 * and University of California, Berkeley.
6 * April 1, 1998
7 *
8 * ---------------------------------------------------------------------
9 */
10 /*
11 * Include files
12 */
13 #include "pblas.h"
14 #include "PBpblas.h"
15 #include "PBtools.h"
16 #include "PBblacs.h"
17 #include "PBblas.h"
18 
19 #ifdef __STDC__
20 void pztrsm_( F_CHAR_T SIDE, F_CHAR_T UPLO, F_CHAR_T TRANS, F_CHAR_T DIAG,
21  int * M, int * N, double * ALPHA,
22  double * A, int * IA, int * JA, int * DESCA,
23  double * B, int * IB, int * JB, int * DESCB )
24 #else
25 void pztrsm_( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
26  A, IA, JA, DESCA, B, IB, JB, DESCB )
27 /*
28 * .. Scalar Arguments ..
29 */
30  F_CHAR_T DIAG, SIDE, TRANS, UPLO;
31  int * IA, * IB, * JA, * JB, * M, * N;
32  double * ALPHA;
33 /*
34 * .. Array Arguments ..
35 */
36  int * DESCA, * DESCB;
37  double * A, * B;
38 #endif
39 {
40 /*
41 * Purpose
42 * =======
43 *
44 * PZTRSM solves one of the matrix equations
45 *
46 * op( sub( A ) )*X = alpha*sub( B ), or
47 *
48 * X*op( sub( A ) ) = alpha*sub( B ),
49 *
50 * where
51 *
52 * sub( A ) denotes A(IA:IA+M-1,JA:JA+M-1) if SIDE = 'L',
53 * A(IA:IA+N-1,JA:JA+N-1) if SIDE = 'R', and,
54 *
55 * sub( B ) denotes B(IB:IB+M-1,JB:JB+N-1).
56 *
57 * Alpha is a scalar, X and sub( B ) are m by n submatrices, sub( A ) is
58 * a unit, or non-unit, upper or lower triangular submatrix and op( Y )
59 * is one of
60 *
61 * op( Y ) = Y or op( Y ) = Y' or op( Y ) = conjg( Y' ).
62 *
63 * The submatrix X is overwritten on sub( B ).
64 *
65 * Notes
66 * =====
67 *
68 * A description vector is associated with each 2D block-cyclicly dis-
69 * tributed matrix. This vector stores the information required to
70 * establish the mapping between a matrix entry and its corresponding
71 * process and memory location.
72 *
73 * In the following comments, the character _ should be read as
74 * "of the distributed matrix". Let A be a generic term for any 2D
75 * block cyclicly distributed matrix. Its description vector is DESC_A:
76 *
77 * NOTATION STORED IN EXPLANATION
78 * ---------------- --------------- ------------------------------------
79 * DTYPE_A (global) DESCA[ DTYPE_ ] The descriptor type.
80 * CTXT_A (global) DESCA[ CTXT_ ] The BLACS context handle, indicating
81 * the NPROW x NPCOL BLACS process grid
82 * A is distributed over. The context
83 * itself is global, but the handle
84 * (the integer value) may vary.
85 * M_A (global) DESCA[ M_ ] The number of rows in the distribu-
86 * ted matrix A, M_A >= 0.
87 * N_A (global) DESCA[ N_ ] The number of columns in the distri-
88 * buted matrix A, N_A >= 0.
89 * IMB_A (global) DESCA[ IMB_ ] The number of rows of the upper left
90 * block of the matrix A, IMB_A > 0.
91 * INB_A (global) DESCA[ INB_ ] The number of columns of the upper
92 * left block of the matrix A,
93 * INB_A > 0.
94 * MB_A (global) DESCA[ MB_ ] The blocking factor used to distri-
95 * bute the last M_A-IMB_A rows of A,
96 * MB_A > 0.
97 * NB_A (global) DESCA[ NB_ ] The blocking factor used to distri-
98 * bute the last N_A-INB_A columns of
99 * A, NB_A > 0.
100 * RSRC_A (global) DESCA[ RSRC_ ] The process row over which the first
101 * row of the matrix A is distributed,
102 * NPROW > RSRC_A >= 0.
103 * CSRC_A (global) DESCA[ CSRC_ ] The process column over which the
104 * first column of A is distributed.
105 * NPCOL > CSRC_A >= 0.
106 * LLD_A (local) DESCA[ LLD_ ] The leading dimension of the local
107 * array storing the local blocks of
108 * the distributed matrix A,
109 * IF( Lc( 1, N_A ) > 0 )
110 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
111 * ELSE
112 * LLD_A >= 1.
113 *
114 * Let K be the number of rows of a matrix A starting at the global in-
115 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
116 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
117 * receive if these K rows were distributed over NPROW processes. If K
118 * is the number of columns of a matrix A starting at the global index
119 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
120 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
121 * these K columns were distributed over NPCOL processes.
122 *
123 * The values of Lr() and Lc() may be determined via a call to the func-
124 * tion PB_Cnumroc:
125 * Lr( IA, K ) = PB_Cnumroc( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
126 * Lc( JA, K ) = PB_Cnumroc( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
127 *
128 * Arguments
129 * =========
130 *
131 * SIDE (global input) CHARACTER*1
132 * On entry, SIDE specifies whether op( sub( A ) ) appears on
133 * the left or right of X as follows:
134 *
135 * SIDE = 'L' or 'l' op( sub( A ) )*X = alpha*sub( B ),
136 *
137 * SIDE = 'R' or 'r' X*op( sub( A ) ) = alpha*sub( B ).
138 *
139 * UPLO (global input) CHARACTER*1
140 * On entry, UPLO specifies whether the submatrix sub( A ) is
141 * an upper or lower triangular submatrix as follows:
142 *
143 * UPLO = 'U' or 'u' sub( A ) is an upper triangular
144 * submatrix,
145 *
146 * UPLO = 'L' or 'l' sub( A ) is a lower triangular
147 * submatrix.
148 *
149 * TRANSA (global input) CHARACTER*1
150 * On entry, TRANSA specifies the form of op( sub( A ) ) to be
151 * used in the matrix multiplication as follows:
152 *
153 * TRANSA = 'N' or 'n' op( sub( A ) ) = sub( A ),
154 *
155 * TRANSA = 'T' or 't' op( sub( A ) ) = sub( A )',
156 *
157 * TRANSA = 'C' or 'c' op( sub( A ) ) = conjg( sub( A )' ).
158 *
159 * DIAG (global input) CHARACTER*1
160 * On entry, DIAG specifies whether or not sub( A ) is unit
161 * triangular as follows:
162 *
163 * DIAG = 'U' or 'u' sub( A ) is assumed to be unit trian-
164 * gular,
165 *
166 * DIAG = 'N' or 'n' sub( A ) is not assumed to be unit tri-
167 * angular.
168 *
169 * M (global input) INTEGER
170 * On entry, M specifies the number of rows of the submatrix
171 * sub( B ). M must be at least zero.
172 *
173 * N (global input) INTEGER
174 * On entry, N specifies the number of columns of the submatrix
175 * sub( B ). N must be at least zero.
176 *
177 * ALPHA (global input) COMPLEX*16
178 * On entry, ALPHA specifies the scalar alpha. When ALPHA is
179 * supplied as zero then the local entries of the array B
180 * corresponding to the entries of the submatrix sub( B ) need
181 * not be set on input.
182 *
183 * A (local input) COMPLEX*16 array
184 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is
185 * at least Lc( 1, JA+M-1 ) when SIDE = 'L' or 'l' and is at
186 * least Lc( 1, JA+N-1 ) otherwise. Before entry, this array
187 * contains the local entries of the matrix A.
188 * Before entry with UPLO = 'U' or 'u', this array contains the
189 * local entries corresponding to the entries of the upper tri-
190 * angular submatrix sub( A ), and the local entries correspon-
191 * ding to the entries of the strictly lower triangular part of
192 * the submatrix sub( A ) are not referenced.
193 * Before entry with UPLO = 'L' or 'l', this array contains the
194 * local entries corresponding to the entries of the lower tri-
195 * angular submatrix sub( A ), and the local entries correspon-
196 * ding to the entries of the strictly upper triangular part of
197 * the submatrix sub( A ) are not referenced.
198 * Note that when DIAG = 'U' or 'u', the local entries corres-
199 * ponding to the diagonal elements of the submatrix sub( A )
200 * are not referenced either, but are assumed to be unity.
201 *
202 * IA (global input) INTEGER
203 * On entry, IA specifies A's global row index, which points to
204 * the beginning of the submatrix sub( A ).
205 *
206 * JA (global input) INTEGER
207 * On entry, JA specifies A's global column index, which points
208 * to the beginning of the submatrix sub( A ).
209 *
210 * DESCA (global and local input) INTEGER array
211 * On entry, DESCA is an integer array of dimension DLEN_. This
212 * is the array descriptor for the matrix A.
213 *
214 * B (local input/local output) COMPLEX*16 array
215 * On entry, B is an array of dimension (LLD_B, Kb), where Kb is
216 * at least Lc( 1, JB+N-1 ). Before entry, this array contains
217 * the local entries of the matrix B.
218 * On exit, the local entries of this array corresponding to the
219 * to the entries of the submatrix sub( B ) are overwritten by
220 * the local entries of the m by n solution submatrix.
221 *
222 * IB (global input) INTEGER
223 * On entry, IB specifies B's global row index, which points to
224 * the beginning of the submatrix sub( B ).
225 *
226 * JB (global input) INTEGER
227 * On entry, JB specifies B's global column index, which points
228 * to the beginning of the submatrix sub( B ).
229 *
230 * DESCB (global and local input) INTEGER array
231 * On entry, DESCB is an integer array of dimension DLEN_. This
232 * is the array descriptor for the matrix B.
233 *
234 * -- Written on April 1, 1998 by
235 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
236 *
237 * ---------------------------------------------------------------------
238 */
239 /*
240 * .. Local Scalars ..
241 */
242  char DiagA, DirB, OpC, OpR, SideOp, TopC, TopR, TranOp, UploA,
243  Var, ctop, ctopsave, rtop, rtopsave;
244  int Ai, Aj, Bi, Bj, ChooseAB, ForceTop, ctxt, info, itmp, lside,
245  mycol, myrow, nb, notran, nounit, npcol, nprow, upper;
246  double ABestL, ABestR, Best, tmp1, tmp2, tmp3, tmp4;
247  PBTYP_T * type;
248 /*
249 * .. Local Arrays ..
250 */
251  int Ad[DLEN_], Bd[DLEN_];
252 /* ..
253 * .. Executable Statements ..
254 *
255 */
256  lside = ( ( SideOp = Mupcase( F2C_CHAR( SIDE )[0] ) ) == CLEFT );
257  upper = ( ( UploA = Mupcase( F2C_CHAR( UPLO )[0] ) ) == CUPPER );
258  notran = ( ( TranOp = Mupcase( F2C_CHAR( TRANS )[0] ) ) == CNOTRAN );
259  nounit = ( ( DiagA = Mupcase( F2C_CHAR( DIAG )[0] ) ) == CNOUNIT );
260  PB_CargFtoC( *IA, *JA, DESCA, &Ai, &Aj, Ad );
261  PB_CargFtoC( *IB, *JB, DESCB, &Bi, &Bj, Bd );
262 #ifndef NO_ARGCHK
263 /*
264 * Test the input parameters
265 */
266  Cblacs_gridinfo( ( ctxt = Ad[CTXT_] ), &nprow, &npcol, &myrow, &mycol );
267  if( !( info = ( ( nprow == -1 ) ? -( 1101 + CTXT_ ) : 0 ) ) )
268  {
269  if( ( !lside ) && ( SideOp != CRIGHT ) )
270  {
271  PB_Cwarn( ctxt, __LINE__, "PZTRSM", "Illegal SIDE = %c\n", SideOp );
272  info = -1;
273  }
274  else if( ( !upper ) && ( UploA != CLOWER ) )
275  {
276  PB_Cwarn( ctxt, __LINE__, "PZTRSM", "Illegal UPLO = %c\n", UploA );
277  info = -2;
278  }
279  else if( ( !notran ) && ( TranOp != CTRAN ) && ( TranOp != CCOTRAN ) )
280  {
281  PB_Cwarn( ctxt, __LINE__, "PZTRSM", "Illegal TRANS = %c\n", TranOp );
282  info = -3;
283  }
284  else if( ( !nounit ) && ( DiagA != CUNIT ) )
285  {
286  PB_Cwarn( ctxt, __LINE__, "PZTRSM", "Illegal DIAG = %c\n", DiagA );
287  info = -4;
288  }
289  if( lside )
290  PB_Cchkmat( ctxt, "PZTRSM", "A", *M, 5, *M, 5, Ai, Aj, Ad, 11,
291  &info );
292  else
293  PB_Cchkmat( ctxt, "PZTRSM", "A", *N, 6, *N, 6, Ai, Aj, Ad, 11,
294  &info );
295  PB_Cchkmat( ctxt, "PZTRSM", "B", *M, 5, *N, 6, Bi, Bj, Bd, 15,
296  &info );
297  }
298  if( info ) { PB_Cabort( ctxt, "PZTRSM", info ); return; }
299 #endif
300 /*
301 * Quick return if possible
302 */
303  if( *M == 0 || *N == 0 ) return;
304 /*
305 * Get type structure
306 */
307  type = PB_Cztypeset();
308 /*
309 * And when alpha is zero
310 */
311  if( ( ALPHA[REAL_PART] == ZERO ) && ( ALPHA[IMAG_PART] == ZERO ) )
312  {
313  PB_Cplapad( type, ALL, NOCONJG, *M, *N, type->zero, type->zero,
314  ((char *) B), Bi, Bj, Bd );
315  return;
316  }
317 /*
318 * Start the operations
319 */
320 #ifdef NO_ARGCHK
321  Cblacs_gridinfo( ( ctxt = Ad[CTXT_] ), &nprow, &npcol, &myrow, &mycol );
322 #endif
323 /*
324 * Algorithm selection is based on approximation of the communication volume
325 * for distributed and aligned operands.
326 */
327  nb = pilaenv_( &ctxt, C2F_CHAR( &type->type ) );
328 /*
329 * ABestR, ABestL : both operands sub( A ) and sub( B ) are communicated
330 * ( N >> M when SIDE is left and M >> N otherwise )
331 * Best : only sub( B ) is communicated
332 * ( M >> N when SIDE is left and N >> M otherwise )
333 */
334  if( lside )
335  {
336  if( notran )
337  {
338  tmp1 = DNROC( *M, Ad[MB_], nprow ); tmp4 = DNROC( *N, Bd[NB_], npcol );
339  ABestR = (double)(*M) *
340  ( ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp1 / TWO ) +
341  ( ( ( Bd[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp4 ) );
342  itmp = MIN( Ad[MB_], Ad[NB_] );
343  Best = (double)(*N) *
344  ( (double)(CEIL( *M, itmp )) * (double)(itmp) *
345  ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : ONE ) +
346  ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : ONE ) );
347  ChooseAB = ( ABestR <= ( 2.0 * Best ) );
348  }
349  else
350  {
351  tmp1 = DNROC( *M, Ad[MB_], nprow ); tmp2 = DNROC( *M, Ad[NB_], npcol );
352  tmp4 = DNROC( *N, Bd[NB_], npcol );
353  ABestL = (double)(*M) *
354  ( ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp1 / TWO ) +
355  CBRATIO *
356  ( ( ( Bd[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp4 ) );
357  ABestR = (double)(*M) *
358  ( ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp1 / TWO ) +
359  ( ( ( Bd[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp4 ) +
360  MAX( tmp2, tmp1 ) / TWO );
361  itmp = MIN( Ad[MB_], Ad[NB_] );
362  tmp2 = DNROC( *M, Ad[NB_], npcol ); tmp3 = DNROC( *M, Bd[MB_], nprow );
363  Best = (double)(*N) *
364  ( (double)(CEIL( *M, itmp )) * (double)(itmp) *
365  ( ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : ONE ) +
366  ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : ONE ) ) +
367  MAX( tmp2, tmp3 ) );
368  ChooseAB = ( ( ABestL <= ( 2.0 * Best ) ) ||
369  ( ABestR <= ( 2.0 * Best ) ) );
370  }
371  }
372  else
373  {
374  if( notran )
375  {
376  tmp2 = DNROC( *N, Ad[NB_], npcol ); tmp3 = DNROC( *M, Bd[MB_], nprow );
377  ABestR = (double)(*N) *
378  ( ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp2 / TWO ) +
379  ( ( ( Bd[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp3 ) );
380  itmp = MIN( Ad[MB_], Ad[NB_] );
381  Best = (double)(*M) *
382  ( (double)(CEIL( *N, itmp )) * (double)(itmp) *
383  ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : ONE ) +
384  ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : ONE ) );
385  ChooseAB = ( ABestR <= ( 2.0 * Best ) );
386  }
387  else
388  {
389  tmp1 = DNROC( *N, Ad[MB_], nprow ); tmp2 = DNROC( *N, Ad[NB_], npcol );
390  tmp3 = DNROC( *M, Bd[MB_], nprow );
391  ABestL = (double)(*N) *
392  ( ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp2 / TWO ) +
393  CBRATIO *
394  ( ( ( Bd[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp3 ) );
395  ABestR = (double)(*N) *
396  ( ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : tmp2 / TWO ) +
397  ( ( ( Bd[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : tmp3 ) +
398  MAX( tmp2, tmp1 ) / TWO );
399  itmp = MIN( Ad[MB_], Ad[NB_] );
400  tmp1 = DNROC( *N, Ad[MB_], nprow ); tmp4 = DNROC( *N, Bd[NB_], npcol );
401  Best = (double)(*M) *
402  ( (double)(CEIL( *N, itmp )) * (double)(itmp) *
403  ( ( ( ( Ad[RSRC_] == -1 ) || ( nprow == 1 ) ) ? ZERO : ONE ) +
404  ( ( ( Ad[CSRC_] == -1 ) || ( npcol == 1 ) ) ? ZERO : ONE ) ) +
405  MAX( tmp1, tmp4 ) );
406  ChooseAB = ( ( ABestL <= ( 2.0 * Best ) ) ||
407  ( ABestR <= ( 2.0 * Best ) ) );
408  }
409  }
410 
411 /*
412 * Var can remain uninitialized but is nevertheless used in PB_CptrsmAB.c
413 * provide a default here. TODO: does this make sense ?
414 *==19891== at 0x44F81B: PB_CptrsmAB (PB_CptrsmAB.c:538)
415 *==19891== by 0x427BE7: pdtrsm_ (pdtrsm_.c:488)
416 *==19891== by 0x405E46: MAIN_ (pdblas3tim.f:727)
417 */
418  Var = CRIGHT;
419 
420 
421  if( ChooseAB )
422  {
423 /*
424 * BLACS topologies are enforced iff M and N are strictly greater than the
425 * logical block size returned by pilaenv_. Otherwise, it is assumed that the
426 * routine calling this routine has already selected an adequate topology.
427 */
428  ForceTop = ( ( *M > nb ) && ( *N > nb ) );
429 
430  if( ForceTop )
431  {
432  if( lside )
433  {
434  if( notran )
435  {
436  OpR = CBCAST; OpC = CBCAST; Var = CRIGHT;
437  if( upper ) { TopR = TopC = CTOP_DRING; }
438  else { TopR = TopC = CTOP_IRING; }
439  }
440  else
441  {
442  if( ABestL <= ABestR )
443  {
444  OpR = CBCAST; OpC = CCOMBINE; Var = CLEFT;
445  if( upper ) { TopR = TopC = CTOP_IRING; }
446  else { TopR = TopC = CTOP_DRING; }
447  }
448  else
449  {
450  OpR = CBCAST; OpC = CBCAST; Var = CRIGHT;
451  if( upper ) { TopR = TopC = CTOP_IRING; }
452  else { TopR = TopC = CTOP_DRING; }
453  }
454  }
455  }
456  else
457  {
458  if( notran )
459  {
460  OpR = CBCAST; OpC = CBCAST; Var = CRIGHT;
461  if( upper ) { TopR = TopC = CTOP_IRING; }
462  else { TopR = TopC = CTOP_DRING; }
463  }
464  else
465  {
466  if( ABestL <= ABestR )
467  {
468  OpR = CCOMBINE; OpC = CBCAST; Var = CLEFT;
469  if( upper ) { TopR = TopC = CTOP_DRING; }
470  else { TopR = TopC = CTOP_IRING; }
471  }
472  else
473  {
474  OpR = CBCAST; OpC = CBCAST; Var = CRIGHT;
475  if( upper ) { TopR = TopC = CTOP_DRING; }
476  else { TopR = TopC = CTOP_IRING; }
477  }
478  }
479  }
480 
481  rtop = *PB_Ctop( &ctxt, &OpR, ROW, TOP_GET );
482  ctop = *PB_Ctop( &ctxt, &OpC, COLUMN, TOP_GET );
483 
484  if( ( rtopsave = rtop ) != TopR )
485  rtop = *PB_Ctop( &ctxt, &OpR, ROW, &TopR );
486  if( ( ctopsave = ctop ) != TopC )
487  ctop = *PB_Ctop( &ctxt, &OpC, COLUMN, &TopC );
488 /*
489 * Remove the next 4 lines when the BLACS combine operations support ring
490 * topologies
491 */
492  if( OpR == CCOMBINE )
493  rtop = *PB_Ctop( &ctxt, &OpR, ROW, TOP_DEFAULT );
494  if( OpC == CCOMBINE )
495  ctop = *PB_Ctop( &ctxt, &OpC, COLUMN, TOP_DEFAULT );
496  }
497 
498  PB_CptrsmAB( type, &Var, &SideOp, &UploA, &TranOp, &DiagA, *M, *N,
499  ((char *)ALPHA), ((char *)A), Ai, Aj, Ad, ((char *)B),
500  Bi, Bj, Bd );
501 /*
502 * Restore the BLACS topologies when necessary.
503 */
504  if( ForceTop )
505  {
506  rtopsave = *PB_Ctop( &ctxt, &OpR, ROW, &rtopsave );
507  ctopsave = *PB_Ctop( &ctxt, &OpC, COLUMN, &ctopsave );
508  }
509  }
510  else
511  {
512 /*
513 * BLACS topologies are always enforced.
514 */
515  if( ( lside && notran ) || ( !lside && !notran ) )
516  {
517  OpR = CCOMBINE; OpC = CBCAST;
518  if( upper ) { TopR = TopC = CTOP_DRING; }
519  else { TopR = TopC = CTOP_IRING; }
520 /*
521 * Remove the next line when the BLACS combine operations support ring
522 * topologies
523 */
524  TopR = CTOP_DEFAULT;
525  }
526  else
527  {
528  OpR = CBCAST; OpC = CCOMBINE;
529  if( upper ) { TopR = TopC = CTOP_IRING; }
530  else { TopR = TopC = CTOP_DRING; }
531 /*
532 * Remove the next line when the BLACS combine operations support ring
533 * topologies
534 */
535  TopC = CTOP_DEFAULT;
536  }
537 
538  rtop = *PB_Ctop( &ctxt, &OpR, ROW, TOP_GET );
539  ctop = *PB_Ctop( &ctxt, &OpC, COLUMN, TOP_GET );
540 
541  if( ( rtopsave = rtop ) != TopR )
542  rtop = *PB_Ctop( &ctxt, &OpR, ROW, &TopR );
543  if( ( ctopsave = ctop ) != TopC )
544  ctop = *PB_Ctop( &ctxt, &OpC, COLUMN, &TopC );
545 
546  if( lside ) DirB = ( rtop == CTOP_DRING ? CBACKWARD : CFORWARD );
547  else DirB = ( ctop == CTOP_DRING ? CBACKWARD : CFORWARD );
548 
549  PB_CptrsmB( type, &DirB, &SideOp, &UploA, &TranOp, &DiagA, *M, *N,
550  ((char *)ALPHA), ((char *)A), Ai, Aj, Ad, ((char *)B),
551  Bi, Bj, Bd );
552 /*
553 * Restore the BLACS topologies.
554 */
555  rtopsave = *PB_Ctop( &ctxt, &OpR, ROW, &rtopsave );
556  ctopsave = *PB_Ctop( &ctxt, &OpC, COLUMN, &ctopsave );
557  }
558 /*
559 * End of PZTRSM
560 */
561 }
ROW
#define ROW
Definition: PBblacs.h:46
MB_
#define MB_
Definition: PBtools.h:43
TOP_DEFAULT
#define TOP_DEFAULT
Definition: PBblacs.h:51
PB_Cwarn
void PB_Cwarn()
NB_
#define NB_
Definition: PBtools.h:44
COLUMN
#define COLUMN
Definition: PBblacs.h:45
CSRC_
#define CSRC_
Definition: PBtools.h:46
PBblacs.h
PBtools.h
CRIGHT
#define CRIGHT
Definition: PBblas.h:30
PBblas.h
CBCAST
#define CBCAST
Definition: PBblacs.h:23
CCOTRAN
#define CCOTRAN
Definition: PBblas.h:22
NOCONJG
#define NOCONJG
Definition: PBblas.h:45
REAL_PART
#define REAL_PART
Definition: pblas.h:135
PBTYP_T::type
char type
Definition: pblas.h:327
PBpblas.h
PB_Cztypeset
PBTYP_T * PB_Cztypeset()
Definition: PB_Cztypeset.c:19
DLEN_
#define DLEN_
Definition: PBtools.h:48
CUNIT
#define CUNIT
Definition: PBblas.h:32
CEIL
#define CEIL(a, b)
Definition: PBtools.h:80
CTOP_IRING
#define CTOP_IRING
Definition: PBblacs.h:27
PB_CptrsmAB
void PB_CptrsmAB()
pztrsm_
void pztrsm_(F_CHAR_T SIDE, F_CHAR_T UPLO, F_CHAR_T TRANS, F_CHAR_T DIAG, int *M, int *N, double *ALPHA, double *A, int *IA, int *JA, int *DESCA, double *B, int *IB, int *JB, int *DESCB)
Definition: pztrsm_.c:25
F_CHAR_T
char * F_CHAR_T
Definition: pblas.h:118
ZERO
#define ZERO
Definition: PBtools.h:66
CTOP_DRING
#define CTOP_DRING
Definition: PBblacs.h:28
pilaenv_
int pilaenv_()
PB_Cabort
void PB_Cabort()
CLOWER
#define CLOWER
Definition: PBblas.h:25
PB_Cplapad
void PB_Cplapad()
PB_CptrsmB
void PB_CptrsmB()
F2C_CHAR
#define F2C_CHAR(a)
Definition: pblas.h:120
TOP_GET
#define TOP_GET
Definition: PBblacs.h:50
PB_Ctop
char * PB_Ctop()
ONE
#define ONE
Definition: PBtools.h:64
RSRC_
#define RSRC_
Definition: PBtools.h:45
CNOTRAN
#define CNOTRAN
Definition: PBblas.h:18
PB_CargFtoC
void PB_CargFtoC()
PB_Cchkmat
void PB_Cchkmat()
CFORWARD
#define CFORWARD
Definition: PBblas.h:38
ALL
#define ALL
Definition: PBblas.h:50
MIN
#define MIN(a_, b_)
Definition: PBtools.h:76
C2F_CHAR
#define C2F_CHAR(a)
Definition: pblas.h:121
CBRATIO
#define CBRATIO
Definition: pblas.h:37
MAX
#define MAX(a_, b_)
Definition: PBtools.h:77
Cblacs_gridinfo
void Cblacs_gridinfo()
PBTYP_T
Definition: pblas.h:325
Mupcase
#define Mupcase(C)
Definition: PBtools.h:83
pblas.h
CUPPER
#define CUPPER
Definition: PBblas.h:26
CTRAN
#define CTRAN
Definition: PBblas.h:20
CCOMBINE
#define CCOMBINE
Definition: PBblacs.h:24
TWO
#define TWO
Definition: PBtools.h:65
CLEFT
#define CLEFT
Definition: PBblas.h:29
CBACKWARD
#define CBACKWARD
Definition: PBblas.h:39
CTXT_
#define CTXT_
Definition: PBtools.h:38
IMAG_PART
#define IMAG_PART
Definition: pblas.h:136
PBTYP_T::zero
char * zero
Definition: pblas.h:331
CNOUNIT
#define CNOUNIT
Definition: PBblas.h:33
DNROC
#define DNROC(n_, nb_, p_)
Definition: PBtools.h:111
CTOP_DEFAULT
#define CTOP_DEFAULT
Definition: PBblacs.h:26