ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pzblastst.f
Go to the documentation of this file.
1  SUBROUTINE pzoptee( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
2 *
3 * -- PBLAS test 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 * .. Scalar Arguments ..
9  INTEGER ICTXT, NOUT, SCODE
10 * ..
11 * .. Array Arguments ..
12  CHARACTER*(*) SNAME
13 * ..
14 * .. Subroutine Arguments ..
15  EXTERNAL subptr
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PZOPTEE tests whether the PBLAS respond correctly to a bad option
22 * argument.
23 *
24 * Notes
25 * =====
26 *
27 * A description vector is associated with each 2D block-cyclicly dis-
28 * tributed matrix. This vector stores the information required to
29 * establish the mapping between a matrix entry and its corresponding
30 * process and memory location.
31 *
32 * In the following comments, the character _ should be read as
33 * "of the distributed matrix". Let A be a generic term for any 2D
34 * block cyclicly distributed matrix. Its description vector is DESCA:
35 *
36 * NOTATION STORED IN EXPLANATION
37 * ---------------- --------------- ------------------------------------
38 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
39 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
40 * the NPROW x NPCOL BLACS process grid
41 * A is distributed over. The context
42 * itself is global, but the handle
43 * (the integer value) may vary.
44 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
45 * ted matrix A, M_A >= 0.
46 * N_A (global) DESCA( N_ ) The number of columns in the distri-
47 * buted matrix A, N_A >= 0.
48 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
49 * block of the matrix A, IMB_A > 0.
50 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
51 * left block of the matrix A,
52 * INB_A > 0.
53 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
54 * bute the last M_A-IMB_A rows of A,
55 * MB_A > 0.
56 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
57 * bute the last N_A-INB_A columns of
58 * A, NB_A > 0.
59 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
60 * row of the matrix A is distributed,
61 * NPROW > RSRC_A >= 0.
62 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
63 * first column of A is distributed.
64 * NPCOL > CSRC_A >= 0.
65 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
66 * array storing the local blocks of
67 * the distributed matrix A,
68 * IF( Lc( 1, N_A ) > 0 )
69 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
70 * ELSE
71 * LLD_A >= 1.
72 *
73 * Let K be the number of rows of a matrix A starting at the global in-
74 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
75 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
76 * receive if these K rows were distributed over NPROW processes. If K
77 * is the number of columns of a matrix A starting at the global index
78 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
79 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
80 * these K columns were distributed over NPCOL processes.
81 *
82 * The values of Lr() and Lc() may be determined via a call to the func-
83 * tion PB_NUMROC:
84 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
85 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
86 *
87 * Arguments
88 * =========
89 *
90 * ICTXT (local input) INTEGER
91 * On entry, ICTXT specifies the BLACS context handle, indica-
92 * ting the global context of the operation. The context itself
93 * is global, but the value of ICTXT is local.
94 *
95 * NOUT (global input) INTEGER
96 * On entry, NOUT specifies the unit number for the output file.
97 * When NOUT is 6, output to screen, when NOUT is 0, output to
98 * stderr. NOUT is only defined for process 0.
99 *
100 * SUBPTR (global input) SUBROUTINE
101 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
102 * EXTERNAL in the calling subroutine.
103 *
104 * SCODE (global input) INTEGER
105 * On entry, SCODE specifies the calling sequence code.
106 *
107 * SNAME (global input) CHARACTER*(*)
108 * On entry, SNAME specifies the subroutine name calling this
109 * subprogram.
110 *
111 * Calling sequence encodings
112 * ==========================
113 *
114 * code Formal argument list Examples
115 *
116 * 11 (n, v1,v2) _SWAP, _COPY
117 * 12 (n,s1, v1 ) _SCAL, _SCAL
118 * 13 (n,s1, v1,v2) _AXPY, _DOT_
119 * 14 (n,s1,i1,v1 ) _AMAX
120 * 15 (n,u1, v1 ) _ASUM, _NRM2
121 *
122 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
123 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
124 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
125 * 24 ( m,n,s1,v1,v2,m1) _GER_
126 * 25 (uplo, n,s1,v1, m1) _SYR
127 * 26 (uplo, n,u1,v1, m1) _HER
128 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
129 *
130 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
131 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
132 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
133 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
134 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
135 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
136 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
137 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
138 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
139 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
140 *
141 * -- Written on April 1, 1998 by
142 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
143 *
144 * =====================================================================
145 *
146 * .. Local Scalars ..
147  INTEGER APOS
148 * ..
149 * .. External Subroutines ..
150  EXTERNAL pzchkopt
151 * ..
152 * .. Executable Statements ..
153 *
154 * Level 2 PBLAS
155 *
156  IF( scode.EQ.21 ) THEN
157 *
158 * Check 1st (and only) option
159 *
160  apos = 1
161  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
162 *
163  ELSE IF( scode.EQ.22 .OR. scode.EQ.25 .OR. scode.EQ.26 .OR.
164  $ scode.EQ.27 ) THEN
165 *
166 * Check 1st (and only) option
167 *
168  apos = 1
169  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
170 *
171  ELSE IF( scode.EQ.23 ) THEN
172 *
173 * Check 1st option
174 *
175  apos = 1
176  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
177 *
178 * Check 2nd option
179 *
180  apos = 2
181  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
182 *
183 * Check 3rd option
184 *
185  apos = 3
186  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'D', apos )
187 *
188 * Level 3 PBLAS
189 *
190  ELSE IF( scode.EQ.31 ) THEN
191 *
192 * Check 1st option
193 *
194  apos = 1
195  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
196 *
197 * Check 2'nd option
198 *
199  apos = 2
200  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'B', apos )
201 *
202  ELSE IF( scode.EQ.32 ) THEN
203 *
204 * Check 1st option
205 *
206  apos = 1
207  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
208 *
209 * Check 2nd option
210 *
211  apos = 2
212  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
213 *
214  ELSE IF( scode.EQ.33 .OR. scode.EQ.34 .OR. scode.EQ.35 .OR.
215  $ scode.EQ.36 .OR. scode.EQ.40 ) THEN
216 *
217 * Check 1st option
218 *
219  apos = 1
220  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
221 *
222 * Check 2'nd option
223 *
224  apos = 2
225  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
226 *
227  ELSE IF( scode.EQ.38 ) THEN
228 *
229 * Check 1st option
230 *
231  apos = 1
232  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
233 *
234 * Check 2nd option
235 *
236  apos = 2
237  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
238 *
239 * Check 3rd option
240 *
241  apos = 3
242  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
243 *
244 * Check 4th option
245 *
246  apos = 4
247  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'D', apos )
248 *
249 *
250  ELSE IF( scode.EQ.39 ) THEN
251 *
252 * Check 1st option
253 *
254  apos = 1
255  CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
256 *
257  END IF
258 *
259  RETURN
260 *
261 * End of PZOPTEE
262 *
263  END
264  SUBROUTINE pzchkopt( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
265  $ ARGPOS )
266 *
267 * -- PBLAS test routine (version 2.0) --
268 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
269 * and University of California, Berkeley.
270 * April 1, 1998
271 *
272 * .. Scalar Arguments ..
273  CHARACTER*1 ARGNAM
274  INTEGER ARGPOS, ICTXT, NOUT, SCODE
275 * ..
276 * .. Array Arguments ..
277  CHARACTER*(*) SNAME
278 * ..
279 * .. Subroutine Arguments ..
280  EXTERNAL subptr
281 * ..
282 *
283 * Purpose
284 * =======
285 *
286 * PZCHKOPT tests the option ARGNAM in any PBLAS routine.
287 *
288 * Notes
289 * =====
290 *
291 * A description vector is associated with each 2D block-cyclicly dis-
292 * tributed matrix. This vector stores the information required to
293 * establish the mapping between a matrix entry and its corresponding
294 * process and memory location.
295 *
296 * In the following comments, the character _ should be read as
297 * "of the distributed matrix". Let A be a generic term for any 2D
298 * block cyclicly distributed matrix. Its description vector is DESCA:
299 *
300 * NOTATION STORED IN EXPLANATION
301 * ---------------- --------------- ------------------------------------
302 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
303 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
304 * the NPROW x NPCOL BLACS process grid
305 * A is distributed over. The context
306 * itself is global, but the handle
307 * (the integer value) may vary.
308 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
309 * ted matrix A, M_A >= 0.
310 * N_A (global) DESCA( N_ ) The number of columns in the distri-
311 * buted matrix A, N_A >= 0.
312 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
313 * block of the matrix A, IMB_A > 0.
314 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
315 * left block of the matrix A,
316 * INB_A > 0.
317 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
318 * bute the last M_A-IMB_A rows of A,
319 * MB_A > 0.
320 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
321 * bute the last N_A-INB_A columns of
322 * A, NB_A > 0.
323 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
324 * row of the matrix A is distributed,
325 * NPROW > RSRC_A >= 0.
326 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
327 * first column of A is distributed.
328 * NPCOL > CSRC_A >= 0.
329 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
330 * array storing the local blocks of
331 * the distributed matrix A,
332 * IF( Lc( 1, N_A ) > 0 )
333 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
334 * ELSE
335 * LLD_A >= 1.
336 *
337 * Let K be the number of rows of a matrix A starting at the global in-
338 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
339 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
340 * receive if these K rows were distributed over NPROW processes. If K
341 * is the number of columns of a matrix A starting at the global index
342 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
343 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
344 * these K columns were distributed over NPCOL processes.
345 *
346 * The values of Lr() and Lc() may be determined via a call to the func-
347 * tion PB_NUMROC:
348 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
349 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
350 *
351 * Arguments
352 * =========
353 *
354 * ICTXT (local input) INTEGER
355 * On entry, ICTXT specifies the BLACS context handle, indica-
356 * ting the global context of the operation. The context itself
357 * is global, but the value of ICTXT is local.
358 *
359 * NOUT (global input) INTEGER
360 * On entry, NOUT specifies the unit number for the output file.
361 * When NOUT is 6, output to screen, when NOUT is 0, output to
362 * stderr. NOUT is only defined for process 0.
363 *
364 * SUBPTR (global input) SUBROUTINE
365 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
366 * EXTERNAL in the calling subroutine.
367 *
368 * SCODE (global input) INTEGER
369 * On entry, SCODE specifies the calling sequence code.
370 *
371 * SNAME (global input) CHARACTER*(*)
372 * On entry, SNAME specifies the subroutine name calling this
373 * subprogram.
374 *
375 * ARGNAM (global input) CHARACTER*(*)
376 * On entry, ARGNAM specifies the name of the option to be
377 * checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'.
378 *
379 * ARGPOS (global input) INTEGER
380 * On entry, ARGPOS indicates the position of the option ARGNAM
381 * to be tested.
382 *
383 * -- Written on April 1, 1998 by
384 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
385 *
386 * =====================================================================
387 *
388 * .. Local Scalars ..
389  INTEGER INFOT
390 * ..
391 * .. External Subroutines ..
392  EXTERNAL pchkpbe, pzcallsub, pzsetpblas
393 * ..
394 * .. External Functions ..
395  LOGICAL LSAME
396  EXTERNAL lsame
397 * ..
398 * .. Common Blocks ..
399  CHARACTER DIAG, SIDE, TRANSA, TRANSB, UPLO
400  COMMON /pblasc/diag, side, transa, transb, uplo
401 * ..
402 * .. Executable Statements ..
403 *
404 * Reiniatilize the dummy arguments to correct values
405 *
406  CALL pzsetpblas( ictxt )
407 *
408  IF( lsame( argnam, 'D' ) ) THEN
409 *
410 * Generate bad DIAG option
411 *
412  diag = '/'
413 *
414  ELSE IF( lsame( argnam, 'S' ) ) THEN
415 *
416 * Generate bad SIDE option
417 *
418  side = '/'
419 *
420  ELSE IF( lsame( argnam, 'A' ) ) THEN
421 *
422 * Generate bad TRANSA option
423 *
424  transa = '/'
425 *
426  ELSE IF( lsame( argnam, 'B' ) ) THEN
427 *
428 * Generate bad TRANSB option
429 *
430  transb = '/'
431 *
432  ELSE IF( lsame( argnam, 'U' ) ) THEN
433 *
434 * Generate bad UPLO option
435 *
436  uplo = '/'
437 *
438  END IF
439 *
440 * Set INFOT to the position of the bad dimension argument
441 *
442  infot = argpos
443 *
444 * Call the PBLAS routine
445 *
446  CALL pzcallsub( subptr, scode )
447  CALL pchkpbe( ictxt, nout, sname, infot )
448 *
449  RETURN
450 *
451 * End of PZCHKOPT
452 *
453  END
454  SUBROUTINE pzdimee( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
455 *
456 * -- PBLAS test routine (version 2.0) --
457 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
458 * and University of California, Berkeley.
459 * April 1, 1998
460 *
461 * .. Scalar Arguments ..
462  INTEGER ICTXT, NOUT, SCODE
463 * ..
464 * .. Array Arguments ..
465  CHARACTER*(*) SNAME
466 * ..
467 * .. Subroutine Arguments ..
468  EXTERNAL subptr
469 * ..
470 *
471 * Purpose
472 * =======
473 *
474 * PZDIMEE tests whether the PBLAS respond correctly to a bad dimension
475 * argument.
476 *
477 * Notes
478 * =====
479 *
480 * A description vector is associated with each 2D block-cyclicly dis-
481 * tributed matrix. This vector stores the information required to
482 * establish the mapping between a matrix entry and its corresponding
483 * process and memory location.
484 *
485 * In the following comments, the character _ should be read as
486 * "of the distributed matrix". Let A be a generic term for any 2D
487 * block cyclicly distributed matrix. Its description vector is DESCA:
488 *
489 * NOTATION STORED IN EXPLANATION
490 * ---------------- --------------- ------------------------------------
491 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
492 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
493 * the NPROW x NPCOL BLACS process grid
494 * A is distributed over. The context
495 * itself is global, but the handle
496 * (the integer value) may vary.
497 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
498 * ted matrix A, M_A >= 0.
499 * N_A (global) DESCA( N_ ) The number of columns in the distri-
500 * buted matrix A, N_A >= 0.
501 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
502 * block of the matrix A, IMB_A > 0.
503 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
504 * left block of the matrix A,
505 * INB_A > 0.
506 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
507 * bute the last M_A-IMB_A rows of A,
508 * MB_A > 0.
509 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
510 * bute the last N_A-INB_A columns of
511 * A, NB_A > 0.
512 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
513 * row of the matrix A is distributed,
514 * NPROW > RSRC_A >= 0.
515 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
516 * first column of A is distributed.
517 * NPCOL > CSRC_A >= 0.
518 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
519 * array storing the local blocks of
520 * the distributed matrix A,
521 * IF( Lc( 1, N_A ) > 0 )
522 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
523 * ELSE
524 * LLD_A >= 1.
525 *
526 * Let K be the number of rows of a matrix A starting at the global in-
527 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
528 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
529 * receive if these K rows were distributed over NPROW processes. If K
530 * is the number of columns of a matrix A starting at the global index
531 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
532 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
533 * these K columns were distributed over NPCOL processes.
534 *
535 * The values of Lr() and Lc() may be determined via a call to the func-
536 * tion PB_NUMROC:
537 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
538 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
539 *
540 * Arguments
541 * =========
542 *
543 * ICTXT (local input) INTEGER
544 * On entry, ICTXT specifies the BLACS context handle, indica-
545 * ting the global context of the operation. The context itself
546 * is global, but the value of ICTXT is local.
547 *
548 * NOUT (global input) INTEGER
549 * On entry, NOUT specifies the unit number for the output file.
550 * When NOUT is 6, output to screen, when NOUT is 0, output to
551 * stderr. NOUT is only defined for process 0.
552 *
553 * SUBPTR (global input) SUBROUTINE
554 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
555 * EXTERNAL in the calling subroutine.
556 *
557 * SCODE (global input) INTEGER
558 * On entry, SCODE specifies the calling sequence code.
559 *
560 * SNAME (global input) CHARACTER*(*)
561 * On entry, SNAME specifies the subroutine name calling this
562 * subprogram.
563 *
564 * Calling sequence encodings
565 * ==========================
566 *
567 * code Formal argument list Examples
568 *
569 * 11 (n, v1,v2) _SWAP, _COPY
570 * 12 (n,s1, v1 ) _SCAL, _SCAL
571 * 13 (n,s1, v1,v2) _AXPY, _DOT_
572 * 14 (n,s1,i1,v1 ) _AMAX
573 * 15 (n,u1, v1 ) _ASUM, _NRM2
574 *
575 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
576 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
577 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
578 * 24 ( m,n,s1,v1,v2,m1) _GER_
579 * 25 (uplo, n,s1,v1, m1) _SYR
580 * 26 (uplo, n,u1,v1, m1) _HER
581 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
582 *
583 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
584 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
585 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
586 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
587 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
588 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
589 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
590 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
591 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
592 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
593 *
594 * -- Written on April 1, 1998 by
595 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
596 *
597 * =====================================================================
598 *
599 * .. Local Scalars ..
600  INTEGER APOS
601 * ..
602 * .. External Subroutines ..
603  EXTERNAL pzchkdim
604 * ..
605 * .. Executable Statements ..
606 *
607 * Level 1 PBLAS
608 *
609  IF( scode.EQ.11 .OR. scode.EQ.12 .OR. scode.EQ.13 .OR.
610  $ scode.EQ.14 .OR. scode.EQ.15 ) THEN
611 *
612 * Check 1st (and only) dimension
613 *
614  apos = 1
615  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
616 *
617 * Level 2 PBLAS
618 *
619  ELSE IF( scode.EQ.21 ) THEN
620 *
621 * Check 1st dimension
622 *
623  apos = 2
624  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
625 *
626 * Check 2nd dimension
627 *
628  apos = 3
629  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
630 *
631  ELSE IF( scode.EQ.22 .OR. scode.EQ.25 .OR. scode.EQ.26 .OR.
632  $ scode.EQ.27 ) THEN
633 *
634 * Check 1st (and only) dimension
635 *
636  apos = 2
637  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
638 *
639  ELSE IF( scode.EQ.23 ) THEN
640 *
641 * Check 1st (and only) dimension
642 *
643  apos = 4
644  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
645 *
646  ELSE IF( scode.EQ.24 ) THEN
647 *
648 * Check 1st dimension
649 *
650  apos = 1
651  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
652 *
653 * Check 2nd dimension
654 *
655  apos = 2
656  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
657 *
658 * Level 3 PBLAS
659 *
660  ELSE IF( scode.EQ.31 ) THEN
661 *
662 * Check 1st dimension
663 *
664  apos = 3
665  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
666 *
667 * Check 2nd dimension
668 *
669  apos = 4
670  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
671 *
672 * Check 3rd dimension
673 *
674  apos = 5
675  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'K', apos )
676 *
677  ELSE IF( scode.EQ.32 ) THEN
678 *
679 * Check 1st dimension
680 *
681  apos = 3
682  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
683 *
684 * Check 2nd dimension
685 *
686  apos = 4
687  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
688 *
689  ELSE IF( scode.EQ.33 .OR. scode.EQ.34 .OR. scode.EQ.35 .OR.
690  $ scode.EQ.36 ) THEN
691 *
692 * Check 1st dimension
693 *
694  apos = 3
695  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
696 *
697 * Check 2nd dimension
698 *
699  apos = 4
700  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'K', apos )
701 *
702  ELSE IF( scode.EQ.37 ) THEN
703 *
704 * Check 1st dimension
705 *
706  apos = 1
707  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
708 *
709 * Check 2nd dimension
710 *
711  apos = 2
712  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
713 *
714  ELSE IF( scode.EQ.38 ) THEN
715 *
716 * Check 1st dimension
717 *
718  apos = 5
719  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
720 *
721 * Check 2nd dimension
722 *
723  apos = 6
724  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
725 *
726  ELSE IF( scode.EQ.39 ) THEN
727 *
728 * Check 1st dimension
729 *
730  apos = 2
731  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
732 *
733 * Check 2nd dimension
734 *
735  apos = 3
736  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
737 *
738  ELSE IF( scode.EQ.40 ) THEN
739 *
740 * Check 1st dimension
741 *
742  apos = 3
743  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
744 *
745 * Check 2nd dimension
746 *
747  apos = 4
748  CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
749 *
750  END IF
751 *
752  RETURN
753 *
754 * End of PZDIMEE
755 *
756  END
757  SUBROUTINE pzchkdim( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
758  $ ARGPOS )
759 *
760 * -- PBLAS test routine (version 2.0) --
761 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
762 * and University of California, Berkeley.
763 * April 1, 1998
764 *
765 * .. Scalar Arguments ..
766  CHARACTER*1 ARGNAM
767  INTEGER ARGPOS, ICTXT, NOUT, SCODE
768 * ..
769 * .. Array Arguments ..
770  CHARACTER*(*) SNAME
771 * ..
772 * .. Subroutine Arguments ..
773  EXTERNAL subptr
774 * ..
775 *
776 * Purpose
777 * =======
778 *
779 * PZCHKDIM tests the dimension ARGNAM in any PBLAS routine.
780 *
781 * Notes
782 * =====
783 *
784 * A description vector is associated with each 2D block-cyclicly dis-
785 * tributed matrix. This vector stores the information required to
786 * establish the mapping between a matrix entry and its corresponding
787 * process and memory location.
788 *
789 * In the following comments, the character _ should be read as
790 * "of the distributed matrix". Let A be a generic term for any 2D
791 * block cyclicly distributed matrix. Its description vector is DESCA:
792 *
793 * NOTATION STORED IN EXPLANATION
794 * ---------------- --------------- ------------------------------------
795 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
796 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
797 * the NPROW x NPCOL BLACS process grid
798 * A is distributed over. The context
799 * itself is global, but the handle
800 * (the integer value) may vary.
801 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
802 * ted matrix A, M_A >= 0.
803 * N_A (global) DESCA( N_ ) The number of columns in the distri-
804 * buted matrix A, N_A >= 0.
805 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
806 * block of the matrix A, IMB_A > 0.
807 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
808 * left block of the matrix A,
809 * INB_A > 0.
810 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
811 * bute the last M_A-IMB_A rows of A,
812 * MB_A > 0.
813 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
814 * bute the last N_A-INB_A columns of
815 * A, NB_A > 0.
816 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
817 * row of the matrix A is distributed,
818 * NPROW > RSRC_A >= 0.
819 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
820 * first column of A is distributed.
821 * NPCOL > CSRC_A >= 0.
822 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
823 * array storing the local blocks of
824 * the distributed matrix A,
825 * IF( Lc( 1, N_A ) > 0 )
826 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
827 * ELSE
828 * LLD_A >= 1.
829 *
830 * Let K be the number of rows of a matrix A starting at the global in-
831 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
832 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
833 * receive if these K rows were distributed over NPROW processes. If K
834 * is the number of columns of a matrix A starting at the global index
835 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
836 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
837 * these K columns were distributed over NPCOL processes.
838 *
839 * The values of Lr() and Lc() may be determined via a call to the func-
840 * tion PB_NUMROC:
841 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
842 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
843 *
844 * Arguments
845 * =========
846 *
847 * ICTXT (local input) INTEGER
848 * On entry, ICTXT specifies the BLACS context handle, indica-
849 * ting the global context of the operation. The context itself
850 * is global, but the value of ICTXT is local.
851 *
852 * NOUT (global input) INTEGER
853 * On entry, NOUT specifies the unit number for the output file.
854 * When NOUT is 6, output to screen, when NOUT is 0, output to
855 * stderr. NOUT is only defined for process 0.
856 *
857 * SUBPTR (global input) SUBROUTINE
858 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
859 * EXTERNAL in the calling subroutine.
860 *
861 * SCODE (global input) INTEGER
862 * On entry, SCODE specifies the calling sequence code.
863 *
864 * SNAME (global input) CHARACTER*(*)
865 * On entry, SNAME specifies the subroutine name calling this
866 * subprogram.
867 *
868 * ARGNAM (global input) CHARACTER*(*)
869 * On entry, ARGNAM specifies the name of the dimension to be
870 * checked. ARGNAM can either be 'M', 'N' or 'K'.
871 *
872 * ARGPOS (global input) INTEGER
873 * On entry, ARGPOS indicates the position of the option ARGNAM
874 * to be tested.
875 *
876 * -- Written on April 1, 1998 by
877 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
878 *
879 * =====================================================================
880 *
881 * .. Local Scalars ..
882  INTEGER INFOT
883 * ..
884 * .. External Subroutines ..
885  EXTERNAL pchkpbe, pzcallsub, pzsetpblas
886 * ..
887 * .. External Functions ..
888  LOGICAL LSAME
889  EXTERNAL LSAME
890 * ..
891 * .. Common Blocks ..
892  INTEGER KDIM, MDIM, NDIM
893  COMMON /PBLASN/KDIM, MDIM, NDIM
894 * ..
895 * .. Executable Statements ..
896 *
897 * Reiniatilize the dummy arguments to correct values
898 *
899  CALL pzsetpblas( ictxt )
900 *
901  IF( lsame( argnam, 'M' ) ) THEN
902 *
903 * Generate bad MDIM
904 *
905  mdim = -1
906 *
907  ELSE IF( lsame( argnam, 'N' ) ) THEN
908 *
909 * Generate bad NDIM
910 *
911  ndim = -1
912 *
913  ELSE
914 *
915 * Generate bad KDIM
916 *
917  kdim = -1
918 *
919  END IF
920 *
921 * Set INFOT to the position of the bad dimension argument
922 *
923  infot = argpos
924 *
925 * Call the PBLAS routine
926 *
927  CALL pzcallsub( subptr, scode )
928  CALL pchkpbe( ictxt, nout, sname, infot )
929 *
930  RETURN
931 *
932 * End of PZCHKDIM
933 *
934  END
935  SUBROUTINE pzvecee( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
936 *
937 * -- PBLAS test routine (version 2.0) --
938 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
939 * and University of California, Berkeley.
940 * April 1, 1998
941 *
942 * .. Scalar Arguments ..
943  INTEGER ICTXT, NOUT, SCODE
944 * ..
945 * .. Array Arguments ..
946  CHARACTER*7 SNAME
947 * ..
948 * .. Subroutine Arguments ..
949  EXTERNAL subptr
950 * ..
951 *
952 * Purpose
953 * =======
954 *
955 * PZVECEE tests whether the PBLAS respond correctly to a bad vector
956 * argument. Each vector <vec> is described by: <vec>, I<vec>, J<vec>,
957 * DESC<vec>, INC<vec>. Out of all these, only I<vec>, J<vec>,
958 * DESC<vec>, and INC<vec> can be tested.
959 *
960 * Notes
961 * =====
962 *
963 * A description vector is associated with each 2D block-cyclicly dis-
964 * tributed matrix. This vector stores the information required to
965 * establish the mapping between a matrix entry and its corresponding
966 * process and memory location.
967 *
968 * In the following comments, the character _ should be read as
969 * "of the distributed matrix". Let A be a generic term for any 2D
970 * block cyclicly distributed matrix. Its description vector is DESCA:
971 *
972 * NOTATION STORED IN EXPLANATION
973 * ---------------- --------------- ------------------------------------
974 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
975 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
976 * the NPROW x NPCOL BLACS process grid
977 * A is distributed over. The context
978 * itself is global, but the handle
979 * (the integer value) may vary.
980 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
981 * ted matrix A, M_A >= 0.
982 * N_A (global) DESCA( N_ ) The number of columns in the distri-
983 * buted matrix A, N_A >= 0.
984 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
985 * block of the matrix A, IMB_A > 0.
986 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
987 * left block of the matrix A,
988 * INB_A > 0.
989 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
990 * bute the last M_A-IMB_A rows of A,
991 * MB_A > 0.
992 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
993 * bute the last N_A-INB_A columns of
994 * A, NB_A > 0.
995 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
996 * row of the matrix A is distributed,
997 * NPROW > RSRC_A >= 0.
998 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
999 * first column of A is distributed.
1000 * NPCOL > CSRC_A >= 0.
1001 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1002 * array storing the local blocks of
1003 * the distributed matrix A,
1004 * IF( Lc( 1, N_A ) > 0 )
1005 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1006 * ELSE
1007 * LLD_A >= 1.
1008 *
1009 * Let K be the number of rows of a matrix A starting at the global in-
1010 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1011 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1012 * receive if these K rows were distributed over NPROW processes. If K
1013 * is the number of columns of a matrix A starting at the global index
1014 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1015 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1016 * these K columns were distributed over NPCOL processes.
1017 *
1018 * The values of Lr() and Lc() may be determined via a call to the func-
1019 * tion PB_NUMROC:
1020 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1021 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1022 *
1023 * Arguments
1024 * =========
1025 *
1026 * ICTXT (local input) INTEGER
1027 * On entry, ICTXT specifies the BLACS context handle, indica-
1028 * ting the global context of the operation. The context itself
1029 * is global, but the value of ICTXT is local.
1030 *
1031 * NOUT (global input) INTEGER
1032 * On entry, NOUT specifies the unit number for the output file.
1033 * When NOUT is 6, output to screen, when NOUT is 0, output to
1034 * stderr. NOUT is only defined for process 0.
1035 *
1036 * SUBPTR (global input) SUBROUTINE
1037 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
1038 * EXTERNAL in the calling subroutine.
1039 *
1040 * SCODE (global input) INTEGER
1041 * On entry, SCODE specifies the calling sequence code.
1042 *
1043 * SNAME (global input) CHARACTER*(*)
1044 * On entry, SNAME specifies the subroutine name calling this
1045 * subprogram.
1046 *
1047 * Calling sequence encodings
1048 * ==========================
1049 *
1050 * code Formal argument list Examples
1051 *
1052 * 11 (n, v1,v2) _SWAP, _COPY
1053 * 12 (n,s1, v1 ) _SCAL, _SCAL
1054 * 13 (n,s1, v1,v2) _AXPY, _DOT_
1055 * 14 (n,s1,i1,v1 ) _AMAX
1056 * 15 (n,u1, v1 ) _ASUM, _NRM2
1057 *
1058 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
1059 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
1060 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
1061 * 24 ( m,n,s1,v1,v2,m1) _GER_
1062 * 25 (uplo, n,s1,v1, m1) _SYR
1063 * 26 (uplo, n,u1,v1, m1) _HER
1064 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
1065 *
1066 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
1067 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
1068 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
1069 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
1070 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
1071 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
1072 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
1073 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
1074 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
1075 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
1076 *
1077 * -- Written on April 1, 1998 by
1078 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1079 *
1080 * =====================================================================
1081 *
1082 * .. Local Scalars ..
1083  INTEGER APOS
1084 * ..
1085 * .. External Subroutines ..
1086  EXTERNAL pzchkmat
1087 * ..
1088 * .. Executable Statements ..
1089 *
1090 * Level 1 PBLAS
1091 *
1092  IF( scode.EQ.11 ) THEN
1093 *
1094 * Check 1st vector
1095 *
1096  apos = 2
1097  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1098 *
1099 * Check 2nd vector
1100 *
1101  apos = 7
1102  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1103 *
1104  ELSE IF( scode.EQ.12 .OR. scode.EQ.15 ) THEN
1105 *
1106 * Check 1st (and only) vector
1107 *
1108  apos = 3
1109  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1110 *
1111  ELSE IF( scode.EQ.13 ) THEN
1112 *
1113 * Check 1st vector
1114 *
1115  apos = 3
1116  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1117 *
1118 * Check 2nd vector
1119 *
1120  apos = 8
1121  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1122 *
1123  ELSE IF( scode.EQ.14 ) THEN
1124 *
1125 * Check 1st (and only) vector
1126 *
1127  apos = 4
1128  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1129 *
1130 * Level 2 PBLAS
1131 *
1132  ELSE IF( scode.EQ.21 ) THEN
1133 *
1134 * Check 1st vector
1135 *
1136  apos = 9
1137  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1138 *
1139 * Check 2nd vector
1140 *
1141  apos = 15
1142  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1143 *
1144  ELSE IF( scode.EQ.22 ) THEN
1145 *
1146 * Check 1st vector
1147 *
1148  apos = 8
1149  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1150 *
1151 * Check 2nd vector
1152 *
1153  apos = 14
1154  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1155 *
1156  ELSE IF( scode.EQ.23 ) THEN
1157 *
1158 * Check 1st (and only) vector
1159 *
1160  apos = 9
1161  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1162 *
1163  ELSE IF( scode.EQ.24 .OR. scode.EQ.27 ) THEN
1164 *
1165 * Check 1st vector
1166 *
1167  apos = 4
1168  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1169 *
1170 * Check 2nd vector
1171 *
1172  apos = 9
1173  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1174 *
1175  ELSE IF( scode.EQ.26 .OR. scode.EQ.27 ) THEN
1176 *
1177 * Check 1'st (and only) vector
1178 *
1179  apos = 4
1180  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1181 *
1182  END IF
1183 *
1184  RETURN
1185 *
1186 * End of PZVECEE
1187 *
1188  END
1189  SUBROUTINE pzmatee( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
1191 * -- PBLAS test routine (version 2.0) --
1192 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1193 * and University of California, Berkeley.
1194 * April 1, 1998
1195 *
1196 * .. Scalar Arguments ..
1197  INTEGER ICTXT, NOUT, SCODE
1198 * ..
1199 * .. Array Arguments ..
1200  CHARACTER*7 SNAME
1201 * ..
1202 * .. Subroutine Arguments ..
1203  EXTERNAL subptr
1204 * ..
1205 *
1206 * Purpose
1207 * =======
1208 *
1209 * PZMATEE tests whether the PBLAS respond correctly to a bad matrix
1210 * argument. Each matrix <mat> is described by: <mat>, I<mat>, J<mat>,
1211 * and DESC<mat>. Out of all these, only I<vec>, J<vec> and DESC<mat>
1212 * can be tested.
1213 *
1214 * Notes
1215 * =====
1216 *
1217 * A description vector is associated with each 2D block-cyclicly dis-
1218 * tributed matrix. This vector stores the information required to
1219 * establish the mapping between a matrix entry and its corresponding
1220 * process and memory location.
1221 *
1222 * In the following comments, the character _ should be read as
1223 * "of the distributed matrix". Let A be a generic term for any 2D
1224 * block cyclicly distributed matrix. Its description vector is DESCA:
1225 *
1226 * NOTATION STORED IN EXPLANATION
1227 * ---------------- --------------- ------------------------------------
1228 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1229 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1230 * the NPROW x NPCOL BLACS process grid
1231 * A is distributed over. The context
1232 * itself is global, but the handle
1233 * (the integer value) may vary.
1234 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
1235 * ted matrix A, M_A >= 0.
1236 * N_A (global) DESCA( N_ ) The number of columns in the distri-
1237 * buted matrix A, N_A >= 0.
1238 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1239 * block of the matrix A, IMB_A > 0.
1240 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
1241 * left block of the matrix A,
1242 * INB_A > 0.
1243 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1244 * bute the last M_A-IMB_A rows of A,
1245 * MB_A > 0.
1246 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1247 * bute the last N_A-INB_A columns of
1248 * A, NB_A > 0.
1249 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1250 * row of the matrix A is distributed,
1251 * NPROW > RSRC_A >= 0.
1252 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1253 * first column of A is distributed.
1254 * NPCOL > CSRC_A >= 0.
1255 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1256 * array storing the local blocks of
1257 * the distributed matrix A,
1258 * IF( Lc( 1, N_A ) > 0 )
1259 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1260 * ELSE
1261 * LLD_A >= 1.
1262 *
1263 * Let K be the number of rows of a matrix A starting at the global in-
1264 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1265 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1266 * receive if these K rows were distributed over NPROW processes. If K
1267 * is the number of columns of a matrix A starting at the global index
1268 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1269 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1270 * these K columns were distributed over NPCOL processes.
1271 *
1272 * The values of Lr() and Lc() may be determined via a call to the func-
1273 * tion PB_NUMROC:
1274 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1275 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1276 *
1277 * Arguments
1278 * =========
1279 *
1280 * ICTXT (local input) INTEGER
1281 * On entry, ICTXT specifies the BLACS context handle, indica-
1282 * ting the global context of the operation. The context itself
1283 * is global, but the value of ICTXT is local.
1284 *
1285 * NOUT (global input) INTEGER
1286 * On entry, NOUT specifies the unit number for the output file.
1287 * When NOUT is 6, output to screen, when NOUT is 0, output to
1288 * stderr. NOUT is only defined for process 0.
1289 *
1290 * SUBPTR (global input) SUBROUTINE
1291 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
1292 * EXTERNAL in the calling subroutine.
1293 *
1294 * SCODE (global input) INTEGER
1295 * On entry, SCODE specifies the calling sequence code.
1296 *
1297 * SNAME (global input) CHARACTER*(*)
1298 * On entry, SNAME specifies the subroutine name calling this
1299 * subprogram.
1300 *
1301 * Calling sequence encodings
1302 * ==========================
1303 *
1304 * code Formal argument list Examples
1305 *
1306 * 11 (n, v1,v2) _SWAP, _COPY
1307 * 12 (n,s1, v1 ) _SCAL, _SCAL
1308 * 13 (n,s1, v1,v2) _AXPY, _DOT_
1309 * 14 (n,s1,i1,v1 ) _AMAX
1310 * 15 (n,u1, v1 ) _ASUM, _NRM2
1311 *
1312 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
1313 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
1314 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
1315 * 24 ( m,n,s1,v1,v2,m1) _GER_
1316 * 25 (uplo, n,s1,v1, m1) _SYR
1317 * 26 (uplo, n,u1,v1, m1) _HER
1318 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
1319 *
1320 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
1321 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
1322 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
1323 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
1324 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
1325 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
1326 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
1327 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
1328 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
1329 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
1330 *
1331 * -- Written on April 1, 1998 by
1332 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1333 *
1334 * =====================================================================
1335 *
1336 * .. Local Scalars ..
1337  INTEGER APOS
1338 * ..
1339 * .. External Subroutines ..
1340  EXTERNAL pzchkmat
1341 * ..
1342 * .. Executable Statements ..
1343 *
1344 * Level 2 PBLAS
1345 *
1346  IF( scode.EQ.21 .OR. scode.EQ.23 ) THEN
1347 *
1348 * Check 1st (and only) matrix
1349 *
1350  apos = 5
1351  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1352 *
1353  ELSE IF( scode.EQ.22 ) THEN
1354 *
1355 * Check 1st (and only) matrix
1356 *
1357  apos = 4
1358  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1359 *
1360  ELSE IF( scode.EQ.24 .OR. scode.EQ.27 ) THEN
1361 *
1362 * Check 1st (and only) matrix
1363 *
1364  apos = 14
1365  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1366 *
1367  ELSE IF( scode.EQ.25 .OR. scode.EQ.26 ) THEN
1368 *
1369 * Check 1st (and only) matrix
1370 *
1371  apos = 9
1372  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1373 *
1374 * Level 3 PBLAS
1375 *
1376  ELSE IF( scode.EQ.31 ) THEN
1377 *
1378 * Check 1st matrix
1379 *
1380  apos = 7
1381  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1382 *
1383 * Check 2nd matrix
1384 *
1385  apos = 11
1386  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1387 *
1388 * Check 3nd matrix
1389 *
1390  apos = 16
1391  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1392 *
1393  ELSE IF( scode.EQ.32 .OR. scode.EQ.35 .OR. scode.EQ.36 ) THEN
1394 *
1395 * Check 1st matrix
1396 *
1397  apos = 6
1398  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1399 *
1400 * Check 2nd matrix
1401 *
1402  apos = 10
1403  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1404 *
1405 * Check 3nd matrix
1406 *
1407  apos = 15
1408  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1409 *
1410  ELSE IF( scode.EQ.33 .OR. scode.EQ.34 ) THEN
1411 *
1412 * Check 1st matrix
1413 *
1414  apos = 6
1415  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1416 *
1417 * Check 2nd matrix
1418 *
1419  apos = 11
1420  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1421 *
1422  ELSE IF( scode.EQ.37 ) THEN
1423 *
1424 * Check 1st matrix
1425 *
1426  apos = 4
1427  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1428 *
1429 * Check 2nd matrix
1430 *
1431  apos = 9
1432  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1433 *
1434  ELSE IF( scode.EQ.38 ) THEN
1435 *
1436 * Check 1st matrix
1437 *
1438  apos = 8
1439  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1440 *
1441 * Check 2nd matrix
1442 *
1443  apos = 12
1444  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1445 *
1446  ELSE IF( scode.EQ.39 ) THEN
1447 *
1448 * Check 1st matrix
1449 *
1450  apos = 5
1451  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1452 *
1453 * Check 2nd matrix
1454 *
1455  apos = 10
1456  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1457 *
1458  ELSE IF( scode.EQ.40 ) THEN
1459 *
1460 * Check 1st matrix
1461 *
1462  apos = 6
1463  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1464 *
1465 * Check 2nd matrix
1466 *
1467  apos = 11
1468  CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1469 *
1470  END IF
1471 *
1472  RETURN
1473 *
1474 * End of PZMATEE
1475 *
1476  END
1477  SUBROUTINE pzsetpblas( ICTXT )
1479 * -- PBLAS test routine (version 2.0) --
1480 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1481 * and University of California, Berkeley.
1482 * April 1, 1998
1483 *
1484 * .. Scalar Arguments ..
1485  INTEGER ICTXT
1486 * ..
1487 *
1488 * Purpose
1489 * =======
1490 *
1491 * PZSETPBLAS initializes *all* the dummy arguments to correct values.
1492 *
1493 * Notes
1494 * =====
1495 *
1496 * A description vector is associated with each 2D block-cyclicly dis-
1497 * tributed matrix. This vector stores the information required to
1498 * establish the mapping between a matrix entry and its corresponding
1499 * process and memory location.
1500 *
1501 * In the following comments, the character _ should be read as
1502 * "of the distributed matrix". Let A be a generic term for any 2D
1503 * block cyclicly distributed matrix. Its description vector is DESCA:
1504 *
1505 * NOTATION STORED IN EXPLANATION
1506 * ---------------- --------------- ------------------------------------
1507 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1508 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1509 * the NPROW x NPCOL BLACS process grid
1510 * A is distributed over. The context
1511 * itself is global, but the handle
1512 * (the integer value) may vary.
1513 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
1514 * ted matrix A, M_A >= 0.
1515 * N_A (global) DESCA( N_ ) The number of columns in the distri-
1516 * buted matrix A, N_A >= 0.
1517 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1518 * block of the matrix A, IMB_A > 0.
1519 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
1520 * left block of the matrix A,
1521 * INB_A > 0.
1522 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1523 * bute the last M_A-IMB_A rows of A,
1524 * MB_A > 0.
1525 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1526 * bute the last N_A-INB_A columns of
1527 * A, NB_A > 0.
1528 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1529 * row of the matrix A is distributed,
1530 * NPROW > RSRC_A >= 0.
1531 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1532 * first column of A is distributed.
1533 * NPCOL > CSRC_A >= 0.
1534 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1535 * array storing the local blocks of
1536 * the distributed matrix A,
1537 * IF( Lc( 1, N_A ) > 0 )
1538 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1539 * ELSE
1540 * LLD_A >= 1.
1541 *
1542 * Let K be the number of rows of a matrix A starting at the global in-
1543 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1544 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1545 * receive if these K rows were distributed over NPROW processes. If K
1546 * is the number of columns of a matrix A starting at the global index
1547 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1548 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1549 * these K columns were distributed over NPCOL processes.
1550 *
1551 * The values of Lr() and Lc() may be determined via a call to the func-
1552 * tion PB_NUMROC:
1553 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1554 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1555 *
1556 * Arguments
1557 * =========
1558 *
1559 * ICTXT (local input) INTEGER
1560 * On entry, ICTXT specifies the BLACS context handle, indica-
1561 * ting the global context of the operation. The context itself
1562 * is global, but the value of ICTXT is local.
1563 *
1564 * -- Written on April 1, 1998 by
1565 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1566 *
1567 * =====================================================================
1568 *
1569 * .. Parameters ..
1570  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1571  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1572  $ rsrc_
1573  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1574  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1575  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1576  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1577  DOUBLE PRECISION RONE
1578  COMPLEX*16 ONE
1579  parameter( one = ( 1.0d+0, 0.0d+0 ),
1580  $ rone = 1.0d+0 )
1581 * ..
1582 * .. External Subroutines ..
1583  EXTERNAL pb_descset2
1584 * ..
1585 * .. Common Blocks ..
1586  CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
1587  INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1588  $ jc, jx, jy, kdim, mdim, ndim
1589  DOUBLE PRECISION USCLR
1590  COMPLEX*16 SCLR
1591  INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1592  $ descx( dlen_ ), descy( dlen_ )
1593  COMPLEX*16 A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
1594  COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
1595  COMMON /pblasd/desca, descb, descc, descx, descy
1596  COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
1597  $ ja, jb, jc, jx, jy
1598  COMMON /pblasm/a, b, c
1599  COMMON /pblasn/kdim, mdim, ndim
1600  COMMON /pblass/sclr, usclr
1601  COMMON /pblasv/x, y
1602 * ..
1603 * .. Executable Statements ..
1604 *
1605 * Set default values for options
1606 *
1607  diag = 'N'
1608  side = 'L'
1609  transa = 'N'
1610  transb = 'N'
1611  uplo = 'U'
1612 *
1613 * Set default values for scalars
1614 *
1615  kdim = 1
1616  mdim = 1
1617  ndim = 1
1618  isclr = 1
1619  sclr = one
1620  usclr = rone
1621 *
1622 * Set default values for distributed matrix A
1623 *
1624  a( 1, 1 ) = one
1625  a( 2, 1 ) = one
1626  a( 1, 2 ) = one
1627  a( 2, 2 ) = one
1628  ia = 1
1629  ja = 1
1630  CALL pb_descset2( desca, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
1631 *
1632 * Set default values for distributed matrix B
1633 *
1634  b( 1, 1 ) = one
1635  b( 2, 1 ) = one
1636  b( 1, 2 ) = one
1637  b( 2, 2 ) = one
1638  ib = 1
1639  jb = 1
1640  CALL pb_descset2( descb, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
1641 *
1642 * Set default values for distributed matrix C
1643 *
1644  c( 1, 1 ) = one
1645  c( 2, 1 ) = one
1646  c( 1, 2 ) = one
1647  c( 2, 2 ) = one
1648  ic = 1
1649  jc = 1
1650  CALL pb_descset2( descc, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
1651 *
1652 * Set default values for distributed matrix X
1653 *
1654  x( 1 ) = one
1655  x( 2 ) = one
1656  ix = 1
1657  jx = 1
1658  CALL pb_descset2( descx, 2, 1, 1, 1, 1, 1, 0, 0, ictxt, 2 )
1659  incx = 1
1660 *
1661 * Set default values for distributed matrix Y
1662 *
1663  y( 1 ) = one
1664  y( 2 ) = one
1665  iy = 1
1666  jy = 1
1667  CALL pb_descset2( descy, 2, 1, 1, 1, 1, 1, 0, 0, ictxt, 2 )
1668  incy = 1
1669 *
1670  RETURN
1671 *
1672 * End of PZSETPBLAS
1673 *
1674  END
1675  SUBROUTINE pzchkmat( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
1676  $ ARGPOS )
1678 * -- PBLAS test routine (version 2.0) --
1679 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1680 * and University of California, Berkeley.
1681 * April 1, 1998
1682 *
1683 * .. Scalar Arguments ..
1684  CHARACTER*1 ARGNAM
1685  INTEGER ARGPOS, ICTXT, NOUT, SCODE
1686 * ..
1687 * .. Array Arguments ..
1688  CHARACTER*(*) SNAME
1689 * ..
1690 * .. Subroutine Arguments ..
1691  EXTERNAL subptr
1692 * ..
1693 *
1694 * Purpose
1695 * =======
1696 *
1697 * PZCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
1698 *
1699 * Notes
1700 * =====
1701 *
1702 * A description vector is associated with each 2D block-cyclicly dis-
1703 * tributed matrix. This vector stores the information required to
1704 * establish the mapping between a matrix entry and its corresponding
1705 * process and memory location.
1706 *
1707 * In the following comments, the character _ should be read as
1708 * "of the distributed matrix". Let A be a generic term for any 2D
1709 * block cyclicly distributed matrix. Its description vector is DESCA:
1710 *
1711 * NOTATION STORED IN EXPLANATION
1712 * ---------------- --------------- ------------------------------------
1713 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1714 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1715 * the NPROW x NPCOL BLACS process grid
1716 * A is distributed over. The context
1717 * itself is global, but the handle
1718 * (the integer value) may vary.
1719 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
1720 * ted matrix A, M_A >= 0.
1721 * N_A (global) DESCA( N_ ) The number of columns in the distri-
1722 * buted matrix A, N_A >= 0.
1723 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1724 * block of the matrix A, IMB_A > 0.
1725 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
1726 * left block of the matrix A,
1727 * INB_A > 0.
1728 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1729 * bute the last M_A-IMB_A rows of A,
1730 * MB_A > 0.
1731 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1732 * bute the last N_A-INB_A columns of
1733 * A, NB_A > 0.
1734 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1735 * row of the matrix A is distributed,
1736 * NPROW > RSRC_A >= 0.
1737 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1738 * first column of A is distributed.
1739 * NPCOL > CSRC_A >= 0.
1740 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1741 * array storing the local blocks of
1742 * the distributed matrix A,
1743 * IF( Lc( 1, N_A ) > 0 )
1744 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1745 * ELSE
1746 * LLD_A >= 1.
1747 *
1748 * Let K be the number of rows of a matrix A starting at the global in-
1749 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1750 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1751 * receive if these K rows were distributed over NPROW processes. If K
1752 * is the number of columns of a matrix A starting at the global index
1753 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1754 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1755 * these K columns were distributed over NPCOL processes.
1756 *
1757 * The values of Lr() and Lc() may be determined via a call to the func-
1758 * tion PB_NUMROC:
1759 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1760 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1761 *
1762 * Arguments
1763 * =========
1764 *
1765 * ICTXT (local input) INTEGER
1766 * On entry, ICTXT specifies the BLACS context handle, indica-
1767 * ting the global context of the operation. The context itself
1768 * is global, but the value of ICTXT is local.
1769 *
1770 * NOUT (global input) INTEGER
1771 * On entry, NOUT specifies the unit number for the output file.
1772 * When NOUT is 6, output to screen, when NOUT is 0, output to
1773 * stderr. NOUT is only defined for process 0.
1774 *
1775 * SUBPTR (global input) SUBROUTINE
1776 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
1777 * EXTERNAL in the calling subroutine.
1778 *
1779 * SCODE (global input) INTEGER
1780 * On entry, SCODE specifies the calling sequence code.
1781 *
1782 * SNAME (global input) CHARACTER*(*)
1783 * On entry, SNAME specifies the subroutine name calling this
1784 * subprogram.
1785 *
1786 * ARGNAM (global input) CHARACTER*(*)
1787 * On entry, ARGNAM specifies the name of the matrix or vector
1788 * to be checked. ARGNAM can either be 'A', 'B' or 'C' when one
1789 * wants to check a matrix, and 'X' or 'Y' for a vector.
1790 *
1791 * ARGPOS (global input) INTEGER
1792 * On entry, ARGPOS indicates the position of the first argument
1793 * of the matrix (or vector) ARGNAM.
1794 *
1795 * -- Written on April 1, 1998 by
1796 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1797 *
1798 * =====================================================================
1799 *
1800 * .. Parameters ..
1801  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1802  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1803  $ RSRC_
1804  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1805  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1806  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1807  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1808  INTEGER DESCMULT
1809  PARAMETER ( DESCMULT = 100 )
1810 * ..
1811 * .. Local Scalars ..
1812  INTEGER I, INFOT, NPROW, NPCOL, MYROW, MYCOL
1813 * ..
1814 * .. External Subroutines ..
1815  EXTERNAL blacs_gridinfo, pchkpbe, pzcallsub, pzsetpblas
1816 * ..
1817 * .. External Functions ..
1818  LOGICAL LSAME
1819  EXTERNAL LSAME
1820 * ..
1821 * .. Common Blocks ..
1822  INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1823  $ JC, JX, JY
1824  INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1825  $ descx( dlen_ ), descy( dlen_ )
1826  COMMON /pblasd/desca, descb, descc, descx, descy
1827  COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
1828  $ ja, jb, jc, jx, jy
1829 * ..
1830 * .. Executable Statements ..
1831 *
1832  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1833 *
1834  IF( lsame( argnam, 'A' ) ) THEN
1835 *
1836 * Check IA. Set all other OK, bad IA
1837 *
1838  CALL pzsetpblas( ictxt )
1839  ia = -1
1840  infot = argpos + 1
1841  CALL pzcallsub( subptr, scode )
1842  CALL pchkpbe( ictxt, nout, sname, infot )
1843 *
1844 * Check JA. Set all other OK, bad JA
1845 *
1846  CALL pzsetpblas( ictxt )
1847  ja = -1
1848  infot = argpos + 2
1849  CALL pzcallsub( subptr, scode )
1850  CALL pchkpbe( ictxt, nout, sname, infot )
1851 *
1852 * Check DESCA. Set all other OK, bad DESCA
1853 *
1854  DO 10 i = 1, dlen_
1855 *
1856 * Set I'th entry of DESCA to incorrect value, rest ok.
1857 *
1858  CALL pzsetpblas( ictxt )
1859  desca( i ) = -2
1860  infot = ( ( argpos + 3 ) * descmult ) + i
1861  CALL pzcallsub( subptr, scode )
1862  CALL pchkpbe( ictxt, nout, sname, infot )
1863 *
1864 * Extra tests for RSRCA, CSRCA, LDA
1865 *
1866  IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1867  $ ( i.EQ.lld_ ) ) THEN
1868 *
1869  CALL pzsetpblas( ictxt )
1870 *
1871 * Test RSRCA >= NPROW
1872 *
1873  IF( i.EQ.rsrc_ )
1874  $ desca( i ) = nprow
1875 *
1876 * Test CSRCA >= NPCOL
1877 *
1878  IF( i.EQ.csrc_ )
1879  $ desca( i ) = npcol
1880 *
1881 * Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1882 *
1883  IF( i.EQ.lld_ ) THEN
1884  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1885  desca( i ) = 1
1886  ELSE
1887  desca( i ) = 0
1888  END IF
1889  END IF
1890 *
1891  infot = ( ( argpos + 3 ) * descmult ) + i
1892  CALL pzcallsub( subptr, scode )
1893  CALL pchkpbe( ictxt, nout, sname, infot )
1894 *
1895  END IF
1896 *
1897  10 CONTINUE
1898 *
1899  ELSE IF( lsame( argnam, 'B' ) ) THEN
1900 *
1901 * Check IB. Set all other OK, bad IB
1902 *
1903  CALL pzsetpblas( ictxt )
1904  ib = -1
1905  infot = argpos + 1
1906  CALL pzcallsub( subptr, scode )
1907  CALL pchkpbe( ictxt, nout, sname, infot )
1908 *
1909 * Check JB. Set all other OK, bad JB
1910 *
1911  CALL pzsetpblas( ictxt )
1912  jb = -1
1913  infot = argpos + 2
1914  CALL pzcallsub( subptr, scode )
1915  CALL pchkpbe( ictxt, nout, sname, infot )
1916 *
1917 * Check DESCB. Set all other OK, bad DESCB
1918 *
1919  DO 20 i = 1, dlen_
1920 *
1921 * Set I'th entry of DESCB to incorrect value, rest ok.
1922 *
1923  CALL pzsetpblas( ictxt )
1924  descb( i ) = -2
1925  infot = ( ( argpos + 3 ) * descmult ) + i
1926  CALL pzcallsub( subptr, scode )
1927  CALL pchkpbe( ictxt, nout, sname, infot )
1928 *
1929 * Extra tests for RSRCB, CSRCB, LDB
1930 *
1931  IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1932  $ ( i.EQ.lld_ ) ) THEN
1933 *
1934  CALL pzsetpblas( ictxt )
1935 *
1936 * Test RSRCB >= NPROW
1937 *
1938  IF( i.EQ.rsrc_ )
1939  $ descb( i ) = nprow
1940 *
1941 * Test CSRCB >= NPCOL
1942 *
1943  IF( i.EQ.csrc_ )
1944  $ descb( i ) = npcol
1945 *
1946 * Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1947 *
1948  IF( i.EQ.lld_ ) THEN
1949  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1950  descb( i ) = 1
1951  ELSE
1952  descb( i ) = 0
1953  END IF
1954  END IF
1955 *
1956  infot = ( ( argpos + 3 ) * descmult ) + i
1957  CALL pzcallsub( subptr, scode )
1958  CALL pchkpbe( ictxt, nout, sname, infot )
1959 *
1960  END IF
1961 *
1962  20 CONTINUE
1963 *
1964  ELSE IF( lsame( argnam, 'C' ) ) THEN
1965 *
1966 * Check IC. Set all other OK, bad IC
1967 *
1968  CALL pzsetpblas( ictxt )
1969  ic = -1
1970  infot = argpos + 1
1971  CALL pzcallsub( subptr, scode )
1972  CALL pchkpbe( ictxt, nout, sname, infot )
1973 *
1974 * Check JC. Set all other OK, bad JC
1975 *
1976  CALL pzsetpblas( ictxt )
1977  jc = -1
1978  infot = argpos + 2
1979  CALL pzcallsub( subptr, scode )
1980  CALL pchkpbe( ictxt, nout, sname, infot )
1981 *
1982 * Check DESCC. Set all other OK, bad DESCC
1983 *
1984  DO 30 i = 1, dlen_
1985 *
1986 * Set I'th entry of DESCC to incorrect value, rest ok.
1987 *
1988  CALL pzsetpblas( ictxt )
1989  descc( i ) = -2
1990  infot = ( ( argpos + 3 ) * descmult ) + i
1991  CALL pzcallsub( subptr, scode )
1992  CALL pchkpbe( ictxt, nout, sname, infot )
1993 *
1994 * Extra tests for RSRCC, CSRCC, LDC
1995 *
1996  IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1997  $ ( i.EQ.lld_ ) ) THEN
1998 *
1999  CALL pzsetpblas( ictxt )
2000 *
2001 * Test RSRCC >= NPROW
2002 *
2003  IF( i.EQ.rsrc_ )
2004  $ descc( i ) = nprow
2005 *
2006 * Test CSRCC >= NPCOL
2007 *
2008  IF( i.EQ.csrc_ )
2009  $ descc( i ) = npcol
2010 *
2011 * Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2012 *
2013  IF( i.EQ.lld_ ) THEN
2014  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2015  descc( i ) = 1
2016  ELSE
2017  descc( i ) = 0
2018  END IF
2019  END IF
2020 *
2021  infot = ( ( argpos + 3 ) * descmult ) + i
2022  CALL pzcallsub( subptr, scode )
2023  CALL pchkpbe( ictxt, nout, sname, infot )
2024 *
2025  END IF
2026 *
2027  30 CONTINUE
2028 *
2029  ELSE IF( lsame( argnam, 'X' ) ) THEN
2030 *
2031 * Check IX. Set all other OK, bad IX
2032 *
2033  CALL pzsetpblas( ictxt )
2034  ix = -1
2035  infot = argpos + 1
2036  CALL pzcallsub( subptr, scode )
2037  CALL pchkpbe( ictxt, nout, sname, infot )
2038 *
2039 * Check JX. Set all other OK, bad JX
2040 *
2041  CALL pzsetpblas( ictxt )
2042  jx = -1
2043  infot = argpos + 2
2044  CALL pzcallsub( subptr, scode )
2045  CALL pchkpbe( ictxt, nout, sname, infot )
2046 *
2047 * Check DESCX. Set all other OK, bad DESCX
2048 *
2049  DO 40 i = 1, dlen_
2050 *
2051 * Set I'th entry of DESCX to incorrect value, rest ok.
2052 *
2053  CALL pzsetpblas( ictxt )
2054  descx( i ) = -2
2055  infot = ( ( argpos + 3 ) * descmult ) + i
2056  CALL pzcallsub( subptr, scode )
2057  CALL pchkpbe( ictxt, nout, sname, infot )
2058 *
2059 * Extra tests for RSRCX, CSRCX, LDX
2060 *
2061  IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2062  $ ( i.EQ.lld_ ) ) THEN
2063 *
2064  CALL pzsetpblas( ictxt )
2065 *
2066 * Test RSRCX >= NPROW
2067 *
2068  IF( i.EQ.rsrc_ )
2069  $ descx( i ) = nprow
2070 *
2071 * Test CSRCX >= NPCOL
2072 *
2073  IF( i.EQ.csrc_ )
2074  $ descx( i ) = npcol
2075 *
2076 * Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2077 *
2078  IF( i.EQ.lld_ ) THEN
2079  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2080  descx( i ) = 1
2081  ELSE
2082  descx( i ) = 0
2083  END IF
2084  END IF
2085 *
2086  infot = ( ( argpos + 3 ) * descmult ) + i
2087  CALL pzcallsub( subptr, scode )
2088  CALL pchkpbe( ictxt, nout, sname, infot )
2089 *
2090  END IF
2091 *
2092  40 CONTINUE
2093 *
2094 * Check INCX. Set all other OK, bad INCX
2095 *
2096  CALL pzsetpblas( ictxt )
2097  incx = -1
2098  infot = argpos + 4
2099  CALL pzcallsub( subptr, scode )
2100  CALL pchkpbe( ictxt, nout, sname, infot )
2101 *
2102  ELSE
2103 *
2104 * Check IY. Set all other OK, bad IY
2105 *
2106  CALL pzsetpblas( ictxt )
2107  iy = -1
2108  infot = argpos + 1
2109  CALL pzcallsub( subptr, scode )
2110  CALL pchkpbe( ictxt, nout, sname, infot )
2111 *
2112 * Check JY. Set all other OK, bad JY
2113 *
2114  CALL pzsetpblas( ictxt )
2115  jy = -1
2116  infot = argpos + 2
2117  CALL pzcallsub( subptr, scode )
2118  CALL pchkpbe( ictxt, nout, sname, infot )
2119 *
2120 * Check DESCY. Set all other OK, bad DESCY
2121 *
2122  DO 50 i = 1, dlen_
2123 *
2124 * Set I'th entry of DESCY to incorrect value, rest ok.
2125 *
2126  CALL pzsetpblas( ictxt )
2127  descy( i ) = -2
2128  infot = ( ( argpos + 3 ) * descmult ) + i
2129  CALL pzcallsub( subptr, scode )
2130  CALL pchkpbe( ictxt, nout, sname, infot )
2131 *
2132 * Extra tests for RSRCY, CSRCY, LDY
2133 *
2134  IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2135  $ ( i.EQ.lld_ ) ) THEN
2136 *
2137  CALL pzsetpblas( ictxt )
2138 *
2139 * Test RSRCY >= NPROW
2140 *
2141  IF( i.EQ.rsrc_ )
2142  $ descy( i ) = nprow
2143 *
2144 * Test CSRCY >= NPCOL
2145 *
2146  IF( i.EQ.csrc_ )
2147  $ descy( i ) = npcol
2148 *
2149 * Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2150 *
2151  IF( i.EQ.lld_ ) THEN
2152  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2153  descy( i ) = 1
2154  ELSE
2155  descy( i ) = 0
2156  END IF
2157  END IF
2158 *
2159  infot = ( ( argpos + 3 ) * descmult ) + i
2160  CALL pzcallsub( subptr, scode )
2161  CALL pchkpbe( ictxt, nout, sname, infot )
2162 *
2163  END IF
2164 *
2165  50 CONTINUE
2166 *
2167 * Check INCY. Set all other OK, bad INCY
2168 *
2169  CALL pzsetpblas( ictxt )
2170  incy = -1
2171  infot = argpos + 4
2172  CALL pzcallsub( subptr, scode )
2173  CALL pchkpbe( ictxt, nout, sname, infot )
2174 *
2175  END IF
2176 *
2177  RETURN
2178 *
2179 * End of PZCHKMAT
2180 *
2181  END
2182  SUBROUTINE pzcallsub( SUBPTR, SCODE )
2184 * -- PBLAS test routine (version 2.0) --
2185 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2186 * and University of California, Berkeley.
2187 * April 1, 1998
2188 *
2189 * .. Scalar Arguments ..
2190  INTEGER SCODE
2191 * ..
2192 * .. Subroutine Arguments ..
2193  EXTERNAL subptr
2194 * ..
2195 *
2196 * Purpose
2197 * =======
2198 *
2199 * PZCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
2200 * tified by SCODE.
2201 *
2202 * Notes
2203 * =====
2204 *
2205 * A description vector is associated with each 2D block-cyclicly dis-
2206 * tributed matrix. This vector stores the information required to
2207 * establish the mapping between a matrix entry and its corresponding
2208 * process and memory location.
2209 *
2210 * In the following comments, the character _ should be read as
2211 * "of the distributed matrix". Let A be a generic term for any 2D
2212 * block cyclicly distributed matrix. Its description vector is DESCA:
2213 *
2214 * NOTATION STORED IN EXPLANATION
2215 * ---------------- --------------- ------------------------------------
2216 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2217 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2218 * the NPROW x NPCOL BLACS process grid
2219 * A is distributed over. The context
2220 * itself is global, but the handle
2221 * (the integer value) may vary.
2222 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2223 * ted matrix A, M_A >= 0.
2224 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2225 * buted matrix A, N_A >= 0.
2226 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2227 * block of the matrix A, IMB_A > 0.
2228 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2229 * left block of the matrix A,
2230 * INB_A > 0.
2231 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2232 * bute the last M_A-IMB_A rows of A,
2233 * MB_A > 0.
2234 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2235 * bute the last N_A-INB_A columns of
2236 * A, NB_A > 0.
2237 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2238 * row of the matrix A is distributed,
2239 * NPROW > RSRC_A >= 0.
2240 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2241 * first column of A is distributed.
2242 * NPCOL > CSRC_A >= 0.
2243 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2244 * array storing the local blocks of
2245 * the distributed matrix A,
2246 * IF( Lc( 1, N_A ) > 0 )
2247 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2248 * ELSE
2249 * LLD_A >= 1.
2250 *
2251 * Let K be the number of rows of a matrix A starting at the global in-
2252 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2253 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2254 * receive if these K rows were distributed over NPROW processes. If K
2255 * is the number of columns of a matrix A starting at the global index
2256 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2257 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2258 * these K columns were distributed over NPCOL processes.
2259 *
2260 * The values of Lr() and Lc() may be determined via a call to the func-
2261 * tion PB_NUMROC:
2262 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2263 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2264 *
2265 * Arguments
2266 * =========
2267 *
2268 * SUBPTR (global input) SUBROUTINE
2269 * On entry, SUBPTR is a subroutine. SUBPTR must be declared
2270 * EXTERNAL in the calling subroutine.
2271 *
2272 * SCODE (global input) INTEGER
2273 * On entry, SCODE specifies the calling sequence code.
2274 *
2275 * Calling sequence encodings
2276 * ==========================
2277 *
2278 * code Formal argument list Examples
2279 *
2280 * 11 (n, v1,v2) _SWAP, _COPY
2281 * 12 (n,s1, v1 ) _SCAL, _SCAL
2282 * 13 (n,s1, v1,v2) _AXPY, _DOT_
2283 * 14 (n,s1,i1,v1 ) _AMAX
2284 * 15 (n,u1, v1 ) _ASUM, _NRM2
2285 *
2286 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2287 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2288 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2289 * 24 ( m,n,s1,v1,v2,m1) _GER_
2290 * 25 (uplo, n,s1,v1, m1) _SYR
2291 * 26 (uplo, n,u1,v1, m1) _HER
2292 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2293 *
2294 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2295 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2296 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2297 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2298 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2299 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2300 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
2301 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2302 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2303 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2304 *
2305 * -- Written on April 1, 1998 by
2306 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2307 *
2308 * =====================================================================
2309 *
2310 * .. Parameters ..
2311  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2312  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2313  $ RSRC_
2314  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2315  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2316  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2317  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2318 * ..
2319 * .. Common Blocks ..
2320  CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2321  INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
2322  $ JC, JX, JY, KDIM, MDIM, NDIM
2323  DOUBLE PRECISION USCLR
2324  COMPLEX*16 SCLR
2325  INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
2326  $ descx( dlen_ ), descy( dlen_ )
2327  COMPLEX*16 A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
2328  COMMON /pblasc/diag, side, transa, transb, uplo
2329  COMMON /pblasd/desca, descb, descc, descx, descy
2330  COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
2331  $ ja, jb, jc, jx, jy
2332  COMMON /pblasm/a, b, c
2333  COMMON /pblasn/kdim, mdim, ndim
2334  COMMON /pblass/sclr, usclr
2335  COMMON /pblasv/x, y
2336 * ..
2337 * .. Executable Statements ..
2338 *
2339 * Level 1 PBLAS
2340 *
2341  IF( scode.EQ.11 ) THEN
2342 *
2343  CALL subptr( ndim, x, ix, jx, descx, incx, y, iy, jy, descy,
2344  $ incy )
2345 *
2346  ELSE IF( scode.EQ.12 ) THEN
2347 *
2348  CALL subptr( ndim, sclr, x, ix, jx, descx, incx )
2349 *
2350  ELSE IF( scode.EQ.13 ) THEN
2351 *
2352  CALL subptr( ndim, sclr, x, ix, jx, descx, incx, y, iy, jy,
2353  $ descy, incy )
2354 *
2355  ELSE IF( scode.EQ.14 ) THEN
2356 *
2357  CALL subptr( ndim, sclr, isclr, x, ix, jx, descx, incx )
2358 *
2359  ELSE IF( scode.EQ.15 ) THEN
2360 *
2361  CALL subptr( ndim, usclr, x, ix, jx, descx, incx )
2362 *
2363 * Level 2 PBLAS
2364 *
2365  ELSE IF( scode.EQ.21 ) THEN
2366 *
2367  CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, x, ix,
2368  $ jx, descx, incx, sclr, y, iy, jy, descy, incy )
2369 *
2370  ELSE IF( scode.EQ.22 ) THEN
2371 *
2372  CALL subptr( uplo, ndim, sclr, a, ia, ja, desca, x, ix, jx,
2373  $ descx, incx, sclr, y, iy, jy, descy, incy )
2374 *
2375  ELSE IF( scode.EQ.23 ) THEN
2376 *
2377  CALL subptr( uplo, transa, diag, ndim, a, ia, ja, desca, x, ix,
2378  $ jx, descx, incx )
2379 *
2380  ELSE IF( scode.EQ.24 ) THEN
2381 *
2382  CALL subptr( mdim, ndim, sclr, x, ix, jx, descx, incx, y, iy,
2383  $ jy, descy, incy, a, ia, ja, desca )
2384 *
2385  ELSE IF( scode.EQ.25 ) THEN
2386 *
2387  CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, a, ia,
2388  $ ja, desca )
2389 *
2390  ELSE IF( scode.EQ.26 ) THEN
2391 *
2392  CALL subptr( uplo, ndim, usclr, x, ix, jx, descx, incx, a, ia,
2393  $ ja, desca )
2394 *
2395  ELSE IF( scode.EQ.27 ) THEN
2396 *
2397  CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, y, iy,
2398  $ jy, descy, incy, a, ia, ja, desca )
2399 *
2400 * Level 3 PBLAS
2401 *
2402  ELSE IF( scode.EQ.31 ) THEN
2403 *
2404  CALL subptr( transa, transb, mdim, ndim, kdim, sclr, a, ia, ja,
2405  $ desca, b, ib, jb, descb, sclr, c, ic, jc, descc )
2406 *
2407  ELSE IF( scode.EQ.32 ) THEN
2408 *
2409  CALL subptr( side, uplo, mdim, ndim, sclr, a, ia, ja, desca, b,
2410  $ ib, jb, descb, sclr, c, ic, jc, descc )
2411 *
2412  ELSE IF( scode.EQ.33 ) THEN
2413 *
2414  CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2415  $ sclr, c, ic, jc, descc )
2416 *
2417  ELSE IF( scode.EQ.34 ) THEN
2418 *
2419  CALL subptr( uplo, transa, ndim, kdim, usclr, a, ia, ja, desca,
2420  $ usclr, c, ic, jc, descc )
2421 *
2422  ELSE IF( scode.EQ.35 ) THEN
2423 *
2424  CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2425  $ b, ib, jb, descb, sclr, c, ic, jc, descc )
2426 *
2427  ELSE IF( scode.EQ.36 ) THEN
2428 *
2429  CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2430  $ b, ib, jb, descb, usclr, c, ic, jc, descc )
2431 *
2432  ELSE IF( scode.EQ.37 ) THEN
2433 *
2434  CALL subptr( mdim, ndim, sclr, a, ia, ja, desca, sclr, c, ic,
2435  $ jc, descc )
2436 *
2437  ELSE IF( scode.EQ.38 ) THEN
2438 *
2439  CALL subptr( side, uplo, transa, diag, mdim, ndim, sclr, a, ia,
2440  $ ja, desca, b, ib, jb, descb )
2441 *
2442  ELSE IF( scode.EQ.39 ) THEN
2443 *
2444  CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, sclr,
2445  $ c, ic, jc, descc )
2446 *
2447  ELSE IF( scode.EQ.40 ) THEN
2448 *
2449  CALL subptr( uplo, transa, mdim, ndim, sclr, a, ia, ja, desca,
2450  $ sclr, c, ic, jc, descc )
2451 *
2452  END IF
2453 *
2454  RETURN
2455 *
2456 * End of PZCALLSUB
2457 *
2458  END
2459  SUBROUTINE pzerrset( ERR, ERRMAX, XTRUE, X )
2461 * -- PBLAS test routine (version 2.0) --
2462 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2463 * and University of California, Berkeley.
2464 * April 1, 1998
2465 *
2466 * .. Scalar Arguments ..
2467  DOUBLE PRECISION ERR, ERRMAX
2468  COMPLEX*16 X, XTRUE
2469 * ..
2470 *
2471 * Purpose
2472 * =======
2473 *
2474 * PZERRSET computes the absolute difference ERR = |XTRUE - X| and com-
2475 * pares it with zero. ERRMAX accumulates the absolute error difference.
2476 *
2477 * Notes
2478 * =====
2479 *
2480 * A description vector is associated with each 2D block-cyclicly dis-
2481 * tributed matrix. This vector stores the information required to
2482 * establish the mapping between a matrix entry and its corresponding
2483 * process and memory location.
2484 *
2485 * In the following comments, the character _ should be read as
2486 * "of the distributed matrix". Let A be a generic term for any 2D
2487 * block cyclicly distributed matrix. Its description vector is DESCA:
2488 *
2489 * NOTATION STORED IN EXPLANATION
2490 * ---------------- --------------- ------------------------------------
2491 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2492 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2493 * the NPROW x NPCOL BLACS process grid
2494 * A is distributed over. The context
2495 * itself is global, but the handle
2496 * (the integer value) may vary.
2497 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2498 * ted matrix A, M_A >= 0.
2499 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2500 * buted matrix A, N_A >= 0.
2501 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2502 * block of the matrix A, IMB_A > 0.
2503 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2504 * left block of the matrix A,
2505 * INB_A > 0.
2506 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2507 * bute the last M_A-IMB_A rows of A,
2508 * MB_A > 0.
2509 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2510 * bute the last N_A-INB_A columns of
2511 * A, NB_A > 0.
2512 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2513 * row of the matrix A is distributed,
2514 * NPROW > RSRC_A >= 0.
2515 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2516 * first column of A is distributed.
2517 * NPCOL > CSRC_A >= 0.
2518 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2519 * array storing the local blocks of
2520 * the distributed matrix A,
2521 * IF( Lc( 1, N_A ) > 0 )
2522 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2523 * ELSE
2524 * LLD_A >= 1.
2525 *
2526 * Let K be the number of rows of a matrix A starting at the global in-
2527 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2528 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2529 * receive if these K rows were distributed over NPROW processes. If K
2530 * is the number of columns of a matrix A starting at the global index
2531 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2532 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2533 * these K columns were distributed over NPCOL processes.
2534 *
2535 * The values of Lr() and Lc() may be determined via a call to the func-
2536 * tion PB_NUMROC:
2537 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2538 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2539 *
2540 * Arguments
2541 * =========
2542 *
2543 * ERR (local output) DOUBLE PRECISION
2544 * On exit, ERR specifies the absolute difference |XTRUE - X|.
2545 *
2546 * ERRMAX (local input/local output) DOUBLE PRECISION
2547 * On entry, ERRMAX specifies a previously computed error. On
2548 * exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
2549 *
2550 * XTRUE (local input) COMPLEX*16
2551 * On entry, XTRUE specifies the true value.
2552 *
2553 * X (local input) COMPLEX*16
2554 * On entry, X specifies the value to be compared to XTRUE.
2555 *
2556 * -- Written on April 1, 1998 by
2557 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2558 *
2559 * =====================================================================
2560 *
2561 * .. External Functions ..
2562  DOUBLE PRECISION PDDIFF
2563  EXTERNAL PDDIFF
2564 * ..
2565 * .. Intrinsic Functions ..
2566  INTRINSIC abs, dble, dimag, max
2567 * ..
2568 * .. Executable Statements ..
2569 *
2570  err = abs( pddiff( dble( xtrue ), dble( x ) ) )
2571  err = max( err, abs( pddiff( dimag( xtrue ), dimag( x ) ) ) )
2572 *
2573  errmax = max( errmax, err )
2574 *
2575  RETURN
2576 *
2577 * End of PZERRSET
2578 *
2579  END
2580  SUBROUTINE pzchkvin( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
2581  $ INFO )
2583 * -- PBLAS test routine (version 2.0) --
2584 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2585 * and University of California, Berkeley.
2586 * April 1, 1998
2587 *
2588 * .. Scalar Arguments ..
2589  INTEGER INCX, INFO, IX, JX, N
2590  DOUBLE PRECISION ERRMAX
2591 * ..
2592 * .. Array Arguments ..
2593  INTEGER DESCX( * )
2594  COMPLEX*16 PX( * ), X( * )
2595 * ..
2596 *
2597 * Purpose
2598 * =======
2599 *
2600 * PZCHKVIN checks that the submatrix sub( PX ) remained unchanged. The
2601 * local array entries are compared element by element, and their dif-
2602 * ference is tested against 0.0 as well as the epsilon machine. Notice
2603 * that this difference should be numerically exactly the zero machine,
2604 * but because of the possible fluctuation of some of the data we flag-
2605 * ged differently a difference less than twice the epsilon machine. The
2606 * largest error is also returned.
2607 *
2608 * Notes
2609 * =====
2610 *
2611 * A description vector is associated with each 2D block-cyclicly dis-
2612 * tributed matrix. This vector stores the information required to
2613 * establish the mapping between a matrix entry and its corresponding
2614 * process and memory location.
2615 *
2616 * In the following comments, the character _ should be read as
2617 * "of the distributed matrix". Let A be a generic term for any 2D
2618 * block cyclicly distributed matrix. Its description vector is DESCA:
2619 *
2620 * NOTATION STORED IN EXPLANATION
2621 * ---------------- --------------- ------------------------------------
2622 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2623 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2624 * the NPROW x NPCOL BLACS process grid
2625 * A is distributed over. The context
2626 * itself is global, but the handle
2627 * (the integer value) may vary.
2628 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2629 * ted matrix A, M_A >= 0.
2630 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2631 * buted matrix A, N_A >= 0.
2632 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2633 * block of the matrix A, IMB_A > 0.
2634 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2635 * left block of the matrix A,
2636 * INB_A > 0.
2637 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2638 * bute the last M_A-IMB_A rows of A,
2639 * MB_A > 0.
2640 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2641 * bute the last N_A-INB_A columns of
2642 * A, NB_A > 0.
2643 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2644 * row of the matrix A is distributed,
2645 * NPROW > RSRC_A >= 0.
2646 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2647 * first column of A is distributed.
2648 * NPCOL > CSRC_A >= 0.
2649 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2650 * array storing the local blocks of
2651 * the distributed matrix A,
2652 * IF( Lc( 1, N_A ) > 0 )
2653 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2654 * ELSE
2655 * LLD_A >= 1.
2656 *
2657 * Let K be the number of rows of a matrix A starting at the global in-
2658 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2659 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2660 * receive if these K rows were distributed over NPROW processes. If K
2661 * is the number of columns of a matrix A starting at the global index
2662 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2663 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2664 * these K columns were distributed over NPCOL processes.
2665 *
2666 * The values of Lr() and Lc() may be determined via a call to the func-
2667 * tion PB_NUMROC:
2668 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2669 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2670 *
2671 * Arguments
2672 * =========
2673 *
2674 * ERRMAX (global output) DOUBLE PRECISION
2675 * On exit, ERRMAX specifies the largest absolute element-wise
2676 * difference between sub( X ) and sub( PX ).
2677 *
2678 * N (global input) INTEGER
2679 * On entry, N specifies the length of the subvector operand
2680 * sub( X ). N must be at least zero.
2681 *
2682 * X (local input) COMPLEX*16 array
2683 * On entry, X is an array of dimension (DESCX( M_ ),*). This
2684 * array contains a local copy of the initial entire matrix PX.
2685 *
2686 * PX (local input) COMPLEX*16 array
2687 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2688 * array contains the local entries of the matrix PX.
2689 *
2690 * IX (global input) INTEGER
2691 * On entry, IX specifies X's global row index, which points to
2692 * the beginning of the submatrix sub( X ).
2693 *
2694 * JX (global input) INTEGER
2695 * On entry, JX specifies X's global column index, which points
2696 * to the beginning of the submatrix sub( X ).
2697 *
2698 * DESCX (global and local input) INTEGER array
2699 * On entry, DESCX is an integer array of dimension DLEN_. This
2700 * is the array descriptor for the matrix X.
2701 *
2702 * INCX (global input) INTEGER
2703 * On entry, INCX specifies the global increment for the
2704 * elements of X. Only two values of INCX are supported in
2705 * this version, namely 1 and M_X. INCX must not be zero.
2706 *
2707 * INFO (global output) INTEGER
2708 * On exit, if INFO = 0, no error has been found,
2709 * If INFO > 0, the maximum abolute error found is in (0,eps],
2710 * If INFO < 0, the maximum abolute error found is in (eps,+oo).
2711 *
2712 * -- Written on April 1, 1998 by
2713 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2714 *
2715 * =====================================================================
2716 *
2717 * .. Parameters ..
2718  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2719  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2720  $ RSRC_
2721  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
2722  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2723  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2724  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2725  DOUBLE PRECISION ZERO
2726  PARAMETER ( ZERO = 0.0d+0 )
2727 * ..
2728 * .. Local Scalars ..
2729  LOGICAL COLREP, ROWREP
2730  INTEGER I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
2731  $ IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL,
2732  $ MYCOL, MYROW, NPCOL, NPROW
2733  DOUBLE PRECISION ERR, EPS
2734 * ..
2735 * .. External Subroutines ..
2736  EXTERNAL blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
2737 * ..
2738 * .. External Functions ..
2739  DOUBLE PRECISION PDLAMCH
2740  EXTERNAL pdlamch
2741 * ..
2742 * .. Intrinsic Functions ..
2743  INTRINSIC abs, dble, dimag, max, min, mod
2744 * ..
2745 * .. Executable Statements ..
2746 *
2747  info = 0
2748  errmax = zero
2749 *
2750 * Quick return if possible
2751 *
2752  IF( n.LE.0 )
2753  $ RETURN
2754 *
2755  ictxt = descx( ctxt_ )
2756  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2757 *
2758  eps = pdlamch( ictxt, 'eps' )
2759 *
2760  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol, iix,
2761  $ jjx, ixrow, ixcol )
2762 *
2763  ldx = descx( m_ )
2764  ldpx = descx( lld_ )
2765  rowrep = ( ixrow.EQ.-1 )
2766  colrep = ( ixcol.EQ.-1 )
2767 *
2768  IF( n.EQ.1 ) THEN
2769 *
2770  IF( ( myrow.EQ.ixrow .OR. rowrep ) .AND.
2771  $ ( mycol.EQ.ixcol .OR. colrep ) )
2772  $ CALL pzerrset( err, errmax, x( ix+(jx-1)*ldx ),
2773  $ px( iix+(jjx-1)*ldpx ) )
2774 *
2775  ELSE IF( incx.EQ.descx( m_ ) ) THEN
2776 *
2777 * sub( X ) is a row vector
2778 *
2779  jb = descx( inb_ ) - jx + 1
2780  IF( jb.LE.0 )
2781  $ jb = ( ( -jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2782  jb = min( jb, n )
2783  jn = jx + jb - 1
2784 *
2785  IF( myrow.EQ.ixrow .OR. rowrep ) THEN
2786 *
2787  icurcol = ixcol
2788  IF( mycol.EQ.icurcol .OR. colrep ) THEN
2789  DO 10 j = jx, jn
2790  CALL pzerrset( err, errmax, x( ix+(j-1)*ldx ),
2791  $ px( iix+(jjx-1)*ldpx ) )
2792  jjx = jjx + 1
2793  10 CONTINUE
2794  END IF
2795  icurcol = mod( icurcol+1, npcol )
2796 *
2797  DO 30 j = jn+1, jx+n-1, descx( nb_ )
2798  jb = min( jx+n-j, descx( nb_ ) )
2799 *
2800  IF( mycol.EQ.icurcol .OR. colrep ) THEN
2801 *
2802  DO 20 kk = 0, jb-1
2803  CALL pzerrset( err, errmax, x( ix+(j+kk-1)*ldx ),
2804  $ px( iix+(jjx+kk-1)*ldpx ) )
2805  20 CONTINUE
2806 *
2807  jjx = jjx + jb
2808 *
2809  END IF
2810 *
2811  icurcol = mod( icurcol+1, npcol )
2812 *
2813  30 CONTINUE
2814 *
2815  END IF
2816 *
2817  ELSE
2818 *
2819 * sub( X ) is a column vector
2820 *
2821  ib = descx( imb_ ) - ix + 1
2822  IF( ib.LE.0 )
2823  $ ib = ( ( -ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2824  ib = min( ib, n )
2825  in = ix + ib - 1
2826 *
2827  IF( mycol.EQ.ixcol .OR. colrep ) THEN
2828 *
2829  icurrow = ixrow
2830  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
2831  DO 40 i = ix, in
2832  CALL pzerrset( err, errmax, x( i+(jx-1)*ldx ),
2833  $ px( iix+(jjx-1)*ldpx ) )
2834  iix = iix + 1
2835  40 CONTINUE
2836  END IF
2837  icurrow = mod( icurrow+1, nprow )
2838 *
2839  DO 60 i = in+1, ix+n-1, descx( mb_ )
2840  ib = min( ix+n-i, descx( mb_ ) )
2841 *
2842  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
2843 *
2844  DO 50 kk = 0, ib-1
2845  CALL pzerrset( err, errmax, x( i+kk+(jx-1)*ldx ),
2846  $ px( iix+kk+(jjx-1)*ldpx ) )
2847  50 CONTINUE
2848 *
2849  iix = iix + ib
2850 *
2851  END IF
2852 *
2853  icurrow = mod( icurrow+1, nprow )
2854 *
2855  60 CONTINUE
2856 *
2857  END IF
2858 *
2859  END IF
2860 *
2861  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
2862  $ -1, -1 )
2863 *
2864  IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
2865  info = 1
2866  ELSE IF( errmax.GT.eps ) THEN
2867  info = -1
2868  END IF
2869 *
2870  RETURN
2871 *
2872 * End of PZCHKVIN
2873 *
2874  END
2875  SUBROUTINE pzchkvout( N, X, PX, IX, JX, DESCX, INCX, INFO )
2877 * -- PBLAS test routine (version 2.0) --
2878 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2879 * and University of California, Berkeley.
2880 * April 1, 1998
2881 *
2882 * .. Scalar Arguments ..
2883  INTEGER INCX, INFO, IX, JX, N
2884 * ..
2885 * .. Array Arguments ..
2886  INTEGER DESCX( * )
2887  COMPLEX*16 PX( * ), X( * )
2888 * ..
2889 *
2890 * Purpose
2891 * =======
2892 *
2893 * PZCHKVOUT checks that the matrix PX \ sub( PX ) remained unchanged.
2894 * The local array entries are compared element by element, and their
2895 * difference is tested against 0.0 as well as the epsilon machine. No-
2896 * tice that this difference should be numerically exactly the zero ma-
2897 * chine, but because of the possible movement of some of the data we
2898 * flagged differently a difference less than twice the epsilon machine.
2899 * The largest error is reported.
2900 *
2901 * Notes
2902 * =====
2903 *
2904 * A description vector is associated with each 2D block-cyclicly dis-
2905 * tributed matrix. This vector stores the information required to
2906 * establish the mapping between a matrix entry and its corresponding
2907 * process and memory location.
2908 *
2909 * In the following comments, the character _ should be read as
2910 * "of the distributed matrix". Let A be a generic term for any 2D
2911 * block cyclicly distributed matrix. Its description vector is DESCA:
2912 *
2913 * NOTATION STORED IN EXPLANATION
2914 * ---------------- --------------- ------------------------------------
2915 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2916 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2917 * the NPROW x NPCOL BLACS process grid
2918 * A is distributed over. The context
2919 * itself is global, but the handle
2920 * (the integer value) may vary.
2921 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2922 * ted matrix A, M_A >= 0.
2923 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2924 * buted matrix A, N_A >= 0.
2925 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2926 * block of the matrix A, IMB_A > 0.
2927 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2928 * left block of the matrix A,
2929 * INB_A > 0.
2930 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2931 * bute the last M_A-IMB_A rows of A,
2932 * MB_A > 0.
2933 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2934 * bute the last N_A-INB_A columns of
2935 * A, NB_A > 0.
2936 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2937 * row of the matrix A is distributed,
2938 * NPROW > RSRC_A >= 0.
2939 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2940 * first column of A is distributed.
2941 * NPCOL > CSRC_A >= 0.
2942 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2943 * array storing the local blocks of
2944 * the distributed matrix A,
2945 * IF( Lc( 1, N_A ) > 0 )
2946 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2947 * ELSE
2948 * LLD_A >= 1.
2949 *
2950 * Let K be the number of rows of a matrix A starting at the global in-
2951 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2952 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2953 * receive if these K rows were distributed over NPROW processes. If K
2954 * is the number of columns of a matrix A starting at the global index
2955 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2956 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2957 * these K columns were distributed over NPCOL processes.
2958 *
2959 * The values of Lr() and Lc() may be determined via a call to the func-
2960 * tion PB_NUMROC:
2961 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2962 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2963 *
2964 * Arguments
2965 * =========
2966 *
2967 * N (global input) INTEGER
2968 * On entry, N specifies the length of the subvector operand
2969 * sub( X ). N must be at least zero.
2970 *
2971 * X (local input) COMPLEX*16 array
2972 * On entry, X is an array of dimension (DESCX( M_ ),*). This
2973 * array contains a local copy of the initial entire matrix PX.
2974 *
2975 * PX (local input) COMPLEX*16 array
2976 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2977 * array contains the local entries of the matrix PX.
2978 *
2979 * IX (global input) INTEGER
2980 * On entry, IX specifies X's global row index, which points to
2981 * the beginning of the submatrix sub( X ).
2982 *
2983 * JX (global input) INTEGER
2984 * On entry, JX specifies X's global column index, which points
2985 * to the beginning of the submatrix sub( X ).
2986 *
2987 * DESCX (global and local input) INTEGER array
2988 * On entry, DESCX is an integer array of dimension DLEN_. This
2989 * is the array descriptor for the matrix X.
2990 *
2991 * INCX (global input) INTEGER
2992 * On entry, INCX specifies the global increment for the
2993 * elements of X. Only two values of INCX are supported in
2994 * this version, namely 1 and M_X. INCX must not be zero.
2995 *
2996 * INFO (global output) INTEGER
2997 * On exit, if INFO = 0, no error has been found,
2998 * If INFO > 0, the maximum abolute error found is in (0,eps],
2999 * If INFO < 0, the maximum abolute error found is in (eps,+oo).
3000 *
3001 * -- Written on April 1, 1998 by
3002 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3003 *
3004 * =====================================================================
3005 *
3006 * .. Parameters ..
3007  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3008  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3009  $ RSRC_
3010  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3011  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3012  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3013  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3014  DOUBLE PRECISION ZERO
3015  PARAMETER ( ZERO = 0.0d+0 )
3016 * ..
3017 * .. Local Scalars ..
3018  LOGICAL COLREP, ROWREP
3019  INTEGER I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
3020  $ J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL,
3021  $ MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL,
3022  $ nprow, nqall
3023  DOUBLE PRECISION EPS, ERR, ERRMAX
3024 * ..
3025 * .. External Subroutines ..
3026  EXTERNAL BLACS_GRIDINFO, DGAMX2D, PZERRSET
3027 * ..
3028 * .. External Functions ..
3029  INTEGER PB_NUMROC
3030  DOUBLE PRECISION PDLAMCH
3031  EXTERNAL PDLAMCH, PB_NUMROC
3032 * ..
3033 * .. Intrinsic Functions ..
3034  INTRINSIC abs, dble, dimag, max, min, mod
3035 * ..
3036 * .. Executable Statements ..
3037 *
3038  info = 0
3039  errmax = zero
3040 *
3041 * Quick return if possible
3042 *
3043  IF( ( descx( m_ ).LE.0 ).OR.( descx( n_ ).LE.0 ) )
3044  $ RETURN
3045 *
3046 * Start the operations
3047 *
3048  ictxt = descx( ctxt_ )
3049  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3050 *
3051  eps = pdlamch( ictxt, 'eps' )
3052 *
3053  mpall = pb_numroc( descx( m_ ), 1, descx( imb_ ), descx( mb_ ),
3054  $ myrow, descx( rsrc_ ), nprow )
3055  nqall = pb_numroc( descx( n_ ), 1, descx( inb_ ), descx( nb_ ),
3056  $ mycol, descx( csrc_ ), npcol )
3057 *
3058  mbx = descx( mb_ )
3059  nbx = descx( nb_ )
3060  ldx = descx( m_ )
3061  ldpx = descx( lld_ )
3062  icurrow = descx( rsrc_ )
3063  icurcol = descx( csrc_ )
3064  rowrep = ( icurrow.EQ.-1 )
3065  colrep = ( icurcol.EQ.-1 )
3066  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3067  imbx = descx( imb_ )
3068  ELSE
3069  imbx = mbx
3070  END IF
3071  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3072  inbx = descx( inb_ )
3073  ELSE
3074  inbx = nbx
3075  END IF
3076  IF( rowrep ) THEN
3077  myrowdist = 0
3078  ELSE
3079  myrowdist = mod( myrow - icurrow + nprow, nprow )
3080  END IF
3081  IF( colrep ) THEN
3082  mycoldist = 0
3083  ELSE
3084  mycoldist = mod( mycol - icurcol + npcol, npcol )
3085  END IF
3086  ii = 1
3087  jj = 1
3088 *
3089  IF( incx.EQ.descx( m_ ) ) THEN
3090 *
3091 * sub( X ) is a row vector
3092 *
3093  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3094 *
3095  i = 1
3096  IF( mycoldist.EQ.0 ) THEN
3097  j = 1
3098  ELSE
3099  j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3100  END IF
3101  jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3102  ib = min( descx( m_ ), descx( imb_ ) )
3103 *
3104  DO 20 kk = 0, jb-1
3105  DO 10 ll = 0, ib-1
3106  IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR. j+kk.GT.jx+n-1 )
3107  $ CALL pzerrset( err, errmax,
3108  $ x( i+ll+(j+kk-1)*ldx ),
3109  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3110  10 CONTINUE
3111  20 CONTINUE
3112  IF( colrep ) THEN
3113  j = j + inbx
3114  ELSE
3115  j = j + inbx + ( npcol - 1 ) * nbx
3116  END IF
3117 *
3118  DO 50 jj = inbx+1, nqall, nbx
3119  jb = min( nqall-jj+1, nbx )
3120 *
3121  DO 40 kk = 0, jb-1
3122  DO 30 ll = 0, ib-1
3123  IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3124  $ j+kk.GT.jx+n-1 )
3125  $ CALL pzerrset( err, errmax,
3126  $ x( i+ll+(j+kk-1)*ldx ),
3127  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3128  30 CONTINUE
3129  40 CONTINUE
3130 *
3131  IF( colrep ) THEN
3132  j = j + nbx
3133  ELSE
3134  j = j + npcol * nbx
3135  END IF
3136 *
3137  50 CONTINUE
3138 *
3139  ii = ii + ib
3140 *
3141  END IF
3142 *
3143  icurrow = mod( icurrow + 1, nprow )
3144 *
3145  DO 110 i = descx( imb_ ) + 1, descx( m_ ), mbx
3146  ib = min( descx( m_ ) - i + 1, mbx )
3147 *
3148  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3149 *
3150  IF( mycoldist.EQ.0 ) THEN
3151  j = 1
3152  ELSE
3153  j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3154  END IF
3155 *
3156  jj = 1
3157  jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3158  DO 70 kk = 0, jb-1
3159  DO 60 ll = 0, ib-1
3160  IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3161  $ j+kk.GT.jx+n-1 )
3162  $ CALL pzerrset( err, errmax,
3163  $ x( i+ll+(j+kk-1)*ldx ),
3164  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3165  60 CONTINUE
3166  70 CONTINUE
3167  IF( colrep ) THEN
3168  j = j + inbx
3169  ELSE
3170  j = j + inbx + ( npcol - 1 ) * nbx
3171  END IF
3172 *
3173  DO 100 jj = inbx+1, nqall, nbx
3174  jb = min( nqall-jj+1, nbx )
3175 *
3176  DO 90 kk = 0, jb-1
3177  DO 80 ll = 0, ib-1
3178  IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3179  $ j+kk.GT.jx+n-1 )
3180  $ CALL pzerrset( err, errmax,
3181  $ x( i+ll+(j+kk-1)*ldx ),
3182  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3183  80 CONTINUE
3184  90 CONTINUE
3185 *
3186  IF( colrep ) THEN
3187  j = j + nbx
3188  ELSE
3189  j = j + npcol * nbx
3190  END IF
3191 *
3192  100 CONTINUE
3193 *
3194  ii = ii + ib
3195 *
3196  END IF
3197 *
3198  icurrow = mod( icurrow + 1, nprow )
3199 *
3200  110 CONTINUE
3201 *
3202  ELSE
3203 *
3204 * sub( X ) is a column vector
3205 *
3206  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3207 *
3208  j = 1
3209  IF( myrowdist.EQ.0 ) THEN
3210  i = 1
3211  ELSE
3212  i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3213  END IF
3214  ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3215  jb = min( descx( n_ ), descx( inb_ ) )
3216 *
3217  DO 130 kk = 0, jb-1
3218  DO 120 ll = 0, ib-1
3219  IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR. i+ll.GT.ix+n-1 )
3220  $ CALL pzerrset( err, errmax,
3221  $ x( i+ll+(j+kk-1)*ldx ),
3222  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3223  120 CONTINUE
3224  130 CONTINUE
3225  IF( rowrep ) THEN
3226  i = i + imbx
3227  ELSE
3228  i = i + imbx + ( nprow - 1 ) * mbx
3229  END IF
3230 *
3231  DO 160 ii = imbx+1, mpall, mbx
3232  ib = min( mpall-ii+1, mbx )
3233 *
3234  DO 150 kk = 0, jb-1
3235  DO 140 ll = 0, ib-1
3236  IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3237  $ i+ll.GT.ix+n-1 )
3238  $ CALL pzerrset( err, errmax,
3239  $ x( i+ll+(j+kk-1)*ldx ),
3240  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3241  140 CONTINUE
3242  150 CONTINUE
3243 *
3244  IF( rowrep ) THEN
3245  i = i + mbx
3246  ELSE
3247  i = i + nprow * mbx
3248  END IF
3249 *
3250  160 CONTINUE
3251 *
3252  jj = jj + jb
3253 *
3254  END IF
3255 *
3256  icurcol = mod( icurcol + 1, npcol )
3257 *
3258  DO 220 j = descx( inb_ ) + 1, descx( n_ ), nbx
3259  jb = min( descx( n_ ) - j + 1, nbx )
3260 *
3261  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3262 *
3263  IF( myrowdist.EQ.0 ) THEN
3264  i = 1
3265  ELSE
3266  i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3267  END IF
3268 *
3269  ii = 1
3270  ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3271  DO 180 kk = 0, jb-1
3272  DO 170 ll = 0, ib-1
3273  IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3274  $ i+ll.GT.ix+n-1 )
3275  $ CALL pzerrset( err, errmax,
3276  $ x( i+ll+(j+kk-1)*ldx ),
3277  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3278  170 CONTINUE
3279  180 CONTINUE
3280  IF( rowrep ) THEN
3281  i = i + imbx
3282  ELSE
3283  i = i + imbx + ( nprow - 1 ) * mbx
3284  END IF
3285 *
3286  DO 210 ii = imbx+1, mpall, mbx
3287  ib = min( mpall-ii+1, mbx )
3288 *
3289  DO 200 kk = 0, jb-1
3290  DO 190 ll = 0, ib-1
3291  IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3292  $ i+ll.GT.ix+n-1 )
3293  $ CALL pzerrset( err, errmax,
3294  $ x( i+ll+(j+kk-1)*ldx ),
3295  $ px( ii+ll+(jj+kk-1)*ldpx ) )
3296  190 CONTINUE
3297  200 CONTINUE
3298 *
3299  IF( rowrep ) THEN
3300  i = i + mbx
3301  ELSE
3302  i = i + nprow * mbx
3303  END IF
3304 *
3305  210 CONTINUE
3306 *
3307  jj = jj + jb
3308 *
3309  END IF
3310 *
3311  icurcol = mod( icurcol + 1, npcol )
3312 *
3313  220 CONTINUE
3314 *
3315  END IF
3316 *
3317  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3318  $ -1, -1 )
3319 *
3320  IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3321  info = 1
3322  ELSE IF( errmax.GT.eps ) THEN
3323  info = -1
3324  END IF
3325 *
3326  RETURN
3327 *
3328 * End of PZCHKVOUT
3329 *
3330  END
3331  SUBROUTINE pzchkmin( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO )
3333 * -- PBLAS test routine (version 2.0) --
3334 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3335 * and University of California, Berkeley.
3336 * April 1, 1998
3337 *
3338 * .. Scalar Arguments ..
3339  INTEGER IA, INFO, JA, M, N
3340  DOUBLE PRECISION ERRMAX
3341 * ..
3342 * .. Array Arguments ..
3343  INTEGER DESCA( * )
3344  COMPLEX*16 PA( * ), A( * )
3345 * ..
3346 *
3347 * Purpose
3348 * =======
3349 *
3350 * PZCHKMIN checks that the submatrix sub( PA ) remained unchanged. The
3351 * local array entries are compared element by element, and their dif-
3352 * ference is tested against 0.0 as well as the epsilon machine. Notice
3353 * that this difference should be numerically exactly the zero machine,
3354 * but because of the possible fluctuation of some of the data we flag-
3355 * ged differently a difference less than twice the epsilon machine. The
3356 * largest error is also returned.
3357 *
3358 * Notes
3359 * =====
3360 *
3361 * A description vector is associated with each 2D block-cyclicly dis-
3362 * tributed matrix. This vector stores the information required to
3363 * establish the mapping between a matrix entry and its corresponding
3364 * process and memory location.
3365 *
3366 * In the following comments, the character _ should be read as
3367 * "of the distributed matrix". Let A be a generic term for any 2D
3368 * block cyclicly distributed matrix. Its description vector is DESCA:
3369 *
3370 * NOTATION STORED IN EXPLANATION
3371 * ---------------- --------------- ------------------------------------
3372 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3373 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3374 * the NPROW x NPCOL BLACS process grid
3375 * A is distributed over. The context
3376 * itself is global, but the handle
3377 * (the integer value) may vary.
3378 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
3379 * ted matrix A, M_A >= 0.
3380 * N_A (global) DESCA( N_ ) The number of columns in the distri-
3381 * buted matrix A, N_A >= 0.
3382 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3383 * block of the matrix A, IMB_A > 0.
3384 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
3385 * left block of the matrix A,
3386 * INB_A > 0.
3387 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3388 * bute the last M_A-IMB_A rows of A,
3389 * MB_A > 0.
3390 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3391 * bute the last N_A-INB_A columns of
3392 * A, NB_A > 0.
3393 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3394 * row of the matrix A is distributed,
3395 * NPROW > RSRC_A >= 0.
3396 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3397 * first column of A is distributed.
3398 * NPCOL > CSRC_A >= 0.
3399 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3400 * array storing the local blocks of
3401 * the distributed matrix A,
3402 * IF( Lc( 1, N_A ) > 0 )
3403 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
3404 * ELSE
3405 * LLD_A >= 1.
3406 *
3407 * Let K be the number of rows of a matrix A starting at the global in-
3408 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3409 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3410 * receive if these K rows were distributed over NPROW processes. If K
3411 * is the number of columns of a matrix A starting at the global index
3412 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3413 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3414 * these K columns were distributed over NPCOL processes.
3415 *
3416 * The values of Lr() and Lc() may be determined via a call to the func-
3417 * tion PB_NUMROC:
3418 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3419 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3420 *
3421 * Arguments
3422 * =========
3423 *
3424 * ERRMAX (global output) DOUBLE PRECISION
3425 * On exit, ERRMAX specifies the largest absolute element-wise
3426 * difference between sub( A ) and sub( PA ).
3427 *
3428 * M (global input) INTEGER
3429 * On entry, M specifies the number of rows of the submatrix
3430 * operand sub( A ). M must be at least zero.
3431 *
3432 * N (global input) INTEGER
3433 * On entry, N specifies the number of columns of the submatrix
3434 * operand sub( A ). N must be at least zero.
3435 *
3436 * A (local input) COMPLEX*16 array
3437 * On entry, A is an array of dimension (DESCA( M_ ),*). This
3438 * array contains a local copy of the initial entire matrix PA.
3439 *
3440 * PA (local input) COMPLEX*16 array
3441 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3442 * array contains the local entries of the matrix PA.
3443 *
3444 * IA (global input) INTEGER
3445 * On entry, IA specifies A's global row index, which points to
3446 * the beginning of the submatrix sub( A ).
3447 *
3448 * JA (global input) INTEGER
3449 * On entry, JA specifies A's global column index, which points
3450 * to the beginning of the submatrix sub( A ).
3451 *
3452 * DESCA (global and local input) INTEGER array
3453 * On entry, DESCA is an integer array of dimension DLEN_. This
3454 * is the array descriptor for the matrix A.
3455 *
3456 * INFO (global output) INTEGER
3457 * On exit, if INFO = 0, no error has been found,
3458 * If INFO > 0, the maximum abolute error found is in (0,eps],
3459 * If INFO < 0, the maximum abolute error found is in (eps,+oo).
3460 *
3461 * -- Written on April 1, 1998 by
3462 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3463 *
3464 * =====================================================================
3465 *
3466 * .. Parameters ..
3467  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3468  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3469  $ RSRC_
3470  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3471  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3472  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3473  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3474  DOUBLE PRECISION ZERO
3475  PARAMETER ( ZERO = 0.0d+0 )
3476 * ..
3477 * .. Local Scalars ..
3478  LOGICAL COLREP, ROWREP
3479  INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
3480  $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
3481  $ KK, LDA, LDPA, LL, MYCOL, MYROW, NPCOL, NPROW
3482  DOUBLE PRECISION ERR, EPS
3483 * ..
3484 * .. External Subroutines ..
3485  EXTERNAL blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
3486 * ..
3487 * .. External Functions ..
3488  DOUBLE PRECISION PDLAMCH
3489  EXTERNAL pdlamch
3490 * ..
3491 * .. Intrinsic Functions ..
3492  INTRINSIC abs, dble, dimag, max, min, mod
3493 * ..
3494 * .. Executable Statements ..
3495 *
3496  info = 0
3497  errmax = zero
3498 *
3499 * Quick return if posssible
3500 *
3501  IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )
3502  $ RETURN
3503 *
3504 * Start the operations
3505 *
3506  ictxt = desca( ctxt_ )
3507  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3508 *
3509  eps = pdlamch( ictxt, 'eps' )
3510 *
3511  CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia,
3512  $ jja, iarow, iacol )
3513 *
3514  ii = iia
3515  jj = jja
3516  lda = desca( m_ )
3517  ldpa = desca( lld_ )
3518  icurrow = iarow
3519  icurcol = iacol
3520  rowrep = ( iarow.EQ.-1 )
3521  colrep = ( iacol.EQ.-1 )
3522 *
3523 * Handle the first block of column separately
3524 *
3525  jb = desca( inb_ ) - ja + 1
3526  IF( jb.LE.0 )
3527  $ jb = ( ( -jb ) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
3528  jb = min( jb, n )
3529  jn = ja + jb - 1
3530 *
3531  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3532 *
3533  DO 40 h = 0, jb-1
3534  ib = desca( imb_ ) - ia + 1
3535  IF( ib.LE.0 )
3536  $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
3537  ib = min( ib, m )
3538  in = ia + ib - 1
3539  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3540  DO 10 k = 0, ib-1
3541  CALL pzerrset( err, errmax, a( ia+k+(ja+h-1)*lda ),
3542  $ pa( ii+k+(jj+h-1)*ldpa ) )
3543  10 CONTINUE
3544  ii = ii + ib
3545  END IF
3546  icurrow = mod( icurrow+1, nprow )
3547 *
3548 * Loop over remaining block of rows
3549 *
3550  DO 30 i = in+1, ia+m-1, desca( mb_ )
3551  ib = min( desca( mb_ ), ia+m-i )
3552  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3553  DO 20 k = 0, ib-1
3554  CALL pzerrset( err, errmax, a( i+k+(ja+h-1)*lda ),
3555  $ pa( ii+k+(jj+h-1)*ldpa ) )
3556  20 CONTINUE
3557  ii = ii + ib
3558  END IF
3559  icurrow = mod( icurrow+1, nprow )
3560  30 CONTINUE
3561 *
3562  ii = iia
3563  icurrow = iarow
3564  40 CONTINUE
3565 *
3566  jj = jj + jb
3567 *
3568  END IF
3569 *
3570  icurcol = mod( icurcol+1, npcol )
3571 *
3572 * Loop over remaining column blocks
3573 *
3574  DO 90 j = jn+1, ja+n-1, desca( nb_ )
3575  jb = min( desca( nb_ ), ja+n-j )
3576  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3577  DO 80 h = 0, jb-1
3578  ib = desca( imb_ ) - ia + 1
3579  IF( ib.LE.0 )
3580  $ ib = ( ( -ib ) / desca( mb_ ) + 1 )*desca( mb_ ) + ib
3581  ib = min( ib, m )
3582  in = ia + ib - 1
3583  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3584  DO 50 k = 0, ib-1
3585  CALL pzerrset( err, errmax, a( ia+k+(j+h-1)*lda ),
3586  $ pa( ii+k+(jj+h-1)*ldpa ) )
3587  50 CONTINUE
3588  ii = ii + ib
3589  END IF
3590  icurrow = mod( icurrow+1, nprow )
3591 *
3592 * Loop over remaining block of rows
3593 *
3594  DO 70 i = in+1, ia+m-1, desca( mb_ )
3595  ib = min( desca( mb_ ), ia+m-i )
3596  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3597  DO 60 k = 0, ib-1
3598  CALL pzerrset( err, errmax,
3599  $ a( i+k+(j+h-1)*lda ),
3600  $ pa( ii+k+(jj+h-1)*ldpa ) )
3601  60 CONTINUE
3602  ii = ii + ib
3603  END IF
3604  icurrow = mod( icurrow+1, nprow )
3605  70 CONTINUE
3606 *
3607  ii = iia
3608  icurrow = iarow
3609  80 CONTINUE
3610 *
3611  jj = jj + jb
3612  END IF
3613 *
3614  icurcol = mod( icurcol+1, npcol )
3615 *
3616  90 CONTINUE
3617 *
3618  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3619  $ -1, -1 )
3620 *
3621  IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3622  info = 1
3623  ELSE IF( errmax.GT.eps ) THEN
3624  info = -1
3625  END IF
3626 *
3627  RETURN
3628 *
3629 * End of PZCHKMIN
3630 *
3631  END
3632  SUBROUTINE pzchkmout( M, N, A, PA, IA, JA, DESCA, INFO )
3634 * -- PBLAS test routine (version 2.0) --
3635 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3636 * and University of California, Berkeley.
3637 * April 1, 1998
3638 *
3639 * .. Scalar Arguments ..
3640  INTEGER IA, INFO, JA, M, N
3641 * ..
3642 * .. Array Arguments ..
3643  INTEGER DESCA( * )
3644  COMPLEX*16 A( * ), PA( * )
3645 * ..
3646 *
3647 * Purpose
3648 * =======
3649 *
3650 * PZCHKMOUT checks that the matrix PA \ sub( PA ) remained unchanged.
3651 * The local array entries are compared element by element, and their
3652 * difference is tested against 0.0 as well as the epsilon machine. No-
3653 * tice that this difference should be numerically exactly the zero ma-
3654 * chine, but because of the possible movement of some of the data we
3655 * flagged differently a difference less than twice the epsilon machine.
3656 * The largest error is reported.
3657 *
3658 * Notes
3659 * =====
3660 *
3661 * A description vector is associated with each 2D block-cyclicly dis-
3662 * tributed matrix. This vector stores the information required to
3663 * establish the mapping between a matrix entry and its corresponding
3664 * process and memory location.
3665 *
3666 * In the following comments, the character _ should be read as
3667 * "of the distributed matrix". Let A be a generic term for any 2D
3668 * block cyclicly distributed matrix. Its description vector is DESCA:
3669 *
3670 * NOTATION STORED IN EXPLANATION
3671 * ---------------- --------------- ------------------------------------
3672 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3673 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3674 * the NPROW x NPCOL BLACS process grid
3675 * A is distributed over. The context
3676 * itself is global, but the handle
3677 * (the integer value) may vary.
3678 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
3679 * ted matrix A, M_A >= 0.
3680 * N_A (global) DESCA( N_ ) The number of columns in the distri-
3681 * buted matrix A, N_A >= 0.
3682 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3683 * block of the matrix A, IMB_A > 0.
3684 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
3685 * left block of the matrix A,
3686 * INB_A > 0.
3687 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3688 * bute the last M_A-IMB_A rows of A,
3689 * MB_A > 0.
3690 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3691 * bute the last N_A-INB_A columns of
3692 * A, NB_A > 0.
3693 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3694 * row of the matrix A is distributed,
3695 * NPROW > RSRC_A >= 0.
3696 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3697 * first column of A is distributed.
3698 * NPCOL > CSRC_A >= 0.
3699 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3700 * array storing the local blocks of
3701 * the distributed matrix A,
3702 * IF( Lc( 1, N_A ) > 0 )
3703 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
3704 * ELSE
3705 * LLD_A >= 1.
3706 *
3707 * Let K be the number of rows of a matrix A starting at the global in-
3708 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3709 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3710 * receive if these K rows were distributed over NPROW processes. If K
3711 * is the number of columns of a matrix A starting at the global index
3712 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3713 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3714 * these K columns were distributed over NPCOL processes.
3715 *
3716 * The values of Lr() and Lc() may be determined via a call to the func-
3717 * tion PB_NUMROC:
3718 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3719 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3720 *
3721 * Arguments
3722 * =========
3723 *
3724 * M (global input) INTEGER
3725 * On entry, M specifies the number of rows of the submatrix
3726 * sub( PA ). M must be at least zero.
3727 *
3728 * N (global input) INTEGER
3729 * On entry, N specifies the number of columns of the submatrix
3730 * sub( PA ). N must be at least zero.
3731 *
3732 * A (local input) COMPLEX*16 array
3733 * On entry, A is an array of dimension (DESCA( M_ ),*). This
3734 * array contains a local copy of the initial entire matrix PA.
3735 *
3736 * PA (local input) COMPLEX*16 array
3737 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3738 * array contains the local entries of the matrix PA.
3739 *
3740 * IA (global input) INTEGER
3741 * On entry, IA specifies A's global row index, which points to
3742 * the beginning of the submatrix sub( A ).
3743 *
3744 * JA (global input) INTEGER
3745 * On entry, JA specifies A's global column index, which points
3746 * to the beginning of the submatrix sub( A ).
3747 *
3748 * DESCA (global and local input) INTEGER array
3749 * On entry, DESCA is an integer array of dimension DLEN_. This
3750 * is the array descriptor for the matrix A.
3751 *
3752 * INFO (global output) INTEGER
3753 * On exit, if INFO = 0, no error has been found,
3754 * If INFO > 0, the maximum abolute error found is in (0,eps],
3755 * If INFO < 0, the maximum abolute error found is in (eps,+oo).
3756 *
3757 * -- Written on April 1, 1998 by
3758 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3759 *
3760 * =====================================================================
3761 *
3762 * .. Parameters ..
3763  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3764  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3765  $ RSRC_
3766  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3767  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3768  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3769  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3770  DOUBLE PRECISION ZERO
3771  PARAMETER ( ZERO = 0.0d+0 )
3772 * ..
3773 * .. Local Scalars ..
3774  LOGICAL COLREP, ROWREP
3775  INTEGER I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
3776  $ LDA, LDPA, LL, MPALL, MYCOL, MYROW, MYROWDIST,
3777  $ NPCOL, NPROW
3778  DOUBLE PRECISION EPS, ERR, ERRMAX
3779 * ..
3780 * .. External Subroutines ..
3781  EXTERNAL blacs_gridinfo, dgamx2d, pzerrset
3782 * ..
3783 * .. External Functions ..
3784  INTEGER PB_NUMROC
3785  DOUBLE PRECISION PDLAMCH
3786  EXTERNAL PDLAMCH, PB_NUMROC
3787 * ..
3788 * .. Intrinsic Functions ..
3789  INTRINSIC max, min, mod
3790 * ..
3791 * .. Executable Statements ..
3792 *
3793  info = 0
3794  errmax = zero
3795 *
3796 * Quick return if possible
3797 *
3798  IF( ( desca( m_ ).LE.0 ).OR.( desca( n_ ).LE.0 ) )
3799  $ RETURN
3800 *
3801 * Start the operations
3802 *
3803  ictxt = desca( ctxt_ )
3804  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3805 *
3806  eps = pdlamch( ictxt, 'eps' )
3807 *
3808  mpall = pb_numroc( desca( m_ ), 1, desca( imb_ ), desca( mb_ ),
3809  $ myrow, desca( rsrc_ ), nprow )
3810 *
3811  lda = desca( m_ )
3812  ldpa = desca( lld_ )
3813 *
3814  ii = 1
3815  jj = 1
3816  rowrep = ( desca( rsrc_ ).EQ.-1 )
3817  colrep = ( desca( csrc_ ).EQ.-1 )
3818  icurcol = desca( csrc_ )
3819  IF( myrow.EQ.desca( rsrc_ ) .OR. rowrep ) THEN
3820  imba = desca( imb_ )
3821  ELSE
3822  imba = desca( mb_ )
3823  END IF
3824  IF( rowrep ) THEN
3825  myrowdist = 0
3826  ELSE
3827  myrowdist = mod( myrow - desca( rsrc_ ) + nprow, nprow )
3828  END IF
3829 *
3830  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3831 *
3832  j = 1
3833  IF( myrowdist.EQ.0 ) THEN
3834  i = 1
3835  ELSE
3836  i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3837  END IF
3838  ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3839  jb = min( desca( n_ ), desca( inb_ ) )
3840 *
3841  DO 20 kk = 0, jb-1
3842  DO 10 ll = 0, ib-1
3843  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3844  $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3845  $ CALL pzerrset( err, errmax, a( i+ll+(j+kk-1)*lda ),
3846  $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3847  10 CONTINUE
3848  20 CONTINUE
3849  IF( rowrep ) THEN
3850  i = i + imba
3851  ELSE
3852  i = i + imba + ( nprow - 1 ) * desca( mb_ )
3853  END IF
3854 *
3855  DO 50 ii = imba + 1, mpall, desca( mb_ )
3856  ib = min( mpall-ii+1, desca( mb_ ) )
3857 *
3858  DO 40 kk = 0, jb-1
3859  DO 30 ll = 0, ib-1
3860  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3861  $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3862  $ CALL pzerrset( err, errmax,
3863  $ a( i+ll+(j+kk-1)*lda ),
3864  $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3865  30 CONTINUE
3866  40 CONTINUE
3867 *
3868  IF( rowrep ) THEN
3869  i = i + desca( mb_ )
3870  ELSE
3871  i = i + nprow * desca( mb_ )
3872  END IF
3873 *
3874  50 CONTINUE
3875 *
3876  jj = jj + jb
3877 *
3878  END IF
3879 *
3880  icurcol = mod( icurcol + 1, npcol )
3881 *
3882  DO 110 j = desca( inb_ ) + 1, desca( n_ ), desca( nb_ )
3883  jb = min( desca( n_ ) - j + 1, desca( nb_ ) )
3884 *
3885  IF( mycol.EQ.icurcol .OR. colrep ) THEN
3886 *
3887  IF( myrowdist.EQ.0 ) THEN
3888  i = 1
3889  ELSE
3890  i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3891  END IF
3892 *
3893  ii = 1
3894  ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3895  DO 70 kk = 0, jb-1
3896  DO 60 ll = 0, ib-1
3897  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3898  $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3899  $ CALL pzerrset( err, errmax,
3900  $ a( i+ll+(j+kk-1)*lda ),
3901  $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3902  60 CONTINUE
3903  70 CONTINUE
3904  IF( rowrep ) THEN
3905  i = i + imba
3906  ELSE
3907  i = i + imba + ( nprow - 1 ) * desca( mb_ )
3908  END IF
3909 *
3910  DO 100 ii = imba+1, mpall, desca( mb_ )
3911  ib = min( mpall-ii+1, desca( mb_ ) )
3912 *
3913  DO 90 kk = 0, jb-1
3914  DO 80 ll = 0, ib-1
3915  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3916  $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3917  $ CALL pzerrset( err, errmax,
3918  $ a( i+ll+(j+kk-1)*lda ),
3919  $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3920  80 CONTINUE
3921  90 CONTINUE
3922 *
3923  IF( rowrep ) THEN
3924  i = i + desca( mb_ )
3925  ELSE
3926  i = i + nprow * desca( mb_ )
3927  END IF
3928 *
3929  100 CONTINUE
3930 *
3931  jj = jj + jb
3932 *
3933  END IF
3934 *
3935  icurcol = mod( icurcol + 1, npcol )
3936 * INSERT MODE
3937  110 CONTINUE
3938 *
3939  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3940  $ -1, -1 )
3941 *
3942  IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3943  info = 1
3944  ELSE IF( errmax.GT.eps ) THEN
3945  info = -1
3946  END IF
3947 *
3948  RETURN
3949 *
3950 * End of PZCHKMOUT
3951 *
3952  END
3953  SUBROUTINE pzmprnt( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT,
3954  $ CMATNM )
3956 * -- PBLAS test routine (version 2.0) --
3957 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3958 * and University of California, Berkeley.
3959 * April 1, 1998
3960 *
3961 * .. Scalar Arguments ..
3962  INTEGER ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
3963 * ..
3964 * .. Array Arguments ..
3965  CHARACTER*(*) CMATNM
3966  COMPLEX*16 A( LDA, * )
3967 * ..
3968 *
3969 * Purpose
3970 * =======
3971 *
3972 * PZMPRNT prints to the standard output an array A of size m by n. Only
3973 * the process of coordinates ( IRPRNT, ICPRNT ) is printing.
3974 *
3975 * Arguments
3976 * =========
3977 *
3978 * ICTXT (local input) INTEGER
3979 * On entry, ICTXT specifies the BLACS context handle, indica-
3980 * ting the global context of the operation. The context itself
3981 * is global, but the value of ICTXT is local.
3982 *
3983 * NOUT (global input) INTEGER
3984 * On entry, NOUT specifies the unit number for the output file.
3985 * When NOUT is 6, output to screen, when NOUT is 0, output to
3986 * stderr. NOUT is only defined for process 0.
3987 *
3988 * M (global input) INTEGER
3989 * On entry, M specifies the number of rows of the matrix A. M
3990 * must be at least zero.
3991 *
3992 * N (global input) INTEGER
3993 * On entry, N specifies the number of columns of the matrix A.
3994 * N must be at least zero.
3995 *
3996 * A (local input) COMPLEX*16 array
3997 * On entry, A is an array of dimension (LDA,N). The leading m
3998 * by n part of this array is printed.
3999 *
4000 * LDA (local input) INTEGER
4001 * On entry, LDA specifies the leading dimension of the local
4002 * array A to be printed. LDA must be at least MAX( 1, M ).
4003 *
4004 * IRPRNT (global input) INTEGER
4005 * On entry, IRPRNT specifies the process row coordinate of the
4006 * printing process.
4007 *
4008 * ICPRNT (global input) INTEGER
4009 * On entry, ICPRNT specifies the process column coordinate of
4010 * the printing process.
4011 *
4012 * CMATNM (global input) CHARACTER*(*)
4013 * On entry, CMATNM specifies the identifier of the matrix to be
4014 * printed.
4015 *
4016 * -- Written on April 1, 1998 by
4017 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4018 *
4019 * =====================================================================
4020 *
4021 * .. Local Scalars ..
4022  INTEGER I, J, MYCOL, MYROW, NPCOL, NPROW
4023 * ..
4024 * .. External Subroutines ..
4025  EXTERNAL BLACS_GRIDINFO
4026 * ..
4027 * .. Intrinsic Functions ..
4028  INTRINSIC dble, dimag
4029 * ..
4030 * .. Executable Statements ..
4031 *
4032 * Quick return if possible
4033 *
4034  IF( ( m.LE.0 ).OR.( n.LE.0 ) )
4035  $ RETURN
4036 *
4037 * Get grid parameters
4038 *
4039  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4040 *
4041  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
4042 *
4043  WRITE( nout, fmt = * )
4044  DO 20 j = 1, n
4045 *
4046  DO 10 i = 1, m
4047 *
4048  WRITE( nout, fmt = 9999 ) cmatnm, i, j,
4049  $ dble( a( i, j ) ), dimag( a( i, j ) )
4050 *
4051  10 CONTINUE
4052 *
4053  20 CONTINUE
4054 *
4055  END IF
4056 *
4057  9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18, '+i*(',
4058  $ d30.18, ')' )
4059 *
4060  RETURN
4061 *
4062 * End of PZMPRNT
4063 *
4064  END
4065  SUBROUTINE pzvprnt( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT,
4066  $ CVECNM )
4068 * -- PBLAS test routine (version 2.0) --
4069 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4070 * and University of California, Berkeley.
4071 * April 1, 1998
4072 *
4073 * .. Scalar Arguments ..
4074  INTEGER ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
4075 * ..
4076 * .. Array Arguments ..
4077  CHARACTER*(*) CVECNM
4078  COMPLEX*16 X( * )
4079 * ..
4080 *
4081 * Purpose
4082 * =======
4083 *
4084 * PZVPRNT prints to the standard output an vector x of length n. Only
4085 * the process of coordinates ( IRPRNT, ICPRNT ) is printing.
4086 *
4087 * Arguments
4088 * =========
4089 *
4090 * ICTXT (local input) INTEGER
4091 * On entry, ICTXT specifies the BLACS context handle, indica-
4092 * ting the global context of the operation. The context itself
4093 * is global, but the value of ICTXT is local.
4094 *
4095 * NOUT (global input) INTEGER
4096 * On entry, NOUT specifies the unit number for the output file.
4097 * When NOUT is 6, output to screen, when NOUT is 0, output to
4098 * stderr. NOUT is only defined for process 0.
4099 *
4100 * N (global input) INTEGER
4101 * On entry, N specifies the length of the vector X. N must be
4102 * at least zero.
4103 *
4104 * X (global input) COMPLEX*16 array
4105 * On entry, X is an array of dimension at least
4106 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
4107 * ted array X must contain the vector x.
4108 *
4109 * INCX (global input) INTEGER.
4110 * On entry, INCX specifies the increment for the elements of X.
4111 * INCX must not be zero.
4112 *
4113 * IRPRNT (global input) INTEGER
4114 * On entry, IRPRNT specifies the process row coordinate of the
4115 * printing process.
4116 *
4117 * ICPRNT (global input) INTEGER
4118 * On entry, ICPRNT specifies the process column coordinate of
4119 * the printing process.
4120 *
4121 * CVECNM (global input) CHARACTER*(*)
4122 * On entry, CVECNM specifies the identifier of the vector to be
4123 * printed.
4124 *
4125 * -- Written on April 1, 1998 by
4126 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4127 *
4128 * =====================================================================
4129 *
4130 * .. Local Scalars ..
4131  INTEGER I, MYCOL, MYROW, NPCOL, NPROW
4132 * ..
4133 * .. External Subroutines ..
4134  EXTERNAL BLACS_GRIDINFO
4135 * ..
4136 * .. Intrinsic Functions ..
4137  INTRINSIC dble, dimag
4138 * ..
4139 * .. Executable Statements ..
4140 *
4141 * Quick return if possible
4142 *
4143  IF( n.LE.0 )
4144  $ RETURN
4145 *
4146 * Get grid parameters
4147 *
4148  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4149 *
4150  IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
4151 *
4152  WRITE( nout, fmt = * )
4153  DO 10 i = 1, 1 + ( n-1 )*incx, incx
4154 *
4155  WRITE( nout, fmt = 9999 ) cvecnm, i, dble( x( i ) ),
4156  $ dimag( x( i ) )
4157 *
4158  10 CONTINUE
4159 *
4160  END IF
4161 *
4162  9999 FORMAT( 1x, a, '(', i6, ')=', d30.18, '+i*(', d30.18, ')' )
4163 *
4164  RETURN
4165 *
4166 * End of PZVPRNT
4167 *
4168  END
4169  SUBROUTINE pzmvch( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
4170  $ X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY,
4171  $ DESCY, INCY, G, ERR, INFO )
4173 * -- PBLAS test routine (version 2.0) --
4174 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4175 * and University of California, Berkeley.
4176 * April 1, 1998
4177 *
4178 * .. Scalar Arguments ..
4179  CHARACTER*1 TRANS
4180  INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4181  $ JY, M, N
4182  DOUBLE PRECISION ERR
4183  COMPLEX*16 ALPHA, BETA
4184 * ..
4185 * .. Array Arguments ..
4186  INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4187  DOUBLE PRECISION G( * )
4188  COMPLEX*16 A( * ), PY( * ), X( * ), Y( * )
4189 * ..
4190 *
4191 * Purpose
4192 * =======
4193 *
4194 * PZMVCH checks the results of the computational tests.
4195 *
4196 * Notes
4197 * =====
4198 *
4199 * A description vector is associated with each 2D block-cyclicly dis-
4200 * tributed matrix. This vector stores the information required to
4201 * establish the mapping between a matrix entry and its corresponding
4202 * process and memory location.
4203 *
4204 * In the following comments, the character _ should be read as
4205 * "of the distributed matrix". Let A be a generic term for any 2D
4206 * block cyclicly distributed matrix. Its description vector is DESCA:
4207 *
4208 * NOTATION STORED IN EXPLANATION
4209 * ---------------- --------------- ------------------------------------
4210 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4211 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4212 * the NPROW x NPCOL BLACS process grid
4213 * A is distributed over. The context
4214 * itself is global, but the handle
4215 * (the integer value) may vary.
4216 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
4217 * ted matrix A, M_A >= 0.
4218 * N_A (global) DESCA( N_ ) The number of columns in the distri-
4219 * buted matrix A, N_A >= 0.
4220 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4221 * block of the matrix A, IMB_A > 0.
4222 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
4223 * left block of the matrix A,
4224 * INB_A > 0.
4225 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4226 * bute the last M_A-IMB_A rows of A,
4227 * MB_A > 0.
4228 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4229 * bute the last N_A-INB_A columns of
4230 * A, NB_A > 0.
4231 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4232 * row of the matrix A is distributed,
4233 * NPROW > RSRC_A >= 0.
4234 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4235 * first column of A is distributed.
4236 * NPCOL > CSRC_A >= 0.
4237 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4238 * array storing the local blocks of
4239 * the distributed matrix A,
4240 * IF( Lc( 1, N_A ) > 0 )
4241 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
4242 * ELSE
4243 * LLD_A >= 1.
4244 *
4245 * Let K be the number of rows of a matrix A starting at the global in-
4246 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4247 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4248 * receive if these K rows were distributed over NPROW processes. If K
4249 * is the number of columns of a matrix A starting at the global index
4250 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4251 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4252 * these K columns were distributed over NPCOL processes.
4253 *
4254 * The values of Lr() and Lc() may be determined via a call to the func-
4255 * tion PB_NUMROC:
4256 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4257 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4258 *
4259 * Arguments
4260 * =========
4261 *
4262 * ICTXT (local input) INTEGER
4263 * On entry, ICTXT specifies the BLACS context handle, indica-
4264 * ting the global context of the operation. The context itself
4265 * is global, but the value of ICTXT is local.
4266 *
4267 * TRANS (global input) CHARACTER*1
4268 * On entry, TRANS specifies which matrix-vector product is to
4269 * be computed as follows:
4270 * If TRANS = 'T',
4271 * sub( Y ) = BETA * sub( Y ) + sub( A )**T * sub( X ),
4272 * else if TRANS = 'C',
4273 * sub( Y ) = BETA * sub( Y ) + sub( A )**H * sub( X ),
4274 * otherwise
4275 * sub( Y ) = BETA * sub( Y ) + sub( A ) * sub( X ).
4276 *
4277 * M (global input) INTEGER
4278 * On entry, M specifies the number of rows of the submatrix
4279 * operand matrix A. M must be at least zero.
4280 *
4281 * N (global input) INTEGER
4282 * On entry, N specifies the number of columns of the subma-
4283 * trix operand matrix A. N must be at least zero.
4284 *
4285 * ALPHA (global input) COMPLEX*16
4286 * On entry, ALPHA specifies the scalar alpha.
4287 *
4288 * A (local input) COMPLEX*16 array
4289 * On entry, A is an array of dimension (DESCA( M_ ),*). This
4290 * array contains a local copy of the initial entire matrix PA.
4291 *
4292 * IA (global input) INTEGER
4293 * On entry, IA specifies A's global row index, which points to
4294 * the beginning of the submatrix sub( A ).
4295 *
4296 * JA (global input) INTEGER
4297 * On entry, JA specifies A's global column index, which points
4298 * to the beginning of the submatrix sub( A ).
4299 *
4300 * DESCA (global and local input) INTEGER array
4301 * On entry, DESCA is an integer array of dimension DLEN_. This
4302 * is the array descriptor for the matrix A.
4303 *
4304 * X (local input) COMPLEX*16 array
4305 * On entry, X is an array of dimension (DESCX( M_ ),*). This
4306 * array contains a local copy of the initial entire matrix PX.
4307 *
4308 * IX (global input) INTEGER
4309 * On entry, IX specifies X's global row index, which points to
4310 * the beginning of the submatrix sub( X ).
4311 *
4312 * JX (global input) INTEGER
4313 * On entry, JX specifies X's global column index, which points
4314 * to the beginning of the submatrix sub( X ).
4315 *
4316 * DESCX (global and local input) INTEGER array
4317 * On entry, DESCX is an integer array of dimension DLEN_. This
4318 * is the array descriptor for the matrix X.
4319 *
4320 * INCX (global input) INTEGER
4321 * On entry, INCX specifies the global increment for the
4322 * elements of X. Only two values of INCX are supported in
4323 * this version, namely 1 and M_X. INCX must not be zero.
4324 *
4325 * BETA (global input) COMPLEX*16
4326 * On entry, BETA specifies the scalar beta.
4327 *
4328 * Y (local input/local output) COMPLEX*16 array
4329 * On entry, Y is an array of dimension (DESCY( M_ ),*). This
4330 * array contains a local copy of the initial entire matrix PY.
4331 *
4332 * PY (local input) COMPLEX*16 array
4333 * On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
4334 * array contains the local entries of the matrix PY.
4335 *
4336 * IY (global input) INTEGER
4337 * On entry, IY specifies Y's global row index, which points to
4338 * the beginning of the submatrix sub( Y ).
4339 *
4340 * JY (global input) INTEGER
4341 * On entry, JY specifies Y's global column index, which points
4342 * to the beginning of the submatrix sub( Y ).
4343 *
4344 * DESCY (global and local input) INTEGER array
4345 * On entry, DESCY is an integer array of dimension DLEN_. This
4346 * is the array descriptor for the matrix Y.
4347 *
4348 * INCY (global input) INTEGER
4349 * On entry, INCY specifies the global increment for the
4350 * elements of Y. Only two values of INCY are supported in
4351 * this version, namely 1 and M_Y. INCY must not be zero.
4352 *
4353 * G (workspace) DOUBLE PRECISION array
4354 * On entry, G is an array of dimension at least MAX( M, N ). G
4355 * is used to compute the gauges.
4356 *
4357 * ERR (global output) DOUBLE PRECISION
4358 * On exit, ERR specifies the largest error in absolute value.
4359 *
4360 * INFO (global output) INTEGER
4361 * On exit, if INFO <> 0, the result is less than half accurate.
4362 *
4363 * -- Written on April 1, 1998 by
4364 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4365 *
4366 * =====================================================================
4367 *
4368 * .. Parameters ..
4369  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4370  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4371  $ RSRC_
4372  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
4373  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4374  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4375  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4376  DOUBLE PRECISION RZERO, RONE
4377  parameter( rzero = 0.0d+0, rone = 1.0d+0 )
4378  COMPLEX*16 ZERO, ONE
4379  PARAMETER ( ZERO = ( 0.0d+0, 0.0d+0 ),
4380  $ one = ( 1.0d+0, 0.0d+0 ) )
4381 * ..
4382 * .. Local Scalars ..
4383  LOGICAL COLREP, CTRAN, ROWREP, TRAN
4384  INTEGER I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
4385  $ ioffy, iycol, iyrow, j, jb, jjy, jn, kk, lda,
4386  $ ldpy, ldx, ldy, ml, mycol, myrow, nl, npcol,
4387  $ nprow
4388  DOUBLE PRECISION EPS, ERRI, GTMP
4389  COMPLEX*16 C, TBETA, YTMP
4390 * ..
4391 * .. External Subroutines ..
4392  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
4393 * ..
4394 * .. External Functions ..
4395  LOGICAL LSAME
4396  DOUBLE PRECISION PDLAMCH
4397  EXTERNAL lsame, pdlamch
4398 * ..
4399 * .. Intrinsic Functions ..
4400  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
4401 * ..
4402 * .. Statement Functions ..
4403  DOUBLE PRECISION ABS1
4404  abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
4405 * ..
4406 * .. Executable Statements ..
4407 *
4408  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4409 *
4410  eps = pdlamch( ictxt, 'eps' )
4411 *
4412  IF( m.EQ.0 .OR. n.EQ.0 ) THEN
4413  tbeta = one
4414  ELSE
4415  tbeta = beta
4416  END IF
4417 *
4418  tran = lsame( trans, 'T' )
4419  ctran = lsame( trans, 'C' )
4420  IF( tran.OR.ctran ) THEN
4421  ml = n
4422  nl = m
4423  ELSE
4424  ml = m
4425  nl = n
4426  END IF
4427 *
4428  lda = max( 1, desca( m_ ) )
4429  ldx = max( 1, descx( m_ ) )
4430  ldy = max( 1, descy( m_ ) )
4431 *
4432 * Compute expected result in Y using data in A, X and Y.
4433 * Compute gauges in G. This part of the computation is performed
4434 * by every process in the grid.
4435 *
4436  ioffy = iy + ( jy - 1 ) * ldy
4437  DO 40 i = 1, ml
4438  ytmp = zero
4439  gtmp = rzero
4440  ioffx = ix + ( jx - 1 ) * ldx
4441  IF( tran )THEN
4442  ioffa = ia + ( ja + i - 2 ) * lda
4443  DO 10 j = 1, nl
4444  ytmp = ytmp + a( ioffa ) * x( ioffx )
4445  gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4446  ioffa = ioffa + 1
4447  ioffx = ioffx + incx
4448  10 CONTINUE
4449  ELSE IF( ctran )THEN
4450  ioffa = ia + ( ja + i - 2 ) * lda
4451  DO 20 j = 1, nl
4452  ytmp = ytmp + dconjg( a( ioffa ) ) * x( ioffx )
4453  gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4454  ioffa = ioffa + 1
4455  ioffx = ioffx + incx
4456  20 CONTINUE
4457  ELSE
4458  ioffa = ia + i - 1 + ( ja - 1 ) * lda
4459  DO 30 j = 1, nl
4460  ytmp = ytmp + a( ioffa ) * x( ioffx )
4461  gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4462  ioffa = ioffa + lda
4463  ioffx = ioffx + incx
4464  30 CONTINUE
4465  END IF
4466  g( i ) = abs1( alpha )*gtmp + abs1( tbeta )*abs1( y( ioffy ) )
4467  y( ioffy ) = alpha * ytmp + tbeta * y( ioffy )
4468  ioffy = ioffy + incy
4469  40 CONTINUE
4470 *
4471 * Compute the error ratio for this result.
4472 *
4473  err = rzero
4474  info = 0
4475  ldpy = descy( lld_ )
4476  ioffy = iy + ( jy - 1 ) * ldy
4477  CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol, iiy,
4478  $ jjy, iyrow, iycol )
4479  icurrow = iyrow
4480  icurcol = iycol
4481  rowrep = ( iyrow.EQ.-1 )
4482  colrep = ( iycol.EQ.-1 )
4483 *
4484  IF( incy.EQ.descy( m_ ) ) THEN
4485 *
4486 * sub( Y ) is a row vector
4487 *
4488  jb = descy( inb_ ) - jy + 1
4489  IF( jb.LE.0 )
4490  $ jb = ( ( -jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
4491  jb = min( jb, ml )
4492  jn = jy + jb - 1
4493 *
4494  DO 50 j = jy, jn
4495 *
4496  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4497  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4498  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
4499  IF( g( j-jy+1 ).NE.rzero )
4500  $ erri = erri / g( j-jy+1 )
4501  err = max( err, erri )
4502  IF( err*sqrt( eps ).GE.rone )
4503  $ info = 1
4504  jjy = jjy + 1
4505  END IF
4506 *
4507  ioffy = ioffy + incy
4508 *
4509  50 CONTINUE
4510 *
4511  icurcol = mod( icurcol+1, npcol )
4512 *
4513  DO 70 j = jn+1, jy+ml-1, descy( nb_ )
4514  jb = min( jy+ml-j, descy( nb_ ) )
4515 *
4516  DO 60 kk = 0, jb-1
4517 *
4518  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4519  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4520  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
4521  IF( g( j+kk-jy+1 ).NE.rzero )
4522  $ erri = erri / g( j+kk-jy+1 )
4523  err = max( err, erri )
4524  IF( err*sqrt( eps ).GE.rone )
4525  $ info = 1
4526  jjy = jjy + 1
4527  END IF
4528 *
4529  ioffy = ioffy + incy
4530 *
4531  60 CONTINUE
4532 *
4533  icurcol = mod( icurcol+1, npcol )
4534 *
4535  70 CONTINUE
4536 *
4537  ELSE
4538 *
4539 * sub( Y ) is a column vector
4540 *
4541  ib = descy( imb_ ) - iy + 1
4542  IF( ib.LE.0 )
4543  $ ib = ( ( -ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
4544  ib = min( ib, ml )
4545  in = iy + ib - 1
4546 *
4547  DO 80 i = iy, in
4548 *
4549  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4550  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4551  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
4552  IF( g( i-iy+1 ).NE.rzero )
4553  $ erri = erri / g( i-iy+1 )
4554  err = max( err, erri )
4555  IF( err*sqrt( eps ).GE.rone )
4556  $ info = 1
4557  iiy = iiy + 1
4558  END IF
4559 *
4560  ioffy = ioffy + incy
4561 *
4562  80 CONTINUE
4563 *
4564  icurrow = mod( icurrow+1, nprow )
4565 *
4566  DO 100 i = in+1, iy+ml-1, descy( mb_ )
4567  ib = min( iy+ml-i, descy( mb_ ) )
4568 *
4569  DO 90 kk = 0, ib-1
4570 *
4571  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4572  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4573  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
4574  IF( g( i+kk-iy+1 ).NE.rzero )
4575  $ erri = erri / g( i+kk-iy+1 )
4576  err = max( err, erri )
4577  IF( err*sqrt( eps ).GE.rone )
4578  $ info = 1
4579  iiy = iiy + 1
4580  END IF
4581 *
4582  ioffy = ioffy + incy
4583 *
4584  90 CONTINUE
4585 *
4586  icurrow = mod( icurrow+1, nprow )
4587 *
4588  100 CONTINUE
4589 *
4590  END IF
4591 *
4592 * If INFO = 0, all results are at least half accurate.
4593 *
4594  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
4595  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
4596  $ mycol )
4597 *
4598  RETURN
4599 *
4600 * End of PZMVCH
4601 *
4602  END
4603  SUBROUTINE pzvmch( ICTXT, TRANS, UPLO, M, N, ALPHA, X, IX, JX,
4604  $ DESCX, INCX, Y, IY, JY, DESCY, INCY, A, PA,
4605  $ IA, JA, DESCA, G, ERR, INFO )
4607 * -- PBLAS test routine (version 2.0) --
4608 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4609 * and University of California, Berkeley.
4610 * April 1, 1998
4611 *
4612 * .. Scalar Arguments ..
4613  CHARACTER*1 TRANS, UPLO
4614  INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4615  $ JY, M, N
4616  DOUBLE PRECISION ERR
4617  COMPLEX*16 ALPHA
4618 * ..
4619 * .. Array Arguments ..
4620  INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4621  DOUBLE PRECISION G( * )
4622  COMPLEX*16 A( * ), PA( * ), X( * ), Y( * )
4623 * ..
4624 *
4625 * Purpose
4626 * =======
4627 *
4628 * PZVMCH checks the results of the computational tests.
4629 *
4630 * Notes
4631 * =====
4632 *
4633 * A description vector is associated with each 2D block-cyclicly dis-
4634 * tributed matrix. This vector stores the information required to
4635 * establish the mapping between a matrix entry and its corresponding
4636 * process and memory location.
4637 *
4638 * In the following comments, the character _ should be read as
4639 * "of the distributed matrix". Let A be a generic term for any 2D
4640 * block cyclicly distributed matrix. Its description vector is DESCA:
4641 *
4642 * NOTATION STORED IN EXPLANATION
4643 * ---------------- --------------- ------------------------------------
4644 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4645 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4646 * the NPROW x NPCOL BLACS process grid
4647 * A is distributed over. The context
4648 * itself is global, but the handle
4649 * (the integer value) may vary.
4650 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
4651 * ted matrix A, M_A >= 0.
4652 * N_A (global) DESCA( N_ ) The number of columns in the distri-
4653 * buted matrix A, N_A >= 0.
4654 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4655 * block of the matrix A, IMB_A > 0.
4656 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
4657 * left block of the matrix A,
4658 * INB_A > 0.
4659 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4660 * bute the last M_A-IMB_A rows of A,
4661 * MB_A > 0.
4662 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4663 * bute the last N_A-INB_A columns of
4664 * A, NB_A > 0.
4665 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4666 * row of the matrix A is distributed,
4667 * NPROW > RSRC_A >= 0.
4668 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4669 * first column of A is distributed.
4670 * NPCOL > CSRC_A >= 0.
4671 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4672 * array storing the local blocks of
4673 * the distributed matrix A,
4674 * IF( Lc( 1, N_A ) > 0 )
4675 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
4676 * ELSE
4677 * LLD_A >= 1.
4678 *
4679 * Let K be the number of rows of a matrix A starting at the global in-
4680 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4681 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4682 * receive if these K rows were distributed over NPROW processes. If K
4683 * is the number of columns of a matrix A starting at the global index
4684 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4685 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4686 * these K columns were distributed over NPCOL processes.
4687 *
4688 * The values of Lr() and Lc() may be determined via a call to the func-
4689 * tion PB_NUMROC:
4690 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4691 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4692 *
4693 * Arguments
4694 * =========
4695 *
4696 * ICTXT (local input) INTEGER
4697 * On entry, ICTXT specifies the BLACS context handle, indica-
4698 * ting the global context of the operation. The context itself
4699 * is global, but the value of ICTXT is local.
4700 *
4701 * TRANS (global input) CHARACTER*1
4702 * On entry, TRANS specifies the operation to be performed in
4703 * the complex cases:
4704 * if TRANS = 'C',
4705 * sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**H,
4706 * otherwise
4707 * sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**T.
4708 *
4709 * UPLO (global input) CHARACTER*1
4710 * On entry, UPLO specifies which part of the submatrix sub( A )
4711 * is to be referenced as follows:
4712 * If UPLO = 'L', only the lower triangular part,
4713 * If UPLO = 'U', only the upper triangular part,
4714 * else the entire matrix is to be referenced.
4715 *
4716 * M (global input) INTEGER
4717 * On entry, M specifies the number of rows of the submatrix
4718 * operand matrix A. M must be at least zero.
4719 *
4720 * N (global input) INTEGER
4721 * On entry, N specifies the number of columns of the subma-
4722 * trix operand matrix A. N must be at least zero.
4723 *
4724 * ALPHA (global input) COMPLEX*16
4725 * On entry, ALPHA specifies the scalar alpha.
4726 *
4727 * X (local input) COMPLEX*16 array
4728 * On entry, X is an array of dimension (DESCX( M_ ),*). This
4729 * array contains a local copy of the initial entire matrix PX.
4730 *
4731 * IX (global input) INTEGER
4732 * On entry, IX specifies X's global row index, which points to
4733 * the beginning of the submatrix sub( X ).
4734 *
4735 * JX (global input) INTEGER
4736 * On entry, JX specifies X's global column index, which points
4737 * to the beginning of the submatrix sub( X ).
4738 *
4739 * DESCX (global and local input) INTEGER array
4740 * On entry, DESCX is an integer array of dimension DLEN_. This
4741 * is the array descriptor for the matrix X.
4742 *
4743 * INCX (global input) INTEGER
4744 * On entry, INCX specifies the global increment for the
4745 * elements of X. Only two values of INCX are supported in
4746 * this version, namely 1 and M_X. INCX must not be zero.
4747 *
4748 * Y (local input) COMPLEX*16 array
4749 * On entry, Y is an array of dimension (DESCY( M_ ),*). This
4750 * array contains a local copy of the initial entire matrix PY.
4751 *
4752 * IY (global input) INTEGER
4753 * On entry, IY specifies Y's global row index, which points to
4754 * the beginning of the submatrix sub( Y ).
4755 *
4756 * JY (global input) INTEGER
4757 * On entry, JY specifies Y's global column index, which points
4758 * to the beginning of the submatrix sub( Y ).
4759 *
4760 * DESCY (global and local input) INTEGER array
4761 * On entry, DESCY is an integer array of dimension DLEN_. This
4762 * is the array descriptor for the matrix Y.
4763 *
4764 * INCY (global input) INTEGER
4765 * On entry, INCY specifies the global increment for the
4766 * elements of Y. Only two values of INCY are supported in
4767 * this version, namely 1 and M_Y. INCY must not be zero.
4768 *
4769 * A (local input/local output) COMPLEX*16 array
4770 * On entry, A is an array of dimension (DESCA( M_ ),*). This
4771 * array contains a local copy of the initial entire matrix PA.
4772 *
4773 * PA (local input) COMPLEX*16 array
4774 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
4775 * array contains the local entries of the matrix PA.
4776 *
4777 * IA (global input) INTEGER
4778 * On entry, IA specifies A's global row index, which points to
4779 * the beginning of the submatrix sub( A ).
4780 *
4781 * JA (global input) INTEGER
4782 * On entry, JA specifies A's global column index, which points
4783 * to the beginning of the submatrix sub( A ).
4784 *
4785 * DESCA (global and local input) INTEGER array
4786 * On entry, DESCA is an integer array of dimension DLEN_. This
4787 * is the array descriptor for the matrix A.
4788 *
4789 * G (workspace) DOUBLE PRECISION array
4790 * On entry, G is an array of dimension at least MAX( M, N ). G
4791 * is used to compute the gauges.
4792 *
4793 * ERR (global output) DOUBLE PRECISION
4794 * On exit, ERR specifies the largest error in absolute value.
4795 *
4796 * INFO (global output) INTEGER
4797 * On exit, if INFO <> 0, the result is less than half accurate.
4798 *
4799 * -- Written on April 1, 1998 by
4800 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4801 *
4802 * =====================================================================
4803 *
4804 * .. Parameters ..
4805  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4806  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4807  $ RSRC_
4808  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
4809  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4810  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4811  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4812  DOUBLE PRECISION ZERO, ONE
4813  PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
4814 * ..
4815 * .. Local Scalars ..
4816  LOGICAL COLREP, CTRAN, LOWER, ROWREP, UPPER
4817  INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
4818  $ in, ioffa, ioffx, ioffy, j, jja, kk, lda, ldpa,
4819  $ ldx, ldy, mycol, myrow, npcol, nprow
4820  DOUBLE PRECISION EPS, ERRI, GTMP
4821  COMPLEX*16 ATMP, C
4822 * ..
4823 * .. External Subroutines ..
4824  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
4825 * ..
4826 * .. External Functions ..
4827  LOGICAL LSAME
4828  DOUBLE PRECISION PDLAMCH
4829  EXTERNAL LSAME, PDLAMCH
4830 * ..
4831 * .. Intrinsic Functions ..
4832  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
4833 * ..
4834 * .. Statement Functions ..
4835  DOUBLE PRECISION ABS1
4836  ABS1( C ) = abs( dble( c ) ) + abs( dimag( c ) )
4837 * ..
4838 * .. Executable Statements ..
4839 *
4840  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4841 *
4842  eps = pdlamch( ictxt, 'eps' )
4843 *
4844  ctran = lsame( trans, 'C' )
4845  upper = lsame( uplo, 'U' )
4846  lower = lsame( uplo, 'L' )
4847 *
4848  lda = max( 1, desca( m_ ) )
4849  ldx = max( 1, descx( m_ ) )
4850  ldy = max( 1, descy( m_ ) )
4851 *
4852 * Compute expected result in A using data in A, X and Y.
4853 * Compute gauges in G. This part of the computation is performed
4854 * by every process in the grid.
4855 *
4856  DO 70 j = 1, n
4857 *
4858  ioffy = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
4859 *
4860  IF( lower ) THEN
4861  ibeg = j
4862  iend = m
4863  DO 10 i = 1, j-1
4864  g( i ) = zero
4865  10 CONTINUE
4866  ELSE IF( upper ) THEN
4867  ibeg = 1
4868  iend = j
4869  DO 20 i = j+1, m
4870  g( i ) = zero
4871  20 CONTINUE
4872  ELSE
4873  ibeg = 1
4874  iend = m
4875  END IF
4876 *
4877  DO 30 i = ibeg, iend
4878 *
4879  ioffx = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
4880  ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
4881  IF( ctran ) THEN
4882  atmp = x( ioffx ) * dconjg( y( ioffy ) )
4883  ELSE
4884  atmp = x( ioffx ) * y( ioffy )
4885  END IF
4886  gtmp = abs1( x( ioffx ) ) * abs1( y( ioffy ) )
4887  g( i ) = abs1( alpha ) * gtmp + abs1( a( ioffa ) )
4888  a( ioffa ) = alpha * atmp + a( ioffa )
4889 *
4890  30 CONTINUE
4891 *
4892 * Compute the error ratio for this result.
4893 *
4894  info = 0
4895  err = zero
4896  ldpa = desca( lld_ )
4897  ioffa = ia + ( ja + j - 2 ) * lda
4898  CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
4899  $ iia, jja, iarow, iacol )
4900  rowrep = ( iarow.EQ.-1 )
4901  colrep = ( iacol.EQ.-1 )
4902 *
4903  IF( mycol.EQ.iacol .OR. colrep ) THEN
4904 *
4905  icurrow = iarow
4906  ib = desca( imb_ ) - ia + 1
4907  IF( ib.LE.0 )
4908  $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
4909  ib = min( ib, m )
4910  in = ia + ib - 1
4911 *
4912  DO 40 i = ia, in
4913 *
4914  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
4915  erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
4916  IF( g( i-ia+1 ).NE.zero )
4917  $ erri = erri / g( i-ia+1 )
4918  err = max( err, erri )
4919  IF( err*sqrt( eps ).GE.one )
4920  $ info = 1
4921  iia = iia + 1
4922  END IF
4923 *
4924  ioffa = ioffa + 1
4925 *
4926  40 CONTINUE
4927 *
4928  icurrow = mod( icurrow+1, nprow )
4929 *
4930  DO 60 i = in+1, ia+m-1, desca( mb_ )
4931  ib = min( ia+m-i, desca( mb_ ) )
4932 *
4933  DO 50 kk = 0, ib-1
4934 *
4935  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
4936  erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
4937  IF( g( i+kk-ia+1 ).NE.zero )
4938  $ erri = erri / g( i+kk-ia+1 )
4939  err = max( err, erri )
4940  IF( err*sqrt( eps ).GE.one )
4941  $ info = 1
4942  iia = iia + 1
4943  END IF
4944 *
4945  ioffa = ioffa + 1
4946 *
4947  50 CONTINUE
4948 *
4949  icurrow = mod( icurrow+1, nprow )
4950 *
4951  60 CONTINUE
4952 *
4953  END IF
4954 *
4955 * If INFO = 0, all results are at least half accurate.
4956 *
4957  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
4958  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
4959  $ mycol )
4960  IF( info.NE.0 )
4961  $ GO TO 80
4962 *
4963  70 CONTINUE
4964 *
4965  80 CONTINUE
4966 *
4967  RETURN
4968 *
4969 * End of PZVMCH
4970 *
4971  END
4972  SUBROUTINE pzvmch2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
4973  $ INCX, Y, IY, JY, DESCY, INCY, A, PA, IA,
4974  $ JA, DESCA, G, ERR, INFO )
4976 * -- PBLAS test routine (version 2.0) --
4977 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4978 * and University of California, Berkeley.
4979 * April 1, 1998
4980 *
4981 * .. Scalar Arguments ..
4982  CHARACTER*1 UPLO
4983  INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4984  $ jy, m, n
4985  DOUBLE PRECISION ERR
4986  COMPLEX*16 ALPHA
4987 * ..
4988 * .. Array Arguments ..
4989  INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4990  DOUBLE PRECISION G( * )
4991  COMPLEX*16 A( * ), PA( * ), X( * ), Y( * )
4992 * ..
4993 *
4994 * Purpose
4995 * =======
4996 *
4997 * PZVMCH2 checks the results of the computational tests.
4998 *
4999 * Notes
5000 * =====
5001 *
5002 * A description vector is associated with each 2D block-cyclicly dis-
5003 * tributed matrix. This vector stores the information required to
5004 * establish the mapping between a matrix entry and its corresponding
5005 * process and memory location.
5006 *
5007 * In the following comments, the character _ should be read as
5008 * "of the distributed matrix". Let A be a generic term for any 2D
5009 * block cyclicly distributed matrix. Its description vector is DESCA:
5010 *
5011 * NOTATION STORED IN EXPLANATION
5012 * ---------------- --------------- ------------------------------------
5013 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5014 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5015 * the NPROW x NPCOL BLACS process grid
5016 * A is distributed over. The context
5017 * itself is global, but the handle
5018 * (the integer value) may vary.
5019 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
5020 * ted matrix A, M_A >= 0.
5021 * N_A (global) DESCA( N_ ) The number of columns in the distri-
5022 * buted matrix A, N_A >= 0.
5023 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5024 * block of the matrix A, IMB_A > 0.
5025 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
5026 * left block of the matrix A,
5027 * INB_A > 0.
5028 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5029 * bute the last M_A-IMB_A rows of A,
5030 * MB_A > 0.
5031 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5032 * bute the last N_A-INB_A columns of
5033 * A, NB_A > 0.
5034 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5035 * row of the matrix A is distributed,
5036 * NPROW > RSRC_A >= 0.
5037 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5038 * first column of A is distributed.
5039 * NPCOL > CSRC_A >= 0.
5040 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5041 * array storing the local blocks of
5042 * the distributed matrix A,
5043 * IF( Lc( 1, N_A ) > 0 )
5044 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
5045 * ELSE
5046 * LLD_A >= 1.
5047 *
5048 * Let K be the number of rows of a matrix A starting at the global in-
5049 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5050 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5051 * receive if these K rows were distributed over NPROW processes. If K
5052 * is the number of columns of a matrix A starting at the global index
5053 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5054 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5055 * these K columns were distributed over NPCOL processes.
5056 *
5057 * The values of Lr() and Lc() may be determined via a call to the func-
5058 * tion PB_NUMROC:
5059 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5060 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5061 *
5062 * Arguments
5063 * =========
5064 *
5065 * ICTXT (local input) INTEGER
5066 * On entry, ICTXT specifies the BLACS context handle, indica-
5067 * ting the global context of the operation. The context itself
5068 * is global, but the value of ICTXT is local.
5069 *
5070 * UPLO (global input) CHARACTER*1
5071 * On entry, UPLO specifies which part of the submatrix sub( A )
5072 * is to be referenced as follows:
5073 * If UPLO = 'L', only the lower triangular part,
5074 * If UPLO = 'U', only the upper triangular part,
5075 * else the entire matrix is to be referenced.
5076 *
5077 * M (global input) INTEGER
5078 * On entry, M specifies the number of rows of the submatrix
5079 * operand matrix A. M must be at least zero.
5080 *
5081 * N (global input) INTEGER
5082 * On entry, N specifies the number of columns of the subma-
5083 * trix operand matrix A. N must be at least zero.
5084 *
5085 * ALPHA (global input) COMPLEX*16
5086 * On entry, ALPHA specifies the scalar alpha.
5087 *
5088 * X (local input) COMPLEX*16 array
5089 * On entry, X is an array of dimension (DESCX( M_ ),*). This
5090 * array contains a local copy of the initial entire matrix PX.
5091 *
5092 * IX (global input) INTEGER
5093 * On entry, IX specifies X's global row index, which points to
5094 * the beginning of the submatrix sub( X ).
5095 *
5096 * JX (global input) INTEGER
5097 * On entry, JX specifies X's global column index, which points
5098 * to the beginning of the submatrix sub( X ).
5099 *
5100 * DESCX (global and local input) INTEGER array
5101 * On entry, DESCX is an integer array of dimension DLEN_. This
5102 * is the array descriptor for the matrix X.
5103 *
5104 * INCX (global input) INTEGER
5105 * On entry, INCX specifies the global increment for the
5106 * elements of X. Only two values of INCX are supported in
5107 * this version, namely 1 and M_X. INCX must not be zero.
5108 *
5109 * Y (local input) COMPLEX*16 array
5110 * On entry, Y is an array of dimension (DESCY( M_ ),*). This
5111 * array contains a local copy of the initial entire matrix PY.
5112 *
5113 * IY (global input) INTEGER
5114 * On entry, IY specifies Y's global row index, which points to
5115 * the beginning of the submatrix sub( Y ).
5116 *
5117 * JY (global input) INTEGER
5118 * On entry, JY specifies Y's global column index, which points
5119 * to the beginning of the submatrix sub( Y ).
5120 *
5121 * DESCY (global and local input) INTEGER array
5122 * On entry, DESCY is an integer array of dimension DLEN_. This
5123 * is the array descriptor for the matrix Y.
5124 *
5125 * INCY (global input) INTEGER
5126 * On entry, INCY specifies the global increment for the
5127 * elements of Y. Only two values of INCY are supported in
5128 * this version, namely 1 and M_Y. INCY must not be zero.
5129 *
5130 * A (local input/local output) COMPLEX*16 array
5131 * On entry, A is an array of dimension (DESCA( M_ ),*). This
5132 * array contains a local copy of the initial entire matrix PA.
5133 *
5134 * PA (local input) COMPLEX*16 array
5135 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
5136 * array contains the local entries of the matrix PA.
5137 *
5138 * IA (global input) INTEGER
5139 * On entry, IA specifies A's global row index, which points to
5140 * the beginning of the submatrix sub( A ).
5141 *
5142 * JA (global input) INTEGER
5143 * On entry, JA specifies A's global column index, which points
5144 * to the beginning of the submatrix sub( A ).
5145 *
5146 * DESCA (global and local input) INTEGER array
5147 * On entry, DESCA is an integer array of dimension DLEN_. This
5148 * is the array descriptor for the matrix A.
5149 *
5150 * G (workspace) DOUBLE PRECISION array
5151 * On entry, G is an array of dimension at least MAX( M, N ). G
5152 * is used to compute the gauges.
5153 *
5154 * ERR (global output) DOUBLE PRECISION
5155 * On exit, ERR specifies the largest error in absolute value.
5156 *
5157 * INFO (global output) INTEGER
5158 * On exit, if INFO <> 0, the result is less than half accurate.
5159 *
5160 * -- Written on April 1, 1998 by
5161 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5162 *
5163 * =====================================================================
5164 *
5165 * .. Parameters ..
5166  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5167  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5168  $ RSRC_
5169  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
5170  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5171  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5172  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5173  DOUBLE PRECISION ZERO, ONE
5174  PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
5175 * ..
5176 * .. Local Scalars ..
5177  LOGICAL COLREP, LOWER, ROWREP, UPPER
5178  INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
5179  $ IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J,
5180  $ JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW,
5181  $ npcol, nprow
5182  DOUBLE PRECISION EPS, ERRI, GTMP
5183  COMPLEX*16 C, ATMP
5184 * ..
5185 * .. External Subroutines ..
5186  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5187 * ..
5188 * .. External Functions ..
5189  LOGICAL LSAME
5190  DOUBLE PRECISION PDLAMCH
5191  EXTERNAL LSAME, PDLAMCH
5192 * ..
5193 * .. Intrinsic Functions ..
5194  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5195 * ..
5196 * .. Statement Functions ..
5197  DOUBLE PRECISION ABS1
5198  abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
5199 * ..
5200 * .. Executable Statements ..
5201 *
5202  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
5203 *
5204  eps = pdlamch( ictxt, 'eps' )
5205 *
5206  upper = lsame( uplo, 'U' )
5207  lower = lsame( uplo, 'L' )
5208 *
5209  lda = max( 1, desca( m_ ) )
5210  ldx = max( 1, descx( m_ ) )
5211  ldy = max( 1, descy( m_ ) )
5212 *
5213 * Compute expected result in A using data in A, X and Y.
5214 * Compute gauges in G. This part of the computation is performed
5215 * by every process in the grid.
5216 *
5217  DO 70 j = 1, n
5218 *
5219  ioffxj = ix + ( jx - 1 ) * ldx + ( j - 1 ) * incx
5220  ioffyj = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
5221 *
5222  IF( lower ) THEN
5223  ibeg = j
5224  iend = m
5225  DO 10 i = 1, j-1
5226  g( i ) = zero
5227  10 CONTINUE
5228  ELSE IF( upper ) THEN
5229  ibeg = 1
5230  iend = j
5231  DO 20 i = j+1, m
5232  g( i ) = zero
5233  20 CONTINUE
5234  ELSE
5235  ibeg = 1
5236  iend = m
5237  END IF
5238 *
5239  DO 30 i = ibeg, iend
5240  ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
5241  ioffxi = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
5242  ioffyi = iy + ( jy - 1 ) * ldy + ( i - 1 ) * incy
5243  atmp = alpha * x( ioffxi ) * dconjg( y( ioffyj ) )
5244  atmp = atmp + y( ioffyi ) * dconjg( alpha * x( ioffxj ) )
5245  gtmp = abs1( alpha * x( ioffxi ) ) * abs1( y( ioffyj ) )
5246  gtmp = gtmp + abs1( y( ioffyi ) ) *
5247  $ abs1( dconjg( alpha * x( ioffxj ) ) )
5248  g( i ) = gtmp + abs1( a( ioffa ) )
5249  a( ioffa ) = a( ioffa ) + atmp
5250 *
5251  30 CONTINUE
5252 *
5253 * Compute the error ratio for this result.
5254 *
5255  info = 0
5256  err = zero
5257  ldpa = desca( lld_ )
5258  ioffa = ia + ( ja + j - 2 ) * lda
5259  CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
5260  $ iia, jja, iarow, iacol )
5261  rowrep = ( iarow.EQ.-1 )
5262  colrep = ( iacol.EQ.-1 )
5263 *
5264  IF( mycol.EQ.iacol .OR. colrep ) THEN
5265 *
5266  icurrow = iarow
5267  ib = desca( imb_ ) - ia + 1
5268  IF( ib.LE.0 )
5269  $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
5270  ib = min( ib, m )
5271  in = ia + ib - 1
5272 *
5273  DO 40 i = ia, in
5274 *
5275  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5276  erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
5277  IF( g( i-ia+1 ).NE.zero )
5278  $ erri = erri / g( i-ia+1 )
5279  err = max( err, erri )
5280  IF( err*sqrt( eps ).GE.one )
5281  $ info = 1
5282  iia = iia + 1
5283  END IF
5284 *
5285  ioffa = ioffa + 1
5286 *
5287  40 CONTINUE
5288 *
5289  icurrow = mod( icurrow+1, nprow )
5290 *
5291  DO 60 i = in+1, ia+m-1, desca( mb_ )
5292  ib = min( ia+m-i, desca( mb_ ) )
5293 *
5294  DO 50 kk = 0, ib-1
5295 *
5296  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5297  erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
5298  IF( g( i+kk-ia+1 ).NE.zero )
5299  $ erri = erri / g( i+kk-ia+1 )
5300  err = max( err, erri )
5301  IF( err*sqrt( eps ).GE.one )
5302  $ info = 1
5303  iia = iia + 1
5304  END IF
5305 *
5306  ioffa = ioffa + 1
5307 *
5308  50 CONTINUE
5309 *
5310  icurrow = mod( icurrow+1, nprow )
5311 *
5312  60 CONTINUE
5313 *
5314  END IF
5315 *
5316 * If INFO = 0, all results are at least half accurate.
5317 *
5318  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
5319  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
5320  $ mycol )
5321  IF( info.NE.0 )
5322  $ GO TO 80
5323 *
5324  70 CONTINUE
5325 *
5326  80 CONTINUE
5327 *
5328  RETURN
5329 *
5330 * End of PZVMCH2
5331 *
5332  END
5333  SUBROUTINE pzmmch( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA,
5334  $ JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
5335  $ JC, DESCC, CT, G, ERR, INFO )
5337 * -- PBLAS test routine (version 2.0) --
5338 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5339 * and University of California, Berkeley.
5340 * April 1, 1998
5341 *
5342 * .. Scalar Arguments ..
5343  CHARACTER*1 TRANSA, TRANSB
5344  INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
5345  DOUBLE PRECISION ERR
5346  COMPLEX*16 ALPHA, BETA
5347 * ..
5348 * .. Array Arguments ..
5349  INTEGER DESCA( * ), DESCB( * ), DESCC( * )
5350  DOUBLE PRECISION G( * )
5351  COMPLEX*16 A( * ), B( * ), C( * ), CT( * ), PC( * )
5352 * ..
5353 *
5354 * Purpose
5355 * =======
5356 *
5357 * PZMMCH checks the results of the computational tests.
5358 *
5359 * Notes
5360 * =====
5361 *
5362 * A description vector is associated with each 2D block-cyclicly dis-
5363 * tributed matrix. This vector stores the information required to
5364 * establish the mapping between a matrix entry and its corresponding
5365 * process and memory location.
5366 *
5367 * In the following comments, the character _ should be read as
5368 * "of the distributed matrix". Let A be a generic term for any 2D
5369 * block cyclicly distributed matrix. Its description vector is DESCA:
5370 *
5371 * NOTATION STORED IN EXPLANATION
5372 * ---------------- --------------- ------------------------------------
5373 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5374 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5375 * the NPROW x NPCOL BLACS process grid
5376 * A is distributed over. The context
5377 * itself is global, but the handle
5378 * (the integer value) may vary.
5379 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
5380 * ted matrix A, M_A >= 0.
5381 * N_A (global) DESCA( N_ ) The number of columns in the distri-
5382 * buted matrix A, N_A >= 0.
5383 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5384 * block of the matrix A, IMB_A > 0.
5385 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
5386 * left block of the matrix A,
5387 * INB_A > 0.
5388 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5389 * bute the last M_A-IMB_A rows of A,
5390 * MB_A > 0.
5391 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5392 * bute the last N_A-INB_A columns of
5393 * A, NB_A > 0.
5394 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5395 * row of the matrix A is distributed,
5396 * NPROW > RSRC_A >= 0.
5397 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5398 * first column of A is distributed.
5399 * NPCOL > CSRC_A >= 0.
5400 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5401 * array storing the local blocks of
5402 * the distributed matrix A,
5403 * IF( Lc( 1, N_A ) > 0 )
5404 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
5405 * ELSE
5406 * LLD_A >= 1.
5407 *
5408 * Let K be the number of rows of a matrix A starting at the global in-
5409 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5410 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5411 * receive if these K rows were distributed over NPROW processes. If K
5412 * is the number of columns of a matrix A starting at the global index
5413 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5414 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5415 * these K columns were distributed over NPCOL processes.
5416 *
5417 * The values of Lr() and Lc() may be determined via a call to the func-
5418 * tion PB_NUMROC:
5419 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5420 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5421 *
5422 * Arguments
5423 * =========
5424 *
5425 * ICTXT (local input) INTEGER
5426 * On entry, ICTXT specifies the BLACS context handle, indica-
5427 * ting the global context of the operation. The context itself
5428 * is global, but the value of ICTXT is local.
5429 *
5430 * TRANSA (global input) CHARACTER*1
5431 * On entry, TRANSA specifies if the matrix operand A is to be
5432 * transposed.
5433 *
5434 * TRANSB (global input) CHARACTER*1
5435 * On entry, TRANSB specifies if the matrix operand B is to be
5436 * transposed.
5437 *
5438 * M (global input) INTEGER
5439 * On entry, M specifies the number of rows of C.
5440 *
5441 * N (global input) INTEGER
5442 * On entry, N specifies the number of columns of C.
5443 *
5444 * K (global input) INTEGER
5445 * On entry, K specifies the number of columns (resp. rows) of A
5446 * when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
5447 * PxSYR2K, PxHERK and PxHER2K.
5448 *
5449 * ALPHA (global input) COMPLEX*16
5450 * On entry, ALPHA specifies the scalar alpha.
5451 *
5452 * A (local input) COMPLEX*16 array
5453 * On entry, A is an array of dimension (DESCA( M_ ),*). This
5454 * array contains a local copy of the initial entire matrix PA.
5455 *
5456 * IA (global input) INTEGER
5457 * On entry, IA specifies A's global row index, which points to
5458 * the beginning of the submatrix sub( A ).
5459 *
5460 * JA (global input) INTEGER
5461 * On entry, JA specifies A's global column index, which points
5462 * to the beginning of the submatrix sub( A ).
5463 *
5464 * DESCA (global and local input) INTEGER array
5465 * On entry, DESCA is an integer array of dimension DLEN_. This
5466 * is the array descriptor for the matrix A.
5467 *
5468 * B (local input) COMPLEX*16 array
5469 * On entry, B is an array of dimension (DESCB( M_ ),*). This
5470 * array contains a local copy of the initial entire matrix PB.
5471 *
5472 * IB (global input) INTEGER
5473 * On entry, IB specifies B's global row index, which points to
5474 * the beginning of the submatrix sub( B ).
5475 *
5476 * JB (global input) INTEGER
5477 * On entry, JB specifies B's global column index, which points
5478 * to the beginning of the submatrix sub( B ).
5479 *
5480 * DESCB (global and local input) INTEGER array
5481 * On entry, DESCB is an integer array of dimension DLEN_. This
5482 * is the array descriptor for the matrix B.
5483 *
5484 * BETA (global input) COMPLEX*16
5485 * On entry, BETA specifies the scalar beta.
5486 *
5487 * C (local input/local output) COMPLEX*16 array
5488 * On entry, C is an array of dimension (DESCC( M_ ),*). This
5489 * array contains a local copy of the initial entire matrix PC.
5490 *
5491 * PC (local input) COMPLEX*16 array
5492 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5493 * array contains the local pieces of the matrix PC.
5494 *
5495 * IC (global input) INTEGER
5496 * On entry, IC specifies C's global row index, which points to
5497 * the beginning of the submatrix sub( C ).
5498 *
5499 * JC (global input) INTEGER
5500 * On entry, JC specifies C's global column index, which points
5501 * to the beginning of the submatrix sub( C ).
5502 *
5503 * DESCC (global and local input) INTEGER array
5504 * On entry, DESCC is an integer array of dimension DLEN_. This
5505 * is the array descriptor for the matrix C.
5506 *
5507 * CT (workspace) COMPLEX*16 array
5508 * On entry, CT is an array of dimension at least MAX(M,N,K). CT
5509 * holds a copy of the current column of C.
5510 *
5511 * G (workspace) DOUBLE PRECISION array
5512 * On entry, G is an array of dimension at least MAX(M,N,K). G
5513 * is used to compute the gauges.
5514 *
5515 * ERR (global output) DOUBLE PRECISION
5516 * On exit, ERR specifies the largest error in absolute value.
5517 *
5518 * INFO (global output) INTEGER
5519 * On exit, if INFO <> 0, the result is less than half accurate.
5520 *
5521 * -- Written on April 1, 1998 by
5522 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5523 *
5524 * =====================================================================
5525 *
5526 * .. Parameters ..
5527  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5528  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5529  $ RSRC_
5530  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
5531  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5532  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5533  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5534  DOUBLE PRECISION RZERO, RONE
5535  PARAMETER ( RZERO = 0.0d+0, rone = 1.0d+0 )
5536  COMPLEX*16 ZERO
5537  PARAMETER ( ZERO = ( 0.0d+0, 0.0d+0 ) )
5538 * ..
5539 * .. Local Scalars ..
5540  LOGICAL COLREP, CTRANA, CTRANB, ROWREP, TRANA, TRANB
5541  INTEGER I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
5542  $ IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC,
5543  $ MYCOL, MYROW, NPCOL, NPROW
5544  DOUBLE PRECISION EPS, ERRI
5545  COMPLEX*16 Z
5546 * ..
5547 * .. External Subroutines ..
5548  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5549 * ..
5550 * .. External Functions ..
5551  LOGICAL LSAME
5552  DOUBLE PRECISION PDLAMCH
5553  EXTERNAL LSAME, PDLAMCH
5554 * ..
5555 * .. Intrinsic Functions ..
5556  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5557 * ..
5558 * .. Statement Functions ..
5559  DOUBLE PRECISION ABS1
5560  ABS1( Z ) = abs( dble( z ) ) + abs( dimag( z ) )
5561 * ..
5562 * .. Executable Statements ..
5563 *
5564  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
5565 *
5566  eps = pdlamch( ictxt, 'eps' )
5567 *
5568  trana = lsame( transa, 'T' ).OR.lsame( transa, 'C' )
5569  tranb = lsame( transb, 'T' ).OR.lsame( transb, 'C' )
5570  ctrana = lsame( transa, 'C' )
5571  ctranb = lsame( transb, 'C' )
5572 *
5573  lda = max( 1, desca( m_ ) )
5574  ldb = max( 1, descb( m_ ) )
5575  ldc = max( 1, descc( m_ ) )
5576 *
5577 * Compute expected result in C using data in A, B and C.
5578 * Compute gauges in G. This part of the computation is performed
5579 * by every process in the grid.
5580 *
5581  DO 240 j = 1, n
5582 *
5583  ioffc = ic + ( jc + j - 2 ) * ldc
5584  DO 10 i = 1, m
5585  ct( i ) = zero
5586  g( i ) = rzero
5587  10 CONTINUE
5588 *
5589  IF( .NOT.trana .AND. .NOT.tranb ) THEN
5590  DO 30 kk = 1, k
5591  ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5592  DO 20 i = 1, m
5593  ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5594  ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5595  g( i ) = g( i ) + abs( a( ioffa ) ) *
5596  $ abs( b( ioffb ) )
5597  20 CONTINUE
5598  30 CONTINUE
5599  ELSE IF( trana .AND. .NOT.tranb ) THEN
5600  IF( ctrana ) THEN
5601  DO 50 kk = 1, k
5602  ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5603  DO 40 i = 1, m
5604  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5605  ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5606  $ b( ioffb )
5607  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5608  $ abs1( b( ioffb ) )
5609  40 CONTINUE
5610  50 CONTINUE
5611  ELSE
5612  DO 70 kk = 1, k
5613  ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5614  DO 60 i = 1, m
5615  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5616  ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5617  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5618  $ abs1( b( ioffb ) )
5619  60 CONTINUE
5620  70 CONTINUE
5621  END IF
5622  ELSE IF( .NOT.trana .AND. tranb ) THEN
5623  IF( ctranb ) THEN
5624  DO 90 kk = 1, k
5625  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5626  DO 80 i = 1, m
5627  ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5628  ct( i ) = ct( i ) + a( ioffa ) *
5629  $ dconjg( b( ioffb ) )
5630  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5631  $ abs1( b( ioffb ) )
5632  80 CONTINUE
5633  90 CONTINUE
5634  ELSE
5635  DO 110 kk = 1, k
5636  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5637  DO 100 i = 1, m
5638  ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5639  ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5640  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5641  $ abs1( b( ioffb ) )
5642  100 CONTINUE
5643  110 CONTINUE
5644  END IF
5645  ELSE IF( trana .AND. tranb ) THEN
5646  IF( ctrana ) THEN
5647  IF( ctranb ) THEN
5648  DO 130 kk = 1, k
5649  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5650  DO 120 i = 1, m
5651  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5652  ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5653  $ dconjg( b( ioffb ) )
5654  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5655  $ abs1( b( ioffb ) )
5656  120 CONTINUE
5657  130 CONTINUE
5658  ELSE
5659  DO 150 kk = 1, k
5660  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5661  DO 140 i = 1, m
5662  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5663  ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5664  $ b( ioffb )
5665  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5666  $ abs1( b( ioffb ) )
5667  140 CONTINUE
5668  150 CONTINUE
5669  END IF
5670  ELSE
5671  IF( ctranb ) THEN
5672  DO 170 kk = 1, k
5673  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5674  DO 160 i = 1, m
5675  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5676  ct( i ) = ct( i ) + a( ioffa ) *
5677  $ dconjg( b( ioffb ) )
5678  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5679  $ abs1( b( ioffb ) )
5680  160 CONTINUE
5681  170 CONTINUE
5682  ELSE
5683  DO 190 kk = 1, k
5684  ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5685  DO 180 i = 1, m
5686  ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5687  ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5688  g( i ) = g( i ) + abs1( a( ioffa ) ) *
5689  $ abs1( b( ioffb ) )
5690  180 CONTINUE
5691  190 CONTINUE
5692  END IF
5693  END IF
5694  END IF
5695 *
5696  DO 200 i = 1, m
5697  ct( i ) = alpha*ct( i ) + beta * c( ioffc )
5698  g( i ) = abs1( alpha )*g( i ) +
5699  $ abs1( beta )*abs1( c( ioffc ) )
5700  c( ioffc ) = ct( i )
5701  ioffc = ioffc + 1
5702  200 CONTINUE
5703 *
5704 * Compute the error ratio for this result.
5705 *
5706  err = rzero
5707  info = 0
5708  ldpc = descc( lld_ )
5709  ioffc = ic + ( jc + j - 2 ) * ldc
5710  CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
5711  $ iic, jjc, icrow, iccol )
5712  icurrow = icrow
5713  rowrep = ( icrow.EQ.-1 )
5714  colrep = ( iccol.EQ.-1 )
5715 *
5716  IF( mycol.EQ.iccol .OR. colrep ) THEN
5717 *
5718  ibb = descc( imb_ ) - ic + 1
5719  IF( ibb.LE.0 )
5720  $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
5721  ibb = min( ibb, m )
5722  in = ic + ibb - 1
5723 *
5724  DO 210 i = ic, in
5725 *
5726  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5727  erri = abs( pc( iic+(jjc-1)*ldpc ) -
5728  $ c( ioffc ) ) / eps
5729  IF( g( i-ic+1 ).NE.rzero )
5730  $ erri = erri / g( i-ic+1 )
5731  err = max( err, erri )
5732  IF( err*sqrt( eps ).GE.rone )
5733  $ info = 1
5734  iic = iic + 1
5735  END IF
5736 *
5737  ioffc = ioffc + 1
5738 *
5739  210 CONTINUE
5740 *
5741  icurrow = mod( icurrow+1, nprow )
5742 *
5743  DO 230 i = in+1, ic+m-1, descc( mb_ )
5744  ibb = min( ic+m-i, descc( mb_ ) )
5745 *
5746  DO 220 kk = 0, ibb-1
5747 *
5748  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5749  erri = abs( pc( iic+(jjc-1)*ldpc ) -
5750  $ c( ioffc ) )/eps
5751  IF( g( i+kk-ic+1 ).NE.rzero )
5752  $ erri = erri / g( i+kk-ic+1 )
5753  err = max( err, erri )
5754  IF( err*sqrt( eps ).GE.rone )
5755  $ info = 1
5756  iic = iic + 1
5757  END IF
5758 *
5759  ioffc = ioffc + 1
5760 *
5761  220 CONTINUE
5762 *
5763  icurrow = mod( icurrow+1, nprow )
5764 *
5765  230 CONTINUE
5766 *
5767  END IF
5768 *
5769 * If INFO = 0, all results are at least half accurate.
5770 *
5771  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
5772  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
5773  $ mycol )
5774  IF( info.NE.0 )
5775  $ GO TO 250
5776 *
5777  240 CONTINUE
5778 *
5779  250 CONTINUE
5780 *
5781  RETURN
5782 *
5783 * End of PZMMCH
5784 *
5785  END
5786  SUBROUTINE pzmmch1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
5787  $ DESCA, BETA, C, PC, IC, JC, DESCC, CT, G,
5788  $ ERR, INFO )
5790 * -- PBLAS test routine (version 2.0) --
5791 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5792 * and University of California, Berkeley.
5793 * April 1, 1998
5794 *
5795 * .. Scalar Arguments ..
5796  CHARACTER*1 TRANS, UPLO
5797  INTEGER IA, IC, ICTXT, INFO, JA, JC, K, N
5798  DOUBLE PRECISION ERR
5799  COMPLEX*16 ALPHA, BETA
5800 * ..
5801 * .. Array Arguments ..
5802  INTEGER DESCA( * ), DESCC( * )
5803  DOUBLE PRECISION G( * )
5804  COMPLEX*16 A( * ), C( * ), CT( * ), PC( * )
5805 * ..
5806 *
5807 * Purpose
5808 * =======
5809 *
5810 * PZMMCH1 checks the results of the computational tests.
5811 *
5812 * Notes
5813 * =====
5814 *
5815 * A description vector is associated with each 2D block-cyclicly dis-
5816 * tributed matrix. This vector stores the information required to
5817 * establish the mapping between a matrix entry and its corresponding
5818 * process and memory location.
5819 *
5820 * In the following comments, the character _ should be read as
5821 * "of the distributed matrix". Let A be a generic term for any 2D
5822 * block cyclicly distributed matrix. Its description vector is DESCA:
5823 *
5824 * NOTATION STORED IN EXPLANATION
5825 * ---------------- --------------- ------------------------------------
5826 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5827 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5828 * the NPROW x NPCOL BLACS process grid
5829 * A is distributed over. The context
5830 * itself is global, but the handle
5831 * (the integer value) may vary.
5832 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
5833 * ted matrix A, M_A >= 0.
5834 * N_A (global) DESCA( N_ ) The number of columns in the distri-
5835 * buted matrix A, N_A >= 0.
5836 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5837 * block of the matrix A, IMB_A > 0.
5838 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
5839 * left block of the matrix A,
5840 * INB_A > 0.
5841 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5842 * bute the last M_A-IMB_A rows of A,
5843 * MB_A > 0.
5844 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5845 * bute the last N_A-INB_A columns of
5846 * A, NB_A > 0.
5847 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5848 * row of the matrix A is distributed,
5849 * NPROW > RSRC_A >= 0.
5850 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5851 * first column of A is distributed.
5852 * NPCOL > CSRC_A >= 0.
5853 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5854 * array storing the local blocks of
5855 * the distributed matrix A,
5856 * IF( Lc( 1, N_A ) > 0 )
5857 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
5858 * ELSE
5859 * LLD_A >= 1.
5860 *
5861 * Let K be the number of rows of a matrix A starting at the global in-
5862 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5863 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5864 * receive if these K rows were distributed over NPROW processes. If K
5865 * is the number of columns of a matrix A starting at the global index
5866 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5867 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5868 * these K columns were distributed over NPCOL processes.
5869 *
5870 * The values of Lr() and Lc() may be determined via a call to the func-
5871 * tion PB_NUMROC:
5872 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5873 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5874 *
5875 * Arguments
5876 * =========
5877 *
5878 * ICTXT (local input) INTEGER
5879 * On entry, ICTXT specifies the BLACS context handle, indica-
5880 * ting the global context of the operation. The context itself
5881 * is global, but the value of ICTXT is local.
5882 *
5883 * UPLO (global input) CHARACTER*1
5884 * On entry, UPLO specifies which part of C should contain the
5885 * result.
5886 *
5887 * TRANS (global input) CHARACTER*1
5888 * On entry, TRANS specifies whether the matrix A has to be
5889 * transposed or not before computing the matrix-matrix product.
5890 *
5891 * N (global input) INTEGER
5892 * On entry, N specifies the order the submatrix operand C. N
5893 * must be at least zero.
5894 *
5895 * K (global input) INTEGER
5896 * On entry, K specifies the number of columns (resp. rows) of A
5897 * when TRANS = 'N' (resp. TRANS <> 'N'). K must be at least
5898 * zero.
5899 *
5900 * ALPHA (global input) COMPLEX*16
5901 * On entry, ALPHA specifies the scalar alpha.
5902 *
5903 * A (local input) COMPLEX*16 array
5904 * On entry, A is an array of dimension (DESCA( M_ ),*). This
5905 * array contains a local copy of the initial entire matrix PA.
5906 *
5907 * IA (global input) INTEGER
5908 * On entry, IA specifies A's global row index, which points to
5909 * the beginning of the submatrix sub( A ).
5910 *
5911 * JA (global input) INTEGER
5912 * On entry, JA specifies A's global column index, which points
5913 * to the beginning of the submatrix sub( A ).
5914 *
5915 * DESCA (global and local input) INTEGER array
5916 * On entry, DESCA is an integer array of dimension DLEN_. This
5917 * is the array descriptor for the matrix A.
5918 *
5919 * BETA (global input) COMPLEX*16
5920 * On entry, BETA specifies the scalar beta.
5921 *
5922 * C (local input/local output) COMPLEX*16 array
5923 * On entry, C is an array of dimension (DESCC( M_ ),*). This
5924 * array contains a local copy of the initial entire matrix PC.
5925 *
5926 * PC (local input) COMPLEX*16 array
5927 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5928 * array contains the local pieces of the matrix PC.
5929 *
5930 * IC (global input) INTEGER
5931 * On entry, IC specifies C's global row index, which points to
5932 * the beginning of the submatrix sub( C ).
5933 *
5934 * JC (global input) INTEGER
5935 * On entry, JC specifies C's global column index, which points
5936 * to the beginning of the submatrix sub( C ).
5937 *
5938 * DESCC (global and local input) INTEGER array
5939 * On entry, DESCC is an integer array of dimension DLEN_. This
5940 * is the array descriptor for the matrix C.
5941 *
5942 * CT (workspace) COMPLEX*16 array
5943 * On entry, CT is an array of dimension at least MAX(M,N,K). CT
5944 * holds a copy of the current column of C.
5945 *
5946 * G (workspace) DOUBLE PRECISION array
5947 * On entry, G is an array of dimension at least MAX(M,N,K). G
5948 * is used to compute the gauges.
5949 *
5950 * ERR (global output) DOUBLE PRECISION
5951 * On exit, ERR specifies the largest error in absolute value.
5952 *
5953 * INFO (global output) INTEGER
5954 * On exit, if INFO <> 0, the result is less than half accurate.
5955 *
5956 * -- Written on April 1, 1998 by
5957 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5958 *
5959 * =====================================================================
5960 *
5961 * .. Parameters ..
5962  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5963  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5964  $ RSRC_
5965  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
5966  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5967  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5968  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5969  DOUBLE PRECISION RZERO, RONE
5970  PARAMETER ( RZERO = 0.0d+0, rone = 1.0d+0 )
5971  COMPLEX*16 ZERO
5972  PARAMETER ( ZERO = ( 0.0d+0, 0.0d+0 ) )
5973 * ..
5974 * .. Local Scalars ..
5975  LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
5976  INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
5977  $ IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
5978  $ ldc, ldpc, mycol, myrow, npcol, nprow
5979  DOUBLE PRECISION EPS, ERRI
5980  COMPLEX*16 Z
5981 * ..
5982 * .. External Subroutines ..
5983  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5984 * ..
5985 * .. External Functions ..
5986  LOGICAL LSAME
5987  DOUBLE PRECISION PDLAMCH
5988  EXTERNAL lsame, pdlamch
5989 * ..
5990 * .. Intrinsic Functions ..
5991  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5992 * ..
5993 * .. Statement Functions ..
5994  DOUBLE PRECISION ABS1
5995  abs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
5996 * ..
5997 * .. Executable Statements ..
5998 *
5999  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6000 *
6001  eps = pdlamch( ictxt, 'eps' )
6002 *
6003  upper = lsame( uplo, 'U' )
6004  notran = lsame( trans, 'N' )
6005  tran = lsame( trans, 'T' )
6006  htran = lsame( trans, 'H' )
6007 *
6008  lda = max( 1, desca( m_ ) )
6009  ldc = max( 1, descc( m_ ) )
6010 *
6011 * Compute expected result in C using data in A, B and C.
6012 * Compute gauges in G. This part of the computation is performed
6013 * by every process in the grid.
6014 *
6015  DO 140 j = 1, n
6016 *
6017  IF( upper ) THEN
6018  ibeg = 1
6019  iend = j
6020  ELSE
6021  ibeg = j
6022  iend = n
6023  END IF
6024 *
6025  DO 10 i = 1, n
6026  ct( i ) = zero
6027  g( i ) = rzero
6028  10 CONTINUE
6029 *
6030  IF( notran ) THEN
6031  DO 30 kk = 1, k
6032  ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6033  DO 20 i = ibeg, iend
6034  ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6035  ct( i ) = ct( i ) + a( ioffak ) * a( ioffan )
6036  g( i ) = g( i ) + abs1( a( ioffak ) ) *
6037  $ abs1( a( ioffan ) )
6038  20 CONTINUE
6039  30 CONTINUE
6040  ELSE IF( tran ) THEN
6041  DO 50 kk = 1, k
6042  ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6043  DO 40 i = ibeg, iend
6044  ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6045  ct( i ) = ct( i ) + a( ioffak ) * a( ioffan )
6046  g( i ) = g( i ) + abs1( a( ioffak ) ) *
6047  $ abs1( a( ioffan ) )
6048  40 CONTINUE
6049  50 CONTINUE
6050  ELSE IF( htran ) THEN
6051  DO 70 kk = 1, k
6052  ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6053  DO 60 i = ibeg, iend
6054  ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6055  ct( i ) = ct( i ) + a( ioffan ) *
6056  $ dconjg( a( ioffak ) )
6057  g( i ) = g( i ) + abs1( a( ioffak ) ) *
6058  $ abs1( a( ioffan ) )
6059  60 CONTINUE
6060  70 CONTINUE
6061  ELSE
6062  DO 90 kk = 1, k
6063  ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6064  DO 80 i = ibeg, iend
6065  ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6066  ct( i ) = ct( i ) + dconjg( a( ioffan ) ) *
6067  $ a( ioffak )
6068  g( i ) = g( i ) + abs1( dconjg( a( ioffan ) ) ) *
6069  $ abs1( a( ioffak ) )
6070  80 CONTINUE
6071  90 CONTINUE
6072  END IF
6073 *
6074  ioffc = ic + ibeg - 1 + ( jc + j - 2 ) * ldc
6075 *
6076  DO 100 i = ibeg, iend
6077  ct( i ) = alpha*ct( i ) + beta * c( ioffc )
6078  g( i ) = abs1( alpha )*g( i ) +
6079  $ abs1( beta )*abs1( c( ioffc ) )
6080  c( ioffc ) = ct( i )
6081  ioffc = ioffc + 1
6082  100 CONTINUE
6083 *
6084 * Compute the error ratio for this result.
6085 *
6086  err = rzero
6087  info = 0
6088  ldpc = descc( lld_ )
6089  ioffc = ic + ( jc + j - 2 ) * ldc
6090  CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
6091  $ iic, jjc, icrow, iccol )
6092  icurrow = icrow
6093  rowrep = ( icrow.EQ.-1 )
6094  colrep = ( iccol.EQ.-1 )
6095 *
6096  IF( mycol.EQ.iccol .OR. colrep ) THEN
6097 *
6098  ibb = descc( imb_ ) - ic + 1
6099  IF( ibb.LE.0 )
6100  $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
6101  ibb = min( ibb, n )
6102  in = ic + ibb - 1
6103 *
6104  DO 110 i = ic, in
6105 *
6106  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6107  erri = abs( pc( iic+(jjc-1)*ldpc ) -
6108  $ c( ioffc ) ) / eps
6109  IF( g( i-ic+1 ).NE.rzero )
6110  $ erri = erri / g( i-ic+1 )
6111  err = max( err, erri )
6112  IF( err*sqrt( eps ).GE.rone )
6113  $ info = 1
6114  iic = iic + 1
6115  END IF
6116 *
6117  ioffc = ioffc + 1
6118 *
6119  110 CONTINUE
6120 *
6121  icurrow = mod( icurrow+1, nprow )
6122 *
6123  DO 130 i = in+1, ic+n-1, descc( mb_ )
6124  ibb = min( ic+n-i, descc( mb_ ) )
6125 *
6126  DO 120 kk = 0, ibb-1
6127 *
6128  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6129  erri = abs( pc( iic+(jjc-1)*ldpc ) -
6130  $ c( ioffc ) )/eps
6131  IF( g( i+kk-ic+1 ).NE.rzero )
6132  $ erri = erri / g( i+kk-ic+1 )
6133  err = max( err, erri )
6134  IF( err*sqrt( eps ).GE.rone )
6135  $ info = 1
6136  iic = iic + 1
6137  END IF
6138 *
6139  ioffc = ioffc + 1
6140 *
6141  120 CONTINUE
6142 *
6143  icurrow = mod( icurrow+1, nprow )
6144 *
6145  130 CONTINUE
6146 *
6147  END IF
6148 *
6149 * If INFO = 0, all results are at least half accurate.
6150 *
6151  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6152  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6153  $ mycol )
6154  IF( info.NE.0 )
6155  $ GO TO 150
6156 *
6157  140 CONTINUE
6158 *
6159  150 CONTINUE
6160 *
6161  RETURN
6162 *
6163 * End of PZMMCH1
6164 *
6165  END
6166  SUBROUTINE pzmmch2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
6167  $ DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
6168  $ JC, DESCC, CT, G, ERR, INFO )
6170 * -- PBLAS test routine (version 2.0) --
6171 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6172 * and University of California, Berkeley.
6173 * April 1, 1998
6174 *
6175 * .. Scalar Arguments ..
6176  CHARACTER*1 TRANS, UPLO
6177  INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
6178  DOUBLE PRECISION ERR
6179  COMPLEX*16 ALPHA, BETA
6180 * ..
6181 * .. Array Arguments ..
6182  INTEGER DESCA( * ), DESCB( * ), DESCC( * )
6183  DOUBLE PRECISION G( * )
6184  COMPLEX*16 A( * ), B( * ), C( * ), CT( * ),
6185  $ PC( * )
6186 * ..
6187 *
6188 * Purpose
6189 * =======
6190 *
6191 * PZMMCH2 checks the results of the computational tests.
6192 *
6193 * Notes
6194 * =====
6195 *
6196 * A description vector is associated with each 2D block-cyclicly dis-
6197 * tributed matrix. This vector stores the information required to
6198 * establish the mapping between a matrix entry and its corresponding
6199 * process and memory location.
6200 *
6201 * In the following comments, the character _ should be read as
6202 * "of the distributed matrix". Let A be a generic term for any 2D
6203 * block cyclicly distributed matrix. Its description vector is DESCA:
6204 *
6205 * NOTATION STORED IN EXPLANATION
6206 * ---------------- --------------- ------------------------------------
6207 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6208 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6209 * the NPROW x NPCOL BLACS process grid
6210 * A is distributed over. The context
6211 * itself is global, but the handle
6212 * (the integer value) may vary.
6213 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
6214 * ted matrix A, M_A >= 0.
6215 * N_A (global) DESCA( N_ ) The number of columns in the distri-
6216 * buted matrix A, N_A >= 0.
6217 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6218 * block of the matrix A, IMB_A > 0.
6219 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
6220 * left block of the matrix A,
6221 * INB_A > 0.
6222 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6223 * bute the last M_A-IMB_A rows of A,
6224 * MB_A > 0.
6225 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6226 * bute the last N_A-INB_A columns of
6227 * A, NB_A > 0.
6228 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6229 * row of the matrix A is distributed,
6230 * NPROW > RSRC_A >= 0.
6231 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6232 * first column of A is distributed.
6233 * NPCOL > CSRC_A >= 0.
6234 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6235 * array storing the local blocks of
6236 * the distributed matrix A,
6237 * IF( Lc( 1, N_A ) > 0 )
6238 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
6239 * ELSE
6240 * LLD_A >= 1.
6241 *
6242 * Let K be the number of rows of a matrix A starting at the global in-
6243 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6244 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6245 * receive if these K rows were distributed over NPROW processes. If K
6246 * is the number of columns of a matrix A starting at the global index
6247 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6248 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6249 * these K columns were distributed over NPCOL processes.
6250 *
6251 * The values of Lr() and Lc() may be determined via a call to the func-
6252 * tion PB_NUMROC:
6253 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6254 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6255 *
6256 * Arguments
6257 * =========
6258 *
6259 * ICTXT (local input) INTEGER
6260 * On entry, ICTXT specifies the BLACS context handle, indica-
6261 * ting the global context of the operation. The context itself
6262 * is global, but the value of ICTXT is local.
6263 *
6264 * UPLO (global input) CHARACTER*1
6265 * On entry, UPLO specifies which part of C should contain the
6266 * result.
6267 *
6268 * TRANS (global input) CHARACTER*1
6269 * On entry, TRANS specifies whether the matrices A and B have
6270 * to be transposed or not before computing the matrix-matrix
6271 * product.
6272 *
6273 * N (global input) INTEGER
6274 * On entry, N specifies the order the submatrix operand C. N
6275 * must be at least zero.
6276 *
6277 * K (global input) INTEGER
6278 * On entry, K specifies the number of columns (resp. rows) of A
6279 * and B when TRANS = 'N' (resp. TRANS <> 'N'). K must be at
6280 * least zero.
6281 *
6282 * ALPHA (global input) COMPLEX*16
6283 * On entry, ALPHA specifies the scalar alpha.
6284 *
6285 * A (local input) COMPLEX*16 array
6286 * On entry, A is an array of dimension (DESCA( M_ ),*). This
6287 * array contains a local copy of the initial entire matrix PA.
6288 *
6289 * IA (global input) INTEGER
6290 * On entry, IA specifies A's global row index, which points to
6291 * the beginning of the submatrix sub( A ).
6292 *
6293 * JA (global input) INTEGER
6294 * On entry, JA specifies A's global column index, which points
6295 * to the beginning of the submatrix sub( A ).
6296 *
6297 * DESCA (global and local input) INTEGER array
6298 * On entry, DESCA is an integer array of dimension DLEN_. This
6299 * is the array descriptor for the matrix A.
6300 *
6301 * B (local input) COMPLEX*16 array
6302 * On entry, B is an array of dimension (DESCB( M_ ),*). This
6303 * array contains a local copy of the initial entire matrix PB.
6304 *
6305 * IB (global input) INTEGER
6306 * On entry, IB specifies B's global row index, which points to
6307 * the beginning of the submatrix sub( B ).
6308 *
6309 * JB (global input) INTEGER
6310 * On entry, JB specifies B's global column index, which points
6311 * to the beginning of the submatrix sub( B ).
6312 *
6313 * DESCB (global and local input) INTEGER array
6314 * On entry, DESCB is an integer array of dimension DLEN_. This
6315 * is the array descriptor for the matrix B.
6316 *
6317 * BETA (global input) COMPLEX*16
6318 * On entry, BETA specifies the scalar beta.
6319 *
6320 * C (local input/local output) COMPLEX*16 array
6321 * On entry, C is an array of dimension (DESCC( M_ ),*). This
6322 * array contains a local copy of the initial entire matrix PC.
6323 *
6324 * PC (local input) COMPLEX*16 array
6325 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6326 * array contains the local pieces of the matrix PC.
6327 *
6328 * IC (global input) INTEGER
6329 * On entry, IC specifies C's global row index, which points to
6330 * the beginning of the submatrix sub( C ).
6331 *
6332 * JC (global input) INTEGER
6333 * On entry, JC specifies C's global column index, which points
6334 * to the beginning of the submatrix sub( C ).
6335 *
6336 * DESCC (global and local input) INTEGER array
6337 * On entry, DESCC is an integer array of dimension DLEN_. This
6338 * is the array descriptor for the matrix C.
6339 *
6340 * CT (workspace) COMPLEX*16 array
6341 * On entry, CT is an array of dimension at least MAX(M,N,K). CT
6342 * holds a copy of the current column of C.
6343 *
6344 * G (workspace) DOUBLE PRECISION array
6345 * On entry, G is an array of dimension at least MAX(M,N,K). G
6346 * is used to compute the gauges.
6347 *
6348 * ERR (global output) DOUBLE PRECISION
6349 * On exit, ERR specifies the largest error in absolute value.
6350 *
6351 * INFO (global output) INTEGER
6352 * On exit, if INFO <> 0, the result is less than half accurate.
6353 *
6354 * -- Written on April 1, 1998 by
6355 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6356 *
6357 * =====================================================================
6358 *
6359 * .. Parameters ..
6360  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6361  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6362  $ RSRC_
6363  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
6364  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
6365  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
6366  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
6367  DOUBLE PRECISION RZERO, RONE
6368  PARAMETER ( RZERO = 0.0d+0, rone = 1.0d+0 )
6369  COMPLEX*16 ZERO
6370  PARAMETER ( ZERO = ( 0.0d+0, 0.0d+0 ) )
6371 * ..
6372 * .. Local Scalars ..
6373  LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
6374  INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
6375  $ IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
6376  $ JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
6377  $ NPCOL, NPROW
6378  DOUBLE PRECISION EPS, ERRI
6379  COMPLEX*16 Z
6380 * ..
6381 * .. External Subroutines ..
6382  EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
6383 * ..
6384 * .. External Functions ..
6385  LOGICAL LSAME
6386  DOUBLE PRECISION PDLAMCH
6387  EXTERNAL lsame, pdlamch
6388 * ..
6389 * .. Intrinsic Functions ..
6390  INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
6391 * ..
6392 * .. Statement Functions ..
6393  DOUBLE PRECISION ABS1
6394  ABS1( Z ) = abs( dble( z ) ) + abs( dimag( z ) )
6395 * ..
6396 * .. Executable Statements ..
6397 *
6398  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6399 *
6400  eps = pdlamch( ictxt, 'eps' )
6401 *
6402  upper = lsame( uplo, 'U' )
6403  htran = lsame( trans, 'H' )
6404  notran = lsame( trans, 'N' )
6405  tran = lsame( trans, 'T' )
6406 *
6407  lda = max( 1, desca( m_ ) )
6408  ldb = max( 1, descb( m_ ) )
6409  ldc = max( 1, descc( m_ ) )
6410 *
6411 * Compute expected result in C using data in A, B and C.
6412 * Compute gauges in G. This part of the computation is performed
6413 * by every process in the grid.
6414 *
6415  DO 140 j = 1, n
6416 *
6417  IF( upper ) THEN
6418  ibeg = 1
6419  iend = j
6420  ELSE
6421  ibeg = j
6422  iend = n
6423  END IF
6424 *
6425  DO 10 i = 1, n
6426  ct( i ) = zero
6427  g( i ) = rzero
6428  10 CONTINUE
6429 *
6430  IF( notran ) THEN
6431  DO 30 kk = 1, k
6432  ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6433  ioffbk = ib + j - 1 + ( jb + kk - 2 ) * ldb
6434  DO 20 i = ibeg, iend
6435  ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6436  ioffbn = ib + i - 1 + ( jb + kk - 2 ) * ldb
6437  ct( i ) = ct( i ) + alpha * (
6438  $ a( ioffan ) * b( ioffbk ) +
6439  $ b( ioffbn ) * a( ioffak ) )
6440  g( i ) = g( i ) + abs( alpha ) * (
6441  $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6442  $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6443  20 CONTINUE
6444  30 CONTINUE
6445  ELSE IF( tran ) THEN
6446  DO 50 kk = 1, k
6447  ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6448  ioffbk = ib + kk - 1 + ( jb + j - 2 ) * ldb
6449  DO 40 i = ibeg, iend
6450  ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6451  ioffbn = ib + kk - 1 + ( jb + i - 2 ) * ldb
6452  ct( i ) = ct( i ) + alpha * (
6453  $ a( ioffan ) * b( ioffbk ) +
6454  $ b( ioffbn ) * a( ioffak ) )
6455  g( i ) = g( i ) + abs( alpha ) * (
6456  $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6457  $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6458  40 CONTINUE
6459  50 CONTINUE
6460  ELSE IF( htran ) THEN
6461  DO 70 kk = 1, k
6462  ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6463  ioffbk = ib + j - 1 + ( jb + kk - 2 ) * ldb
6464  DO 60 i = ibeg, iend
6465  ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6466  ioffbn = ib + i - 1 + ( jb + kk - 2 ) * ldb
6467  ct( i ) = ct( i ) +
6468  $ alpha * a( ioffan ) * dconjg( b( ioffbk ) ) +
6469  $ b( ioffbn ) * dconjg( alpha * a( ioffak ) )
6470  g( i ) = g( i ) + abs1( alpha ) * (
6471  $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6472  $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6473  60 CONTINUE
6474  70 CONTINUE
6475  ELSE
6476  DO 90 kk = 1, k
6477  ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6478  ioffbk = ib + kk - 1 + ( jb + j - 2 ) * ldb
6479  DO 80 i = ibeg, iend
6480  ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6481  ioffbn = ib + kk - 1 + ( jb + i - 2 ) * ldb
6482  ct( i ) = ct( i ) +
6483  $ alpha * dconjg( a( ioffan ) ) * b( ioffbk ) +
6484  $ dconjg( alpha * b( ioffbn ) ) * a( ioffak )
6485  g( i ) = g( i ) + abs1( alpha ) * (
6486  $ abs1( dconjg( a( ioffan ) ) * b( ioffbk ) ) +
6487  $ abs1( dconjg( b( ioffbn ) ) * a( ioffak ) ) )
6488  80 CONTINUE
6489  90 CONTINUE
6490  END IF
6491 *
6492  ioffc = ic + ibeg - 1 + ( jc + j - 2 ) * ldc
6493 *
6494  DO 100 i = ibeg, iend
6495  ct( i ) = ct( i ) + beta * c( ioffc )
6496  g( i ) = g( i ) + abs1( beta )*abs1( c( ioffc ) )
6497  c( ioffc ) = ct( i )
6498  ioffc = ioffc + 1
6499  100 CONTINUE
6500 *
6501 * Compute the error ratio for this result.
6502 *
6503  err = rzero
6504  info = 0
6505  ldpc = descc( lld_ )
6506  ioffc = ic + ( jc + j - 2 ) * ldc
6507  CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
6508  $ iic, jjc, icrow, iccol )
6509  icurrow = icrow
6510  rowrep = ( icrow.EQ.-1 )
6511  colrep = ( iccol.EQ.-1 )
6512 *
6513  IF( mycol.EQ.iccol .OR. colrep ) THEN
6514 *
6515  ibb = descc( imb_ ) - ic + 1
6516  IF( ibb.LE.0 )
6517  $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
6518  ibb = min( ibb, n )
6519  in = ic + ibb - 1
6520 *
6521  DO 110 i = ic, in
6522 *
6523  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6524  erri = abs( pc( iic+(jjc-1)*ldpc ) -
6525  $ c( ioffc ) ) / eps
6526  IF( g( i-ic+1 ).NE.rzero )
6527  $ erri = erri / g( i-ic+1 )
6528  err = max( err, erri )
6529  IF( err*sqrt( eps ).GE.rone )
6530  $ info = 1
6531  iic = iic + 1
6532  END IF
6533 *
6534  ioffc = ioffc + 1
6535 *
6536  110 CONTINUE
6537 *
6538  icurrow = mod( icurrow+1, nprow )
6539 *
6540  DO 130 i = in+1, ic+n-1, descc( mb_ )
6541  ibb = min( ic+n-i, descc( mb_ ) )
6542 *
6543  DO 120 kk = 0, ibb-1
6544 *
6545  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6546  erri = abs( pc( iic+(jjc-1)*ldpc ) -
6547  $ c( ioffc ) )/eps
6548  IF( g( i+kk-ic+1 ).NE.rzero )
6549  $ erri = erri / g( i+kk-ic+1 )
6550  err = max( err, erri )
6551  IF( err*sqrt( eps ).GE.rone )
6552  $ info = 1
6553  iic = iic + 1
6554  END IF
6555 *
6556  ioffc = ioffc + 1
6557 *
6558  120 CONTINUE
6559 *
6560  icurrow = mod( icurrow+1, nprow )
6561 *
6562  130 CONTINUE
6563 *
6564  END IF
6565 *
6566 * If INFO = 0, all results are at least half accurate.
6567 *
6568  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6569  CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6570  $ mycol )
6571  IF( info.NE.0 )
6572  $ GO TO 150
6573 *
6574  140 CONTINUE
6575 *
6576  150 CONTINUE
6577 *
6578  RETURN
6579 *
6580 * End of PZMMCH2
6581 *
6582  END
6583  SUBROUTINE pzmmch3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
6584  $ BETA, C, PC, IC, JC, DESCC, ERR, INFO )
6586 * -- PBLAS test routine (version 2.0) --
6587 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6588 * and University of California, Berkeley.
6589 * April 1, 1998
6590 *
6591 * .. Scalar Arguments ..
6592  CHARACTER*1 TRANS, UPLO
6593  INTEGER IA, IC, INFO, JA, JC, M, N
6594  DOUBLE PRECISION ERR
6595  COMPLEX*16 ALPHA, BETA
6596 * ..
6597 * .. Array Arguments ..
6598  INTEGER DESCA( * ), DESCC( * )
6599  COMPLEX*16 A( * ), C( * ), PC( * )
6600 * ..
6601 *
6602 * Purpose
6603 * =======
6604 *
6605 * PZMMCH3 checks the results of the computational tests.
6606 *
6607 * Notes
6608 * =====
6609 *
6610 * A description vector is associated with each 2D block-cyclicly dis-
6611 * tributed matrix. This vector stores the information required to
6612 * establish the mapping between a matrix entry and its corresponding
6613 * process and memory location.
6614 *
6615 * In the following comments, the character _ should be read as
6616 * "of the distributed matrix". Let A be a generic term for any 2D
6617 * block cyclicly distributed matrix. Its description vector is DESCA:
6618 *
6619 * NOTATION STORED IN EXPLANATION
6620 * ---------------- --------------- ------------------------------------
6621 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6622 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6623 * the NPROW x NPCOL BLACS process grid
6624 * A is distributed over. The context
6625 * itself is global, but the handle
6626 * (the integer value) may vary.
6627 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
6628 * ted matrix A, M_A >= 0.
6629 * N_A (global) DESCA( N_ ) The number of columns in the distri-
6630 * buted matrix A, N_A >= 0.
6631 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6632 * block of the matrix A, IMB_A > 0.
6633 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
6634 * left block of the matrix A,
6635 * INB_A > 0.
6636 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6637 * bute the last M_A-IMB_A rows of A,
6638 * MB_A > 0.
6639 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6640 * bute the last N_A-INB_A columns of
6641 * A, NB_A > 0.
6642 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6643 * row of the matrix A is distributed,
6644 * NPROW > RSRC_A >= 0.
6645 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6646 * first column of A is distributed.
6647 * NPCOL > CSRC_A >= 0.
6648 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6649 * array storing the local blocks of
6650 * the distributed matrix A,
6651 * IF( Lc( 1, N_A ) > 0 )
6652 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
6653 * ELSE
6654 * LLD_A >= 1.
6655 *
6656 * Let K be the number of rows of a matrix A starting at the global in-
6657 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6658 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6659 * receive if these K rows were distributed over NPROW processes. If K
6660 * is the number of columns of a matrix A starting at the global index
6661 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6662 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6663 * these K columns were distributed over NPCOL processes.
6664 *
6665 * The values of Lr() and Lc() may be determined via a call to the func-
6666 * tion PB_NUMROC:
6667 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6668 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6669 *
6670 * Arguments
6671 * =========
6672 *
6673 * UPLO (global input) CHARACTER*1
6674 * On entry, UPLO specifies which part of C should contain the
6675 * result.
6676 *
6677 * TRANS (global input) CHARACTER*1
6678 * On entry, TRANS specifies whether the matrix A has to be
6679 * transposed or not before computing the matrix-matrix addi-
6680 * tion.
6681 *
6682 * M (global input) INTEGER
6683 * On entry, M specifies the number of rows of C.
6684 *
6685 * N (global input) INTEGER
6686 * On entry, N specifies the number of columns of C.
6687 *
6688 * ALPHA (global input) COMPLEX*16
6689 * On entry, ALPHA specifies the scalar alpha.
6690 *
6691 * A (local input) COMPLEX*16 array
6692 * On entry, A is an array of dimension (DESCA( M_ ),*). This
6693 * array contains a local copy of the initial entire matrix PA.
6694 *
6695 * IA (global input) INTEGER
6696 * On entry, IA specifies A's global row index, which points to
6697 * the beginning of the submatrix sub( A ).
6698 *
6699 * JA (global input) INTEGER
6700 * On entry, JA specifies A's global column index, which points
6701 * to the beginning of the submatrix sub( A ).
6702 *
6703 * DESCA (global and local input) INTEGER array
6704 * On entry, DESCA is an integer array of dimension DLEN_. This
6705 * is the array descriptor for the matrix A.
6706 *
6707 * BETA (global input) COMPLEX*16
6708 * On entry, BETA specifies the scalar beta.
6709 *
6710 * C (local input/local output) COMPLEX*16 array
6711 * On entry, C is an array of dimension (DESCC( M_ ),*). This
6712 * array contains a local copy of the initial entire matrix PC.
6713 *
6714 * PC (local input) COMPLEX*16 array
6715 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6716 * array contains the local pieces of the matrix PC.
6717 *
6718 * IC (global input) INTEGER
6719 * On entry, IC specifies C's global row index, which points to
6720 * the beginning of the submatrix sub( C ).
6721 *
6722 * JC (global input) INTEGER
6723 * On entry, JC specifies C's global column index, which points
6724 * to the beginning of the submatrix sub( C ).
6725 *
6726 * DESCC (global and local input) INTEGER array
6727 * On entry, DESCC is an integer array of dimension DLEN_. This
6728 * is the array descriptor for the matrix C.
6729 *
6730 * ERR (global output) DOUBLE PRECISION
6731 * On exit, ERR specifies the largest error in absolute value.
6732 *
6733 * INFO (global output) INTEGER
6734 * On exit, if INFO <> 0, the result is less than half accurate.
6735 *
6736 * -- Written on April 1, 1998 by
6737 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6738 *
6739 * =====================================================================
6740 *
6741 * .. Parameters ..
6742  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6743  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6744  $ RSRC_
6745  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
6746  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
6747  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
6748  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
6749  DOUBLE PRECISION ZERO
6750  PARAMETER ( ZERO = 0.0d+0 )
6751 * ..
6752 * .. Local Scalars ..
6753  LOGICAL COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER
6754  INTEGER I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
6755  $ JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
6756  $ NPROW
6757  DOUBLE PRECISION ERR0, ERRI, PREC
6758 * ..
6759 * .. External Subroutines ..
6760  EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L,
6761  $ pzerraxpby
6762 * ..
6763 * .. External Functions ..
6764  LOGICAL LSAME
6765  DOUBLE PRECISION PDLAMCH
6766  EXTERNAL LSAME, PDLAMCH
6767 * ..
6768 * .. Intrinsic Functions ..
6769  INTRINSIC abs, dconjg, max
6770 * ..
6771 * .. Executable Statements ..
6772 *
6773  ictxt = descc( ctxt_ )
6774  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6775 *
6776  prec = pdlamch( ictxt, 'eps' )
6777 *
6778  upper = lsame( uplo, 'U' )
6779  lower = lsame( uplo, 'L' )
6780  notran = lsame( trans, 'N' )
6781  ctran = lsame( trans, 'C' )
6782 *
6783 * Compute expected result in C using data in A and C. This part of