OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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 )
1190*
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.EQ..OR..EQ..OR..EQ. ELSE IF( SCODE32 SCODE35 SCODE36 ) 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.EQ..OR..EQ. ELSE IF( SCODE33 SCODE34 ) 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.EQ. ELSE IF( SCODE37 ) 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.EQ. ELSE IF( SCODE38 ) 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.EQ. ELSE IF( SCODE39 ) 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.EQ. ELSE IF( SCODE40 ) 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 )
1478*
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 )
1677*
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.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1867.EQ. $ ( ILLD_ ) ) THEN
1868*
1869 CALL PZSETPBLAS( ICTXT )
1870*
1871* Test RSRCA >= NPROW
1872*
1873.EQ. IF( IRSRC_ )
1874 $ DESCA( I ) = NPROW
1875*
1876* Test CSRCA >= NPCOL
1877*
1878.EQ. IF( ICSRC_ )
1879 $ DESCA( I ) = NPCOL
1880*
1881* Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1882*
1883.EQ. IF( ILLD_ ) THEN
1884.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1932.EQ. $ ( ILLD_ ) ) THEN
1933*
1934 CALL PZSETPBLAS( ICTXT )
1935*
1936* Test RSRCB >= NPROW
1937*
1938.EQ. IF( IRSRC_ )
1939 $ DESCB( I ) = NPROW
1940*
1941* Test CSRCB >= NPCOL
1942*
1943.EQ. IF( ICSRC_ )
1944 $ DESCB( I ) = NPCOL
1945*
1946* Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1947*
1948.EQ. IF( ILLD_ ) THEN
1949.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1997.EQ. $ ( ILLD_ ) ) THEN
1998*
1999 CALL PZSETPBLAS( ICTXT )
2000*
2001* Test RSRCC >= NPROW
2002*
2003.EQ. IF( IRSRC_ )
2004 $ DESCC( I ) = NPROW
2005*
2006* Test CSRCC >= NPCOL
2007*
2008.EQ. IF( ICSRC_ )
2009 $ DESCC( I ) = NPCOL
2010*
2011* Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2012*
2013.EQ. IF( ILLD_ ) THEN
2014.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
2062.EQ. $ ( ILLD_ ) ) THEN
2063*
2064 CALL PZSETPBLAS( ICTXT )
2065*
2066* Test RSRCX >= NPROW
2067*
2068.EQ. IF( IRSRC_ )
2069 $ DESCX( I ) = NPROW
2070*
2071* Test CSRCX >= NPCOL
2072*
2073.EQ. IF( ICSRC_ )
2074 $ DESCX( I ) = NPCOL
2075*
2076* Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2077*
2078.EQ. IF( ILLD_ ) THEN
2079.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
2135.EQ. $ ( ILLD_ ) ) THEN
2136*
2137 CALL PZSETPBLAS( ICTXT )
2138*
2139* Test RSRCY >= NPROW
2140*
2141.EQ. IF( IRSRC_ )
2142 $ DESCY( I ) = NPROW
2143*
2144* Test CSRCY >= NPCOL
2145*
2146.EQ. IF( ICSRC_ )
2147 $ DESCY( I ) = NPCOL
2148*
2149* Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2150*
2151.EQ. IF( ILLD_ ) THEN
2152.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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 )
2183*
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.EQ. IF( SCODE11 ) THEN
2342*
2343 CALL SUBPTR( NDIM, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
2344 $ INCY )
2345*
2346.EQ. ELSE IF( SCODE12 ) THEN
2347*
2348 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX )
2349*
2350.EQ. ELSE IF( SCODE13 ) THEN
2351*
2352 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, JY,
2353 $ DESCY, INCY )
2354*
2355.EQ. ELSE IF( SCODE14 ) THEN
2356*
2357 CALL SUBPTR( NDIM, SCLR, ISCLR, X, IX, JX, DESCX, INCX )
2358*
2359.EQ. ELSE IF( SCODE15 ) THEN
2360*
2361 CALL SUBPTR( NDIM, USCLR, X, IX, JX, DESCX, INCX )
2362*
2363* Level 2 PBLAS
2364*
2365.EQ. ELSE IF( SCODE21 ) 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.EQ. ELSE IF( SCODE22 ) 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.EQ. ELSE IF( SCODE23 ) THEN
2376*
2377 CALL SUBPTR( UPLO, TRANSA, DIAG, NDIM, A, IA, JA, DESCA, X, IX,
2378 $ JX, DESCX, INCX )
2379*
2380.EQ. ELSE IF( SCODE24 ) 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.EQ. ELSE IF( SCODE25 ) THEN
2386*
2387 CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, A, IA,
2388 $ JA, DESCA )
2389*
2390.EQ. ELSE IF( SCODE26 ) THEN
2391*
2392 CALL SUBPTR( UPLO, NDIM, USCLR, X, IX, JX, DESCX, INCX, A, IA,
2393 $ JA, DESCA )
2394*
2395.EQ. ELSE IF( SCODE27 ) 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.EQ. ELSE IF( SCODE31 ) 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.EQ. ELSE IF( SCODE32 ) 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.EQ. ELSE IF( SCODE33 ) THEN
2413*
2414 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
2415 $ SCLR, C, IC, JC, DESCC )
2416*
2417.EQ. ELSE IF( SCODE34 ) THEN
2418*
2419 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, USCLR, A, IA, JA, DESCA,
2420 $ USCLR, C, IC, JC, DESCC )
2421*
2422.EQ. ELSE IF( SCODE35 ) 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.EQ. ELSE IF( SCODE36 ) 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.EQ. ELSE IF( SCODE37 ) THEN
2433*
2434 CALL SUBPTR( MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, C, IC,
2435 $ JC, DESCC )
2436*
2437.EQ. ELSE IF( SCODE38 ) THEN
2438*
2439 CALL SUBPTR( SIDE, UPLO, TRANSA, DIAG, MDIM, NDIM, SCLR, A, IA,
2440 $ JA, DESCA, B, IB, JB, DESCB )
2441*
2442.EQ. ELSE IF( SCODE39 ) THEN
2443*
2444 CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR,
2445 $ C, IC, JC, DESCC )
2446*
2447.EQ. ELSE IF( SCODE40 ) 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 )
2460*
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 )
2582*
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.LE. IF( N0 )
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.EQ. ROWREP = ( IXROW-1 )
2766.EQ. COLREP = ( IXCOL-1 )
2767*
2768.EQ. IF( N1 ) THEN
2769*
2770.EQ..OR..AND. IF( ( MYROWIXROW ROWREP )
2771.EQ..OR. $ ( MYCOLIXCOL COLREP ) )
2772 $ CALL PZERRSET( ERR, ERRMAX, X( IX+(JX-1)*LDX ),
2773 $ PX( IIX+(JJX-1)*LDPX ) )
2774*
2775.EQ. ELSE IF( INCXDESCX( M_ ) ) THEN
2776*
2777* sub( X ) is a row vector
2778*
2779 JB = DESCX( INB_ ) - JX + 1
2780.LE. IF( JB0 )
2781 $ JB = ( ( -JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB
2782 JB = MIN( JB, N )
2783 JN = JX + JB - 1
2784*
2785.EQ..OR. IF( MYROWIXROW ROWREP ) THEN
2786*
2787 ICURCOL = IXCOL
2788.EQ..OR. IF( MYCOLICURCOL 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.EQ..OR. IF( MYCOLICURCOL 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.LE. IF( IB0 )
2823 $ IB = ( ( -IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB
2824 IB = MIN( IB, N )
2825 IN = IX + IB - 1
2826*
2827.EQ..OR. IF( MYCOLIXCOL COLREP ) THEN
2828*
2829 ICURROW = IXROW
2830.EQ..OR. IF( MYROWICURROW 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.EQ..OR. IF( MYROWICURROW 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.GT..AND..LE. IF( ERRMAXZERO ERRMAXEPS ) THEN
2865 INFO = 1
2866.GT. ELSE IF( ERRMAXEPS ) 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 )
2876*
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.LE..OR..LE. IF( ( DESCX( M_ )0 )( DESCX( N_ )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.EQ. ROWREP = ( ICURROW-1 )
3065.EQ. COLREP = ( ICURCOL-1 )
3066.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
3067 IMBX = DESCX( IMB_ )
3068 ELSE
3069 IMBX = MBX
3070 END IF
3071.EQ..OR. IF( MYCOLICURCOL 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.EQ. IF( INCXDESCX( M_ ) ) THEN
3090*
3091* sub( X ) is a row vector
3092*
3093.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
3094*
3095 I = 1
3096.EQ. IF( MYCOLDIST0 ) 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.NE..OR..LT..OR..GT. IF( I+LLIX J+KKJX J+KKJX+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.NE..OR..LT..OR. IF( I+LLIX J+KKJX
3124.GT. $ J+KKJX+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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
3149*
3150.EQ. IF( MYCOLDIST0 ) 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.NE..OR..LT..OR. IF( I+LLIX J+KKJX
3161.GT. $ J+KKJX+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.NE..OR..LT..OR. IF( I+LLIX J+KKJX
3179.GT. $ J+KKJX+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.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3207*
3208 J = 1
3209.EQ. IF( MYROWDIST0 ) 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.NE..OR..LT..OR..GT. IF( J+KKJX I+LLIX I+LLIX+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.NE..OR..LT..OR. IF( J+KKJX I+LLIX
3237.GT. $ I+LLIX+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.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3262*
3263.EQ. IF( MYROWDIST0 ) 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.NE..OR..LT..OR. IF( J+KKJX I+LLIX
3274.GT. $ I+LLIX+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.NE..OR..LT..OR. IF( J+KKJX I+LLIX
3292.GT. $ I+LLIX+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.GT..AND..LE. IF( ERRMAXZERO ERRMAXEPS ) THEN
3321 INFO = 1
3322.GT. ELSE IF( ERRMAXEPS ) 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 )
3332*
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.EQ..OR..EQ. IF( ( M0 )( N0 ) )
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.EQ. ROWREP = ( IAROW-1 )
3521.EQ. COLREP = ( IACOL-1 )
3522*
3523* Handle the first block of column separately
3524*
3525 JB = DESCA( INB_ ) - JA + 1
3526.LE. IF( JB0 )
3527 $ JB = ( ( -JB ) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
3528 JB = MIN( JB, N )
3529 JN = JA + JB - 1
3530*
3531.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3532*
3533 DO 40 H = 0, JB-1
3534 IB = DESCA( IMB_ ) - IA + 1
3535.LE. IF( IB0 )
3536 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
3537 IB = MIN( IB, M )
3538 IN = IA + IB - 1
3539.EQ..OR. IF( MYROWICURROW 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.EQ..OR. IF( MYROWICURROW 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.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3577 DO 80 H = 0, JB-1
3578 IB = DESCA( IMB_ ) - IA + 1
3579.LE. IF( IB0 )
3580 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 )*DESCA( MB_ ) + IB
3581 IB = MIN( IB, M )
3582 IN = IA + IB - 1
3583.EQ..OR. IF( MYROWICURROW 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.EQ..OR. IF( MYROWICURROW 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.GT..AND..LE. IF( ERRMAXZERO ERRMAXEPS ) THEN
3622 INFO = 1
3623.GT. ELSE IF( ERRMAXEPS ) 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 )
3633*
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.LE..OR..LE. IF( ( DESCA( M_ )0 )( DESCA( N_ )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.EQ. ROWREP = ( DESCA( RSRC_ )-1 )
3817.EQ. COLREP = ( DESCA( CSRC_ )-1 )
3818 ICURCOL = DESCA( CSRC_ )
3819.EQ..OR. IF( MYROWDESCA( RSRC_ ) 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.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3831*
3832 J = 1
3833.EQ. IF( MYROWDIST0 ) 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.LT..OR..GT..OR. IF( I+LLIA I+LLIA+M-1
3844.LT..OR..GT. $ J+KKJA J+KKJA+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.LT..OR..GT..OR. IF( I+LLIA I+LLIA+M-1
3861.LT..OR..GT. $ J+KKJA J+KKJA+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.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
3886*
3887.EQ. IF( MYROWDIST0 ) 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.LT..OR..GT..OR. IF( I+LLIA I+LLIA+M-1
3898.LT..OR..GT. $ J+KKJA J+KKJA+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.LT..OR..GT..OR. IF( I+LLIA I+LLIA+M-1
3916.LT..OR..GT. $ J+KKJA J+KKJA+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.GT..AND..LE. IF( ERRMAXZERO ERRMAXEPS ) THEN
3943 INFO = 1
3944.GT. ELSE IF( ERRMAXEPS ) 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 )
3955*
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.LE..OR..LE. IF( ( M0 )( N0 ) )
4035 $ RETURN
4036*
4037* Get grid parameters
4038*
4039 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4040*
4041.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) 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 )
4067*
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.LE. IF( N0 )
4144 $ RETURN
4145*
4146* Get grid parameters
4147*
4148 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4149*
4150.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) 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 )
4172*
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.EQ..OR..EQ. IF( M0 N0 ) THEN
4413 TBETA = ONE
4414 ELSE
4415 TBETA = BETA
4416 END IF
4417*
4418 TRAN = LSAME( TRANS, 't' )
4419 CTRAN = LSAME( TRANS, 'c' )
4420.OR. IF( TRANCTRAN ) 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.EQ. ROWREP = ( IYROW-1 )
4482.EQ. COLREP = ( IYCOL-1 )
4483*
4484.EQ. IF( INCYDESCY( M_ ) ) THEN
4485*
4486* sub( Y ) is a row vector
4487*
4488 JB = DESCY( INB_ ) - JY + 1
4489.LE. IF( JB0 )
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.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4497.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4498 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
4499.NE. IF( G( J-JY+1 )RZERO )
4500 $ ERRI = ERRI / G( J-JY+1 )
4501 ERR = MAX( ERR, ERRI )
4502.GE. IF( ERR*SQRT( EPS )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.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4519.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4520 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
4521.NE. IF( G( J+KK-JY+1 )RZERO )
4522 $ ERRI = ERRI / G( J+KK-JY+1 )
4523 ERR = MAX( ERR, ERRI )
4524.GE. IF( ERR*SQRT( EPS )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.LE. IF( IB0 )
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.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4550.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4551 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
4552.NE. IF( G( I-IY+1 )RZERO )
4553 $ ERRI = ERRI / G( I-IY+1 )
4554 ERR = MAX( ERR, ERRI )
4555.GE. IF( ERR*SQRT( EPS )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.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4572.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4573 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
4574.NE. IF( G( I+KK-IY+1 )RZERO )
4575 $ ERRI = ERRI / G( I+KK-IY+1 )
4576 ERR = MAX( ERR, ERRI )
4577.GE. IF( ERR*SQRT( EPS )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 )
4606*
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.EQ. ROWREP = ( IAROW-1 )
4901.EQ. COLREP = ( IACOL-1 )
4902*
4903.EQ..OR. IF( MYCOLIACOL COLREP ) THEN
4904*
4905 ICURROW = IAROW
4906 IB = DESCA( IMB_ ) - IA + 1
4907.LE. IF( IB0 )
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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
4915 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
4916.NE. IF( G( I-IA+1 )ZERO )
4917 $ ERRI = ERRI / G( I-IA+1 )
4918 ERR = MAX( ERR, ERRI )
4919.GE. IF( ERR*SQRT( EPS )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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
4936 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
4937.NE. IF( G( I+KK-IA+1 )ZERO )
4938 $ ERRI = ERRI / G( I+KK-IA+1 )
4939 ERR = MAX( ERR, ERRI )
4940.GE. IF( ERR*SQRT( EPS )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.NE. IF( INFO0 )
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 )
4975*
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.EQ. ROWREP = ( IAROW-1 )
5262.EQ. COLREP = ( IACOL-1 )
5263*
5264.EQ..OR. IF( MYCOLIACOL COLREP ) THEN
5265*
5266 ICURROW = IAROW
5267 IB = DESCA( IMB_ ) - IA + 1
5268.LE. IF( IB0 )
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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5276 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
5277.NE. IF( G( I-IA+1 )ZERO )
5278 $ ERRI = ERRI / G( I-IA+1 )
5279 ERR = MAX( ERR, ERRI )
5280.GE. IF( ERR*SQRT( EPS )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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5297 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
5298.NE. IF( G( I+KK-IA+1 )ZERO )
5299 $ ERRI = ERRI / G( I+KK-IA+1 )
5300 ERR = MAX( ERR, ERRI )
5301.GE. IF( ERR*SQRT( EPS )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.NE. IF( INFO0 )
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 )
5336*
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.NOT..AND..NOT. IF( TRANA 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.AND..NOT. ELSE IF( TRANA 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.NOT..AND. ELSE IF( TRANA 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.AND. ELSE IF( TRANA 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.EQ. ROWREP = ( ICROW-1 )
5714.EQ. COLREP = ( ICCOL-1 )
5715*
5716.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
5717*
5718 IBB = DESCC( IMB_ ) - IC + 1
5719.LE. IF( IBB0 )
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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5727 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5728 $ C( IOFFC ) ) / EPS
5729.NE. IF( G( I-IC+1 )RZERO )
5730 $ ERRI = ERRI / G( I-IC+1 )
5731 ERR = MAX( ERR, ERRI )
5732.GE. IF( ERR*SQRT( EPS )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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5749 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5750 $ C( IOFFC ) )/EPS
5751.NE. IF( G( I+KK-IC+1 )RZERO )
5752 $ ERRI = ERRI / G( I+KK-IC+1 )
5753 ERR = MAX( ERR, ERRI )
5754.GE. IF( ERR*SQRT( EPS )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.NE. IF( INFO0 )
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 )
5789*
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.EQ. ROWREP = ( ICROW-1 )
6094.EQ. COLREP = ( ICCOL-1 )
6095*
6096.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
6097*
6098 IBB = DESCC( IMB_ ) - IC + 1
6099.LE. IF( IBB0 )
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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6107 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6108 $ C( IOFFC ) ) / EPS
6109.NE. IF( G( I-IC+1 )RZERO )
6110 $ ERRI = ERRI / G( I-IC+1 )
6111 ERR = MAX( ERR, ERRI )
6112.GE. IF( ERR*SQRT( EPS )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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6129 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6130 $ C( IOFFC ) )/EPS
6131.NE. IF( G( I+KK-IC+1 )RZERO )
6132 $ ERRI = ERRI / G( I+KK-IC+1 )
6133 ERR = MAX( ERR, ERRI )
6134.GE. IF( ERR*SQRT( EPS )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.NE. IF( INFO0 )
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 )
6169*
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.EQ. ROWREP = ( ICROW-1 )
6511.EQ. COLREP = ( ICCOL-1 )
6512*
6513.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
6514*
6515 IBB = DESCC( IMB_ ) - IC + 1
6516.LE. IF( IBB0 )
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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6524 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6525 $ C( IOFFC ) ) / EPS
6526.NE. IF( G( I-IC+1 )RZERO )
6527 $ ERRI = ERRI / G( I-IC+1 )
6528 ERR = MAX( ERR, ERRI )
6529.GE. IF( ERR*SQRT( EPS )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.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6546 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6547 $ C( IOFFC ) )/EPS
6548.NE. IF( G( I+KK-IC+1 )RZERO )
6549 $ ERRI = ERRI / G( I+KK-IC+1 )
6550 ERR = MAX( ERR, ERRI )
6551.GE. IF( ERR*SQRT( EPS )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.NE. IF( INFO0 )
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 )
6585*
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
6784* the computation is performed by every process in the grid.
6785*
6786 info = 0
6787 err = zero
6788*
6789 lda = max( 1, desca( m_ ) )
6790 ldc = max( 1, descc( m_ ) )
6791 ldpc = max( 1, descc( lld_ ) )
6792 rowrep = ( descc( rsrc_ ).EQ.-1 )
6793 colrep = ( descc( csrc_ ).EQ.-1 )
6794*
6795 IF( notran ) THEN
6796*
6797 DO 20 j = jc, jc + n - 1
6798*
6799 ioffc = ic + ( j - 1 ) * ldc
6800 ioffa = ia + ( ja - 1 + j - jc ) * lda
6801*
6802 DO 10 i = ic, ic + m - 1
6803*
6804 IF( upper ) THEN
6805 IF( ( j - jc ).GE.( i - ic ) ) THEN
6806 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6807 $ c( ioffc ), prec )
6808 ELSE
6809 erri = zero
6810 END IF
6811 ELSE IF( lower ) THEN
6812 IF( ( j - jc ).LE.( i - ic ) ) THEN
6813 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6814 $ c( ioffc ), prec )
6815 ELSE
6816 erri = zero
6817 END IF
6818 ELSE
6819 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6820 $ c( ioffc ), prec )
6821 END IF
6822*
6823 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6824 $ iic, jjc, icrow, iccol )
6825 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6826 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6827 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6828 IF( err0.GT.erri )
6829 $ info = 1
6830 err = max( err, err0 )
6831 END IF
6832*
6833 ioffa = ioffa + 1
6834 ioffc = ioffc + 1
6835*
6836 10 CONTINUE
6837*
6838 20 CONTINUE
6839*
6840 ELSE IF( ctran ) THEN
6841*
6842 DO 40 j = jc, jc + n - 1
6843*
6844 ioffc = ic + ( j - 1 ) * ldc
6845 ioffa = ia + ( j - jc ) + ( ja - 1 ) * lda
6846*
6847 DO 30 i = ic, ic + m - 1
6848*
6849 IF( upper ) THEN
6850 IF( ( j - jc ).GE.( i - ic ) ) THEN
6851 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6852 $ beta, c( ioffc ), prec )
6853 ELSE
6854 erri = zero
6855 END IF
6856 ELSE IF( lower ) THEN
6857 IF( ( j - jc ).LE.( i - ic ) ) THEN
6858 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6859 $ beta, c( ioffc ), prec )
6860 ELSE
6861 erri = zero
6862 END IF
6863 ELSE
6864 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6865 $ beta, c( ioffc ), prec )
6866 END IF
6867*
6868 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6869 $ iic, jjc, icrow, iccol )
6870 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6871 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6872 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6873 IF( err0.GT.erri )
6874 $ info = 1
6875 err = max( err, err0 )
6876 END IF
6877*
6878 ioffc = ioffc + 1
6879 ioffa = ioffa + lda
6880*
6881 30 CONTINUE
6882*
6883 40 CONTINUE
6884*
6885 ELSE
6886*
6887 DO 60 j = jc, jc + n - 1
6888*
6889 ioffc = ic + ( j - 1 ) * ldc
6890 ioffa = ia + ( j - jc ) + ( ja - 1 ) * lda
6891*
6892 DO 50 i = ic, ic + m - 1
6893*
6894 IF( upper ) THEN
6895 IF( ( j - jc ).GE.( i - ic ) ) THEN
6896 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6897 $ c( ioffc ), prec )
6898 ELSE
6899 erri = zero
6900 END IF
6901 ELSE IF( lower ) THEN
6902 IF( ( j - jc ).LE.( i - ic ) ) THEN
6903 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6904 $ c( ioffc ), prec )
6905 ELSE
6906 erri = zero
6907 END IF
6908 ELSE
6909 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6910 $ c( ioffc ), prec )
6911 END IF
6912*
6913 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6914 $ iic, jjc, icrow, iccol )
6915 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6916 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6917 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6918 IF( err0.GT.erri )
6919 $ info = 1
6920 err = max( err, err0 )
6921 END IF
6922*
6923 ioffc = ioffc + 1
6924 ioffa = ioffa + lda
6925*
6926 50 CONTINUE
6927*
6928 60 CONTINUE
6929*
6930 END IF
6931*
6932* If INFO = 0, all results are at least half accurate.
6933*
6934 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6935 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6936 $ mycol )
6937*
6938 RETURN
6939*
6940* End of PZMMCH3
6941*
6942 END
6943 SUBROUTINE pzerraxpby( ERRBND, ALPHA, X, BETA, Y, PREC )
6944*
6945* -- PBLAS test routine (version 2.0) --
6946* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6947* and University of California, Berkeley.
6948* April 1, 1998
6949*
6950* .. Scalar Arguments ..
6951 DOUBLE PRECISION ERRBND, PREC
6952 COMPLEX*16 ALPHA, BETA, X, Y
6953* ..
6954*
6955* Purpose
6956* =======
6957*
6958* PZERRAXPBY serially computes y := beta*y + alpha * x and returns a
6959* scaled relative acceptable error bound on the result.
6960*
6961* Arguments
6962* =========
6963*
6964* ERRBND (global output) DOUBLE PRECISION
6965* On exit, ERRBND specifies the scaled relative acceptable er-
6966* ror bound.
6967*
6968* ALPHA (global input) COMPLEX*16
6969* On entry, ALPHA specifies the scalar alpha.
6970*
6971* X (global input) COMPLEX*16
6972* On entry, X specifies the scalar x to be scaled.
6973*
6974* BETA (global input) COMPLEX*16
6975* On entry, BETA specifies the scalar beta.
6976*
6977* Y (global input/global output) COMPLEX*16
6978* On entry, Y specifies the scalar y to be added. On exit, Y
6979* contains the resulting scalar y.
6980*
6981* PREC (global input) DOUBLE PRECISION
6982* On entry, PREC specifies the machine precision.
6983*
6984* -- Written on April 1, 1998 by
6985* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6986*
6987* =====================================================================
6988*
6989* .. Parameters ..
6990 DOUBLE PRECISION ONE, TWO, ZERO
6991 PARAMETER ( ONE = 1.0d+0, two = 2.0d+0,
6992 $ zero = 0.0d+0 )
6993* ..
6994* .. Local Scalars ..
6995 DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
6996 $ SUMRPOS
6997 COMPLEX*16 TMP
6998* ..
6999* .. Intrinsic Functions ..
7000* ..
7001* .. Executable Statements ..
7002*
7003 sumipos = zero
7004 sumineg = zero
7005 sumrpos = zero
7006 sumrneg = zero
7007 fact = one + two * prec
7008 addbnd = two * two * two * prec
7009*
7010 tmp = alpha * x
7011 IF( dble( tmp ).GE.zero ) THEN
7012 sumrpos = sumrpos + dble( tmp ) * fact
7013 ELSE
7014 sumrneg = sumrneg - dble( tmp ) * fact
7015 END IF
7016 IF( dimag( tmp ).GE.zero ) THEN
7017 sumipos = sumipos + dimag( tmp ) * fact
7018 ELSE
7019 sumineg = sumineg - dimag( tmp ) * fact
7020 END IF
7021*
7022 tmp = beta * y
7023 IF( dble( tmp ).GE.zero ) THEN
7024 sumrpos = sumrpos + dble( tmp ) * fact
7025 ELSE
7026 sumrneg = sumrneg - dble( tmp ) * fact
7027 END IF
7028 IF( dimag( tmp ).GE.zero ) THEN
7029 sumipos = sumipos + dimag( tmp ) * fact
7030 ELSE
7031 sumineg = sumineg - dimag( tmp ) * fact
7032 END IF
7033*
7034 y = ( beta * y ) + ( alpha * x )
7035*
7036 errbnd = addbnd * max( max( sumrpos, sumrneg ),
7037 $ max( sumipos, sumineg ) )
7038*
7039 RETURN
7040*
7041* End of PZERRAXPBY
7042*
7043 END
7044 SUBROUTINE pzipset( TOGGLE, N, A, IA, JA, DESCA )
7045*
7046* -- PBLAS test routine (version 2.0) --
7047* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7048* and University of California, Berkeley.
7049* April 1, 1998
7050*
7051* .. Scalar Arguments ..
7052 CHARACTER*1 TOGGLE
7053 INTEGER IA, JA, N
7054* ..
7055* .. Array Arguments ..
7056 INTEGER DESCA( * )
7057 COMPLEX*16 A( * )
7058* ..
7059*
7060* Purpose
7061* =======
7062*
7063* PZIPSET sets the imaginary part of the diagonal entries of an n by n
7064* matrix sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). This is used to
7065* test the PBLAS routines for complex Hermitian matrices, which are
7066* either not supposed to access or use the imaginary parts of the dia-
7067* gonals, or supposed to set them to zero. The value used to set the
7068* imaginary part of the diagonals depends on the value of TOGGLE.
7069*
7070* Notes
7071* =====
7072*
7073* A description vector is associated with each 2D block-cyclicly dis-
7074* tributed matrix. This vector stores the information required to
7075* establish the mapping between a matrix entry and its corresponding
7076* process and memory location.
7077*
7078* In the following comments, the character _ should be read as
7079* "of the distributed matrix". Let A be a generic term for any 2D
7080* block cyclicly distributed matrix. Its description vector is DESCA:
7081*
7082* NOTATION STORED IN EXPLANATION
7083* ---------------- --------------- ------------------------------------
7084* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7085* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7086* the NPROW x NPCOL BLACS process grid
7087* A is distributed over. The context
7088* itself is global, but the handle
7089* (the integer value) may vary.
7090* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7091* ted matrix A, M_A >= 0.
7092* N_A (global) DESCA( N_ ) The number of columns in the distri-
7093* buted matrix A, N_A >= 0.
7094* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7095* block of the matrix A, IMB_A > 0.
7096* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7097* left block of the matrix A,
7098* INB_A > 0.
7099* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7100* bute the last M_A-IMB_A rows of A,
7101* MB_A > 0.
7102* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7103* bute the last N_A-INB_A columns of
7104* A, NB_A > 0.
7105* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7106* row of the matrix A is distributed,
7107* NPROW > RSRC_A >= 0.
7108* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7109* first column of A is distributed.
7110* NPCOL > CSRC_A >= 0.
7111* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7112* array storing the local blocks of
7113* the distributed matrix A,
7114* IF( Lc( 1, N_A ) > 0 )
7115* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7116* ELSE
7117* LLD_A >= 1.
7118*
7119* Let K be the number of rows of a matrix A starting at the global in-
7120* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7121* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7122* receive if these K rows were distributed over NPROW processes. If K
7123* is the number of columns of a matrix A starting at the global index
7124* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7125* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7126* these K columns were distributed over NPCOL processes.
7127*
7128* The values of Lr() and Lc() may be determined via a call to the func-
7129* tion PB_NUMROC:
7130* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7131* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7132*
7133* Arguments
7134* =========
7135*
7136* TOGGLE (global input) CHARACTER*1
7137* On entry, TOGGLE specifies the set-value to be used as fol-
7138* lows:
7139* If TOGGLE = 'Z' or 'z', the imaginary part of the diago-
7140* nals are set to zero,
7141* If TOGGLE = 'B' or 'b', the imaginary part of the diago-
7142* nals are set to a large value.
7143*
7144* N (global input) INTEGER
7145* On entry, N specifies the order of sub( A ). N must be at
7146* least zero.
7147*
7148* A (local input/local output) pointer to COMPLEX*16
7149* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7150* at least Lc( 1, JA+N-1 ). Before entry, this array contains
7151* the local entries of the matrix A. On exit, the diagonals of
7152* sub( A ) have been updated as specified by TOGGLE.
7153*
7154* IA (global input) INTEGER
7155* On entry, IA specifies A's global row index, which points to
7156* the beginning of the submatrix sub( A ).
7157*
7158* JA (global input) INTEGER
7159* On entry, JA specifies A's global column index, which points
7160* to the beginning of the submatrix sub( A ).
7161*
7162* DESCA (global and local input) INTEGER array
7163* On entry, DESCA is an integer array of dimension DLEN_. This
7164* is the array descriptor for the matrix A.
7165*
7166* -- Written on April 1, 1998 by
7167* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7168*
7169* =====================================================================
7170*
7171* .. Parameters ..
7172 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7173 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7174 $ rsrc_
7175 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
7176 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
7177 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
7178 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
7179 DOUBLE PRECISION ZERO
7180 PARAMETER ( ZERO = 0.0d+0 )
7181* ..
7182* .. Local Scalars ..
7183 LOGICAL COLREP, GODOWN, GOLEFT, ROWREP
7184 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
7185 $ imb1, imbloc, inb1, inbloc, ioffa, ioffd, iupp,
7186 $ jja, joffa, joffd, lcmt, lcmt00, lda, ldap1,
7187 $ lmbloc, lnbloc, low, mb, mblkd, mblks, mbloc,
7188 $ mrcol, mrrow, mycol, myrow, nb, nblkd, nblks,
7189 $ nbloc, np, npcol, nprow, nq, pmb, qnb, upp
7190 DOUBLE PRECISION ALPHA, ATMP
7191* ..
7192* .. Local Arrays ..
7193 INTEGER DESCA2( DLEN_ )
7194* ..
7195* .. External Subroutines ..
7196 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
7197 $ pb_desctrans
7198* ..
7199* .. External Functions ..
7200 LOGICAL LSAME
7201 DOUBLE PRECISION PDLAMCH
7202 EXTERNAL lsame, pdlamch
7203* ..
7204* .. Intrinsic Functions ..
7205 INTRINSIC dble, dcmplx, max, min
7206* ..
7207* .. Executable Statements ..
7208*
7209* Convert descriptor
7210*
7211 CALL pb_desctrans( desca, desca2 )
7212*
7213* Get grid parameters
7214*
7215 ictxt = desca2( ctxt_ )
7216 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
7217*
7218 IF( n.LE.0 )
7219 $ RETURN
7220*
7221 IF( lsame( toggle, 'Z' ) ) THEN
7222 alpha = zero
7223 ELSE IF( lsame( toggle, 'B' ) ) THEN
7224 alpha = pdlamch( ictxt, 'Epsilon' )
7225 alpha = alpha / pdlamch( ictxt, 'Safe minimum' )
7226 END IF
7227*
7228 CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
7229 $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
7230 $ iacol, mrrow, mrcol )
7231*
7232 IF( np.LE.0 .OR. nq.LE.0 )
7233 $ RETURN
7234*
7235* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
7236* ILOW, LOW, IUPP, and UPP.
7237*
7238 mb = desca2( mb_ )
7239 nb = desca2( nb_ )
7240 CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
7241 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
7242 $ lnbloc, ilow, low, iupp, upp )
7243*
7244 ioffa = iia - 1
7245 joffa = jja - 1
7246 rowrep = ( desca2( rsrc_ ).EQ.-1 )
7247 colrep = ( desca2( csrc_ ).EQ.-1 )
7248 lda = desca2( lld_ )
7249 ldap1 = lda + 1
7250*
7251 IF( rowrep ) THEN
7252 pmb = mb
7253 ELSE
7254 pmb = nprow * mb
7255 END IF
7256 IF( colrep ) THEN
7257 qnb = nb
7258 ELSE
7259 qnb = npcol * nb
7260 END IF
7261*
7262* Handle the first block of rows or columns separately, and update
7263* LCMT00, MBLKS and NBLKS.
7264*
7265 godown = ( lcmt00.GT.iupp )
7266 goleft = ( lcmt00.LT.ilow )
7267*
7268 IF( .NOT.godown .AND. .NOT.goleft ) THEN
7269*
7270* LCMT00 >= ILOW && LCMT00 <= IUPP
7271*
7272 IF( lcmt00.GE.0 ) THEN
7273 ijoffa = ioffa + lcmt00 + ( joffa - 1 ) * lda
7274 DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
7275 atmp = dble( a( ijoffa + i*ldap1 ) )
7276 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7277 10 CONTINUE
7278 ELSE
7279 ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
7280 DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
7281 atmp = dble( a( ijoffa + i*ldap1 ) )
7282 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7283 20 CONTINUE
7284 END IF
7285 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
7286 godown = .NOT.goleft
7287*
7288 END IF
7289*
7290 IF( godown ) THEN
7291*
7292 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7293 mblks = mblks - 1
7294 ioffa = ioffa + imbloc
7295*
7296 30 CONTINUE
7297 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7298 lcmt00 = lcmt00 - pmb
7299 mblks = mblks - 1
7300 ioffa = ioffa + mb
7301 GO TO 30
7302 END IF
7303*
7304 IF( mblks.LE.0 )
7305 $ RETURN
7306*
7307 lcmt = lcmt00
7308 mblkd = mblks
7309 ioffd = ioffa
7310*
7311 mbloc = mb
7312 40 CONTINUE
7313 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
7314 IF( mblkd.EQ.1 )
7315 $ mbloc = lmbloc
7316 IF( lcmt.GE.0 ) THEN
7317 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
7318 DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
7319 atmp = dble( a( ijoffa + i*ldap1 ) )
7320 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7321 50 CONTINUE
7322 ELSE
7323 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
7324 DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
7325 atmp = dble( a( ijoffa + i*ldap1 ) )
7326 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7327 60 CONTINUE
7328 END IF
7329 lcmt00 = lcmt
7330 lcmt = lcmt - pmb
7331 mblks = mblkd
7332 mblkd = mblkd - 1
7333 ioffa = ioffd
7334 ioffd = ioffd + mbloc
7335 GO TO 40
7336 END IF
7337*
7338 lcmt00 = lcmt00 + low - ilow + qnb
7339 nblks = nblks - 1
7340 joffa = joffa + inbloc
7341*
7342 ELSE IF( goleft ) THEN
7343*
7344 lcmt00 = lcmt00 + low - ilow + qnb
7345 nblks = nblks - 1
7346 joffa = joffa + inbloc
7347*
7348 70 CONTINUE
7349 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
7350 lcmt00 = lcmt00 + qnb
7351 nblks = nblks - 1
7352 joffa = joffa + nb
7353 GO TO 70
7354 END IF
7355*
7356 IF( nblks.LE.0 )
7357 $ RETURN
7358*
7359 lcmt = lcmt00
7360 nblkd = nblks
7361 joffd = joffa
7362*
7363 nbloc = nb
7364 80 CONTINUE
7365 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
7366 IF( nblkd.EQ.1 )
7367 $ nbloc = lnbloc
7368 IF( lcmt.GE.0 ) THEN
7369 ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
7370 DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
7371 atmp = dble( a( ijoffa + i*ldap1 ) )
7372 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7373 90 CONTINUE
7374 ELSE
7375 ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
7376 DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
7377 atmp = dble( a( ijoffa + i*ldap1 ) )
7378 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7379 100 CONTINUE
7380 END IF
7381 lcmt00 = lcmt
7382 lcmt = lcmt + qnb
7383 nblks = nblkd
7384 nblkd = nblkd - 1
7385 joffa = joffd
7386 joffd = joffd + nbloc
7387 GO TO 80
7388 END IF
7389*
7390 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7391 mblks = mblks - 1
7392 ioffa = ioffa + imbloc
7393*
7394 END IF
7395*
7396 nbloc = nb
7397 110 CONTINUE
7398 IF( nblks.GT.0 ) THEN
7399 IF( nblks.EQ.1 )
7400 $ nbloc = lnbloc
7401 120 CONTINUE
7402 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7403 lcmt00 = lcmt00 - pmb
7404 mblks = mblks - 1
7405 ioffa = ioffa + mb
7406 GO TO 120
7407 END IF
7408*
7409 IF( mblks.LE.0 )
7410 $ RETURN
7411*
7412 lcmt = lcmt00
7413 mblkd = mblks
7414 ioffd = ioffa
7415*
7416 mbloc = mb
7417 130 CONTINUE
7418 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
7419 IF( mblkd.EQ.1 )
7420 $ mbloc = lmbloc
7421 IF( lcmt.GE.0 ) THEN
7422 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
7423 DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
7424 atmp = dble( a( ijoffa + i*ldap1 ) )
7425 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7426 140 CONTINUE
7427 ELSE
7428 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
7429 DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
7430 atmp = dble( a( ijoffa + i*ldap1 ) )
7431 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7432 150 CONTINUE
7433 END IF
7434 lcmt00 = lcmt
7435 lcmt = lcmt - pmb
7436 mblks = mblkd
7437 mblkd = mblkd - 1
7438 ioffa = ioffd
7439 ioffd = ioffd + mbloc
7440 GO TO 130
7441 END IF
7442*
7443 lcmt00 = lcmt00 + qnb
7444 nblks = nblks - 1
7445 joffa = joffa + nbloc
7446 GO TO 110
7447*
7448 END IF
7449*
7450 RETURN
7451*
7452* End of PZIPSET
7453*
7454 END
7455 DOUBLE PRECISION FUNCTION pdlamch( ICTXT, CMACH )
7456*
7457* -- PBLAS test routine (version 2.0) --
7458* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7459* and University of California, Berkeley.
7460* April 1, 1998
7461*
7462* .. Scalar Arguments ..
7463 CHARACTER*1 cmach
7464 INTEGER ictxt
7465* ..
7466*
7467* Purpose
7468* =======
7469*
7470*
7471* .. Local Scalars ..
7472 CHARACTER*1 top
7473 INTEGER idumm
7474 DOUBLE PRECISION temp
7475* ..
7476* .. External Subroutines ..
7477 EXTERNAL dgamn2d, dgamx2d, pb_topget
7478* ..
7479* .. External Functions ..
7480 LOGICAL lsame
7481 DOUBLE PRECISION dlamch
7482 EXTERNAL dlamch, lsame
7483* ..
7484* .. Executable Statements ..
7485*
7486 temp = dlamch( cmach )
7487*
7488 IF( lsame( cmach, 'E' ).OR.lsame( cmach, 'S' ).OR.
7489 $ lsame( cmach, 'M' ).OR.lsame( cmach, 'U' ) ) THEN
7490 CALL pb_topget( ictxt, 'Combine', 'All', top )
7491 idumm = 0
7492 CALL dgamx2d( ictxt, 'All', top, 1, 1, temp, 1, idumm,
7493 $ idumm, -1, -1, idumm )
7494 ELSE IF( lsame( cmach, 'L' ).OR.lsame( cmach, 'O' ) ) THEN
7495 CALL pb_topget( ictxt, 'Combine', 'All', top )
7496 idumm = 0
7497 CALL dgamn2d( ictxt, 'All', top, 1, 1, temp, 1, idumm,
7498 $ idumm, -1, -1, idumm )
7499 END IF
7500*
7501 pdlamch = temp
7502*
7503 RETURN
7504*
7505* End of PDLAMCH
7506*
7507 END
7508 SUBROUTINE pzlaset( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
7509*
7510* -- PBLAS test routine (version 2.0) --
7511* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7512* and University of California, Berkeley.
7513* April 1, 1998
7514*
7515* .. Scalar Arguments ..
7516 CHARACTER*1 UPLO
7517 INTEGER IA, JA, M, N
7518 COMPLEX*16 ALPHA, BETA
7519* ..
7520* .. Array Arguments ..
7521 INTEGER DESCA( * )
7522 COMPLEX*16 A( * )
7523* ..
7524*
7525* Purpose
7526* =======
7527*
7528* PZLASET initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
7529* ted by sub( A ) to beta on the diagonal and alpha on the offdiago-
7530* nals.
7531*
7532* Notes
7533* =====
7534*
7535* A description vector is associated with each 2D block-cyclicly dis-
7536* tributed matrix. This vector stores the information required to
7537* establish the mapping between a matrix entry and its corresponding
7538* process and memory location.
7539*
7540* In the following comments, the character _ should be read as
7541* "of the distributed matrix". Let A be a generic term for any 2D
7542* block cyclicly distributed matrix. Its description vector is DESCA:
7543*
7544* NOTATION STORED IN EXPLANATION
7545* ---------------- --------------- ------------------------------------
7546* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7547* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7548* the NPROW x NPCOL BLACS process grid
7549* A is distributed over. The context
7550* itself is global, but the handle
7551* (the integer value) may vary.
7552* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7553* ted matrix A, M_A >= 0.
7554* N_A (global) DESCA( N_ ) The number of columns in the distri-
7555* buted matrix A, N_A >= 0.
7556* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7557* block of the matrix A, IMB_A > 0.
7558* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7559* left block of the matrix A,
7560* INB_A > 0.
7561* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7562* bute the last M_A-IMB_A rows of A,
7563* MB_A > 0.
7564* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7565* bute the last N_A-INB_A columns of
7566* A, NB_A > 0.
7567* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7568* row of the matrix A is distributed,
7569* NPROW > RSRC_A >= 0.
7570* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7571* first column of A is distributed.
7572* NPCOL > CSRC_A >= 0.
7573* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7574* array storing the local blocks of
7575* the distributed matrix A,
7576* IF( Lc( 1, N_A ) > 0 )
7577* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7578* ELSE
7579* LLD_A >= 1.
7580*
7581* Let K be the number of rows of a matrix A starting at the global in-
7582* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7583* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7584* receive if these K rows were distributed over NPROW processes. If K
7585* is the number of columns of a matrix A starting at the global index
7586* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7587* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7588* these K columns were distributed over NPCOL processes.
7589*
7590* The values of Lr() and Lc() may be determined via a call to the func-
7591* tion PB_NUMROC:
7592* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7593* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7594*
7595* Arguments
7596* =========
7597*
7598* UPLO (global input) CHARACTER*1
7599* On entry, UPLO specifies the part of the submatrix sub( A )
7600* to be set:
7601* = 'L' or 'l': Lower triangular part is set; the strictly
7602* upper triangular part of sub( A ) is not changed;
7603* = 'U' or 'u': Upper triangular part is set; the strictly
7604* lower triangular part of sub( A ) is not changed;
7605* Otherwise: All of the matrix sub( A ) is set.
7606*
7607* M (global input) INTEGER
7608* On entry, M specifies the number of rows of the submatrix
7609* sub( A ). M must be at least zero.
7610*
7611* N (global input) INTEGER
7612* On entry, N specifies the number of columns of the submatrix
7613* sub( A ). N must be at least zero.
7614*
7615* ALPHA (global input) COMPLEX*16
7616* On entry, ALPHA specifies the scalar alpha, i.e., the cons-
7617* tant to which the offdiagonal elements are to be set.
7618*
7619* BETA (global input) COMPLEX*16
7620* On entry, BETA specifies the scalar beta, i.e., the constant
7621* to which the diagonal elements are to be set.
7622*
7623* A (local input/local output) COMPLEX*16 array
7624* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7625* at least Lc( 1, JA+N-1 ). Before entry, this array contains
7626* the local entries of the matrix A to be set. On exit, the
7627* leading m by n submatrix sub( A ) is set as follows:
7628*
7629* if UPLO = 'U', A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
7630* if UPLO = 'L', A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
7631* otherwise, A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M, 1<=j<=N,
7632* and IA+i.NE.JA+j,
7633* and, for all UPLO, A(IA+i-1,JA+i-1) = BETA, 1<=i<=min(M,N).
7634*
7635* IA (global input) INTEGER
7636* On entry, IA specifies A's global row index, which points to
7637* the beginning of the submatrix sub( A ).
7638*
7639* JA (global input) INTEGER
7640* On entry, JA specifies A's global column index, which points
7641* to the beginning of the submatrix sub( A ).
7642*
7643* DESCA (global and local input) INTEGER array
7644* On entry, DESCA is an integer array of dimension DLEN_. This
7645* is the array descriptor for the matrix A.
7646*
7647* -- Written on April 1, 1998 by
7648* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7649*
7650* =====================================================================
7651*
7652* .. Parameters ..
7653 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7654 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7655 $ rsrc_
7656 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
7657 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
7658 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
7659 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
7660* ..
7661* .. Local Scalars ..
7662 LOGICAL GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
7663 $ UPPER
7664 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
7665 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
7666 $ jjmax, joffa, joffd, lcmt, lcmt00, lda, lmbloc,
7667 $ lnbloc, low, m1, mb, mblkd, mblks, mbloc, mp,
7668 $ mrcol, mrrow, mycol, myrow, n1, nb, nblkd,
7669 $ nblks, nbloc, npcol, nprow, nq, pmb, qnb, tmp1,
7670 $ upp
7671* ..
7672* .. Local Arrays ..
7673 INTEGER DESCA2( DLEN_ )
7674* ..
7675* .. External Subroutines ..
7676 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
7677 $ pb_desctrans, pb_zlaset
7678* ..
7679* .. External Functions ..
7680 LOGICAL LSAME
7681 EXTERNAL LSAME
7682* ..
7683* .. Intrinsic Functions ..
7684 INTRINSIC min
7685* ..
7686* .. Executable Statements ..
7687*
7688 IF( m.EQ.0 .OR. n.EQ.0 )
7689 $ RETURN
7690*
7691* Convert descriptor
7692*
7693 CALL pb_desctrans( desca, desca2 )
7694*
7695* Get grid parameters
7696*
7697 ictxt = desca2( ctxt_ )
7698 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
7699*
7700 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
7701 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
7702 $ iacol, mrrow, mrcol )
7703*
7704 IF( mp.LE.0 .OR. nq.LE.0 )
7705 $ RETURN
7706*
7707 isrowrep = ( desca2( rsrc_ ).LT.0 )
7708 iscolrep = ( desca2( csrc_ ).LT.0 )
7709 lda = desca2( lld_ )
7710*
7711 upper = .NOT.( lsame( uplo, 'l' ) )
7712.NOT. LOWER = ( LSAME( UPLO, 'u' ) )
7713*
7714.AND..AND..EQ..OR. IF( ( ( LOWERUPPER )( ALPHABETA ) )
7715.AND. $ ( ISROWREP ISCOLREP ) ) THEN
7716.GT..AND..GT. IF( ( MP0 )( NQ0 ) )
7717 $ CALL PB_ZLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
7718 $ A( IIA + ( JJA - 1 ) * LDA ), LDA )
7719 RETURN
7720 END IF
7721*
7722* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
7723* ILOW, LOW, IUPP, and UPP.
7724*
7725 MB = DESCA2( MB_ )
7726 NB = DESCA2( NB_ )
7727 CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
7728 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
7729 $ LNBLOC, ILOW, LOW, IUPP, UPP )
7730*
7731 IOFFA = IIA - 1
7732 JOFFA = JJA - 1
7733 IIMAX = IOFFA + MP
7734 JJMAX = JOFFA + NQ
7735*
7736 IF( ISROWREP ) THEN
7737 PMB = MB
7738 ELSE
7739 PMB = NPROW * MB
7740 END IF
7741 IF( ISCOLREP ) THEN
7742 QNB = NB
7743 ELSE
7744 QNB = NPCOL * NB
7745 END IF
7746*
7747 M1 = MP
7748 N1 = NQ
7749*
7750* Handle the first block of rows or columns separately, and update
7751* LCMT00, MBLKS and NBLKS.
7752*
7753.GT. GODOWN = ( LCMT00IUPP )
7754.LT. GOLEFT = ( LCMT00ILOW )
7755*
7756.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
7757*
7758* LCMT00 >= ILOW && LCMT00 <= IUPP
7759*
7760.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
7761.NOT. GODOWN = GOLEFT
7762*
7763 CALL PB_ZLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
7764 $ A( IIA+JOFFA*LDA ), LDA )
7765 IF( GODOWN ) THEN
7766.AND..GT. IF( UPPER NQINBLOC )
7767 $ CALL PB_ZLASET( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
7768 $ ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
7769 IIA = IIA + IMBLOC
7770 M1 = M1 - IMBLOC
7771 ELSE
7772.AND..GT. IF( LOWER MPIMBLOC )
7773 $ CALL PB_ZLASET( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
7774 $ ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
7775 JJA = JJA + INBLOC
7776 N1 = N1 - INBLOC
7777 END IF
7778*
7779 END IF
7780*
7781 IF( GODOWN ) THEN
7782*
7783 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7784 MBLKS = MBLKS - 1
7785 IOFFA = IOFFA + IMBLOC
7786*
7787 10 CONTINUE
7788.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7789 LCMT00 = LCMT00 - PMB
7790 MBLKS = MBLKS - 1
7791 IOFFA = IOFFA + MB
7792 GO TO 10
7793 END IF
7794*
7795 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7796.AND..GT. IF( UPPER TMP10 ) THEN
7797 CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7798 $ A( IIA+JOFFA*LDA ), LDA )
7799 IIA = IIA + TMP1
7800 M1 = M1 - TMP1
7801 END IF
7802*
7803.LE. IF( MBLKS0 )
7804 $ RETURN
7805*
7806 LCMT = LCMT00
7807 MBLKD = MBLKS
7808 IOFFD = IOFFA
7809*
7810 MBLOC = MB
7811 20 CONTINUE
7812.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
7813.EQ. IF( MBLKD1 )
7814 $ MBLOC = LMBLOC
7815 CALL PB_ZLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
7816 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7817 LCMT00 = LCMT
7818 LCMT = LCMT - PMB
7819 MBLKS = MBLKD
7820 MBLKD = MBLKD - 1
7821 IOFFA = IOFFD
7822 IOFFD = IOFFD + MBLOC
7823 GO TO 20
7824 END IF
7825*
7826 TMP1 = M1 - IOFFD + IIA - 1
7827.AND..GT. IF( LOWER TMP10 )
7828 $ CALL PB_ZLASET( 'all', TMP1, INBLOC, 0, ALPHA, ALPHA,
7829 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7830*
7831 TMP1 = IOFFA - IIA + 1
7832 M1 = M1 - TMP1
7833 N1 = N1 - INBLOC
7834 LCMT00 = LCMT00 + LOW - ILOW + QNB
7835 NBLKS = NBLKS - 1
7836 JOFFA = JOFFA + INBLOC
7837*
7838.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7839 $ CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7840 $ A( IIA+JOFFA*LDA ), LDA )
7841*
7842 IIA = IOFFA + 1
7843 JJA = JOFFA + 1
7844*
7845 ELSE IF( GOLEFT ) THEN
7846*
7847 LCMT00 = LCMT00 + LOW - ILOW + QNB
7848 NBLKS = NBLKS - 1
7849 JOFFA = JOFFA + INBLOC
7850*
7851 30 CONTINUE
7852.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) THEN
7853 LCMT00 = LCMT00 + QNB
7854 NBLKS = NBLKS - 1
7855 JOFFA = JOFFA + NB
7856 GO TO 30
7857 END IF
7858*
7859 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
7860.AND..GT. IF( LOWER TMP10 ) THEN
7861 CALL PB_ZLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
7862 $ A( IIA+(JJA-1)*LDA ), LDA )
7863 JJA = JJA + TMP1
7864 N1 = N1 - TMP1
7865 END IF
7866*
7867.LE. IF( NBLKS0 )
7868 $ RETURN
7869*
7870 LCMT = LCMT00
7871 NBLKD = NBLKS
7872 JOFFD = JOFFA
7873*
7874 NBLOC = NB
7875 40 CONTINUE
7876.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
7877.EQ. IF( NBLKD1 )
7878 $ NBLOC = LNBLOC
7879 CALL PB_ZLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
7880 $ A( IIA+JOFFD*LDA ), LDA )
7881 LCMT00 = LCMT
7882 LCMT = LCMT + QNB
7883 NBLKS = NBLKD
7884 NBLKD = NBLKD - 1
7885 JOFFA = JOFFD
7886 JOFFD = JOFFD + NBLOC
7887 GO TO 40
7888 END IF
7889*
7890 TMP1 = N1 - JOFFD + JJA - 1
7891.AND..GT. IF( UPPER TMP10 )
7892 $ CALL PB_ZLASET( 'all', IMBLOC, TMP1, 0, ALPHA, ALPHA,
7893 $ A( IIA+JOFFD*LDA ), LDA )
7894*
7895 TMP1 = JOFFA - JJA + 1
7896 M1 = M1 - IMBLOC
7897 N1 = N1 - TMP1
7898 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7899 MBLKS = MBLKS - 1
7900 IOFFA = IOFFA + IMBLOC
7901*
7902.AND..GT..AND..GT. IF( LOWER M10 TMP10 )
7903 $ CALL PB_ZLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
7904 $ A( IOFFA+1+(JJA-1)*LDA ), LDA )
7905*
7906 IIA = IOFFA + 1
7907 JJA = JOFFA + 1
7908*
7909 END IF
7910*
7911 NBLOC = NB
7912 50 CONTINUE
7913.GT. IF( NBLKS0 ) THEN
7914.EQ. IF( NBLKS1 )
7915 $ NBLOC = LNBLOC
7916 60 CONTINUE
7917.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7918 LCMT00 = LCMT00 - PMB
7919 MBLKS = MBLKS - 1
7920 IOFFA = IOFFA + MB
7921 GO TO 60
7922 END IF
7923*
7924 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7925.AND..GT. IF( UPPER TMP10 ) THEN
7926 CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7927 $ A( IIA+JOFFA*LDA ), LDA )
7928 IIA = IIA + TMP1
7929 M1 = M1 - TMP1
7930 END IF
7931*
7932.LE. IF( MBLKS0 )
7933 $ RETURN
7934*
7935 LCMT = LCMT00
7936 MBLKD = MBLKS
7937 IOFFD = IOFFA
7938*
7939 MBLOC = MB
7940 70 CONTINUE
7941.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
7942.EQ. IF( MBLKD1 )
7943 $ MBLOC = LMBLOC
7944 CALL PB_ZLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
7945 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7946 LCMT00 = LCMT
7947 LCMT = LCMT - PMB
7948 MBLKS = MBLKD
7949 MBLKD = MBLKD - 1
7950 IOFFA = IOFFD
7951 IOFFD = IOFFD + MBLOC
7952 GO TO 70
7953 END IF
7954*
7955 TMP1 = M1 - IOFFD + IIA - 1
7956.AND..GT. IF( LOWER TMP10 )
7957 $ CALL PB_ZLASET( 'all', TMP1, NBLOC, 0, ALPHA, ALPHA,
7958 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7959*
7960 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7961 M1 = M1 - TMP1
7962 N1 = N1 - NBLOC
7963 LCMT00 = LCMT00 + QNB
7964 NBLKS = NBLKS - 1
7965 JOFFA = JOFFA + NBLOC
7966*
7967.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7968 $ CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7969 $ A( IIA+JOFFA*LDA ), LDA )
7970*
7971 IIA = IOFFA + 1
7972 JJA = JOFFA + 1
7973*
7974 GO TO 50
7975*
7976 END IF
7977*
7978 RETURN
7979*
7980* End of PZLASET
7981*
7982 END
7983 SUBROUTINE PZLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
7984*
7985* -- PBLAS test routine (version 2.0) --
7986* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7987* and University of California, Berkeley.
7988* April 1, 1998
7989*
7990* .. Scalar Arguments ..
7991 CHARACTER*1 TYPE
7992 INTEGER IA, JA, M, N
7993 COMPLEX*16 ALPHA
7994* ..
7995* .. Array Arguments ..
7996 INTEGER DESCA( * )
7997 COMPLEX*16 A( * )
7998* ..
7999*
8000* Purpose
8001* =======
8002*
8003* PZLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
8004* by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full,
8005* upper triangular, lower triangular or upper Hessenberg.
8006*
8007* Notes
8008* =====
8009*
8010* A description vector is associated with each 2D block-cyclicly dis-
8011* tributed matrix. This vector stores the information required to
8012* establish the mapping between a matrix entry and its corresponding
8013* process and memory location.
8014*
8015* In the following comments, the character _ should be read as
8016* "of the distributed matrix". Let A be a generic term for any 2D
8017* block cyclicly distributed matrix. Its description vector is DESCA:
8018*
8019* NOTATION STORED IN EXPLANATION
8020* ---------------- --------------- ------------------------------------
8021* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8022* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8023* the NPROW x NPCOL BLACS process grid
8024* A is distributed over. The context
8025* itself is global, but the handle
8026* (the integer value) may vary.
8027* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8028* ted matrix A, M_A >= 0.
8029* N_A (global) DESCA( N_ ) The number of columns in the distri-
8030* buted matrix A, N_A >= 0.
8031* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8032* block of the matrix A, IMB_A > 0.
8033* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8034* left block of the matrix A,
8035* INB_A > 0.
8036* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8037* bute the last M_A-IMB_A rows of A,
8038* MB_A > 0.
8039* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8040* bute the last N_A-INB_A columns of
8041* A, NB_A > 0.
8042* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8043* row of the matrix A is distributed,
8044* NPROW > RSRC_A >= 0.
8045* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8046* first column of A is distributed.
8047* NPCOL > CSRC_A >= 0.
8048* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8049* array storing the local blocks of
8050* the distributed matrix A,
8051* IF( Lc( 1, N_A ) > 0 )
8052* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8053* ELSE
8054* LLD_A >= 1.
8055*
8056* Let K be the number of rows of a matrix A starting at the global in-
8057* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8058* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8059* receive if these K rows were distributed over NPROW processes. If K
8060* is the number of columns of a matrix A starting at the global index
8061* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8062* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8063* these K columns were distributed over NPCOL processes.
8064*
8065* The values of Lr() and Lc() may be determined via a call to the func-
8066* tion PB_NUMROC:
8067* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8068* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8069*
8070* Arguments
8071* =========
8072*
8073* TYPE (global input) CHARACTER*1
8074* On entry, TYPE specifies the type of the input submatrix as
8075* follows:
8076* = 'L' or 'l': sub( A ) is a lower triangular matrix,
8077* = 'U' or 'u': sub( A ) is an upper triangular matrix,
8078* = 'H' or 'h': sub( A ) is an upper Hessenberg matrix,
8079* otherwise sub( A ) is a full matrix.
8080*
8081* M (global input) INTEGER
8082* On entry, M specifies the number of rows of the submatrix
8083* sub( A ). M must be at least zero.
8084*
8085* N (global input) INTEGER
8086* On entry, N specifies the number of columns of the submatrix
8087* sub( A ). N must be at least zero.
8088*
8089* ALPHA (global input) COMPLEX*16
8090* On entry, ALPHA specifies the scalar alpha.
8091*
8092* A (local input/local output) COMPLEX*16 array
8093* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8094* at least Lc( 1, JA+N-1 ). Before entry, this array contains
8095* the local entries of the matrix A.
8096* On exit, the local entries of this array corresponding to the
8097* to the entries of the submatrix sub( A ) are overwritten by
8098* the local entries of the m by n scaled submatrix.
8099*
8100* IA (global input) INTEGER
8101* On entry, IA specifies A's global row index, which points to
8102* the beginning of the submatrix sub( A ).
8103*
8104* JA (global input) INTEGER
8105* On entry, JA specifies A's global column index, which points
8106* to the beginning of the submatrix sub( A ).
8107*
8108* DESCA (global and local input) INTEGER array
8109* On entry, DESCA is an integer array of dimension DLEN_. This
8110* is the array descriptor for the matrix A.
8111*
8112* -- Written on April 1, 1998 by
8113* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8114*
8115* =====================================================================
8116*
8117* .. Parameters ..
8118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8120 $ RSRC_
8121 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
8122 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
8123 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
8124 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
8125* ..
8126* .. Local Scalars ..
8127 CHARACTER*1 UPLO
8128 LOGICAL GODOWN, GOLEFT, LOWER, UPPER
8129 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
8130 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
8131 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
8132 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
8133 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
8134 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
8135 $ QNB, TMP1, UPP
8136* ..
8137* .. Local Arrays ..
8138 INTEGER DESCA2( DLEN_ )
8139* ..
8140* .. External Subroutines ..
8141 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
8142 $ PB_DESCTRANS, PB_INFOG2L, PB_ZLASCAL
8143* ..
8144* .. External Functions ..
8145 LOGICAL LSAME
8146 INTEGER PB_NUMROC
8147 EXTERNAL LSAME, PB_NUMROC
8148* ..
8149* .. Intrinsic Functions ..
8150 INTRINSIC MIN
8151* ..
8152* .. Executable Statements ..
8153*
8154* Convert descriptor
8155*
8156 CALL PB_DESCTRANS( DESCA, DESCA2 )
8157*
8158* Get grid parameters
8159*
8160 ICTXT = DESCA2( CTXT_ )
8161 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
8162*
8163* Quick return if possible
8164*
8165.EQ..OR..EQ. IF( M0 N0 )
8166 $ RETURN
8167*
8168 IF( LSAME( TYPE, 'l' ) ) THEN
8169 ITYPE = 1
8170 UPLO = TYPE
8171 UPPER = .FALSE.
8172 LOWER = .TRUE.
8173 IOFFD = 0
8174 ELSE IF( LSAME( TYPE, 'u' ) ) THEN
8175 ITYPE = 2
8176 UPLO = TYPE
8177 UPPER = .TRUE.
8178 LOWER = .FALSE.
8179 IOFFD = 0
8180 ELSE IF( LSAME( TYPE, 'h' ) ) THEN
8181 ITYPE = 3
8182 UPLO = 'u'
8183 UPPER = .TRUE.
8184 LOWER = .FALSE.
8185 IOFFD = 1
8186 ELSE
8187 ITYPE = 0
8188 UPLO = 'a'
8189 UPPER = .TRUE.
8190 LOWER = .TRUE.
8191 IOFFD = 0
8192 END IF
8193*
8194* Compute local indexes
8195*
8196.EQ. IF( ITYPE0 ) THEN
8197*
8198* Full matrix
8199*
8200 CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
8201 $ IIA, JJA, IAROW, IACOL )
8202 MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
8203 $ DESCA2( RSRC_ ), NPROW )
8204 NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
8205 $ DESCA2( CSRC_ ), NPCOL )
8206*
8207.LE..OR..LE. IF( MP0 NQ0 )
8208 $ RETURN
8209*
8210 LDA = DESCA2( LLD_ )
8211 IOFFA = IIA + ( JJA - 1 ) * LDA
8212*
8213 CALL PB_ZLASCAL( 'all', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
8214*
8215 ELSE
8216*
8217* Trapezoidal matrix
8218*
8219 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
8220 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
8221 $ IACOL, MRROW, MRCOL )
8222*
8223.LE..OR..LE. IF( MP0 NQ0 )
8224 $ RETURN
8225*
8226* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
8227* LNBLOC, ILOW, LOW, IUPP, and UPP.
8228*
8229 MB = DESCA2( MB_ )
8230 NB = DESCA2( NB_ )
8231 LDA = DESCA2( LLD_ )
8232*
8233 CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
8234 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
8235 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
8236*
8237 M1 = MP
8238 N1 = NQ
8239 IOFFA = IIA - 1
8240 JOFFA = JJA - 1
8241 IIMAX = IOFFA + MP
8242 JJMAX = JOFFA + NQ
8243*
8244.LT. IF( DESCA2( RSRC_ )0 ) THEN
8245 PMB = MB
8246 ELSE
8247 PMB = NPROW * MB
8248 END IF
8249.LT. IF( DESCA2( CSRC_ )0 ) THEN
8250 QNB = NB
8251 ELSE
8252 QNB = NPCOL * NB
8253 END IF
8254*
8255* Handle the first block of rows or columns separately, and
8256* update LCMT00, MBLKS and NBLKS.
8257*
8258.GT. GODOWN = ( LCMT00IUPP )
8259.LT. GOLEFT = ( LCMT00ILOW )
8260*
8261.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
8262*
8263* LCMT00 >= ILOW && LCMT00 <= IUPP
8264*
8265.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
8266.NOT. GODOWN = GOLEFT
8267*
8268 CALL PB_ZLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
8269 $ A( IIA+JOFFA*LDA ), LDA )
8270 IF( GODOWN ) THEN
8271.AND..GT. IF( UPPER NQINBLOC )
8272 $ CALL PB_ZLASCAL( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
8273 $ A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
8274 IIA = IIA + IMBLOC
8275 M1 = M1 - IMBLOC
8276 ELSE
8277.AND..GT. IF( LOWER MPIMBLOC )
8278 $ CALL PB_ZLASCAL( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
8279 $ A( IIA+IMBLOC+JOFFA*LDA ), LDA )
8280 JJA = JJA + INBLOC
8281 N1 = N1 - INBLOC
8282 END IF
8283*
8284 END IF
8285*
8286 IF( GODOWN ) THEN
8287*
8288 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
8289 MBLKS = MBLKS - 1
8290 IOFFA = IOFFA + IMBLOC
8291*
8292 10 CONTINUE
8293.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
8294 LCMT00 = LCMT00 - PMB
8295 MBLKS = MBLKS - 1
8296 IOFFA = IOFFA + MB
8297 GO TO 10
8298 END IF
8299*
8300 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
8301.AND..GT. IF( UPPER TMP10 ) THEN
8302 CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
8303 $ A( IIA+JOFFA*LDA ), LDA )
8304 IIA = IIA + TMP1
8305 M1 = M1 - TMP1
8306 END IF
8307*
8308.LE. IF( MBLKS0 )
8309 $ RETURN
8310*
8311 LCMT = LCMT00
8312 MBLKD = MBLKS
8313 IOFFD = IOFFA
8314*
8315 MBLOC = MB
8316 20 CONTINUE
8317.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
8318.EQ. IF( MBLKD1 )
8319 $ MBLOC = LMBLOC
8320 CALL PB_ZLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
8321 $ A( IOFFD+1+JOFFA*LDA ), LDA )
8322 LCMT00 = LCMT
8323 LCMT = LCMT - PMB
8324 MBLKS = MBLKD
8325 MBLKD = MBLKD - 1
8326 IOFFA = IOFFD
8327 IOFFD = IOFFD + MBLOC
8328 GO TO 20
8329 END IF
8330*
8331 TMP1 = M1 - IOFFD + IIA - 1
8332.AND..GT. IF( LOWER TMP10 )
8333 $ CALL PB_ZLASCAL( 'all', TMP1, INBLOC, 0, ALPHA,
8334 $ A( IOFFD+1+JOFFA*LDA ), LDA )
8335*
8336 TMP1 = IOFFA - IIA + 1
8337 M1 = M1 - TMP1
8338 N1 = N1 - INBLOC
8339 LCMT00 = LCMT00 + LOW - ILOW + QNB
8340 NBLKS = NBLKS - 1
8341 JOFFA = JOFFA + INBLOC
8342*
8343.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
8344 $ CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
8345 $ A( IIA+JOFFA*LDA ), LDA )
8346*
8347 IIA = IOFFA + 1
8348 JJA = JOFFA + 1
8349*
8350 ELSE IF( GOLEFT ) THEN
8351*
8352 LCMT00 = LCMT00 + LOW - ILOW + QNB
8353 NBLKS = NBLKS - 1
8354 JOFFA = JOFFA + INBLOC
8355*
8356 30 CONTINUE
8357.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) THEN
8358 LCMT00 = LCMT00 + QNB
8359 NBLKS = NBLKS - 1
8360 JOFFA = JOFFA + NB
8361 GO TO 30
8362 END IF
8363*
8364 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
8365.AND..GT. IF( LOWER TMP10 ) THEN
8366 CALL PB_ZLASCAL( 'all', M1, TMP1, 0, ALPHA,
8367 $ A( IIA+(JJA-1)*LDA ), LDA )
8368 JJA = JJA + TMP1
8369 N1 = N1 - TMP1
8370 END IF
8371*
8372.LE. IF( NBLKS0 )
8373 $ RETURN
8374*
8375 LCMT = LCMT00
8376 NBLKD = NBLKS
8377 JOFFD = JOFFA
8378*
8379 NBLOC = NB
8380 40 CONTINUE
8381.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
8382.EQ. IF( NBLKD1 )
8383 $ NBLOC = LNBLOC
8384 CALL PB_ZLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
8385 $ A( IIA+JOFFD*LDA ), LDA )
8386 LCMT00 = LCMT
8387 LCMT = LCMT + QNB
8388 NBLKS = NBLKD
8389 NBLKD = NBLKD - 1
8390 JOFFA = JOFFD
8391 JOFFD = JOFFD + NBLOC
8392 GO TO 40
8393 END IF
8394*
8395 TMP1 = N1 - JOFFD + JJA - 1
8396.AND..GT. IF( UPPER TMP10 )
8397 $ CALL PB_ZLASCAL( 'all', IMBLOC, TMP1, 0, ALPHA,
8398 $ A( IIA+JOFFD*LDA ), LDA )
8399*
8400 TMP1 = JOFFA - JJA + 1
8401 M1 = M1 - IMBLOC
8402 N1 = N1 - TMP1
8403 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
8404 MBLKS = MBLKS - 1
8405 IOFFA = IOFFA + IMBLOC
8406*
8407.AND..GT..AND..GT. IF( LOWER M10 TMP10 )
8408 $ CALL PB_ZLASCAL( 'all', M1, TMP1, 0, ALPHA,
8409 $ A( IOFFA+1+(JJA-1)*LDA ), LDA )
8410*
8411 IIA = IOFFA + 1
8412 JJA = JOFFA + 1
8413*
8414 END IF
8415*
8416 NBLOC = NB
8417 50 CONTINUE
8418.GT. IF( NBLKS0 ) THEN
8419.EQ. IF( NBLKS1 )
8420 $ NBLOC = LNBLOC
8421 60 CONTINUE
8422.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
8423 LCMT00 = LCMT00 - PMB
8424 MBLKS = MBLKS - 1
8425 IOFFA = IOFFA + MB
8426 GO TO 60
8427 END IF
8428*
8429 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
8430.AND..GT. IF( UPPER TMP10 ) THEN
8431 CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
8432 $ A( IIA+JOFFA*LDA ), LDA )
8433 IIA = IIA + TMP1
8434 M1 = M1 - TMP1
8435 END IF
8436*
8437.LE. IF( MBLKS0 )
8438 $ RETURN
8439*
8440 LCMT = LCMT00
8441 MBLKD = MBLKS
8442 IOFFD = IOFFA
8443*
8444 MBLOC = MB
8445 70 CONTINUE
8446.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
8447.EQ. IF( MBLKD1 )
8448 $ MBLOC = LMBLOC
8449 CALL PB_ZLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
8450 $ A( IOFFD+1+JOFFA*LDA ), LDA )
8451 LCMT00 = LCMT
8452 LCMT = LCMT - PMB
8453 MBLKS = MBLKD
8454 MBLKD = MBLKD - 1
8455 IOFFA = IOFFD
8456 IOFFD = IOFFD + MBLOC
8457 GO TO 70
8458 END IF
8459*
8460 TMP1 = M1 - IOFFD + IIA - 1
8461.AND..GT. IF( LOWER TMP10 )
8462 $ CALL PB_ZLASCAL( 'all', TMP1, NBLOC, 0, ALPHA,
8463 $ A( IOFFD+1+JOFFA*LDA ), LDA )
8464*
8465 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
8466 M1 = M1 - TMP1
8467 N1 = N1 - NBLOC
8468 LCMT00 = LCMT00 + QNB
8469 NBLKS = NBLKS - 1
8470 JOFFA = JOFFA + NBLOC
8471*
8472.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
8473 $ CALL PB_ZLASCAL( 'all', tmp1, n1, 0, alpha,
8474 $ a( iia+joffa*lda ), lda )
8475*
8476 iia = ioffa + 1
8477 jja = joffa + 1
8478*
8479 GO TO 50
8480*
8481 END IF
8482*
8483 END IF
8484*
8485 RETURN
8486*
8487* End of PZLASCAL
8488*
8489 END
8490 SUBROUTINE pzlagen( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
8491 $ DESCA, IASEED, A, LDA )
8492*
8493* -- PBLAS test routine (version 2.0) --
8494* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8495* and University of California, Berkeley.
8496* April 1, 1998
8497*
8498* .. Scalar Arguments ..
8499 LOGICAL INPLACE
8500 CHARACTER*1 AFORM, DIAG
8501 INTEGER IA, IASEED, JA, LDA, M, N, OFFA
8502* ..
8503* .. Array Arguments ..
8504 INTEGER DESCA( * )
8505 COMPLEX*16 A( LDA, * )
8506* ..
8507*
8508* Purpose
8509* =======
8510*
8511* PZLAGEN generates (or regenerates) a submatrix sub( A ) denoting
8512* A(IA:IA+M-1,JA:JA+N-1).
8513*
8514* Notes
8515* =====
8516*
8517* A description vector is associated with each 2D block-cyclicly dis-
8518* tributed matrix. This vector stores the information required to
8519* establish the mapping between a matrix entry and its corresponding
8520* process and memory location.
8521*
8522* In the following comments, the character _ should be read as
8523* "of the distributed matrix". Let A be a generic term for any 2D
8524* block cyclicly distributed matrix. Its description vector is DESCA:
8525*
8526* NOTATION STORED IN EXPLANATION
8527* ---------------- --------------- ------------------------------------
8528* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8529* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8530* the NPROW x NPCOL BLACS process grid
8531* A is distributed over. The context
8532* itself is global, but the handle
8533* (the integer value) may vary.
8534* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8535* ted matrix A, M_A >= 0.
8536* N_A (global) DESCA( N_ ) The number of columns in the distri-
8537* buted matrix A, N_A >= 0.
8538* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8539* block of the matrix A, IMB_A > 0.
8540* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8541* left block of the matrix A,
8542* INB_A > 0.
8543* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8544* bute the last M_A-IMB_A rows of A,
8545* MB_A > 0.
8546* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8547* bute the last N_A-INB_A columns of
8548* A, NB_A > 0.
8549* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8550* row of the matrix A is distributed,
8551* NPROW > RSRC_A >= 0.
8552* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8553* first column of A is distributed.
8554* NPCOL > CSRC_A >= 0.
8555* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8556* array storing the local blocks of
8557* the distributed matrix A,
8558* IF( Lc( 1, N_A ) > 0 )
8559* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8560* ELSE
8561* LLD_A >= 1.
8562*
8563* Let K be the number of rows of a matrix A starting at the global in-
8564* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8565* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8566* receive if these K rows were distributed over NPROW processes. If K
8567* is the number of columns of a matrix A starting at the global index
8568* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8569* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8570* these K columns were distributed over NPCOL processes.
8571*
8572* The values of Lr() and Lc() may be determined via a call to the func-
8573* tion PB_NUMROC:
8574* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8575* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8576*
8577* Arguments
8578* =========
8579*
8580* INPLACE (global input) LOGICAL
8581* On entry, INPLACE specifies if the matrix should be generated
8582* in place or not. If INPLACE is .TRUE., the local random array
8583* to be generated will start in memory at the local memory lo-
8584* cation A( 1, 1 ), otherwise it will start at the local posi-
8585* tion induced by IA and JA.
8586*
8587* AFORM (global input) CHARACTER*1
8588* On entry, AFORM specifies the type of submatrix to be genera-
8589* ted as follows:
8590* AFORM = 'S', sub( A ) is a symmetric matrix,
8591* AFORM = 'H', sub( A ) is a Hermitian matrix,
8592* AFORM = 'T', sub( A ) is overrwritten with the transpose
8593* of what would normally be generated,
8594* AFORM = 'C', sub( A ) is overwritten with the conjugate
8595* transpose of what would normally be genera-
8596* ted.
8597* AFORM = 'N', a random submatrix is generated.
8598*
8599* DIAG (global input) CHARACTER*1
8600* On entry, DIAG specifies if the generated submatrix is diago-
8601* nally dominant or not as follows:
8602* DIAG = 'D' : sub( A ) is diagonally dominant,
8603* DIAG = 'N' : sub( A ) is not diagonally dominant.
8604*
8605* OFFA (global input) INTEGER
8606* On entry, OFFA specifies the offdiagonal of the underlying
8607* matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
8608* trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
8609* specifies the main diagonal, OFFA > 0 specifies a subdiago-
8610* nal, and OFFA < 0 specifies a superdiagonal (see further de-
8611* tails).
8612*
8613* M (global input) INTEGER
8614* On entry, M specifies the global number of matrix rows of the
8615* submatrix sub( A ) to be generated. M must be at least zero.
8616*
8617* N (global input) INTEGER
8618* On entry, N specifies the global number of matrix columns of
8619* the submatrix sub( A ) to be generated. N must be at least
8620* zero.
8621*
8622* IA (global input) INTEGER
8623* On entry, IA specifies A's global row index, which points to
8624* the beginning of the submatrix sub( A ).
8625*
8626* JA (global input) INTEGER
8627* On entry, JA specifies A's global column index, which points
8628* to the beginning of the submatrix sub( A ).
8629*
8630* DESCA (global and local input) INTEGER array
8631* On entry, DESCA is an integer array of dimension DLEN_. This
8632* is the array descriptor for the matrix A.
8633*
8634* IASEED (global input) INTEGER
8635* On entry, IASEED specifies the seed number to generate the
8636* matrix A. IASEED must be at least zero.
8637*
8638* A (local output) COMPLEX*16 array
8639* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8640* at least Lc( 1, JA+N-1 ). On exit, this array contains the
8641* local entries of the randomly generated submatrix sub( A ).
8642*
8643* LDA (local input) INTEGER
8644* On entry, LDA specifies the local leading dimension of the
8645* array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
8646* This restriction is however not enforced, and this subroutine
8647* requires only that LDA >= MAX( 1, Mp ) where
8648*
8649* Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
8650*
8651* PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW
8652* and NPCOL can be determined by calling the BLACS subroutine
8653* BLACS_GRIDINFO.
8654*
8655* Further Details
8656* ===============
8657*
8658* OFFD is tied to the matrix described by DESCA, as opposed to the
8659* piece that is currently (re)generated. This is a global information
8660* independent from the distribution parameters. Below are examples of
8661* the meaning of OFFD for a global 7 by 5 matrix:
8662*
8663* ---------------------------------------------------------------------
8664* OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4
8665* -------|-------------------------------------------------------------
8666* | | OFFD=-1 | OFFD=0 OFFD=2
8667* | V V
8668* 0 | . d . . . -> d . . . . . . . . .
8669* 1 | . . d . . . d . . . . . . . .
8670* 2 | . . . d . . . d . . -> d . . . .
8671* 3 | . . . . d . . . d . . d . . .
8672* 4 | . . . . . . . . . d . . d . .
8673* 5 | . . . . . . . . . . . . . d .
8674* 6 | . . . . . . . . . . . . . . d
8675* ---------------------------------------------------------------------
8676*
8677* -- Written on April 1, 1998 by
8678* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8679*
8680* =====================================================================
8681*
8682* .. Parameters ..
8683 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8684 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8685 $ RSRC_
8686 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
8687 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
8688 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
8689 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
8690 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
8691 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
8692 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
8693 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
8694 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
8695 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
8696 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
8697 $ jmp_len = 11 )
8698 DOUBLE PRECISION ZERO
8699 PARAMETER ( ZERO = 0.0d+0 )
8700* ..
8701* .. Local Scalars ..
8702 LOGICAL DIAGDO, SYMM, HERM, NOTRAN
8703 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
8704 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
8705 $ inb1, inbloc, inbvir, info, ioffda, itmp, iupp,
8706 $ ivir, jja, jlocblk, jlocoff, jvir, lcmt00,
8707 $ lmbloc, lnbloc, low, maxmn, mb, mblks, mp,
8708 $ mrcol, mrrow, mycdist, mycol, myrdist, myrow,
8709 $ nb, nblks, npcol, nprow, nq, nvir, rsrc, upp
8710 COMPLEX*16 ALPHA
8711* ..
8712* .. Local Arrays ..
8713 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
8714 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
8715* ..
8716* .. External Subroutines ..
8717 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
8718 $ pb_chkmat, pb_desctrans, pb_initjmp,
8719 $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
8720 $ pb_setlocran, pb_setran, pb_zlagen, pxerbla,
8721 $ pzladom
8722* ..
8723* .. External Functions ..
8724 LOGICAL LSAME
8725 EXTERNAL LSAME
8726* ..
8727* .. Intrinsic Functions ..
8728 INTRINSIC dble, dcmplx, max, min
8729* ..
8730* .. Data Statements ..
8731 DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
8732 $ 12345, 0 /
8733* ..
8734* .. Executable Statements ..
8735*
8736* Convert descriptor
8737*
8738 CALL pb_desctrans( desca, desca2 )
8739*
8740* Test the input arguments
8741*
8742 ictxt = desca2( ctxt_ )
8743 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
8744*
8745* Test the input parameters
8746*
8747 info = 0
8748 IF( nprow.EQ.-1 ) THEN
8749 info = -( 1000 + ctxt_ )
8750 ELSE
8751 symm = lsame( aform, 'S' )
8752 herm = lsame( aform, 'H' )
8753 notran = lsame( aform, 'N' )
8754 diagdo = lsame( diag, 'D' )
8755 IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
8756 $ .NOT.( lsame( aform, 'T' ) ) .AND.
8757 $ .NOT.( lsame( aform, 'C' ) ) ) THEN
8758 info = -2
8759 ELSE IF( ( .NOT.diagdo ) .AND.
8760 $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
8761 info = -3
8762 END IF
8763 CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
8764 END IF
8765*
8766 IF( info.NE.0 ) THEN
8767 CALL pxerbla( ictxt, 'PZLAGEN', -info )
8768 RETURN
8769 END IF
8770*
8771* Quick return if possible
8772*
8773 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
8774 $ RETURN
8775*
8776* Start the operations
8777*
8778 mb = desca2( mb_ )
8779 nb = desca2( nb_ )
8780 imb = desca2( imb_ )
8781 inb = desca2( inb_ )
8782 rsrc = desca2( rsrc_ )
8783 csrc = desca2( csrc_ )
8784*
8785* Figure out local information about the distributed matrix operand
8786*
8787 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
8788 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
8789 $ iacol, mrrow, mrcol )
8790*
8791* Decide where the entries shall be stored in memory
8792*
8793 IF( inplace ) THEN
8794 iia = 1
8795 jja = 1
8796 END IF
8797*
8798* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
8799* ILOW, LOW, IUPP, and UPP.
8800*
8801 ioffda = ja + offa - ia
8802 CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
8803 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
8804 $ lmbloc, lnbloc, ilow, low, iupp, upp )
8805*
8806* Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
8807* This values correspond to the square virtual underlying matrix
8808* of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
8809* to set up the random sequence. For practical purposes, the size
8810* of this virtual matrix is upper bounded by M_ + N_ - 1.
8811*
8812 itmp = max( 0, -offa )
8813 ivir = ia + itmp
8814 imbvir = imb + itmp
8815 nvir = desca2( m_ ) + itmp
8816*
8817 CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
8818 $ ilocoff, myrdist )
8819*
8820 itmp = max( 0, offa )
8821 jvir = ja + itmp
8822 inbvir = inb + itmp
8823 nvir = max( max( nvir, desca2( n_ ) + itmp ),
8824 $ desca2( m_ ) + desca2( n_ ) - 1 )
8825*
8826 CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
8827 $ jlocoff, mycdist )
8828*
8829 IF( symm .OR. herm .OR. notran ) THEN
8830*
8831 CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
8832 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
8833*
8834* Compute constants to jump JMP( * ) numbers in the sequence
8835*
8836 CALL pb_initmuladd( muladd0, jmp, imuladd )
8837*
8838* Compute and set the random value corresponding to A( IA, JA )
8839*
8840 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
8841 $ myrdist, mycdist, nprow, npcol, jmp,
8842 $ imuladd, iran )
8843*
8844 CALL pb_zlagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
8845 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
8846 $ nb, lnbloc, jmp, imuladd )
8847*
8848 END IF
8849*
8850 IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
8851*
8852 CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
8853 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
8854*
8855* Compute constants to jump JMP( * ) numbers in the sequence
8856*
8857 CALL pb_initmuladd( muladd0, jmp, imuladd )
8858*
8859* Compute and set the random value corresponding to A( IA, JA )
8860*
8861 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
8862 $ myrdist, mycdist, nprow, npcol, jmp,
8863 $ imuladd, iran )
8864*
8865 CALL pb_zlagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
8866 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
8867 $ nb, lnbloc, jmp, imuladd )
8868*
8869 END IF
8870*
8871 IF( diagdo ) THEN
8872*
8873 maxmn = max( desca2( m_ ), desca2( n_ ) )
8874 IF( herm ) THEN
8875 alpha = dcmplx( dble( 2 * maxmn ), zero )
8876 ELSE
8877 alpha = dcmplx( dble( nvir ), dble( maxmn ) )
8878 END IF
8879*
8880 IF( ioffda.GE.0 ) THEN
8881 CALL pzladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
8882 $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
8883 ELSE
8884 CALL pzladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
8885 $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
8886 END IF
8887*
8888 END IF
8889*
8890 RETURN
8891*
8892* End of PZLAGEN
8893*
8894 END
8895 SUBROUTINE pzladom( INPLACE, N, ALPHA, A, IA, JA, DESCA )
8896*
8897* -- PBLAS test routine (version 2.0) --
8898* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8899* and University of California, Berkeley.
8900* April 1, 1998
8901*
8902* .. Scalar Arguments ..
8903 LOGICAL INPLACE
8904 INTEGER IA, JA, N
8905 COMPLEX*16 ALPHA
8906* ..
8907* .. Array Arguments ..
8908 INTEGER DESCA( * )
8909 COMPLEX*16 A( * )
8910* ..
8911*
8912* Purpose
8913* =======
8914*
8915* PZLADOM adds alpha to the diagonal entries of an n by n submatrix
8916* sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
8917*
8918* Notes
8919* =====
8920*
8921* A description vector is associated with each 2D block-cyclicly dis-
8922* tributed matrix. This vector stores the information required to
8923* establish the mapping between a matrix entry and its corresponding
8924* process and memory location.
8925*
8926* In the following comments, the character _ should be read as
8927* "of the distributed matrix". Let A be a generic term for any 2D
8928* block cyclicly distributed matrix. Its description vector is DESCA:
8929*
8930* NOTATION STORED IN EXPLANATION
8931* ---------------- --------------- ------------------------------------
8932* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8933* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8934* the NPROW x NPCOL BLACS process grid
8935* A is distributed over. The context
8936* itself is global, but the handle
8937* (the integer value) may vary.
8938* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8939* ted matrix A, M_A >= 0.
8940* N_A (global) DESCA( N_ ) The number of columns in the distri-
8941* buted matrix A, N_A >= 0.
8942* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8943* block of the matrix A, IMB_A > 0.
8944* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8945* left block of the matrix A,
8946* INB_A > 0.
8947* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8948* bute the last M_A-IMB_A rows of A,
8949* MB_A > 0.
8950* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8951* bute the last N_A-INB_A columns of
8952* A, NB_A > 0.
8953* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8954* row of the matrix A is distributed,
8955* NPROW > RSRC_A >= 0.
8956* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8957* first column of A is distributed.
8958* NPCOL > CSRC_A >= 0.
8959* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8960* array storing the local blocks of
8961* the distributed matrix A,
8962* IF( Lc( 1, N_A ) > 0 )
8963* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8964* ELSE
8965* LLD_A >= 1.
8966*
8967* Let K be the number of rows of a matrix A starting at the global in-
8968* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8969* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8970* receive if these K rows were distributed over NPROW processes. If K
8971* is the number of columns of a matrix A starting at the global index
8972* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8973* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8974* these K columns were distributed over NPCOL processes.
8975*
8976* The values of Lr() and Lc() may be determined via a call to the func-
8977* tion PB_NUMROC:
8978* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8979* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8980*
8981* Arguments
8982* =========
8983*
8984* INPLACE (global input) LOGICAL
8985* On entry, INPLACE specifies if the matrix should be generated
8986* in place or not. If INPLACE is .TRUE., the local random array
8987* to be generated will start in memory at the local memory lo-
8988* cation A( 1, 1 ), otherwise it will start at the local posi-
8989* tion induced by IA and JA.
8990*
8991* N (global input) INTEGER
8992* On entry, N specifies the global order of the submatrix
8993* sub( A ) to be modified. N must be at least zero.
8994*
8995* ALPHA (global input) COMPLEX*16
8996* On entry, ALPHA specifies the scalar alpha.
8997*
8998* A (local input/local output) COMPLEX*16 array
8999* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
9000* at least Lc( 1, JA+N-1 ). Before entry, this array contains
9001* the local entries of the matrix A. On exit, the local entries
9002* of this array corresponding to the main diagonal of sub( A )
9003* have been updated.
9004*
9005* IA (global input) INTEGER
9006* On entry, IA specifies A's global row index, which points to
9007* the beginning of the submatrix sub( A ).
9008*
9009* JA (global input) INTEGER
9010* On entry, JA specifies A's global column index, which points
9011* to the beginning of the submatrix sub( A ).
9012*
9013* DESCA (global and local input) INTEGER array
9014* On entry, DESCA is an integer array of dimension DLEN_. This
9015* is the array descriptor for the matrix A.
9016*
9017* -- Written on April 1, 1998 by
9018* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9019*
9020* =====================================================================
9021*
9022* .. Parameters ..
9023 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9024 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
9025 $ RSRC_
9026 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
9027 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9028 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9029 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9030* ..
9031* .. Local Scalars ..
9032 LOGICAL GODOWN, GOLEFT
9033 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
9034 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
9035 $ jja, joffa, joffd, lcmt, lcmt00, lda, ldap1,
9036 $ lmbloc, lnbloc, low, mb, mblkd, mblks, mbloc,
9037 $ mrcol, mrrow, mycol, myrow, nb, nblkd, nblks,
9038 $ nbloc, np, npcol, nprow, nq, pmb, qnb, upp
9039 COMPLEX*16 ATMP
9040* ..
9041* .. Local Scalars ..
9042 INTEGER DESCA2( DLEN_ )
9043* ..
9044* .. External Subroutines ..
9045 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
9046 $ pb_desctrans
9047* ..
9048* .. Intrinsic Functions ..
9049 INTRINSIC abs, dble, dcmplx, dimag, max, min
9050* ..
9051* .. Executable Statements ..
9052*
9053* Convert descriptor
9054*
9055 CALL pb_desctrans( desca, desca2 )
9056*
9057* Get grid parameters
9058*
9059 ictxt = desca2( ctxt_ )
9060 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9061*
9062 IF( n.EQ.0 )
9063 $ RETURN
9064*
9065 CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
9066 $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
9067 $ iacol, mrrow, mrcol )
9068*
9069* Decide where the entries shall be stored in memory
9070*
9071 IF( inplace ) THEN
9072 iia = 1
9073 jja = 1
9074 END IF
9075*
9076* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
9077* ILOW, LOW, IUPP, and UPP.
9078*
9079 mb = desca2( mb_ )
9080 nb = desca2( nb_ )
9081*
9082 CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
9083 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
9084 $ lnbloc, ilow, low, iupp, upp )
9085*
9086 ioffa = iia - 1
9087 joffa = jja - 1
9088 lda = desca2( lld_ )
9089 ldap1 = lda + 1
9090*
9091 IF( desca2( rsrc_ ).LT.0 ) THEN
9092 pmb = mb
9093 ELSE
9094 pmb = nprow * mb
9095 END IF
9096 IF( desca2( csrc_ ).LT.0 ) THEN
9097 qnb = nb
9098 ELSE
9099 qnb = npcol * nb
9100 END IF
9101*
9102* Handle the first block of rows or columns separately, and update
9103* LCMT00, MBLKS and NBLKS.
9104*
9105 godown = ( lcmt00.GT.iupp )
9106 goleft = ( lcmt00.LT.ilow )
9107*
9108 IF( .NOT.godown .AND. .NOT.goleft ) THEN
9109*
9110* LCMT00 >= ILOW && LCMT00 <= IUPP
9111*
9112 IF( lcmt00.GE.0 ) THEN
9113 ijoffa = ioffa+lcmt00 + ( joffa - 1 ) * lda
9114 DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
9115 atmp = a( ijoffa + i*ldap1 )
9116 a( ijoffa + i*ldap1 ) = alpha +
9117 $ dcmplx( abs( dble( atmp ) ),
9118 $ abs( dimag( atmp ) ) )
9119 10 CONTINUE
9120 ELSE
9121 ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
9122 DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
9123 atmp = a( ijoffa + i*ldap1 )
9124 a( ijoffa + i*ldap1 ) = alpha +
9125 $ dcmplx( abs( dble( atmp ) ),
9126 $ abs( dimag( atmp ) ) )
9127 20 CONTINUE
9128 END IF
9129 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
9130 godown = .NOT.goleft
9131*
9132 END IF
9133*
9134 IF( godown ) THEN
9135*
9136 lcmt00 = lcmt00 - ( iupp - upp + pmb )
9137 mblks = mblks - 1
9138 ioffa = ioffa + imbloc
9139*
9140 30 CONTINUE
9141 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
9142 lcmt00 = lcmt00 - pmb
9143 mblks = mblks - 1
9144 ioffa = ioffa + mb
9145 GO TO 30
9146 END IF
9147*
9148 lcmt = lcmt00
9149 mblkd = mblks
9150 ioffd = ioffa
9151*
9152 mbloc = mb
9153 40 CONTINUE
9154 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
9155 IF( mblkd.EQ.1 )
9156 $ mbloc = lmbloc
9157 IF( lcmt.GE.0 ) THEN
9158 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
9159 DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
9160 atmp = a( ijoffa + i*ldap1 )
9161 a( ijoffa + i*ldap1 ) = alpha +
9162 $ dcmplx( abs( dble( atmp ) ),
9163 $ abs( dimag( atmp ) ) )
9164 50 CONTINUE
9165 ELSE
9166 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
9167 DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
9168 atmp = a( ijoffa + i*ldap1 )
9169 a( ijoffa + i*ldap1 ) = alpha +
9170 $ dcmplx( abs( dble( atmp ) ),
9171 $ abs( dimag( atmp ) ) )
9172 60 CONTINUE
9173 END IF
9174 lcmt00 = lcmt
9175 lcmt = lcmt - pmb
9176 mblks = mblkd
9177 mblkd = mblkd - 1
9178 ioffa = ioffd
9179 ioffd = ioffd + mbloc
9180 GO TO 40
9181 END IF
9182*
9183 lcmt00 = lcmt00 + low - ilow + qnb
9184 nblks = nblks - 1
9185 joffa = joffa + inbloc
9186*
9187 ELSE IF( goleft ) THEN
9188*
9189 lcmt00 = lcmt00 + low - ilow + qnb
9190 nblks = nblks - 1
9191 joffa = joffa + inbloc
9192*
9193 70 CONTINUE
9194 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
9195 lcmt00 = lcmt00 + qnb
9196 nblks = nblks - 1
9197 joffa = joffa + nb
9198 GO TO 70
9199 END IF
9200*
9201 lcmt = lcmt00
9202 nblkd = nblks
9203 joffd = joffa
9204*
9205 nbloc = nb
9206 80 CONTINUE
9207 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
9208 IF( nblkd.EQ.1 )
9209 $ nbloc = lnbloc
9210 IF( lcmt.GE.0 ) THEN
9211 ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
9212 DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
9213 atmp = a( ijoffa + i*ldap1 )
9214 a( ijoffa + i*ldap1 ) = alpha +
9215 $ dcmplx( abs( dble( atmp ) ),
9216 $ abs( dimag( atmp ) ) )
9217 90 CONTINUE
9218 ELSE
9219 ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
9220 DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
9221 atmp = a( ijoffa + i*ldap1 )
9222 a( ijoffa + i*ldap1 ) = alpha +
9223 $ dcmplx( abs( dble( atmp ) ),
9224 $ abs( dimag( atmp ) ) )
9225 100 CONTINUE
9226 END IF
9227 lcmt00 = lcmt
9228 lcmt = lcmt + qnb
9229 nblks = nblkd
9230 nblkd = nblkd - 1
9231 joffa = joffd
9232 joffd = joffd + nbloc
9233 GO TO 80
9234 END IF
9235*
9236 lcmt00 = lcmt00 - ( iupp - upp + pmb )
9237 mblks = mblks - 1
9238 ioffa = ioffa + imbloc
9239*
9240 END IF
9241*
9242 nbloc = nb
9243 110 CONTINUE
9244 IF( nblks.GT.0 ) THEN
9245 IF( nblks.EQ.1 )
9246 $ nbloc = lnbloc
9247 120 CONTINUE
9248 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
9249 lcmt00 = lcmt00 - pmb
9250 mblks = mblks - 1
9251 ioffa = ioffa + mb
9252 GO TO 120
9253 END IF
9254*
9255 lcmt = lcmt00
9256 mblkd = mblks
9257 ioffd = ioffa
9258*
9259 mbloc = mb
9260 130 CONTINUE
9261 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
9262 IF( mblkd.EQ.1 )
9263 $ mbloc = lmbloc
9264 IF( lcmt.GE.0 ) THEN
9265 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
9266 DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
9267 atmp = a( ijoffa + i*ldap1 )
9268 a( ijoffa + i*ldap1 ) = alpha +
9269 $ dcmplx( abs( dble( atmp ) ),
9270 $ abs( dimag( atmp ) ) )
9271 140 CONTINUE
9272 ELSE
9273 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
9274 DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
9275 atmp = a( ijoffa + i*ldap1 )
9276 a( ijoffa + i*ldap1 ) = alpha +
9277 $ dcmplx( abs( dble( atmp ) ),
9278 $ abs( dimag( atmp ) ) )
9279 150 CONTINUE
9280 END IF
9281 lcmt00 = lcmt
9282 lcmt = lcmt - pmb
9283 mblks = mblkd
9284 mblkd = mblkd - 1
9285 ioffa = ioffd
9286 ioffd = ioffd + mbloc
9287 GO TO 130
9288 END IF
9289*
9290 lcmt00 = lcmt00 + qnb
9291 nblks = nblks - 1
9292 joffa = joffa + nbloc
9293 GO TO 110
9294*
9295 END IF
9296*
9297 RETURN
9298*
9299* End of PZLADOM
9300*
9301 END
9302 SUBROUTINE pb_pzlaprnt( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
9303 $ CMATNM, NOUT, WORK )
9304*
9305* -- PBLAS test routine (version 2.0) --
9306* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9307* and University of California, Berkeley.
9308* April 1, 1998
9309*
9310* .. Scalar Arguments ..
9311 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT
9312* ..
9313* .. Array Arguments ..
9314 CHARACTER*(*) CMATNM
9315 INTEGER DESCA( * )
9316 COMPLEX*16 A( * ), WORK( * )
9317* ..
9318*
9319* Purpose
9320* =======
9321*
9322* PB_PZLAPRNT prints to the standard output a submatrix sub( A ) deno-
9323* ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
9324* the process of coordinates (IRPRNT, ICPRNT).
9325*
9326* Notes
9327* =====
9328*
9329* A description vector is associated with each 2D block-cyclicly dis-
9330* tributed matrix. This vector stores the information required to
9331* establish the mapping between a matrix entry and its corresponding
9332* process and memory location.
9333*
9334* In the following comments, the character _ should be read as
9335* "of the distributed matrix". Let A be a generic term for any 2D
9336* block cyclicly distributed matrix. Its description vector is DESCA:
9337*
9338* NOTATION STORED IN EXPLANATION
9339* ---------------- --------------- ------------------------------------
9340* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
9341* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
9342* the NPROW x NPCOL BLACS process grid
9343* A is distributed over. The context
9344* itself is global, but the handle
9345* (the integer value) may vary.
9346* M_A (global) DESCA( M_ ) The number of rows in the distribu-
9347* ted matrix A, M_A >= 0.
9348* N_A (global) DESCA( N_ ) The number of columns in the distri-
9349* buted matrix A, N_A >= 0.
9350* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
9351* block of the matrix A, IMB_A > 0.
9352* INB_A (global) DESCA( INB_ ) The number of columns of the upper
9353* left block of the matrix A,
9354* INB_A > 0.
9355* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
9356* bute the last M_A-IMB_A rows of A,
9357* MB_A > 0.
9358* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
9359* bute the last N_A-INB_A columns of
9360* A, NB_A > 0.
9361* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
9362* row of the matrix A is distributed,
9363* NPROW > RSRC_A >= 0.
9364* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
9365* first column of A is distributed.
9366* NPCOL > CSRC_A >= 0.
9367* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
9368* array storing the local blocks of
9369* the distributed matrix A,
9370* IF( Lc( 1, N_A ) > 0 )
9371* LLD_A >= MAX( 1, Lr( 1, M_A ) )
9372* ELSE
9373* LLD_A >= 1.
9374*
9375* Let K be the number of rows of a matrix A starting at the global in-
9376* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
9377* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
9378* receive if these K rows were distributed over NPROW processes. If K
9379* is the number of columns of a matrix A starting at the global index
9380* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
9381* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
9382* these K columns were distributed over NPCOL processes.
9383*
9384* The values of Lr() and Lc() may be determined via a call to the func-
9385* tion PB_NUMROC:
9386* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
9387* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
9388*
9389* Arguments
9390* =========
9391*
9392* M (global input) INTEGER
9393* On entry, M specifies the number of rows of the submatrix
9394* sub( A ). M must be at least zero.
9395*
9396* N (global input) INTEGER
9397* On entry, N specifies the number of columns of the submatrix
9398* sub( A ). N must be at least zero.
9399*
9400* A (local input) COMPLEX*16 array
9401* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
9402* at least Lc( 1, JA+N-1 ). Before entry, this array contains
9403* the local entries of the matrix A.
9404*
9405* IA (global input) INTEGER
9406* On entry, IA specifies A's global row index, which points to
9407* the beginning of the submatrix sub( A ).
9408*
9409* JA (global input) INTEGER
9410* On entry, JA specifies A's global column index, which points
9411* to the beginning of the submatrix sub( A ).
9412*
9413* DESCA (global and local input) INTEGER array
9414* On entry, DESCA is an integer array of dimension DLEN_. This
9415* is the array descriptor for the matrix A.
9416*
9417* IRPRNT (global input) INTEGER
9418* On entry, IRPRNT specifies the row index of the printing pro-
9419* cess.
9420*
9421* ICPRNT (global input) INTEGER
9422* On entry, ICPRNT specifies the column index of the printing
9423* process.
9424*
9425* CMATNM (global input) CHARACTER*(*)
9426* On entry, CMATNM is the name of the matrix to be printed.
9427*
9428* NOUT (global input) INTEGER
9429* On entry, NOUT specifies the output unit number. When NOUT is
9430* equal to 6, the submatrix is printed on the screen.
9431*
9432* WORK (local workspace) COMPLEX*16 array
9433* On entry, WORK is a work array of dimension at least equal to
9434* MAX( IMB_A, MB_A ).
9435*
9436* -- Written on April 1, 1998 by
9437* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9438*
9439* =====================================================================
9440*
9441* .. Parameters ..
9442 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9443 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
9444 $ RSRC_
9445 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
9446 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9447 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9448 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9449* ..
9450* .. Local Scalars ..
9451 INTEGER MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
9452* ..
9453* .. Local Arrays ..
9454 INTEGER DESCA2( DLEN_ )
9455* ..
9456* .. External Subroutines ..
9457 EXTERNAL blacs_gridinfo, pb_desctrans, pb_pzlaprn2
9458* ..
9459* .. Executable Statements ..
9460*
9461* Quick return if possible
9462*
9463 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
9464 $ RETURN
9465*
9466* Convert descriptor
9467*
9468 CALL pb_desctrans( desca, desca2 )
9469*
9470 CALL blacs_gridinfo( desca2( ctxt_ ), nprow, npcol, myrow, mycol )
9471*
9472 IF( desca2( rsrc_ ).GE.0 ) THEN
9473 IF( desca2( csrc_ ).GE.0 ) THEN
9474 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt, icprnt,
9475 $ cmatnm, nout, desca2( rsrc_ ),
9476 $ desca2( csrc_ ), work )
9477 ELSE
9478 DO 10 pcol = 0, npcol - 1
9479 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9480 $ WRITE( nout, * ) 'Colum-replicated array -- ' ,
9481 $ 'copy in process column: ', pcol
9482 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9483 $ icprnt, cmatnm, nout, desca2( rsrc_ ),
9484 $ pcol, work )
9485 10 CONTINUE
9486 END IF
9487 ELSE
9488 IF( desca2( csrc_ ).GE.0 ) THEN
9489 DO 20 prow = 0, nprow - 1
9490 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9491 $ WRITE( nout, * ) 'Row-replicated array -- ' ,
9492 $ 'copy in process row: ', prow
9493 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9494 $ icprnt, cmatnm, nout, prow,
9495 $ desca2( csrc_ ), work )
9496 20 CONTINUE
9497 ELSE
9498 DO 40 prow = 0, nprow - 1
9499 DO 30 pcol = 0, npcol - 1
9500 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9501 $ WRITE( nout, * ) 'Replicated array -- ' ,
9502 $ 'copy in process (', prow, ',', pcol, ')'
9503 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9504 $ icprnt, cmatnm, nout, prow, pcol,
9505 $ work )
9506 30 CONTINUE
9507 40 CONTINUE
9508 END IF
9509 END IF
9510*
9511 RETURN
9512*
9513* End of PB_PZLAPRNT
9514*
9515 END
9516 SUBROUTINE pb_pzlaprn2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
9517 $ CMATNM, NOUT, PROW, PCOL, WORK )
9518*
9519* -- PBLAS test routine (version 2.0) --
9520* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9521* and University of California, Berkeley.
9522* April 1, 1998
9523*
9524* .. Scalar Arguments ..
9525 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
9526* ..
9527* .. Array Arguments ..
9528 CHARACTER*(*) CMATNM
9529 INTEGER DESCA( * )
9530 COMPLEX*16 A( * ), WORK( * )
9531* ..
9532*
9533* .. Parameters ..
9534 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9535 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
9536 $ rsrc_
9537 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
9538 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9539 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9540 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9541* ..
9542* .. Local Scalars ..
9543 LOGICAL AISCOLREP, AISROWREP
9544 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
9545 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
9546 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
9547* ..
9548* .. External Subroutines ..
9549 EXTERNAL blacs_barrier, blacs_gridinfo, pb_infog2l,
9550 $ zgerv2d, zgesd2d
9551* ..
9552* .. Intrinsic Functions ..
9553 INTRINSIC dble, dimag, min
9554* ..
9555* .. Executable Statements ..
9556*
9557* Get grid parameters
9558*
9559 ictxt = desca( ctxt_ )
9560 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9561 CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
9562 $ iia, jja, iarow, iacol )
9563 ii = iia
9564 jj = jja
9565 IF( desca( rsrc_ ).LT.0 ) THEN
9566 aisrowrep = .true.
9567 iarow = prow
9568 icurrow = prow
9569 ELSE
9570 aisrowrep = .false.
9571 icurrow = iarow
9572 END IF
9573 IF( desca( csrc_ ).LT.0 ) THEN
9574 aiscolrep = .true.
9575 iacol = pcol
9576 icurcol = pcol
9577 ELSE
9578 aiscolrep = .false.
9579 icurcol = iacol
9580 END IF
9581 lda = desca( lld_ )
9582 ldw = max( desca( imb_ ), desca( mb_ ) )
9583*
9584* Handle the first block of column separately
9585*
9586 jb = desca( inb_ ) - ja + 1
9587 IF( jb.LE.0 )
9588 $ jb = ( (-jb) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
9589 jb = min( jb, n )
9590 jn = ja+jb-1
9591 DO 60 h = 0, jb-1
9592 ib = desca( imb_ ) - ia + 1
9593 IF( ib.LE.0 )
9594 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
9595 ib = min( ib, m )
9596 in = ia+ib-1
9597 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9598 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9599 DO 10 k = 0, ib-1
9600 WRITE( nout, fmt = 9999 )
9601 $ cmatnm, ia+k, ja+h,
9602 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9603 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9604 10 CONTINUE
9605 END IF
9606 ELSE
9607 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9608 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
9609 $ irprnt, icprnt )
9610 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9611 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow, icurcol )
9612 DO 20 k = 1, ib
9613 WRITE( nout, fmt = 9999 )
9614 $ cmatnm, ia+k-1, ja+h, dble( work( k ) ),
9615 $ dimag( work( k ) )
9616 20 CONTINUE
9617 END IF
9618 END IF
9619 IF( myrow.EQ.icurrow )
9620 $ ii = ii + ib
9621 IF( .NOT.aisrowrep )
9622 $ icurrow = mod( icurrow+1, nprow )
9623 CALL blacs_barrier( ictxt, 'All' )
9624*
9625* Loop over remaining block of rows
9626*
9627 DO 50 i = in+1, ia+m-1, desca( mb_ )
9628 ib = min( desca( mb_ ), ia+m-i )
9629 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9630 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9631 DO 30 k = 0, ib-1
9632 WRITE( nout, fmt = 9999 )
9633 $ cmatnm, i+k, ja+h,
9634 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9635 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9636 30 CONTINUE
9637 END IF
9638 ELSE
9639 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9640 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9641 $ lda, irprnt, icprnt )
9642 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9643 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9644 $ icurcol )
9645 DO 40 k = 1, ib
9646 WRITE( nout, fmt = 9999 )
9647 $ cmatnm, i+k-1, ja+h, dble( work( k ) ),
9648 $ dimag( work( k ) )
9649 40 CONTINUE
9650 END IF
9651 END IF
9652 IF( myrow.EQ.icurrow )
9653 $ ii = ii + ib
9654 IF( .NOT.aisrowrep )
9655 $ icurrow = mod( icurrow+1, nprow )
9656 CALL blacs_barrier( ictxt, 'All' )
9657 50 CONTINUE
9658*
9659 ii = iia
9660 icurrow = iarow
9661 60 CONTINUE
9662*
9663 IF( mycol.EQ.icurcol )
9664 $ jj = jj + jb
9665 IF( .NOT.aiscolrep )
9666 $ icurcol = mod( icurcol+1, npcol )
9667 CALL blacs_barrier( ictxt, 'All' )
9668*
9669* Loop over remaining column blocks
9670*
9671 DO 130 j = jn+1, ja+n-1, desca( nb_ )
9672 jb = min( desca( nb_ ), ja+n-j )
9673 DO 120 h = 0, jb-1
9674 ib = desca( imb_ )-ia+1
9675 IF( ib.LE.0 )
9676 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
9677 ib = min( ib, m )
9678 in = ia+ib-1
9679 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9680 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9681 DO 70 k = 0, ib-1
9682 WRITE( nout, fmt = 9999 )
9683 $ cmatnm, ia+k, j+h,
9684 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9685 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9686 70 CONTINUE
9687 END IF
9688 ELSE
9689 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9690 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9691 $ lda, irprnt, icprnt )
9692 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9693 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9694 $ icurcol )
9695 DO 80 k = 1, ib
9696 WRITE( nout, fmt = 9999 )
9697 $ cmatnm, ia+k-1, j+h, dble( work( k ) ),
9698 $ dimag( work( k ) )
9699 80 CONTINUE
9700 END IF
9701 END IF
9702 IF( myrow.EQ.icurrow )
9703 $ ii = ii + ib
9704 icurrow = mod( icurrow+1, nprow )
9705 CALL blacs_barrier( ictxt, 'All' )
9706*
9707* Loop over remaining block of rows
9708*
9709 DO 110 i = in+1, ia+m-1, desca( mb_ )
9710 ib = min( desca( mb_ ), ia+m-i )
9711 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9712 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9713 DO 90 k = 0, ib-1
9714 WRITE( nout, fmt = 9999 )
9715 $ cmatnm, i+k, j+h,
9716 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9717 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9718 90 CONTINUE
9719 END IF
9720 ELSE
9721 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9722 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9723 $ lda, irprnt, icprnt )
9724 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9725 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9726 $ icurcol )
9727 DO 100 k = 1, ib
9728 WRITE( nout, fmt = 9999 )
9729 $ cmatnm, i+k-1, j+h, dble( work( k ) ),
9730 $ dimag( work( k ) )
9731 100 CONTINUE
9732 END IF
9733 END IF
9734 IF( myrow.EQ.icurrow )
9735 $ ii = ii + ib
9736 IF( .NOT.aisrowrep )
9737 $ icurrow = mod( icurrow+1, nprow )
9738 CALL blacs_barrier( ictxt, 'All' )
9739 110 CONTINUE
9740*
9741 ii = iia
9742 icurrow = iarow
9743 120 CONTINUE
9744*
9745 IF( mycol.EQ.icurcol )
9746 $ jj = jj + jb
9747 IF( .NOT.aiscolrep )
9748 $ icurcol = mod( icurcol+1, npcol )
9749 CALL blacs_barrier( ictxt, 'All' )
9750*
9751 130 CONTINUE
9752*
9753 9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18, '+i*(',
9754 $ d30.18, ')' )
9755*
9756 RETURN
9757*
9758* End of PB_PZLAPRN2
9759*
9760 END
9761 SUBROUTINE pb_zfillpad( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
9762*
9763* -- PBLAS test routine (version 2.0) --
9764* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9765* and University of California, Berkeley.
9766* April 1, 1998
9767*
9768* .. Scalar Arguments ..
9769 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9770 COMPLEX*16 CHKVAL
9771* ..
9772* .. Array Arguments ..
9773 COMPLEX*16 A( * )
9774* ..
9775*
9776* Purpose
9777* =======
9778*
9779* PB_ZFILLPAD surrounds a two dimensional local array with a guard-zone
9780* initialized to the value CHKVAL. The user may later call the routine
9781* PB_ZCHEKPAD to discover if the guardzone has been violated. There are
9782* three guardzones. The first is a buffer of size IPRE that is before
9783* the start of the array. The second is the buffer of size IPOST which
9784* is after the end of the array to be padded. Finally, there is a guard
9785* zone inside every column of the array to be padded, in the elements
9786* of A(M+1:LDA, J).
9787*
9788* Arguments
9789* =========
9790*
9791* ICTXT (local input) INTEGER
9792* On entry, ICTXT specifies the BLACS context handle, indica-
9793* ting the global context of the operation. The context itself
9794* is global, but the value of ICTXT is local.
9795*
9796* M (local input) INTEGER
9797* On entry, M specifies the number of rows in the local array
9798* A. M must be at least zero.
9799*
9800* N (local input) INTEGER
9801* On entry, N specifies the number of columns in the local ar-
9802* ray A. N must be at least zero.
9803*
9804* A (local input/local output) COMPLEX*16 array
9805* On entry, A is an array of dimension (LDA,N). On exit, this
9806* array is the padded array.
9807*
9808* LDA (local input) INTEGER
9809* On entry, LDA specifies the leading dimension of the local
9810* array to be padded. LDA must be at least MAX( 1, M ).
9811*
9812* IPRE (local input) INTEGER
9813* On entry, IPRE specifies the size of the guard zone to put
9814* before the start of the padded array.
9815*
9816* IPOST (local input) INTEGER
9817* On entry, IPOST specifies the size of the guard zone to put
9818* after the end of the padded array.
9819*
9820* CHKVAL (local input) COMPLEX*16
9821* On entry, CHKVAL specifies the value to pad the array with.
9822*
9823* -- Written on April 1, 1998 by
9824* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9825*
9826* =====================================================================
9827*
9828* .. Local Scalars ..
9829 INTEGER I, J, K
9830* ..
9831* .. Executable Statements ..
9832*
9833* Put check buffer in front of A
9834*
9835 IF( ipre.GT.0 ) THEN
9836 DO 10 i = 1, ipre
9837 a( i ) = chkval
9838 10 CONTINUE
9839 ELSE
9840 WRITE( *, fmt = '(A)' )
9841 $ 'WARNING no pre-guardzone in PB_ZFILLPAD'
9842 END IF
9843*
9844* Put check buffer in back of A
9845*
9846 IF( ipost.GT.0 ) THEN
9847 j = ipre+lda*n+1
9848 DO 20 i = j, j+ipost-1
9849 a( i ) = chkval
9850 20 CONTINUE
9851 ELSE
9852 WRITE( *, fmt = '(A)' )
9853 $ 'WARNING no post-guardzone in PB_ZFILLPAD'
9854 END IF
9855*
9856* Put check buffer in all (LDA-M) gaps
9857*
9858 IF( lda.GT.m ) THEN
9859 k = ipre + m + 1
9860 DO 40 j = 1, n
9861 DO 30 i = k, k + ( lda - m ) - 1
9862 a( i ) = chkval
9863 30 CONTINUE
9864 k = k + lda
9865 40 CONTINUE
9866 END IF
9867*
9868 RETURN
9869*
9870* End of PB_ZFILLPAD
9871*
9872 END
9873 SUBROUTINE pb_zchekpad( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
9874 $ CHKVAL )
9875*
9876* -- PBLAS test routine (version 2.0) --
9877* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9878* and University of California, Berkeley.
9879* April 1, 1998
9880*
9881* .. Scalar Arguments ..
9882 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9883 COMPLEX*16 CHKVAL
9884* ..
9885* .. Array Arguments ..
9886 CHARACTER*(*) MESS
9887 COMPLEX*16 A( * )
9888* ..
9889*
9890* Purpose
9891* =======
9892*
9893* PB_ZCHEKPAD checks that the padding around a local array has not been
9894* overwritten since the call to PB_ZFILLPAD. Three types of errors are
9895* reported:
9896*
9897* 1) Overwrite in pre-guardzone. This indicates a memory overwrite has
9898* occurred in the first IPRE elements which form a buffer before the
9899* beginning of A. Therefore, the error message:
9900* 'Overwrite in pre-guardzone: loc( 5) = 18.00000'
9901* tells that the 5th element of the IPRE long buffer has been overwrit-
9902* ten with the value 18, where it should still have the value CHKVAL.
9903*
9904* 2) Overwrite in post-guardzone. This indicates a memory overwrite has
9905* occurred in the last IPOST elements which form a buffer after the end
9906* of A. Error reports are refered from the end of A. Therefore,
9907* 'Overwrite in post-guardzone: loc( 19) = 24.00000'
9908* tells that the 19th element after the end of A was overwritten with
9909* the value 24, where it should still have the value of CHKVAL.
9910*
9911* 3) Overwrite in lda-m gap. Tells you elements between M and LDA were
9912* overwritten. So,
9913* 'Overwrite in lda-m gap: A( 12, 3) = 22.00000'
9914* tells that the element at the 12th row and 3rd column of A was over-
9915* written with the value of 22, where it should still have the value of
9916* CHKVAL.
9917*
9918* Arguments
9919* =========
9920*
9921* ICTXT (local input) INTEGER
9922* On entry, ICTXT specifies the BLACS context handle, indica-
9923* ting the global context of the operation. The context itself
9924* is global, but the value of ICTXT is local.
9925*
9926* MESS (local input) CHARACTER*(*)
9927* On entry, MESS is a ttring containing a user-defined message.
9928*
9929* M (local input) INTEGER
9930* On entry, M specifies the number of rows in the local array
9931* A. M must be at least zero.
9932*
9933* N (local input) INTEGER
9934* On entry, N specifies the number of columns in the local ar-
9935* ray A. N must be at least zero.
9936*
9937* A (local input) COMPLEX*16 array
9938* On entry, A is an array of dimension (LDA,N).
9939*
9940* LDA (local input) INTEGER
9941* On entry, LDA specifies the leading dimension of the local
9942* array to be padded. LDA must be at least MAX( 1, M ).
9943*
9944* IPRE (local input) INTEGER
9945* On entry, IPRE specifies the size of the guard zone to put
9946* before the start of the padded array.
9947*
9948* IPOST (local input) INTEGER
9949* On entry, IPOST specifies the size of the guard zone to put
9950* after the end of the padded array.
9951*
9952* CHKVAL (local input) COMPLEX*16
9953* On entry, CHKVAL specifies the value to pad the array with.
9954*
9955*
9956* -- Written on April 1, 1998 by
9957* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9958*
9959* =====================================================================
9960*
9961* .. Local Scalars ..
9962 CHARACTER*1 TOP
9963 INTEGER I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
9964 $ NPROW
9965* ..
9966* .. External Subroutines ..
9967 EXTERNAL BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
9968* ..
9969* .. Intrinsic Functions ..
9970 INTRINSIC dble, dimag
9971* ..
9972* .. Executable Statements ..
9973*
9974* Get grid parameters
9975*
9976 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9977 iam = myrow*npcol + mycol
9978 info = -1
9979*
9980* Check buffer in front of A
9981*
9982 IF( ipre.GT.0 ) THEN
9983 DO 10 i = 1, ipre
9984 IF( a( i ).NE.chkval ) THEN
9985 WRITE( *, fmt = 9998 ) myrow, mycol, mess, ' pre', i,
9986 $ dble( a( i ) ), dimag( a( i ) )
9987 info = iam
9988 END IF
9989 10 CONTINUE
9990 ELSE
9991 WRITE( *, fmt = * ) 'WARNING no pre-guardzone in PB_ZCHEKPAD'
9992 END IF
9993*
9994* Check buffer after A
9995*
9996 IF( ipost.GT.0 ) THEN
9997 j = ipre+lda*n+1
9998 DO 20 i = j, j+ipost-1
9999 IF( a( i ).NE.chkval ) THEN
10000 WRITE( *, fmt = 9998 ) myrow, mycol, mess, 'post',
10001 $ i-j+1, dble( a( i ) ),
10002 $ dimag( a( i ) )
10003 info = iam
10004 END IF
10005 20 CONTINUE
10006 ELSE
10007 WRITE( *, fmt = * )
10008 $ 'WARNING no post-guardzone buffer in PB_ZCHEKPAD'
10009 END IF
10010*
10011* Check all (LDA-M) gaps
10012*
10013 IF( lda.GT.m ) THEN
10014 k = ipre + m + 1
10015 DO 40 j = 1, n
10016 DO 30 i = k, k + (lda-m) - 1
10017 IF( a( i ).NE.chkval ) THEN
10018 WRITE( *, fmt = 9997 ) myrow, mycol, mess,
10019 $ i-ipre-lda*(j-1), j, dble( a( i ) ),
10020 $ dimag( a( i ) )
10021 info = iam
10022 END IF
10023 30 CONTINUE
10024 k = k + lda
10025 40 CONTINUE
10026 END IF
10027*
10028 CALL pb_topget( ictxt, 'Combine', 'All', top )
10029 CALL igamx2d( ictxt, 'All', top, 1, 1, info, 1, idumm, idumm, -1,
10030 $ 0, 0 )
10031 IF( iam.EQ.0 .AND. info.GE.0 ) THEN
10032 WRITE( *, fmt = 9999 ) info / npcol, mod( info, npcol ), mess
10033 END IF
10034*
10035 9999 FORMAT( '{', i5, ',', i5, '}: Memory overwrite in ', a )
10036 9998 FORMAT( '{', i5, ',', i5, '}: ', a, ' memory overwrite in ',
10037 $ A4, '-guardzone: loc(', I3, ') = ', g20.7, '+ i*',
10038 $ g20.7 )
10039 9997 FORMAT( '{', i5, ',', i5, '}: ', a, ' memory overwrite in ',
10040 $ 'lda-m gap: loc(', i3, ',', i3, ') = ', g20.7,
10041 $ '+ i*', g20.7 )
10042*
10043 RETURN
10044*
10045* End of PB_ZCHEKPAD
10046*
10047 END
10048 SUBROUTINE pb_zlaset( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
10049*
10050* -- PBLAS test routine (version 2.0) --
10051* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10052* and University of California, Berkeley.
10053* April 1, 1998
10054*
10055* .. Scalar Arguments ..
10056 CHARACTER*1 UPLO
10057 INTEGER IOFFD, LDA, M, N
10058 COMPLEX*16 ALPHA, BETA
10059* ..
10060* .. Array Arguments ..
10061 COMPLEX*16 A( LDA, * )
10062* ..
10063*
10064* Purpose
10065* =======
10066*
10067* PB_ZLASET initializes a two-dimensional array A to beta on the diago-
10068* nal specified by IOFFD and alpha on the offdiagonals.
10069*
10070* Arguments
10071* =========
10072*
10073* UPLO (global input) CHARACTER*1
10074* On entry, UPLO specifies which trapezoidal part of the ar-
10075* ray A is to be set as follows:
10076* = 'L' or 'l': Lower triangular part is set; the strictly
10077* upper triangular part of A is not changed,
10078* = 'U' or 'u': Upper triangular part is set; the strictly
10079* lower triangular part of A is not changed,
10080* = 'D' or 'd' Only the diagonal of A is set,
10081* Otherwise: All of the array A is set.
10082*
10083* M (input) INTEGER
10084* On entry, M specifies the number of rows of the array A. M
10085* must be at least zero.
10086*
10087* N (input) INTEGER
10088* On entry, N specifies the number of columns of the array A.
10089* N must be at least zero.
10090*
10091* IOFFD (input) INTEGER
10092* On entry, IOFFD specifies the position of the offdiagonal de-
10093* limiting the upper and lower trapezoidal part of A as follows
10094* (see the notes below):
10095*
10096* IOFFD = 0 specifies the main diagonal A( i, i ),
10097* with i = 1 ... MIN( M, N ),
10098* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
10099* with i = 1 ... MIN( M-IOFFD, N ),
10100* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
10101* with i = 1 ... MIN( M, N+IOFFD ).
10102*
10103* ALPHA (input) COMPLEX*16
10104* On entry, ALPHA specifies the value to which the offdiagonal
10105* array elements are set to.
10106*
10107* BETA (input) COMPLEX*16
10108* On entry, BETA specifies the value to which the diagonal ar-
10109* ray elements are set to.
10110*
10111* A (input/output) COMPLEX*16 array
10112* On entry, A is an array of dimension (LDA,N). Before entry
10113* with UPLO = 'U' or 'u', the leading m by n part of the array
10114* A must contain the upper trapezoidal part of the matrix as
10115* specified by IOFFD to be set, and the strictly lower trape-
10116* zoidal part of A is not referenced; When IUPLO = 'L' or 'l',
10117* the leading m by n part of the array A must contain the
10118* lower trapezoidal part of the matrix as specified by IOFFD to
10119* be set, and the strictly upper trapezoidal part of A is
10120* not referenced.
10121*
10122* LDA (input) INTEGER
10123* On entry, LDA specifies the leading dimension of the array A.
10124* LDA must be at least max( 1, M ).
10125*
10126* Notes
10127* =====
10128* N N
10129* ---------------------------- -----------
10130* | d | | |
10131* M | d 'U' | | 'U' |
10132* | 'L' 'D' | |d |
10133* | d | M | d |
10134* ---------------------------- | 'D' |
10135* | d |
10136* IOFFD < 0 | 'L' d |
10137* | d|
10138* N | |
10139* ----------- -----------
10140* | d 'U'|
10141* | d | IOFFD > 0
10142* M | 'D' |
10143* | d| N
10144* | 'L' | ----------------------------
10145* | | | 'U' |
10146* | | |d |
10147* | | | 'D' |
10148* | | | d |
10149* | | |'L' d |
10150* ----------- ----------------------------
10151*
10152* -- Written on April 1, 1998 by
10153* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10154*
10155* =====================================================================
10156*
10157* .. Local Scalars ..
10158 INTEGER I, J, JTMP, MN
10159* ..
10160* .. External Functions ..
10161 LOGICAL LSAME
10162 EXTERNAL LSAME
10163* ..
10164* .. Intrinsic Functions ..
10165 INTRINSIC max, min
10166* ..
10167* .. Executable Statements ..
10168*
10169* Quick return if possible
10170*
10171 IF( m.LE.0 .OR. n.LE.0 )
10172 $ RETURN
10173*
10174* Start the operations
10175*
10176 IF( lsame( uplo, 'L' ) ) THEN
10177*
10178* Set the diagonal to BETA and the strictly lower triangular
10179* part of the array to ALPHA.
10180*
10181 mn = max( 0, -ioffd )
10182 DO 20 j = 1, min( mn, n )
10183 DO 10 i = 1, m
10184 a( i, j ) = alpha
10185 10 CONTINUE
10186 20 CONTINUE
10187 DO 40 j = mn + 1, min( m - ioffd, n )
10188 jtmp = j + ioffd
10189 a( jtmp, j ) = beta
10190 DO 30 i = jtmp + 1, m
10191 a( i, j ) = alpha
10192 30 CONTINUE
10193 40 CONTINUE
10194*
10195 ELSE IF( lsame( uplo, 'U' ) ) THEN
10196*
10197* Set the diagonal to BETA and the strictly upper triangular
10198* part of the array to ALPHA.
10199*
10200 mn = min( m - ioffd, n )
10201 DO 60 j = max( 0, -ioffd ) + 1, mn
10202 jtmp = j + ioffd
10203 DO 50 i = 1, jtmp - 1
10204 a( i, j ) = alpha
10205 50 CONTINUE
10206 a( jtmp, j ) = beta
10207 60 CONTINUE
10208 DO 80 j = max( 0, mn ) + 1, n
10209 DO 70 i = 1, m
10210 a( i, j ) = alpha
10211 70 CONTINUE
10212 80 CONTINUE
10213*
10214 ELSE IF( lsame( uplo, 'D' ) ) THEN
10215*
10216* Set the array to BETA on the diagonal.
10217*
10218 DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10219 a( j + ioffd, j ) = beta
10220 90 CONTINUE
10221*
10222 ELSE
10223*
10224* Set the array to BETA on the diagonal and ALPHA on the
10225* offdiagonal.
10226*
10227 DO 110 j = 1, n
10228 DO 100 i = 1, m
10229 a( i, j ) = alpha
10230 100 CONTINUE
10231 110 CONTINUE
10232 IF( alpha.NE.beta .AND. ioffd.LT.m .AND. ioffd.GT.-n ) THEN
10233 DO 120 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10234 a( j + ioffd, j ) = beta
10235 120 CONTINUE
10236 END IF
10237*
10238 END IF
10239*
10240 RETURN
10241*
10242* End of PB_ZLASET
10243*
10244 END
10245 SUBROUTINE pb_zlascal( UPLO, M, N, IOFFD, ALPHA, A, LDA )
10246*
10247* -- PBLAS test routine (version 2.0) --
10248* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10249* and University of California, Berkeley.
10250* April 1, 1998
10251*
10252* .. Scalar Arguments ..
10253 CHARACTER*1 UPLO
10254 INTEGER IOFFD, LDA, M, N
10255 COMPLEX*16 ALPHA
10256* ..
10257* .. Array Arguments ..
10258 COMPLEX*16 A( LDA, * )
10259* ..
10260*
10261* Purpose
10262* =======
10263*
10264* PB_ZLASCAL scales a two-dimensional array A by the scalar alpha.
10265*
10266* Arguments
10267* =========
10268*
10269* UPLO (input) CHARACTER*1
10270* On entry, UPLO specifies which trapezoidal part of the ar-
10271* ray A is to be scaled as follows:
10272* = 'L' or 'l': the lower trapezoid of A is scaled,
10273* = 'U' or 'u': the upper trapezoid of A is scaled,
10274* = 'D' or 'd': diagonal specified by IOFFD is scaled,
10275* Otherwise: all of the array A is scaled.
10276*
10277* M (input) INTEGER
10278* On entry, M specifies the number of rows of the array A. M
10279* must be at least zero.
10280*
10281* N (input) INTEGER
10282* On entry, N specifies the number of columns of the array A.
10283* N must be at least zero.
10284*
10285* IOFFD (input) INTEGER
10286* On entry, IOFFD specifies the position of the offdiagonal de-
10287* limiting the upper and lower trapezoidal part of A as follows
10288* (see the notes below):
10289*
10290* IOFFD = 0 specifies the main diagonal A( i, i ),
10291* with i = 1 ... MIN( M, N ),
10292* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
10293* with i = 1 ... MIN( M-IOFFD, N ),
10294* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
10295* with i = 1 ... MIN( M, N+IOFFD ).
10296*
10297* ALPHA (input) COMPLEX*16
10298* On entry, ALPHA specifies the scalar alpha.
10299*
10300* A (input/output) COMPLEX*16 array
10301* On entry, A is an array of dimension (LDA,N). Before entry
10302* with UPLO = 'U' or 'u', the leading m by n part of the array
10303* A must contain the upper trapezoidal part of the matrix as
10304* specified by IOFFD to be scaled, and the strictly lower tra-
10305* pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
10306* the leading m by n part of the array A must contain the lower
10307* trapezoidal part of the matrix as specified by IOFFD to be
10308* scaled, and the strictly upper trapezoidal part of A is not
10309* referenced. On exit, the entries of the trapezoid part of A
10310* determined by UPLO and IOFFD are scaled.
10311*
10312* LDA (input) INTEGER
10313* On entry, LDA specifies the leading dimension of the array A.
10314* LDA must be at least max( 1, M ).
10315*
10316* Notes
10317* =====
10318* N N
10319* ---------------------------- -----------
10320* | d | | |
10321* M | d 'U' | | 'U' |
10322* | 'L' 'D' | |d |
10323* | d | M | d |
10324* ---------------------------- | 'D' |
10325* | d |
10326* IOFFD < 0 | 'L' d |
10327* | d|
10328* N | |
10329* ----------- -----------
10330* | d 'U'|
10331* | d | IOFFD > 0
10332* M | 'D' |
10333* | d| N
10334* | 'L' | ----------------------------
10335* | | | 'U' |
10336* | | |d |
10337* | | | 'D' |
10338* | | | d |
10339* | | |'L' d |
10340* ----------- ----------------------------
10341*
10342* -- Written on April 1, 1998 by
10343* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10344*
10345* =====================================================================
10346*
10347* .. Local Scalars ..
10348 INTEGER I, J, JTMP, MN
10349* ..
10350* .. External Functions ..
10351 LOGICAL LSAME
10352 EXTERNAL LSAME
10353* ..
10354* .. Intrinsic Functions ..
10355 INTRINSIC max, min
10356* ..
10357* .. Executable Statements ..
10358*
10359* Quick return if possible
10360*
10361 IF( m.LE.0 .OR. n.LE.0 )
10362 $ RETURN
10363*
10364* Start the operations
10365*
10366 IF( lsame( uplo, 'L' ) ) THEN
10367*
10368* Scales the lower triangular part of the array by ALPHA.
10369*
10370 mn = max( 0, -ioffd )
10371 DO 20 j = 1, min( mn, n )
10372 DO 10 i = 1, m
10373 a( i, j ) = alpha * a( i, j )
10374 10 CONTINUE
10375 20 CONTINUE
10376 DO 40 j = mn + 1, min( m - ioffd, n )
10377 DO 30 i = j + ioffd, m
10378 a( i, j ) = alpha * a( i, j )
10379 30 CONTINUE
10380 40 CONTINUE
10381*
10382 ELSE IF( lsame( uplo, 'U' ) ) THEN
10383*
10384* Scales the upper triangular part of the array by ALPHA.
10385*
10386 mn = min( m - ioffd, n )
10387 DO 60 j = max( 0, -ioffd ) + 1, mn
10388 DO 50 i = 1, j + ioffd
10389 a( i, j ) = alpha * a( i, j )
10390 50 CONTINUE
10391 60 CONTINUE
10392 DO 80 j = max( 0, mn ) + 1, n
10393 DO 70 i = 1, m
10394 a( i, j ) = alpha * a( i, j )
10395 70 CONTINUE
10396 80 CONTINUE
10397*
10398 ELSE IF( lsame( uplo, 'D' ) ) THEN
10399*
10400* Scales the diagonal entries by ALPHA.
10401*
10402 DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10403 jtmp = j + ioffd
10404 a( jtmp, j ) = alpha * a( jtmp, j )
10405 90 CONTINUE
10406*
10407 ELSE
10408*
10409* Scales the entire array by ALPHA.
10410*
10411 DO 110 j = 1, n
10412 DO 100 i = 1, m
10413 a( i, j ) = alpha * a( i, j )
10414 100 CONTINUE
10415 110 CONTINUE
10416*
10417 END IF
10418*
10419 RETURN
10420*
10421* End of PB_ZLASCAL
10422*
10423 END
10424 SUBROUTINE pb_zlagen( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
10425 $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
10426 $ LNBLOC, JMP, IMULADD )
10427*
10428* -- PBLAS test routine (version 2.0) --
10429* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10430* and University of California, Berkeley.
10431* April 1, 1998
10432*
10433* .. Scalar Arguments ..
10434 CHARACTER*1 UPLO, AFORM
10435 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
10436 $ MB, MBLKS, NB, NBLKS
10437* ..
10438* .. Array Arguments ..
10439 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
10440 COMPLEX*16 A( LDA, * )
10441* ..
10442*
10443* Purpose
10444* =======
10445*
10446* PB_ZLAGEN locally initializes an array A.
10447*
10448* Arguments
10449* =========
10450*
10451* UPLO (global input) CHARACTER*1
10452* On entry, UPLO specifies whether the lower (UPLO='L') trape-
10453* zoidal part or the upper (UPLO='U') trapezoidal part is to be
10454* generated when the matrix to be generated is symmetric or
10455* Hermitian. For all the other values of AFORM, the value of
10456* this input argument is ignored.
10457*
10458* AFORM (global input) CHARACTER*1
10459* On entry, AFORM specifies the type of submatrix to be genera-
10460* ted as follows:
10461* AFORM = 'S', sub( A ) is a symmetric matrix,
10462* AFORM = 'H', sub( A ) is a Hermitian matrix,
10463* AFORM = 'T', sub( A ) is overrwritten with the transpose
10464* of what would normally be generated,
10465* AFORM = 'C', sub( A ) is overwritten with the conjugate
10466* transpose of what would normally be genera-
10467* ted.
10468* AFORM = 'N', a random submatrix is generated.
10469*
10470* A (local output) COMPLEX*16 array
10471* On entry, A is an array of dimension (LLD_A, *). On exit,
10472* this array contains the local entries of the randomly genera-
10473* ted submatrix sub( A ).
10474*
10475* LDA (local input) INTEGER
10476* On entry, LDA specifies the local leading dimension of the
10477* array A. LDA must be at least one.
10478*
10479* LCMT00 (global input) INTEGER
10480* On entry, LCMT00 is the LCM value specifying the off-diagonal
10481* of the underlying matrix of interest. LCMT00=0 specifies the
10482* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
10483* specifies superdiagonals.
10484*
10485* IRAN (local input) INTEGER array
10486* On entry, IRAN is an array of dimension 2 containing respec-
10487* tively the 16-lower and 16-higher bits of the encoding of the
10488* entry of the random sequence corresponding locally to the
10489* first local array entry to generate. Usually, this array is
10490* computed by PB_SETLOCRAN.
10491*
10492* MBLKS (local input) INTEGER
10493* On entry, MBLKS specifies the local number of blocks of rows.
10494* MBLKS is at least zero.
10495*
10496* IMBLOC (local input) INTEGER
10497* On entry, IMBLOC specifies the number of rows (size) of the
10498* local uppest blocks. IMBLOC is at least zero.
10499*
10500* MB (global input) INTEGER
10501* On entry, MB specifies the blocking factor used to partition
10502* the rows of the matrix. MB must be at least one.
10503*
10504* LMBLOC (local input) INTEGER
10505* On entry, LMBLOC specifies the number of rows (size) of the
10506* local lowest blocks. LMBLOC is at least zero.
10507*
10508* NBLKS (local input) INTEGER
10509* On entry, NBLKS specifies the local number of blocks of co-
10510* lumns. NBLKS is at least zero.
10511*
10512* INBLOC (local input) INTEGER
10513* On entry, INBLOC specifies the number of columns (size) of
10514* the local leftmost blocks. INBLOC is at least zero.
10515*
10516* NB (global input) INTEGER
10517* On entry, NB specifies the blocking factor used to partition
10518* the the columns of the matrix. NB must be at least one.
10519*
10520* LNBLOC (local input) INTEGER
10521* On entry, LNBLOC specifies the number of columns (size) of
10522* the local rightmost blocks. LNBLOC is at least zero.
10523*
10524* JMP (local input) INTEGER array
10525* On entry, JMP is an array of dimension JMP_LEN containing the
10526* different jump values used by the random matrix generator.
10527*
10528* IMULADD (local input) INTEGER array
10529* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
10530* jth column of this array contains the encoded initial cons-
10531* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
10532* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
10533* contains respectively the 16-lower and 16-higher bits of the
10534* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
10535* 16-higher bits of the constant c_j.
10536*
10537* -- Written on April 1, 1998 by
10538* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10539*
10540* =====================================================================
10541*
10542* .. Parameters ..
10543 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
10544 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
10545 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
10546 PARAMETER ( JMP_1 = 1, jmp_row = 2, jmp_col = 3,
10547 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
10548 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
10549 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
10550 $ jmp_len = 11 )
10551 DOUBLE PRECISION ZERO
10552 PARAMETER ( ZERO = 0.0d+0 )
10553* ..
10554* .. Local Scalars ..
10555 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
10556 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
10557 COMPLEX*16 DUMMY
10558* ..
10559* .. Local Arrays ..
10560 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
10561* ..
10562* .. External Subroutines ..
10563 EXTERNAL pb_jumpit
10564* ..
10565* .. External Functions ..
10566 LOGICAL LSAME
10567 DOUBLE PRECISION PB_DRAND
10568 EXTERNAL lsame, pb_drand
10569* ..
10570* .. Intrinsic Functions ..
10571 INTRINSIC dble, dcmplx, max, min
10572* ..
10573* .. Executable Statements ..
10574*
10575 DO 10 i = 1, 2
10576 ib1( i ) = iran( i )
10577 ib2( i ) = iran( i )
10578 ib3( i ) = iran( i )
10579 10 CONTINUE
10580*
10581 IF( lsame( aform, 'N' ) ) THEN
10582*
10583* Generate random matrix
10584*
10585 jj = 1
10586*
10587 DO 50 jblk = 1, nblks
10588*
10589 IF( jblk.EQ.1 ) THEN
10590 jb = inbloc
10591 ELSE IF( jblk.EQ.nblks ) THEN
10592 jb = lnbloc
10593 ELSE
10594 jb = nb
10595 END IF
10596*
10597 DO 40 jk = jj, jj + jb - 1
10598*
10599 ii = 1
10600*
10601 DO 30 iblk = 1, mblks
10602*
10603 IF( iblk.EQ.1 ) THEN
10604 ib = imbloc
10605 ELSE IF( iblk.EQ.mblks ) THEN
10606 ib = lmbloc
10607 ELSE
10608 ib = mb
10609 END IF
10610*
10611* Blocks are IB by JB
10612*
10613 DO 20 ik = ii, ii + ib - 1
10614 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10615 $ pb_drand( 0 ) )
10616 20 CONTINUE
10617*
10618 ii = ii + ib
10619*
10620 IF( iblk.EQ.1 ) THEN
10621*
10622* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10623*
10624 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
10625 $ ib0 )
10626*
10627 ELSE
10628*
10629* Jump NPROW * MB rows
10630*
10631 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
10632*
10633 END IF
10634*
10635 ib1( 1 ) = ib0( 1 )
10636 ib1( 2 ) = ib0( 2 )
10637*
10638 30 CONTINUE
10639*
10640* Jump one column
10641*
10642 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
10643*
10644 ib1( 1 ) = ib0( 1 )
10645 ib1( 2 ) = ib0( 2 )
10646 ib2( 1 ) = ib0( 1 )
10647 ib2( 2 ) = ib0( 2 )
10648*
10649 40 CONTINUE
10650*
10651 jj = jj + jb
10652*
10653 IF( jblk.EQ.1 ) THEN
10654*
10655* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10656*
10657 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
10658*
10659 ELSE
10660*
10661* Jump NPCOL * NB columns
10662*
10663 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
10664*
10665 END IF
10666*
10667 ib1( 1 ) = ib0( 1 )
10668 ib1( 2 ) = ib0( 2 )
10669 ib2( 1 ) = ib0( 1 )
10670 ib2( 2 ) = ib0( 2 )
10671 ib3( 1 ) = ib0( 1 )
10672 ib3( 2 ) = ib0( 2 )
10673*
10674 50 CONTINUE
10675*
10676 ELSE IF( lsame( aform, 'T' ) ) THEN
10677*
10678* Generate the transpose of the matrix that would be normally
10679* generated.
10680*
10681 ii = 1
10682*
10683 DO 90 iblk = 1, mblks
10684*
10685 IF( iblk.EQ.1 ) THEN
10686 ib = imbloc
10687 ELSE IF( iblk.EQ.mblks ) THEN
10688 ib = lmbloc
10689 ELSE
10690 ib = mb
10691 END IF
10692*
10693 DO 80 ik = ii, ii + ib - 1
10694*
10695 jj = 1
10696*
10697 DO 70 jblk = 1, nblks
10698*
10699 IF( jblk.EQ.1 ) THEN
10700 jb = inbloc
10701 ELSE IF( jblk.EQ.nblks ) THEN
10702 jb = lnbloc
10703 ELSE
10704 jb = nb
10705 END IF
10706*
10707* Blocks are IB by JB
10708*
10709 DO 60 jk = jj, jj + jb - 1
10710 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10711 $ pb_drand( 0 ) )
10712 60 CONTINUE
10713*
10714 jj = jj + jb
10715*
10716 IF( jblk.EQ.1 ) THEN
10717*
10718* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10719*
10720 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
10721 $ ib0 )
10722*
10723 ELSE
10724*
10725* Jump NPCOL * NB columns
10726*
10727 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
10728*
10729 END IF
10730*
10731 ib1( 1 ) = ib0( 1 )
10732 ib1( 2 ) = ib0( 2 )
10733*
10734 70 CONTINUE
10735*
10736* Jump one row
10737*
10738 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
10739*
10740 ib1( 1 ) = ib0( 1 )
10741 ib1( 2 ) = ib0( 2 )
10742 ib2( 1 ) = ib0( 1 )
10743 ib2( 2 ) = ib0( 2 )
10744*
10745 80 CONTINUE
10746*
10747 ii = ii + ib
10748*
10749 IF( iblk.EQ.1 ) THEN
10750*
10751* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10752*
10753 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
10754*
10755 ELSE
10756*
10757* Jump NPROW * MB rows
10758*
10759 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
10760*
10761 END IF
10762*
10763 ib1( 1 ) = ib0( 1 )
10764 ib1( 2 ) = ib0( 2 )
10765 ib2( 1 ) = ib0( 1 )
10766 ib2( 2 ) = ib0( 2 )
10767 ib3( 1 ) = ib0( 1 )
10768 ib3( 2 ) = ib0( 2 )
10769*
10770 90 CONTINUE
10771*
10772 ELSE IF( lsame( aform, 'S' ) ) THEN
10773*
10774* Generate a symmetric matrix
10775*
10776 IF( lsame( uplo, 'L' ) ) THEN
10777*
10778* generate lower trapezoidal part
10779*
10780 jj = 1
10781 lcmtc = lcmt00
10782*
10783 DO 170 jblk = 1, nblks
10784*
10785 IF( jblk.EQ.1 ) THEN
10786 jb = inbloc
10787 low = 1 - inbloc
10788 ELSE IF( jblk.EQ.nblks ) THEN
10789 jb = lnbloc
10790 low = 1 - nb
10791 ELSE
10792 jb = nb
10793 low = 1 - nb
10794 END IF
10795*
10796 DO 160 jk = jj, jj + jb - 1
10797*
10798 ii = 1
10799 lcmtr = lcmtc
10800*
10801 DO 150 iblk = 1, mblks
10802*
10803 IF( iblk.EQ.1 ) THEN
10804 ib = imbloc
10805 upp = imbloc - 1
10806 ELSE IF( iblk.EQ.mblks ) THEN
10807 ib = lmbloc
10808 upp = mb - 1
10809 ELSE
10810 ib = mb
10811 upp = mb - 1
10812 END IF
10813*
10814* Blocks are IB by JB
10815*
10816 IF( lcmtr.GT.upp ) THEN
10817*
10818 DO 100 ik = ii, ii + ib - 1
10819 dummy = dcmplx( pb_drand( 0 ),
10820 $ pb_drand( 0 ) )
10821 100 CONTINUE
10822*
10823 ELSE IF( lcmtr.GE.low ) THEN
10824*
10825 jtmp = jk - jj + 1
10826 mnb = max( 0, -lcmtr )
10827*
10828 IF( jtmp.LE.min( mnb, jb ) ) THEN
10829*
10830 DO 110 ik = ii, ii + ib - 1
10831 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10832 $ pb_drand( 0 ) )
10833 110 CONTINUE
10834*
10835 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
10836 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
10837*
10838 itmp = ii + jtmp + lcmtr - 1
10839*
10840 DO 120 ik = ii, itmp - 1
10841 dummy = dcmplx( pb_drand( 0 ),
10842 $ pb_drand( 0 ) )
10843 120 CONTINUE
10844*
10845 DO 130 ik = itmp, ii + ib - 1
10846 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10847 $ pb_drand( 0 ) )
10848 130 CONTINUE
10849*
10850 END IF
10851*
10852 ELSE
10853*
10854 DO 140 ik = ii, ii + ib - 1
10855 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10856 $ pb_drand( 0 ) )
10857 140 CONTINUE
10858*
10859 END IF
10860*
10861 ii = ii + ib
10862*
10863 IF( iblk.EQ.1 ) THEN
10864*
10865* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10866*
10867 lcmtr = lcmtr - jmp( jmp_npimbloc )
10868 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
10869 $ ib0 )
10870*
10871 ELSE
10872*
10873* Jump NPROW * MB rows
10874*
10875 lcmtr = lcmtr - jmp( jmp_npmb )
10876 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
10877 $ ib0 )
10878*
10879 END IF
10880*
10881 ib1( 1 ) = ib0( 1 )
10882 ib1( 2 ) = ib0( 2 )
10883*
10884 150 CONTINUE
10885*
10886* Jump one column
10887*
10888 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
10889*
10890 ib1( 1 ) = ib0( 1 )
10891 ib1( 2 ) = ib0( 2 )
10892 ib2( 1 ) = ib0( 1 )
10893 ib2( 2 ) = ib0( 2 )
10894*
10895 160 CONTINUE
10896*
10897 jj = jj + jb
10898*
10899 IF( jblk.EQ.1 ) THEN
10900*
10901* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10902*
10903 lcmtc = lcmtc + jmp( jmp_nqinbloc )
10904 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
10905*
10906 ELSE
10907*
10908* Jump NPCOL * NB columns
10909*
10910 lcmtc = lcmtc + jmp( jmp_nqnb )
10911 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
10912*
10913 END IF
10914*
10915 ib1( 1 ) = ib0( 1 )
10916 ib1( 2 ) = ib0( 2 )
10917 ib2( 1 ) = ib0( 1 )
10918 ib2( 2 ) = ib0( 2 )
10919 ib3( 1 ) = ib0( 1 )
10920 ib3( 2 ) = ib0( 2 )
10921*
10922 170 CONTINUE
10923*
10924 ELSE
10925*
10926* generate upper trapezoidal part
10927*
10928 ii = 1
10929 lcmtr = lcmt00
10930*
10931 DO 250 iblk = 1, mblks
10932*
10933 IF( iblk.EQ.1 ) THEN
10934 ib = imbloc
10935 upp = imbloc - 1
10936 ELSE IF( iblk.EQ.mblks ) THEN
10937 ib = lmbloc
10938 upp = mb - 1
10939 ELSE
10940 ib = mb
10941 upp = mb - 1
10942 END IF
10943*
10944 DO 240 ik = ii, ii + ib - 1
10945*
10946 jj = 1
10947 lcmtc = lcmtr
10948*
10949 DO 230 jblk = 1, nblks
10950*
10951 IF( jblk.EQ.1 ) THEN
10952 jb = inbloc
10953 low = 1 - inbloc
10954 ELSE IF( jblk.EQ.nblks ) THEN
10955 jb = lnbloc
10956 low = 1 - nb
10957 ELSE
10958 jb = nb
10959 low = 1 - nb
10960 END IF
10961*
10962* Blocks are IB by JB
10963*
10964 IF( lcmtc.LT.low ) THEN
10965*
10966 DO 180 jk = jj, jj + jb - 1
10967 dummy = dcmplx( pb_drand( 0 ),
10968 $ pb_drand( 0 ) )
10969 180 CONTINUE
10970*
10971 ELSE IF( lcmtc.LE.upp ) THEN
10972*
10973 itmp = ik - ii + 1
10974 mnb = max( 0, lcmtc )
10975*
10976 IF( itmp.LE.min( mnb, ib ) ) THEN
10977*
10978 DO 190 jk = jj, jj + jb - 1
10979 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10980 $ pb_drand( 0 ) )
10981 190 CONTINUE
10982*
10983 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
10984 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
10985*
10986 jtmp = jj + itmp - lcmtc - 1
10987*
10988 DO 200 jk = jj, jtmp - 1
10989 dummy = dcmplx( pb_drand( 0 ),
10990 $ pb_drand( 0 ) )
10991 200 CONTINUE
10992*
10993 DO 210 jk = jtmp, jj + jb - 1
10994 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10995 $ pb_drand( 0 ) )
10996 210 CONTINUE
10997*
10998 END IF
10999*
11000 ELSE
11001*
11002 DO 220 jk = jj, jj + jb - 1
11003 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11004 $ pb_drand( 0 ) )
11005 220 CONTINUE
11006*
11007 END IF
11008*
11009 jj = jj + jb
11010*
11011 IF( jblk.EQ.1 ) THEN
11012*
11013* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11014*
11015 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11016 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11017 $ ib0 )
11018*
11019 ELSE
11020*
11021* Jump NPCOL * NB columns
11022*
11023 lcmtc = lcmtc + jmp( jmp_nqnb )
11024 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11025 $ ib0 )
11026*
11027 END IF
11028*
11029 ib1( 1 ) = ib0( 1 )
11030 ib1( 2 ) = ib0( 2 )
11031*
11032 230 CONTINUE
11033*
11034* Jump one row
11035*
11036 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11037*
11038 ib1( 1 ) = ib0( 1 )
11039 ib1( 2 ) = ib0( 2 )
11040 ib2( 1 ) = ib0( 1 )
11041 ib2( 2 ) = ib0( 2 )
11042*
11043 240 CONTINUE
11044*
11045 ii = ii + ib
11046*
11047 IF( iblk.EQ.1 ) THEN
11048*
11049* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11050*
11051 lcmtr = lcmtr - jmp( jmp_npimbloc )
11052 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11053*
11054 ELSE
11055*
11056* Jump NPROW * MB rows
11057*
11058 lcmtr = lcmtr - jmp( jmp_npmb )
11059 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11060*
11061 END IF
11062*
11063 ib1( 1 ) = ib0( 1 )
11064 ib1( 2 ) = ib0( 2 )
11065 ib2( 1 ) = ib0( 1 )
11066 ib2( 2 ) = ib0( 2 )
11067 ib3( 1 ) = ib0( 1 )
11068 ib3( 2 ) = ib0( 2 )
11069*
11070 250 CONTINUE
11071*
11072 END IF
11073*
11074 ELSE IF( lsame( aform, 'C' ) ) THEN
11075*
11076* Generate the conjugate transpose of the matrix that would be
11077* normally generated.
11078*
11079 ii = 1
11080*
11081 DO 290 iblk = 1, mblks
11082*
11083 IF( iblk.EQ.1 ) THEN
11084 ib = imbloc
11085 ELSE IF( iblk.EQ.mblks ) THEN
11086 ib = lmbloc
11087 ELSE
11088 ib = mb
11089 END IF
11090*
11091 DO 280 ik = ii, ii + ib - 1
11092*
11093 jj = 1
11094*
11095 DO 270 jblk = 1, nblks
11096*
11097 IF( jblk.EQ.1 ) THEN
11098 jb = inbloc
11099 ELSE IF( jblk.EQ.nblks ) THEN
11100 jb = lnbloc
11101 ELSE
11102 jb = nb
11103 END IF
11104*
11105* Blocks are IB by JB
11106*
11107 DO 260 jk = jj, jj + jb - 1
11108 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11109 $ -pb_drand( 0 ) )
11110 260 CONTINUE
11111*
11112 jj = jj + jb
11113*
11114 IF( jblk.EQ.1 ) THEN
11115*
11116* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11117*
11118 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11119 $ ib0 )
11120*
11121 ELSE
11122*
11123* Jump NPCOL * NB columns
11124*
11125 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11126 $ ib0 )
11127*
11128 END IF
11129*
11130 ib1( 1 ) = ib0( 1 )
11131 ib1( 2 ) = ib0( 2 )
11132*
11133 270 CONTINUE
11134*
11135* Jump one row
11136*
11137 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11138*
11139 ib1( 1 ) = ib0( 1 )
11140 ib1( 2 ) = ib0( 2 )
11141 ib2( 1 ) = ib0( 1 )
11142 ib2( 2 ) = ib0( 2 )
11143*
11144 280 CONTINUE
11145*
11146 ii = ii + ib
11147*
11148 IF( iblk.EQ.1 ) THEN
11149*
11150* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11151*
11152 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11153*
11154 ELSE
11155*
11156* Jump NPROW * MB rows
11157*
11158 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11159*
11160 END IF
11161*
11162 ib1( 1 ) = ib0( 1 )
11163 ib1( 2 ) = ib0( 2 )
11164 ib2( 1 ) = ib0( 1 )
11165 ib2( 2 ) = ib0( 2 )
11166 ib3( 1 ) = ib0( 1 )
11167 ib3( 2 ) = ib0( 2 )
11168*
11169 290 CONTINUE
11170*
11171 ELSE IF( lsame( aform, 'H' ) ) THEN
11172*
11173* Generate a Hermitian matrix
11174*
11175 IF( lsame( uplo, 'L' ) ) THEN
11176*
11177* generate lower trapezoidal part
11178*
11179 jj = 1
11180 lcmtc = lcmt00
11181*
11182 DO 370 jblk = 1, nblks
11183*
11184 IF( jblk.EQ.1 ) THEN
11185 jb = inbloc
11186 low = 1 - inbloc
11187 ELSE IF( jblk.EQ.nblks ) THEN
11188 jb = lnbloc
11189 low = 1 - nb
11190 ELSE
11191 jb = nb
11192 low = 1 - nb
11193 END IF
11194*
11195 DO 360 jk = jj, jj + jb - 1
11196*
11197 ii = 1
11198 lcmtr = lcmtc
11199*
11200 DO 350 iblk = 1, mblks
11201*
11202 IF( iblk.EQ.1 ) THEN
11203 ib = imbloc
11204 upp = imbloc - 1
11205 ELSE IF( iblk.EQ.mblks ) THEN
11206 ib = lmbloc
11207 upp = mb - 1
11208 ELSE
11209 ib = mb
11210 upp = mb - 1
11211 END IF
11212*
11213* Blocks are IB by JB
11214*
11215 IF( lcmtr.GT.upp ) THEN
11216*
11217 DO 300 ik = ii, ii + ib - 1
11218 dummy = dcmplx( pb_drand( 0 ),
11219 $ pb_drand( 0 ) )
11220 300 CONTINUE
11221*
11222 ELSE IF( lcmtr.GE.low ) THEN
11223*
11224 jtmp = jk - jj + 1
11225 mnb = max( 0, -lcmtr )
11226*
11227 IF( jtmp.LE.min( mnb, jb ) ) THEN
11228*
11229 DO 310 ik = ii, ii + ib - 1
11230 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11231 $ pb_drand( 0 ) )
11232 310 CONTINUE
11233*
11234 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
11235 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
11236*
11237 itmp = ii + jtmp + lcmtr - 1
11238*
11239 DO 320 ik = ii, itmp - 1
11240 dummy = dcmplx( pb_drand( 0 ),
11241 $ pb_drand( 0 ) )
11242 320 CONTINUE
11243*
11244 IF( itmp.LE.( ii + ib - 1 ) ) THEN
11245 dummy = dcmplx( pb_drand( 0 ),
11246 $ -pb_drand( 0 ) )
11247 a( itmp, jk ) = dcmplx( dble( dummy ),
11248 $ zero )
11249 END IF
11250*
11251 DO 330 ik = itmp + 1, ii + ib - 1
11252 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11253 $ pb_drand( 0 ) )
11254 330 CONTINUE
11255*
11256 END IF
11257*
11258 ELSE
11259*
11260 DO 340 ik = ii, ii + ib - 1
11261 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11262 $ pb_drand( 0 ) )
11263 340 CONTINUE
11264*
11265 END IF
11266*
11267 ii = ii + ib
11268*
11269 IF( iblk.EQ.1 ) THEN
11270*
11271* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11272*
11273 lcmtr = lcmtr - jmp( jmp_npimbloc )
11274 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
11275 $ ib0 )
11276*
11277 ELSE
11278*
11279* Jump NPROW * MB rows
11280*
11281 lcmtr = lcmtr - jmp( jmp_npmb )
11282 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
11283 $ ib0 )
11284*
11285 END IF
11286*
11287 ib1( 1 ) = ib0( 1 )
11288 ib1( 2 ) = ib0( 2 )
11289*
11290 350 CONTINUE
11291*
11292* Jump one column
11293*
11294 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
11295*
11296 ib1( 1 ) = ib0( 1 )
11297 ib1( 2 ) = ib0( 2 )
11298 ib2( 1 ) = ib0( 1 )
11299 ib2( 2 ) = ib0( 2 )
11300*
11301 360 CONTINUE
11302*
11303 jj = jj + jb
11304*
11305 IF( jblk.EQ.1 ) THEN
11306*
11307* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11308*
11309 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11310 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
11311*
11312 ELSE
11313*
11314* Jump NPCOL * NB columns
11315*
11316 lcmtc = lcmtc + jmp( jmp_nqnb )
11317 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
11318*
11319 END IF
11320*
11321 ib1( 1 ) = ib0( 1 )
11322 ib1( 2 ) = ib0( 2 )
11323 ib2( 1 ) = ib0( 1 )
11324 ib2( 2 ) = ib0( 2 )
11325 ib3( 1 ) = ib0( 1 )
11326 ib3( 2 ) = ib0( 2 )
11327*
11328 370 CONTINUE
11329*
11330 ELSE
11331*
11332* generate upper trapezoidal part
11333*
11334 ii = 1
11335 lcmtr = lcmt00
11336*
11337 DO 450 iblk = 1, mblks
11338*
11339 IF( iblk.EQ.1 ) THEN
11340 ib = imbloc
11341 upp = imbloc - 1
11342 ELSE IF( iblk.EQ.mblks ) THEN
11343 ib = lmbloc
11344 upp = mb - 1
11345 ELSE
11346 ib = mb
11347 upp = mb - 1
11348 END IF
11349*
11350 DO 440 ik = ii, ii + ib - 1
11351*
11352 jj = 1
11353 lcmtc = lcmtr
11354*
11355 DO 430 jblk = 1, nblks
11356*
11357 IF( jblk.EQ.1 ) THEN
11358 jb = inbloc
11359 low = 1 - inbloc
11360 ELSE IF( jblk.EQ.nblks ) THEN
11361 jb = lnbloc
11362 low = 1 - nb
11363 ELSE
11364 jb = nb
11365 low = 1 - nb
11366 END IF
11367*
11368* Blocks are IB by JB
11369*
11370 IF( lcmtc.LT.low ) THEN
11371*
11372 DO 380 jk = jj, jj + jb - 1
11373 dummy = dcmplx( pb_drand( 0 ),
11374 $ -pb_drand( 0 ) )
11375 380 CONTINUE
11376*
11377 ELSE IF( lcmtc.LE.upp ) THEN
11378*
11379 itmp = ik - ii + 1
11380 mnb = max( 0, lcmtc )
11381*
11382 IF( itmp.LE.min( mnb, ib ) ) THEN
11383*
11384 DO 390 jk = jj, jj + jb - 1
11385 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11386 $ -pb_drand( 0 ) )
11387 390 CONTINUE
11388*
11389 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
11390 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
11391*
11392 jtmp = jj + itmp - lcmtc - 1
11393*
11394 DO 400 jk = jj, jtmp - 1
11395 dummy = dcmplx( pb_drand( 0 ),
11396 $ -pb_drand( 0 ) )
11397 400 CONTINUE
11398*
11399 IF( jtmp.LE.( jj + jb - 1 ) ) THEN
11400 dummy = dcmplx( pb_drand( 0 ),
11401 $ -pb_drand( 0 ) )
11402 a( ik, jtmp ) = dcmplx( dble( dummy ),
11403 $ zero )
11404 END IF
11405*
11406 DO 410 jk = jtmp + 1, jj + jb - 1
11407 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11408 $ -pb_drand( 0 ) )
11409 410 CONTINUE
11410*
11411 END IF
11412*
11413 ELSE
11414*
11415 DO 420 jk = jj, jj + jb - 1
11416 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11417 $ -pb_drand( 0 ) )
11418 420 CONTINUE
11419*
11420 END IF
11421*
11422 jj = jj + jb
11423*
11424 IF( jblk.EQ.1 ) THEN
11425*
11426* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11427*
11428 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11429 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11430 $ ib0 )
11431*
11432 ELSE
11433*
11434* Jump NPCOL * NB columns
11435*
11436 lcmtc = lcmtc + jmp( jmp_nqnb )
11437 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11438 $ ib0 )
11439*
11440 END IF
11441*
11442 ib1( 1 ) = ib0( 1 )
11443 ib1( 2 ) = ib0( 2 )
11444*
11445 430 CONTINUE
11446*
11447* Jump one row
11448*
11449 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11450*
11451 ib1( 1 ) = ib0( 1 )
11452 ib1( 2 ) = ib0( 2 )
11453 ib2( 1 ) = ib0( 1 )
11454 ib2( 2 ) = ib0( 2 )
11455*
11456 440 CONTINUE
11457*
11458 ii = ii + ib
11459*
11460 IF( iblk.EQ.1 ) THEN
11461*
11462* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11463*
11464 lcmtr = lcmtr - jmp( jmp_npimbloc )
11465 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11466*
11467 ELSE
11468*
11469* Jump NPROW * MB rows
11470*
11471 lcmtr = lcmtr - jmp( jmp_npmb )
11472 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11473*
11474 END IF
11475*
11476 ib1( 1 ) = ib0( 1 )
11477 ib1( 2 ) = ib0( 2 )
11478 ib2( 1 ) = ib0( 1 )
11479 ib2( 2 ) = ib0( 2 )
11480 ib3( 1 ) = ib0( 1 )
11481 ib3( 2 ) = ib0( 2 )
11482*
11483 450 CONTINUE
11484*
11485 END IF
11486*
11487 END IF
11488*
11489 RETURN
11490*
11491* End of PB_ZLAGEN
11492*
11493 END
11494 DOUBLE PRECISION FUNCTION pb_drand( IDUMM )
11495*
11496* -- PBLAS test routine (version 2.0) --
11497* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
11498* and University of California, Berkeley.
11499* April 1, 1998
11500*
11501* .. Scalar Arguments ..
11502 INTEGER idumm
11503* ..
11504*
11505* Purpose
11506* =======
11507*
11508* PB_DRAND generates the next number in the random sequence. This func-
11509* tion ensures that this number will be in the interval ( -1.0, 1.0 ).
11510*
11511* Arguments
11512* =========
11513*
11514* IDUMM (local input) INTEGER
11515* This argument is ignored, but necessary to a FORTRAN 77 func-
11516* tion.
11517*
11518* Further Details
11519* ===============
11520*
11521* On entry, the array IRAND stored in the common block RANCOM contains
11522* the information (2 integers) required to generate the next number in
11523* the sequence X( n ). This number is computed as
11524*
11525* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
11526*
11527* where the constant d is the largest 32 bit positive integer. The
11528* array IRAND is then updated for the generation of the next number
11529* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
11530* The constants a and c should have been preliminarily stored in the
11531* array IACS as 2 pairs of integers. The initial set up of IRAND and
11532* IACS is performed by the routine PB_SETRAN.
11533*
11534* -- Written on April 1, 1998 by
11535* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
11536*
11537* =====================================================================
11538*
11539* .. Parameters ..
11540 DOUBLE PRECISION one, two
11541 PARAMETER ( one = 1.0d+0, two = 2.0d+0 )
11542* ..
11543* .. External Functions ..
11544 DOUBLE PRECISION pb_dran
11545 EXTERNAL PB_DRAN
11546* ..
11547* .. Executable Statements ..
11548*
11549 pb_drand = one - two * pb_dran( idumm )
11550*
11551 RETURN
11552*
11553* End of PB_DRAND
11554*
11555 END
11556 DOUBLE PRECISION FUNCTION pb_dran( IDUMM )
11557*
11558* -- PBLAS test routine (version 2.0) --
11559* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
11560* and University of California, Berkeley.
11561* April 1, 1998
11562*
11563* .. Scalar Arguments ..
11564 INTEGER idumm
11565* ..
11566*
11567* Purpose
11568* =======
11569*
11570* PB_DRAN generates the next number in the random sequence.
11571*
11572* Arguments
11573* =========
11574*
11575* IDUMM (local input) INTEGER
11576* This argument is ignored, but necessary to a FORTRAN 77 func-
11577* tion.
11578*
11579* Further Details
11580* ===============
11581*
11582* On entry, the array IRAND stored in the common block RANCOM contains
11583* the information (2 integers) required to generate the next number in
11584* the sequence X( n ). This number is computed as
11585*
11586* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
11587*
11588* where the constant d is the largest 32 bit positive integer. The
11589* array IRAND is then updated for the generation of the next number
11590* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
11591* The constants a and c should have been preliminarily stored in the
11592* array IACS as 2 pairs of integers. The initial set up of IRAND and
11593* IACS is performed by the routine PB_SETRAN.
11594*
11595* -- Written on April 1, 1998 by
11596* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
11597*
11598* =====================================================================
11599*
11600* .. Parameters ..
11601 DOUBLE PRECISION divfac, pow16
11602 PARAMETER ( divfac = 2.147483648d+9,
11603 $ pow16 = 6.5536d+4 )
11604* ..
11605* .. Local Arrays ..
11606 INTEGER j( 2 )
11607* ..
11608* .. External Subroutines ..
11609 EXTERNAL pb_ladd, pb_lmul
11610* ..
11611* .. Intrinsic Functions ..
11612 INTRINSIC dble
11613* ..
11614* .. Common Blocks ..
11615 INTEGER iacs( 4 ), irand( 2 )
11616 common /rancom/ irand, iacs
11617* ..
11618* .. Save Statements ..
11619 SAVE /rancom/
11620* ..
11621* .. Executable Statements ..
11622*
11623 pb_dran = ( dble( irand( 1 ) ) + pow16 * dble( irand( 2 ) ) ) /
11624 $ divfac
11625*
11626 CALL pb_lmul( irand, iacs, j )
11627 CALL pb_ladd( j, iacs( 3 ), irand )
11628*
11629 RETURN
11630*
11631* End of PB_DRAN
11632*
11633 END
alpha
#define alpha
Definition eval.h:35
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_ainfog2l
subroutine pb_ainfog2l(m, n, i, j, desc, nprow, npcol, myrow, mycol, imb1, inb1, mp, nq, ii, jj, prow, pcol, rprow, rpcol)
Definition pblastst.f:2023
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastst.f:4480
pb_binfo
subroutine pb_binfo(offd, m, n, imb1, inb1, mb, nb, mrrow, mrcol, lcmt00, mblks, nblks, imbloc, inbloc, lmbloc, lnbloc, ilow, low, iupp, upp)
Definition pblastst.f:3577
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastst.f:4759
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastst.f:3910
pchkpbe
subroutine pchkpbe(ictxt, nout, sname, infot)
Definition pblastst.f:1084
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastst.f:2742
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastst.f:4559
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastst.f:4648
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastst.f:4302
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastst.f:4196
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastst.f:2964
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastst.f:4045
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822
pzcallsub
subroutine pzcallsub(subptr, scode)
Definition pzblastst.f:2183
pzipset
subroutine pzipset(toggle, n, a, ia, ja, desca)
Definition pzblastst.f:7045
pzlaset
subroutine pzlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
Definition pzblastst.f:7509
pzvecee
subroutine pzvecee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:936
pb_dran
double precision function pb_dran(idumm)
Definition pzblastst.f:11557
pb_zlaset
subroutine pb_zlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pzblastst.f:10049
pb_zchekpad
subroutine pb_zchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9875
pzsetpblas
subroutine pzsetpblas(ictxt)
Definition pzblastst.f:1478
pb_zlagen
subroutine pb_zlagen(uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
Definition pzblastst.f:10427
pb_zfillpad
subroutine pb_zfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9762
pzchkmat
subroutine pzchkmat(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:1677
pzmatee
subroutine pzmatee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:1190
pzchkopt
subroutine pzchkopt(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:266
pb_drand
double precision function pb_drand(idumm)
Definition pzblastst.f:11495
pzerraxpby
subroutine pzerraxpby(errbnd, alpha, x, beta, y, prec)
Definition pzblastst.f:6944
pzladom
subroutine pzladom(inplace, n, alpha, a, ia, ja, desca)
Definition pzblastst.f:8896
pb_pzlaprn2
subroutine pb_pzlaprn2(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, prow, pcol, work)
Definition pzblastst.f:9518
pb_pzlaprnt
subroutine pb_pzlaprnt(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, work)
Definition pzblastst.f:9304
pb_zlascal
subroutine pb_zlascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pzblastst.f:10246
pzlagen
subroutine pzlagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition pzblastst.f:8492
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pzblastst.f:7456
pzchkdim
subroutine pzchkdim(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:759
pzoptee
subroutine pzoptee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:2
pzdimee
subroutine pzdimee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:455