OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
psblastst.f
Go to the documentation of this file.
1 SUBROUTINE psoptee( 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* PSOPTEE 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 pschkopt
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 pschkopt( 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 pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
177*
178* Check 2nd option
179*
180 apos = 2
181 CALL pschkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
182*
183* Check 3rd option
184*
185 apos = 3
186 CALL pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
196*
197* Check 2'nd option
198*
199 apos = 2
200 CALL pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
208*
209* Check 2nd option
210*
211 apos = 2
212 CALL pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
221*
222* Check 2'nd option
223*
224 apos = 2
225 CALL pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
233*
234* Check 2nd option
235*
236 apos = 2
237 CALL pschkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
238*
239* Check 3rd option
240*
241 apos = 3
242 CALL pschkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
243*
244* Check 4th option
245*
246 apos = 4
247 CALL pschkopt( 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 pschkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
256*
257 END IF
258*
259 RETURN
260*
261* End of PSOPTEE
262*
263 END
264 SUBROUTINE pschkopt( 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* PSCHKOPT 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, pscallsub, pssetpblas
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 pssetpblas( 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 pscallsub( subptr, scode )
447 CALL pchkpbe( ictxt, nout, sname, infot )
448*
449 RETURN
450*
451* End of PSCHKOPT
452*
453 END
454 SUBROUTINE psdimee( 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* PSDIMEE 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 pschkdim
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 pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
625*
626* Check 2nd dimension
627*
628 apos = 3
629 CALL pschkdim( 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 pschkdim( 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 pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
652*
653* Check 2nd dimension
654*
655 apos = 2
656 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
666*
667* Check 2nd dimension
668*
669 apos = 4
670 CALL pschkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
671*
672* Check 3rd dimension
673*
674 apos = 5
675 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
683*
684* Check 2nd dimension
685*
686 apos = 4
687 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
696*
697* Check 2nd dimension
698*
699 apos = 4
700 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
708*
709* Check 2nd dimension
710*
711 apos = 2
712 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
720*
721* Check 2nd dimension
722*
723 apos = 6
724 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
732*
733* Check 2nd dimension
734*
735 apos = 3
736 CALL pschkdim( 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 pschkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
744*
745* Check 2nd dimension
746*
747 apos = 4
748 CALL pschkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
749*
750 END IF
751*
752 RETURN
753*
754* End of PSDIMEE
755*
756 END
757 SUBROUTINE pschkdim( 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* PSCHKDIM 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, pscallsub, pssetpblas
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 pssetpblas( 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 pscallsub( subptr, scode )
928 CALL pchkpbe( ictxt, nout, sname, infot )
929*
930 RETURN
931*
932* End of PSCHKDIM
933*
934 END
935 SUBROUTINE psvecee( 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* PSVECEE 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 pschkmat
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 pschkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1098*
1099* Check 2nd vector
1100*
1101 apos = 7
1102 CALL pschkmat( 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 pschkmat( 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 pschkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1117*
1118* Check 2nd vector
1119*
1120 apos = 8
1121 CALL pschkmat( 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 pschkmat( 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 pschkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1138*
1139* Check 2nd vector
1140*
1141 apos = 15
1142 CALL pschkmat( 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 pschkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1150*
1151* Check 2nd vector
1152*
1153 apos = 14
1154 CALL pschkmat( 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 pschkmat( 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 pschkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1169*
1170* Check 2nd vector
1171*
1172 apos = 9
1173 CALL pschkmat( 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 pschkmat( ictxt, nout, subptr, scode, sname, 'x', APOS )
1181*
1182 END IF
1183*
1184 RETURN
1185*
1186* End of PSVECEE
1187*
1188 END
1189 SUBROUTINE PSMATEE( 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* PSMATEE 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 PSCHKMAT
1341* ..
1342* .. Executable Statements ..
1343*
1344* Level 2 PBLAS
1345*
1346.EQ..OR..EQ. IF( SCODE21 SCODE23 ) THEN
1347*
1348* Check 1st (and only) matrix
1349*
1350 APOS = 5
1351 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1352*
1353.EQ. ELSE IF( SCODE22 ) THEN
1354*
1355* Check 1st (and only) matrix
1356*
1357 APOS = 4
1358 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1359*
1360.EQ..OR..EQ. ELSE IF( SCODE24 SCODE27 ) THEN
1361*
1362* Check 1st (and only) matrix
1363*
1364 APOS = 14
1365 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1366*
1367.EQ..OR..EQ. ELSE IF( SCODE25 SCODE26 ) THEN
1368*
1369* Check 1st (and only) matrix
1370*
1371 APOS = 9
1372 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1373*
1374* Level 3 PBLAS
1375*
1376.EQ. ELSE IF( SCODE31 ) THEN
1377*
1378* Check 1st matrix
1379*
1380 APOS = 7
1381 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1382*
1383* Check 2nd matrix
1384*
1385 APOS = 11
1386 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', APOS )
1387*
1388* Check 3nd matrix
1389*
1390 APOS = 16
1391 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1399*
1400* Check 2nd matrix
1401*
1402 APOS = 10
1403 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', APOS )
1404*
1405* Check 3nd matrix
1406*
1407 APOS = 15
1408 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1416*
1417* Check 2nd matrix
1418*
1419 APOS = 11
1420 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1428*
1429* Check 2nd matrix
1430*
1431 APOS = 9
1432 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1440*
1441* Check 2nd matrix
1442*
1443 APOS = 12
1444 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1452*
1453* Check 2nd matrix
1454*
1455 APOS = 10
1456 CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
1464*
1465* Check 2nd matrix
1466*
1467 APOS = 11
1468 CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'c', APOS )
1469*
1470 END IF
1471*
1472 RETURN
1473*
1474* End of PSMATEE
1475*
1476 END
1477 SUBROUTINE PSSETPBLAS( 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* PSSETPBLAS 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 REAL ONE
1578 PARAMETER ( ONE = 1.0E+0 )
1579* ..
1580* .. External Subroutines ..
1581 EXTERNAL PB_DESCSET2
1582* ..
1583* .. Common Blocks ..
1584 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
1585 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1586 $ JC, JX, JY, KDIM, MDIM, NDIM
1587 REAL USCLR, SCLR
1588 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1589 $ DESCX( DLEN_ ), DESCY( DLEN_ )
1590 REAL A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
1591 COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
1592 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
1593 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
1594 $ JA, JB, JC, JX, JY
1595 COMMON /PBLASM/A, B, C
1596 COMMON /PBLASN/KDIM, MDIM, NDIM
1597 COMMON /PBLASS/SCLR, USCLR
1598 COMMON /PBLASV/X, Y
1599* ..
1600* .. Executable Statements ..
1601*
1602* Set default values for options
1603*
1604 DIAG = 'n'
1605 SIDE = 'l'
1606 TRANSA = 'n'
1607 TRANSB = 'n'
1608 UPLO = 'u'
1609*
1610* Set default values for scalars
1611*
1612 KDIM = 1
1613 MDIM = 1
1614 NDIM = 1
1615 ISCLR = 1
1616 SCLR = ONE
1617 USCLR = ONE
1618*
1619* Set default values for distributed matrix A
1620*
1621 A( 1, 1 ) = ONE
1622 A( 2, 1 ) = ONE
1623 A( 1, 2 ) = ONE
1624 A( 2, 2 ) = ONE
1625 IA = 1
1626 JA = 1
1627 CALL PB_DESCSET2( DESCA, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1628*
1629* Set default values for distributed matrix B
1630*
1631 B( 1, 1 ) = ONE
1632 B( 2, 1 ) = ONE
1633 B( 1, 2 ) = ONE
1634 B( 2, 2 ) = ONE
1635 IB = 1
1636 JB = 1
1637 CALL PB_DESCSET2( DESCB, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1638*
1639* Set default values for distributed matrix C
1640*
1641 C( 1, 1 ) = ONE
1642 C( 2, 1 ) = ONE
1643 C( 1, 2 ) = ONE
1644 C( 2, 2 ) = ONE
1645 IC = 1
1646 JC = 1
1647 CALL PB_DESCSET2( DESCC, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1648*
1649* Set default values for distributed matrix X
1650*
1651 X( 1 ) = ONE
1652 X( 2 ) = ONE
1653 IX = 1
1654 JX = 1
1655 CALL PB_DESCSET2( DESCX, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1656 INCX = 1
1657*
1658* Set default values for distributed matrix Y
1659*
1660 Y( 1 ) = ONE
1661 Y( 2 ) = ONE
1662 IY = 1
1663 JY = 1
1664 CALL PB_DESCSET2( DESCY, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1665 INCY = 1
1666*
1667 RETURN
1668*
1669* End of PSSETPBLAS
1670*
1671 END
1672 SUBROUTINE PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
1673 $ ARGPOS )
1674*
1675* -- PBLAS test routine (version 2.0) --
1676* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1677* and University of California, Berkeley.
1678* April 1, 1998
1679*
1680* .. Scalar Arguments ..
1681 CHARACTER*1 ARGNAM
1682 INTEGER ARGPOS, ICTXT, NOUT, SCODE
1683* ..
1684* .. Array Arguments ..
1685 CHARACTER*(*) SNAME
1686* ..
1687* .. Subroutine Arguments ..
1688 EXTERNAL SUBPTR
1689* ..
1690*
1691* Purpose
1692* =======
1693*
1694* PSCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
1695*
1696* Notes
1697* =====
1698*
1699* A description vector is associated with each 2D block-cyclicly dis-
1700* tributed matrix. This vector stores the information required to
1701* establish the mapping between a matrix entry and its corresponding
1702* process and memory location.
1703*
1704* In the following comments, the character _ should be read as
1705* "of the distributed matrix". Let A be a generic term for any 2D
1706* block cyclicly distributed matrix. Its description vector is DESCA:
1707*
1708* NOTATION STORED IN EXPLANATION
1709* ---------------- --------------- ------------------------------------
1710* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1711* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1712* the NPROW x NPCOL BLACS process grid
1713* A is distributed over. The context
1714* itself is global, but the handle
1715* (the integer value) may vary.
1716* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1717* ted matrix A, M_A >= 0.
1718* N_A (global) DESCA( N_ ) The number of columns in the distri-
1719* buted matrix A, N_A >= 0.
1720* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1721* block of the matrix A, IMB_A > 0.
1722* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1723* left block of the matrix A,
1724* INB_A > 0.
1725* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1726* bute the last M_A-IMB_A rows of A,
1727* MB_A > 0.
1728* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1729* bute the last N_A-INB_A columns of
1730* A, NB_A > 0.
1731* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1732* row of the matrix A is distributed,
1733* NPROW > RSRC_A >= 0.
1734* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1735* first column of A is distributed.
1736* NPCOL > CSRC_A >= 0.
1737* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1738* array storing the local blocks of
1739* the distributed matrix A,
1740* IF( Lc( 1, N_A ) > 0 )
1741* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1742* ELSE
1743* LLD_A >= 1.
1744*
1745* Let K be the number of rows of a matrix A starting at the global in-
1746* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1747* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1748* receive if these K rows were distributed over NPROW processes. If K
1749* is the number of columns of a matrix A starting at the global index
1750* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1751* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1752* these K columns were distributed over NPCOL processes.
1753*
1754* The values of Lr() and Lc() may be determined via a call to the func-
1755* tion PB_NUMROC:
1756* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1757* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1758*
1759* Arguments
1760* =========
1761*
1762* ICTXT (local input) INTEGER
1763* On entry, ICTXT specifies the BLACS context handle, indica-
1764* ting the global context of the operation. The context itself
1765* is global, but the value of ICTXT is local.
1766*
1767* NOUT (global input) INTEGER
1768* On entry, NOUT specifies the unit number for the output file.
1769* When NOUT is 6, output to screen, when NOUT is 0, output to
1770* stderr. NOUT is only defined for process 0.
1771*
1772* SUBPTR (global input) SUBROUTINE
1773* On entry, SUBPTR is a subroutine. SUBPTR must be declared
1774* EXTERNAL in the calling subroutine.
1775*
1776* SCODE (global input) INTEGER
1777* On entry, SCODE specifies the calling sequence code.
1778*
1779* SNAME (global input) CHARACTER*(*)
1780* On entry, SNAME specifies the subroutine name calling this
1781* subprogram.
1782*
1783* ARGNAM (global input) CHARACTER*(*)
1784* On entry, ARGNAM specifies the name of the matrix or vector
1785* to be checked. ARGNAM can either be 'A', 'B' or 'C' when one
1786* wants to check a matrix, and 'X' or 'Y' for a vector.
1787*
1788* ARGPOS (global input) INTEGER
1789* On entry, ARGPOS indicates the position of the first argument
1790* of the matrix (or vector) ARGNAM.
1791*
1792* -- Written on April 1, 1998 by
1793* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1794*
1795* =====================================================================
1796*
1797* .. Parameters ..
1798 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1799 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1800 $ RSRC_
1801 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
1802 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
1803 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
1804 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
1805 INTEGER DESCMULT
1806 PARAMETER ( DESCMULT = 100 )
1807* ..
1808* .. Local Scalars ..
1809 INTEGER I, INFOT, NPROW, NPCOL, MYROW, MYCOL
1810* ..
1811* .. External Subroutines ..
1812 EXTERNAL BLACS_GRIDINFO, PCHKPBE, PSCALLSUB, PSSETPBLAS
1813* ..
1814* .. External Functions ..
1815 LOGICAL LSAME
1816 EXTERNAL LSAME
1817* ..
1818* .. Common Blocks ..
1819 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1820 $ JC, JX, JY
1821 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1822 $ DESCX( DLEN_ ), DESCY( DLEN_ )
1823 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
1824 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
1825 $ JA, JB, JC, JX, JY
1826* ..
1827* .. Executable Statements ..
1828*
1829 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
1830*
1831 IF( LSAME( ARGNAM, 'a' ) ) THEN
1832*
1833* Check IA. Set all other OK, bad IA
1834*
1835 CALL PSSETPBLAS( ICTXT )
1836 IA = -1
1837 INFOT = ARGPOS + 1
1838 CALL PSCALLSUB( SUBPTR, SCODE )
1839 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1840*
1841* Check JA. Set all other OK, bad JA
1842*
1843 CALL PSSETPBLAS( ICTXT )
1844 JA = -1
1845 INFOT = ARGPOS + 2
1846 CALL PSCALLSUB( SUBPTR, SCODE )
1847 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1848*
1849* Check DESCA. Set all other OK, bad DESCA
1850*
1851 DO 10 I = 1, DLEN_
1852*
1853* Set I'th entry of DESCA to incorrect value, rest ok.
1854*
1855 CALL PSSETPBLAS( ICTXT )
1856 DESCA( I ) = -2
1857 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
1858 CALL PSCALLSUB( SUBPTR, SCODE )
1859 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1860*
1861* Extra tests for RSRCA, CSRCA, LDA
1862*
1863.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1864.EQ. $ ( ILLD_ ) ) THEN
1865*
1866 CALL PSSETPBLAS( ICTXT )
1867*
1868* Test RSRCA >= NPROW
1869*
1870.EQ. IF( IRSRC_ )
1871 $ DESCA( I ) = NPROW
1872*
1873* Test CSRCA >= NPCOL
1874*
1875.EQ. IF( ICSRC_ )
1876 $ DESCA( I ) = NPCOL
1877*
1878* Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1879*
1880.EQ. IF( ILLD_ ) THEN
1881.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1882 DESCA( I ) = 1
1883 ELSE
1884 DESCA( I ) = 0
1885 END IF
1886 END IF
1887*
1888 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
1889 CALL PSCALLSUB( SUBPTR, SCODE )
1890 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1891*
1892 END IF
1893*
1894 10 CONTINUE
1895*
1896 ELSE IF( LSAME( ARGNAM, 'b' ) ) THEN
1897*
1898* Check IB. Set all other OK, bad IB
1899*
1900 CALL PSSETPBLAS( ICTXT )
1901 IB = -1
1902 INFOT = ARGPOS + 1
1903 CALL PSCALLSUB( SUBPTR, SCODE )
1904 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1905*
1906* Check JB. Set all other OK, bad JB
1907*
1908 CALL PSSETPBLAS( ICTXT )
1909 JB = -1
1910 INFOT = ARGPOS + 2
1911 CALL PSCALLSUB( SUBPTR, SCODE )
1912 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1913*
1914* Check DESCB. Set all other OK, bad DESCB
1915*
1916 DO 20 I = 1, DLEN_
1917*
1918* Set I'th entry of DESCB to incorrect value, rest ok.
1919*
1920 CALL PSSETPBLAS( ICTXT )
1921 DESCB( I ) = -2
1922 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
1923 CALL PSCALLSUB( SUBPTR, SCODE )
1924 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1925*
1926* Extra tests for RSRCB, CSRCB, LDB
1927*
1928.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1929.EQ. $ ( ILLD_ ) ) THEN
1930*
1931 CALL PSSETPBLAS( ICTXT )
1932*
1933* Test RSRCB >= NPROW
1934*
1935.EQ. IF( IRSRC_ )
1936 $ DESCB( I ) = NPROW
1937*
1938* Test CSRCB >= NPCOL
1939*
1940.EQ. IF( ICSRC_ )
1941 $ DESCB( I ) = NPCOL
1942*
1943* Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1944*
1945.EQ. IF( ILLD_ ) THEN
1946.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1947 DESCB( I ) = 1
1948 ELSE
1949 DESCB( I ) = 0
1950 END IF
1951 END IF
1952*
1953 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
1954 CALL PSCALLSUB( SUBPTR, SCODE )
1955 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1956*
1957 END IF
1958*
1959 20 CONTINUE
1960*
1961 ELSE IF( LSAME( ARGNAM, 'c' ) ) THEN
1962*
1963* Check IC. Set all other OK, bad IC
1964*
1965 CALL PSSETPBLAS( ICTXT )
1966 IC = -1
1967 INFOT = ARGPOS + 1
1968 CALL PSCALLSUB( SUBPTR, SCODE )
1969 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1970*
1971* Check JC. Set all other OK, bad JC
1972*
1973 CALL PSSETPBLAS( ICTXT )
1974 JC = -1
1975 INFOT = ARGPOS + 2
1976 CALL PSCALLSUB( SUBPTR, SCODE )
1977 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1978*
1979* Check DESCC. Set all other OK, bad DESCC
1980*
1981 DO 30 I = 1, DLEN_
1982*
1983* Set I'th entry of DESCC to incorrect value, rest ok.
1984*
1985 CALL PSSETPBLAS( ICTXT )
1986 DESCC( I ) = -2
1987 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
1988 CALL PSCALLSUB( SUBPTR, SCODE )
1989 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1990*
1991* Extra tests for RSRCC, CSRCC, LDC
1992*
1993.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
1994.EQ. $ ( ILLD_ ) ) THEN
1995*
1996 CALL PSSETPBLAS( ICTXT )
1997*
1998* Test RSRCC >= NPROW
1999*
2000.EQ. IF( IRSRC_ )
2001 $ DESCC( I ) = NPROW
2002*
2003* Test CSRCC >= NPCOL
2004*
2005.EQ. IF( ICSRC_ )
2006 $ DESCC( I ) = NPCOL
2007*
2008* Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2009*
2010.EQ. IF( ILLD_ ) THEN
2011.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
2012 DESCC( I ) = 1
2013 ELSE
2014 DESCC( I ) = 0
2015 END IF
2016 END IF
2017*
2018 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
2019 CALL PSCALLSUB( SUBPTR, SCODE )
2020 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2021*
2022 END IF
2023*
2024 30 CONTINUE
2025*
2026 ELSE IF( LSAME( ARGNAM, 'x' ) ) THEN
2027*
2028* Check IX. Set all other OK, bad IX
2029*
2030 CALL PSSETPBLAS( ICTXT )
2031 IX = -1
2032 INFOT = ARGPOS + 1
2033 CALL PSCALLSUB( SUBPTR, SCODE )
2034 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2035*
2036* Check JX. Set all other OK, bad JX
2037*
2038 CALL PSSETPBLAS( ICTXT )
2039 JX = -1
2040 INFOT = ARGPOS + 2
2041 CALL PSCALLSUB( SUBPTR, SCODE )
2042 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2043*
2044* Check DESCX. Set all other OK, bad DESCX
2045*
2046 DO 40 I = 1, DLEN_
2047*
2048* Set I'th entry of DESCX to incorrect value, rest ok.
2049*
2050 CALL PSSETPBLAS( ICTXT )
2051 DESCX( I ) = -2
2052 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
2053 CALL PSCALLSUB( SUBPTR, SCODE )
2054 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2055*
2056* Extra tests for RSRCX, CSRCX, LDX
2057*
2058.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
2059.EQ. $ ( ILLD_ ) ) THEN
2060*
2061 CALL PSSETPBLAS( ICTXT )
2062*
2063* Test RSRCX >= NPROW
2064*
2065.EQ. IF( IRSRC_ )
2066 $ DESCX( I ) = NPROW
2067*
2068* Test CSRCX >= NPCOL
2069*
2070.EQ. IF( ICSRC_ )
2071 $ DESCX( I ) = NPCOL
2072*
2073* Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2074*
2075.EQ. IF( ILLD_ ) THEN
2076.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
2077 DESCX( I ) = 1
2078 ELSE
2079 DESCX( I ) = 0
2080 END IF
2081 END IF
2082*
2083 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
2084 CALL PSCALLSUB( SUBPTR, SCODE )
2085 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2086*
2087 END IF
2088*
2089 40 CONTINUE
2090*
2091* Check INCX. Set all other OK, bad INCX
2092*
2093 CALL PSSETPBLAS( ICTXT )
2094 INCX = -1
2095 INFOT = ARGPOS + 4
2096 CALL PSCALLSUB( SUBPTR, SCODE )
2097 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2098*
2099 ELSE
2100*
2101* Check IY. Set all other OK, bad IY
2102*
2103 CALL PSSETPBLAS( ICTXT )
2104 IY = -1
2105 INFOT = ARGPOS + 1
2106 CALL PSCALLSUB( SUBPTR, SCODE )
2107 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2108*
2109* Check JY. Set all other OK, bad JY
2110*
2111 CALL PSSETPBLAS( ICTXT )
2112 JY = -1
2113 INFOT = ARGPOS + 2
2114 CALL PSCALLSUB( SUBPTR, SCODE )
2115 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2116*
2117* Check DESCY. Set all other OK, bad DESCY
2118*
2119 DO 50 I = 1, DLEN_
2120*
2121* Set I'th entry of DESCY to incorrect value, rest ok.
2122*
2123 CALL PSSETPBLAS( ICTXT )
2124 DESCY( I ) = -2
2125 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
2126 CALL PSCALLSUB( SUBPTR, SCODE )
2127 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2128*
2129* Extra tests for RSRCY, CSRCY, LDY
2130*
2131.EQ..OR..EQ..OR. IF( ( IRSRC_ ) ( ICSRC_ )
2132.EQ. $ ( ILLD_ ) ) THEN
2133*
2134 CALL PSSETPBLAS( ICTXT )
2135*
2136* Test RSRCY >= NPROW
2137*
2138.EQ. IF( IRSRC_ )
2139 $ DESCY( I ) = NPROW
2140*
2141* Test CSRCY >= NPCOL
2142*
2143.EQ. IF( ICSRC_ )
2144 $ DESCY( I ) = NPCOL
2145*
2146* Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2147*
2148.EQ. IF( ILLD_ ) THEN
2149.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
2150 DESCY( I ) = 1
2151 ELSE
2152 DESCY( I ) = 0
2153 END IF
2154 END IF
2155*
2156 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
2157 CALL PSCALLSUB( SUBPTR, SCODE )
2158 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2159*
2160 END IF
2161*
2162 50 CONTINUE
2163*
2164* Check INCY. Set all other OK, bad INCY
2165*
2166 CALL PSSETPBLAS( ICTXT )
2167 INCY = -1
2168 INFOT = ARGPOS + 4
2169 CALL PSCALLSUB( SUBPTR, SCODE )
2170 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
2171*
2172 END IF
2173*
2174 RETURN
2175*
2176* End of PSCHKMAT
2177*
2178 END
2179 SUBROUTINE PSCALLSUB( SUBPTR, SCODE )
2180*
2181* -- PBLAS test routine (version 2.0) --
2182* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2183* and University of California, Berkeley.
2184* April 1, 1998
2185*
2186* .. Scalar Arguments ..
2187 INTEGER SCODE
2188* ..
2189* .. Subroutine Arguments ..
2190 EXTERNAL SUBPTR
2191* ..
2192*
2193* Purpose
2194* =======
2195*
2196* PSCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
2197* tified by SCODE.
2198*
2199* Notes
2200* =====
2201*
2202* A description vector is associated with each 2D block-cyclicly dis-
2203* tributed matrix. This vector stores the information required to
2204* establish the mapping between a matrix entry and its corresponding
2205* process and memory location.
2206*
2207* In the following comments, the character _ should be read as
2208* "of the distributed matrix". Let A be a generic term for any 2D
2209* block cyclicly distributed matrix. Its description vector is DESCA:
2210*
2211* NOTATION STORED IN EXPLANATION
2212* ---------------- --------------- ------------------------------------
2213* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2214* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2215* the NPROW x NPCOL BLACS process grid
2216* A is distributed over. The context
2217* itself is global, but the handle
2218* (the integer value) may vary.
2219* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2220* ted matrix A, M_A >= 0.
2221* N_A (global) DESCA( N_ ) The number of columns in the distri-
2222* buted matrix A, N_A >= 0.
2223* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2224* block of the matrix A, IMB_A > 0.
2225* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2226* left block of the matrix A,
2227* INB_A > 0.
2228* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2229* bute the last M_A-IMB_A rows of A,
2230* MB_A > 0.
2231* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2232* bute the last N_A-INB_A columns of
2233* A, NB_A > 0.
2234* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2235* row of the matrix A is distributed,
2236* NPROW > RSRC_A >= 0.
2237* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2238* first column of A is distributed.
2239* NPCOL > CSRC_A >= 0.
2240* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2241* array storing the local blocks of
2242* the distributed matrix A,
2243* IF( Lc( 1, N_A ) > 0 )
2244* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2245* ELSE
2246* LLD_A >= 1.
2247*
2248* Let K be the number of rows of a matrix A starting at the global in-
2249* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2250* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2251* receive if these K rows were distributed over NPROW processes. If K
2252* is the number of columns of a matrix A starting at the global index
2253* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2254* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2255* these K columns were distributed over NPCOL processes.
2256*
2257* The values of Lr() and Lc() may be determined via a call to the func-
2258* tion PB_NUMROC:
2259* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2260* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2261*
2262* Arguments
2263* =========
2264*
2265* SUBPTR (global input) SUBROUTINE
2266* On entry, SUBPTR is a subroutine. SUBPTR must be declared
2267* EXTERNAL in the calling subroutine.
2268*
2269* SCODE (global input) INTEGER
2270* On entry, SCODE specifies the calling sequence code.
2271*
2272* Calling sequence encodings
2273* ==========================
2274*
2275* code Formal argument list Examples
2276*
2277* 11 (n, v1,v2) _SWAP, _COPY
2278* 12 (n,s1, v1 ) _SCAL, _SCAL
2279* 13 (n,s1, v1,v2) _AXPY, _DOT_
2280* 14 (n,s1,i1,v1 ) _AMAX
2281* 15 (n,u1, v1 ) _ASUM, _NRM2
2282*
2283* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2284* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2285* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2286* 24 ( m,n,s1,v1,v2,m1) _GER_
2287* 25 (uplo, n,s1,v1, m1) _SYR
2288* 26 (uplo, n,u1,v1, m1) _HER
2289* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2290*
2291* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2292* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2293* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2294* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2295* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2296* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2297* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2298* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2299* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2300* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2301*
2302* -- Written on April 1, 1998 by
2303* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2304*
2305* =====================================================================
2306*
2307* .. Parameters ..
2308 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2309 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2310 $ RSRC_
2311 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2312 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2313 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2314 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2315* ..
2316* .. Common Blocks ..
2317 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2318 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
2319 $ JC, JX, JY, KDIM, MDIM, NDIM
2320 REAL USCLR, SCLR
2321 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
2322 $ DESCX( DLEN_ ), DESCY( DLEN_ )
2323 REAL A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
2324 COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
2325 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
2326 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
2327 $ JA, JB, JC, JX, JY
2328 COMMON /PBLASM/A, B, C
2329 COMMON /PBLASN/KDIM, MDIM, NDIM
2330 COMMON /PBLASS/SCLR, USCLR
2331 COMMON /PBLASV/X, Y
2332* ..
2333* .. Executable Statements ..
2334*
2335* Level 1 PBLAS
2336*
2337.EQ. IF( SCODE11 ) THEN
2338*
2339 CALL SUBPTR( NDIM, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
2340 $ INCY )
2341*
2342.EQ. ELSE IF( SCODE12 ) THEN
2343*
2344 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX )
2345*
2346.EQ. ELSE IF( SCODE13 ) THEN
2347*
2348 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, JY,
2349 $ DESCY, INCY )
2350*
2351.EQ. ELSE IF( SCODE14 ) THEN
2352*
2353 CALL SUBPTR( NDIM, SCLR, ISCLR, X, IX, JX, DESCX, INCX )
2354*
2355.EQ. ELSE IF( SCODE15 ) THEN
2356*
2357 CALL SUBPTR( NDIM, USCLR, X, IX, JX, DESCX, INCX )
2358*
2359* Level 2 PBLAS
2360*
2361.EQ. ELSE IF( SCODE21 ) THEN
2362*
2363 CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, X, IX,
2364 $ JX, DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
2365*
2366.EQ. ELSE IF( SCODE22 ) THEN
2367*
2368 CALL SUBPTR( UPLO, NDIM, SCLR, A, IA, JA, DESCA, X, IX, JX,
2369 $ DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
2370*
2371.EQ. ELSE IF( SCODE23 ) THEN
2372*
2373 CALL SUBPTR( UPLO, TRANSA, DIAG, NDIM, A, IA, JA, DESCA, X, IX,
2374 $ JX, DESCX, INCX )
2375*
2376.EQ. ELSE IF( SCODE24 ) THEN
2377*
2378 CALL SUBPTR( MDIM, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
2379 $ JY, DESCY, INCY, A, IA, JA, DESCA )
2380*
2381.EQ. ELSE IF( SCODE25 ) THEN
2382*
2383 CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, A, IA,
2384 $ JA, DESCA )
2385*
2386.EQ. ELSE IF( SCODE26 ) THEN
2387*
2388 CALL SUBPTR( UPLO, NDIM, USCLR, X, IX, JX, DESCX, INCX, A, IA,
2389 $ JA, DESCA )
2390*
2391.EQ. ELSE IF( SCODE27 ) THEN
2392*
2393 CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
2394 $ JY, DESCY, INCY, A, IA, JA, DESCA )
2395*
2396* Level 3 PBLAS
2397*
2398.EQ. ELSE IF( SCODE31 ) THEN
2399*
2400 CALL SUBPTR( TRANSA, TRANSB, MDIM, NDIM, KDIM, SCLR, A, IA, JA,
2401 $ DESCA, B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
2402*
2403.EQ. ELSE IF( SCODE32 ) THEN
2404*
2405 CALL SUBPTR( SIDE, UPLO, MDIM, NDIM, SCLR, A, IA, JA, DESCA, B,
2406 $ IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
2407*
2408.EQ. ELSE IF( SCODE33 ) THEN
2409*
2410 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
2411 $ SCLR, C, IC, JC, DESCC )
2412*
2413.EQ. ELSE IF( SCODE34 ) THEN
2414*
2415 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, USCLR, A, IA, JA, DESCA,
2416 $ USCLR, C, IC, JC, DESCC )
2417*
2418.EQ. ELSE IF( SCODE35 ) THEN
2419*
2420 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
2421 $ B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
2422*
2423.EQ. ELSE IF( SCODE36 ) THEN
2424*
2425 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
2426 $ B, IB, JB, DESCB, USCLR, C, IC, JC, DESCC )
2427*
2428.EQ. ELSE IF( SCODE37 ) THEN
2429*
2430 CALL SUBPTR( MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, C, IC,
2431 $ JC, DESCC )
2432*
2433.EQ. ELSE IF( SCODE38 ) THEN
2434*
2435 CALL SUBPTR( SIDE, UPLO, TRANSA, DIAG, MDIM, NDIM, SCLR, A, IA,
2436 $ JA, DESCA, B, IB, JB, DESCB )
2437*
2438.EQ. ELSE IF( SCODE39 ) THEN
2439*
2440 CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR,
2441 $ C, IC, JC, DESCC )
2442*
2443.EQ. ELSE IF( SCODE40 ) THEN
2444*
2445 CALL SUBPTR( UPLO, TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA,
2446 $ SCLR, C, IC, JC, DESCC )
2447*
2448 END IF
2449*
2450 RETURN
2451*
2452* End of PSCALLSUB
2453*
2454 END
2455 SUBROUTINE PSERRSET( ERR, ERRMAX, XTRUE, X )
2456*
2457* -- PBLAS test routine (version 2.0) --
2458* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2459* and University of California, Berkeley.
2460* April 1, 1998
2461*
2462* .. Scalar Arguments ..
2463 REAL ERR, ERRMAX, X, XTRUE
2464* ..
2465*
2466* Purpose
2467* =======
2468*
2469* PSERRSET computes the absolute difference ERR = |XTRUE - X| and com-
2470* pares it with zero. ERRMAX accumulates the absolute error difference.
2471*
2472* Notes
2473* =====
2474*
2475* A description vector is associated with each 2D block-cyclicly dis-
2476* tributed matrix. This vector stores the information required to
2477* establish the mapping between a matrix entry and its corresponding
2478* process and memory location.
2479*
2480* In the following comments, the character _ should be read as
2481* "of the distributed matrix". Let A be a generic term for any 2D
2482* block cyclicly distributed matrix. Its description vector is DESCA:
2483*
2484* NOTATION STORED IN EXPLANATION
2485* ---------------- --------------- ------------------------------------
2486* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2487* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2488* the NPROW x NPCOL BLACS process grid
2489* A is distributed over. The context
2490* itself is global, but the handle
2491* (the integer value) may vary.
2492* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2493* ted matrix A, M_A >= 0.
2494* N_A (global) DESCA( N_ ) The number of columns in the distri-
2495* buted matrix A, N_A >= 0.
2496* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2497* block of the matrix A, IMB_A > 0.
2498* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2499* left block of the matrix A,
2500* INB_A > 0.
2501* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2502* bute the last M_A-IMB_A rows of A,
2503* MB_A > 0.
2504* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2505* bute the last N_A-INB_A columns of
2506* A, NB_A > 0.
2507* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2508* row of the matrix A is distributed,
2509* NPROW > RSRC_A >= 0.
2510* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2511* first column of A is distributed.
2512* NPCOL > CSRC_A >= 0.
2513* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2514* array storing the local blocks of
2515* the distributed matrix A,
2516* IF( Lc( 1, N_A ) > 0 )
2517* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2518* ELSE
2519* LLD_A >= 1.
2520*
2521* Let K be the number of rows of a matrix A starting at the global in-
2522* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2523* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2524* receive if these K rows were distributed over NPROW processes. If K
2525* is the number of columns of a matrix A starting at the global index
2526* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2527* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2528* these K columns were distributed over NPCOL processes.
2529*
2530* The values of Lr() and Lc() may be determined via a call to the func-
2531* tion PB_NUMROC:
2532* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2533* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2534*
2535* Arguments
2536* =========
2537*
2538* ERR (local output) REAL
2539* On exit, ERR specifies the absolute difference |XTRUE - X|.
2540*
2541* ERRMAX (local input/local output) REAL
2542* On entry, ERRMAX specifies a previously computed error. On
2543* exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
2544*
2545* XTRUE (local input) REAL
2546* On entry, XTRUE specifies the true value.
2547*
2548* X (local input) REAL
2549* On entry, X specifies the value to be compared to XTRUE.
2550*
2551* -- Written on April 1, 1998 by
2552* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2553*
2554* =====================================================================
2555*
2556* .. External Functions ..
2557 REAL PSDIFF
2558 EXTERNAL PSDIFF
2559* ..
2560* .. Intrinsic Functions ..
2561 INTRINSIC ABS, MAX
2562* ..
2563* .. Executable Statements ..
2564*
2565 ERR = ABS( PSDIFF( XTRUE, X ) )
2566*
2567 ERRMAX = MAX( ERRMAX, ERR )
2568*
2569 RETURN
2570*
2571* End of PSERRSET
2572*
2573 END
2574 SUBROUTINE PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
2575 $ INFO )
2576*
2577* -- PBLAS test routine (version 2.0) --
2578* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2579* and University of California, Berkeley.
2580* April 1, 1998
2581*
2582* .. Scalar Arguments ..
2583 INTEGER INCX, INFO, IX, JX, N
2584 REAL ERRMAX
2585* ..
2586* .. Array Arguments ..
2587 INTEGER DESCX( * )
2588 REAL PX( * ), X( * )
2589* ..
2590*
2591* Purpose
2592* =======
2593*
2594* PSCHKVIN checks that the submatrix sub( PX ) remained unchanged. The
2595* local array entries are compared element by element, and their dif-
2596* ference is tested against 0.0 as well as the epsilon machine. Notice
2597* that this difference should be numerically exactly the zero machine,
2598* but because of the possible fluctuation of some of the data we flag-
2599* ged differently a difference less than twice the epsilon machine. The
2600* largest error is also returned.
2601*
2602* Notes
2603* =====
2604*
2605* A description vector is associated with each 2D block-cyclicly dis-
2606* tributed matrix. This vector stores the information required to
2607* establish the mapping between a matrix entry and its corresponding
2608* process and memory location.
2609*
2610* In the following comments, the character _ should be read as
2611* "of the distributed matrix". Let A be a generic term for any 2D
2612* block cyclicly distributed matrix. Its description vector is DESCA:
2613*
2614* NOTATION STORED IN EXPLANATION
2615* ---------------- --------------- ------------------------------------
2616* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2617* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2618* the NPROW x NPCOL BLACS process grid
2619* A is distributed over. The context
2620* itself is global, but the handle
2621* (the integer value) may vary.
2622* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2623* ted matrix A, M_A >= 0.
2624* N_A (global) DESCA( N_ ) The number of columns in the distri-
2625* buted matrix A, N_A >= 0.
2626* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2627* block of the matrix A, IMB_A > 0.
2628* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2629* left block of the matrix A,
2630* INB_A > 0.
2631* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2632* bute the last M_A-IMB_A rows of A,
2633* MB_A > 0.
2634* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2635* bute the last N_A-INB_A columns of
2636* A, NB_A > 0.
2637* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2638* row of the matrix A is distributed,
2639* NPROW > RSRC_A >= 0.
2640* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2641* first column of A is distributed.
2642* NPCOL > CSRC_A >= 0.
2643* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2644* array storing the local blocks of
2645* the distributed matrix A,
2646* IF( Lc( 1, N_A ) > 0 )
2647* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2648* ELSE
2649* LLD_A >= 1.
2650*
2651* Let K be the number of rows of a matrix A starting at the global in-
2652* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2653* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2654* receive if these K rows were distributed over NPROW processes. If K
2655* is the number of columns of a matrix A starting at the global index
2656* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2657* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2658* these K columns were distributed over NPCOL processes.
2659*
2660* The values of Lr() and Lc() may be determined via a call to the func-
2661* tion PB_NUMROC:
2662* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2663* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2664*
2665* Arguments
2666* =========
2667*
2668* ERRMAX (global output) REAL
2669* On exit, ERRMAX specifies the largest absolute element-wise
2670* difference between sub( X ) and sub( PX ).
2671*
2672* N (global input) INTEGER
2673* On entry, N specifies the length of the subvector operand
2674* sub( X ). N must be at least zero.
2675*
2676* X (local input) REAL array
2677* On entry, X is an array of dimension (DESCX( M_ ),*). This
2678* array contains a local copy of the initial entire matrix PX.
2679*
2680* PX (local input) REAL array
2681* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2682* array contains the local entries of the matrix PX.
2683*
2684* IX (global input) INTEGER
2685* On entry, IX specifies X's global row index, which points to
2686* the beginning of the submatrix sub( X ).
2687*
2688* JX (global input) INTEGER
2689* On entry, JX specifies X's global column index, which points
2690* to the beginning of the submatrix sub( X ).
2691*
2692* DESCX (global and local input) INTEGER array
2693* On entry, DESCX is an integer array of dimension DLEN_. This
2694* is the array descriptor for the matrix X.
2695*
2696* INCX (global input) INTEGER
2697* On entry, INCX specifies the global increment for the
2698* elements of X. Only two values of INCX are supported in
2699* this version, namely 1 and M_X. INCX must not be zero.
2700*
2701* INFO (global output) INTEGER
2702* On exit, if INFO = 0, no error has been found,
2703* If INFO > 0, the maximum abolute error found is in (0,eps],
2704* If INFO < 0, the maximum abolute error found is in (eps,+oo).
2705*
2706* -- Written on April 1, 1998 by
2707* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2708*
2709* =====================================================================
2710*
2711* .. Parameters ..
2712 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2713 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2714 $ RSRC_
2715 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2716 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2717 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2718 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2719 REAL ZERO
2720 PARAMETER ( ZERO = 0.0E+0 )
2721* ..
2722* .. Local Scalars ..
2723 LOGICAL COLREP, ROWREP
2724 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
2725 $ IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL,
2726 $ MYCOL, MYROW, NPCOL, NPROW
2727 REAL ERR, EPS
2728* ..
2729* .. External Subroutines ..
2730 EXTERNAL BLACS_GRIDINFO, PB_INFOG2L, PSERRSET, SGAMX2D
2731* ..
2732* .. External Functions ..
2733 REAL PSLAMCH
2734 EXTERNAL PSLAMCH
2735* ..
2736* .. Intrinsic Functions ..
2737 INTRINSIC ABS, MAX, MIN, MOD
2738* ..
2739* .. Executable Statements ..
2740*
2741 INFO = 0
2742 ERRMAX = ZERO
2743*
2744* Quick return if possible
2745*
2746.LE. IF( N0 )
2747 $ RETURN
2748*
2749 ICTXT = DESCX( CTXT_ )
2750 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
2751*
2752 EPS = PSLAMCH( ICTXT, 'eps' )
2753*
2754 CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, IIX,
2755 $ JJX, IXROW, IXCOL )
2756*
2757 LDX = DESCX( M_ )
2758 LDPX = DESCX( LLD_ )
2759.EQ. ROWREP = ( IXROW-1 )
2760.EQ. COLREP = ( IXCOL-1 )
2761*
2762.EQ. IF( N1 ) THEN
2763*
2764.EQ..OR..AND. IF( ( MYROWIXROW ROWREP )
2765.EQ..OR. $ ( MYCOLIXCOL COLREP ) )
2766 $ CALL PSERRSET( ERR, ERRMAX, X( IX+(JX-1)*LDX ),
2767 $ PX( IIX+(JJX-1)*LDPX ) )
2768*
2769.EQ. ELSE IF( INCXDESCX( M_ ) ) THEN
2770*
2771* sub( X ) is a row vector
2772*
2773 JB = DESCX( INB_ ) - JX + 1
2774.LE. IF( JB0 )
2775 $ JB = ( ( -JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB
2776 JB = MIN( JB, N )
2777 JN = JX + JB - 1
2778*
2779.EQ..OR. IF( MYROWIXROW ROWREP ) THEN
2780*
2781 ICURCOL = IXCOL
2782.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
2783 DO 10 J = JX, JN
2784 CALL PSERRSET( ERR, ERRMAX, X( IX+(J-1)*LDX ),
2785 $ PX( IIX+(JJX-1)*LDPX ) )
2786 JJX = JJX + 1
2787 10 CONTINUE
2788 END IF
2789 ICURCOL = MOD( ICURCOL+1, NPCOL )
2790*
2791 DO 30 J = JN+1, JX+N-1, DESCX( NB_ )
2792 JB = MIN( JX+N-J, DESCX( NB_ ) )
2793*
2794.EQ..OR. IF( MYCOLICURCOL COLREP ) THEN
2795*
2796 DO 20 KK = 0, JB-1
2797 CALL PSERRSET( ERR, ERRMAX, X( IX+(J+KK-1)*LDX ),
2798 $ PX( IIX+(JJX+KK-1)*LDPX ) )
2799 20 CONTINUE
2800*
2801 JJX = JJX + JB
2802*
2803 END IF
2804*
2805 ICURCOL = MOD( ICURCOL+1, NPCOL )
2806*
2807 30 CONTINUE
2808*
2809 END IF
2810*
2811 ELSE
2812*
2813* sub( X ) is a column vector
2814*
2815 IB = DESCX( IMB_ ) - IX + 1
2816.LE. IF( IB0 )
2817 $ IB = ( ( -IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB
2818 IB = MIN( IB, N )
2819 IN = IX + IB - 1
2820*
2821.EQ..OR. IF( MYCOLIXCOL COLREP ) THEN
2822*
2823 ICURROW = IXROW
2824.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
2825 DO 40 I = IX, IN
2826 CALL PSERRSET( ERR, ERRMAX, X( I+(JX-1)*LDX ),
2827 $ PX( IIX+(JJX-1)*LDPX ) )
2828 IIX = IIX + 1
2829 40 CONTINUE
2830 END IF
2831 ICURROW = MOD( ICURROW+1, NPROW )
2832*
2833 DO 60 I = IN+1, IX+N-1, DESCX( MB_ )
2834 IB = MIN( IX+N-I, DESCX( MB_ ) )
2835*
2836.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
2837*
2838 DO 50 KK = 0, IB-1
2839 CALL PSERRSET( ERR, ERRMAX, X( I+KK+(JX-1)*LDX ),
2840 $ PX( IIX+KK+(JJX-1)*LDPX ) )
2841 50 CONTINUE
2842*
2843 IIX = IIX + IB
2844*
2845 END IF
2846*
2847 ICURROW = MOD( ICURROW+1, NPROW )
2848*
2849 60 CONTINUE
2850*
2851 END IF
2852*
2853 END IF
2854*
2855 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, errmax, 1, kk, ll, -1,
2856 $ -1, -1 )
2857*
2858 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
2859 info = 1
2860 ELSE IF( errmax.GT.eps ) THEN
2861 info = -1
2862 END IF
2863*
2864 RETURN
2865*
2866* End of PSCHKVIN
2867*
2868 END
2869 SUBROUTINE pschkvout( N, X, PX, IX, JX, DESCX, INCX, INFO )
2870*
2871* -- PBLAS test routine (version 2.0) --
2872* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2873* and University of California, Berkeley.
2874* April 1, 1998
2875*
2876* .. Scalar Arguments ..
2877 INTEGER INCX, INFO, IX, JX, N
2878* ..
2879* .. Array Arguments ..
2880 INTEGER DESCX( * )
2881 REAL PX( * ), X( * )
2882* ..
2883*
2884* Purpose
2885* =======
2886*
2887* PSCHKVOUT checks that the matrix PX \ sub( PX ) remained unchanged.
2888* The local array entries are compared element by element, and their
2889* difference is tested against 0.0 as well as the epsilon machine. No-
2890* tice that this difference should be numerically exactly the zero ma-
2891* chine, but because of the possible movement of some of the data we
2892* flagged differently a difference less than twice the epsilon machine.
2893* The largest error is reported.
2894*
2895* Notes
2896* =====
2897*
2898* A description vector is associated with each 2D block-cyclicly dis-
2899* tributed matrix. This vector stores the information required to
2900* establish the mapping between a matrix entry and its corresponding
2901* process and memory location.
2902*
2903* In the following comments, the character _ should be read as
2904* "of the distributed matrix". Let A be a generic term for any 2D
2905* block cyclicly distributed matrix. Its description vector is DESCA:
2906*
2907* NOTATION STORED IN EXPLANATION
2908* ---------------- --------------- ------------------------------------
2909* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2910* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2911* the NPROW x NPCOL BLACS process grid
2912* A is distributed over. The context
2913* itself is global, but the handle
2914* (the integer value) may vary.
2915* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2916* ted matrix A, M_A >= 0.
2917* N_A (global) DESCA( N_ ) The number of columns in the distri-
2918* buted matrix A, N_A >= 0.
2919* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2920* block of the matrix A, IMB_A > 0.
2921* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2922* left block of the matrix A,
2923* INB_A > 0.
2924* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2925* bute the last M_A-IMB_A rows of A,
2926* MB_A > 0.
2927* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2928* bute the last N_A-INB_A columns of
2929* A, NB_A > 0.
2930* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2931* row of the matrix A is distributed,
2932* NPROW > RSRC_A >= 0.
2933* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2934* first column of A is distributed.
2935* NPCOL > CSRC_A >= 0.
2936* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2937* array storing the local blocks of
2938* the distributed matrix A,
2939* IF( Lc( 1, N_A ) > 0 )
2940* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2941* ELSE
2942* LLD_A >= 1.
2943*
2944* Let K be the number of rows of a matrix A starting at the global in-
2945* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2946* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2947* receive if these K rows were distributed over NPROW processes. If K
2948* is the number of columns of a matrix A starting at the global index
2949* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2950* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2951* these K columns were distributed over NPCOL processes.
2952*
2953* The values of Lr() and Lc() may be determined via a call to the func-
2954* tion PB_NUMROC:
2955* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2956* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2957*
2958* Arguments
2959* =========
2960*
2961* N (global input) INTEGER
2962* On entry, N specifies the length of the subvector operand
2963* sub( X ). N must be at least zero.
2964*
2965* X (local input) REAL array
2966* On entry, X is an array of dimension (DESCX( M_ ),*). This
2967* array contains a local copy of the initial entire matrix PX.
2968*
2969* PX (local input) REAL array
2970* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2971* array contains the local entries of the matrix PX.
2972*
2973* IX (global input) INTEGER
2974* On entry, IX specifies X's global row index, which points to
2975* the beginning of the submatrix sub( X ).
2976*
2977* JX (global input) INTEGER
2978* On entry, JX specifies X's global column index, which points
2979* to the beginning of the submatrix sub( X ).
2980*
2981* DESCX (global and local input) INTEGER array
2982* On entry, DESCX is an integer array of dimension DLEN_. This
2983* is the array descriptor for the matrix X.
2984*
2985* INCX (global input) INTEGER
2986* On entry, INCX specifies the global increment for the
2987* elements of X. Only two values of INCX are supported in
2988* this version, namely 1 and M_X. INCX must not be zero.
2989*
2990* INFO (global output) INTEGER
2991* On exit, if INFO = 0, no error has been found,
2992* If INFO > 0, the maximum abolute error found is in (0,eps],
2993* If INFO < 0, the maximum abolute error found is in (eps,+oo).
2994*
2995* -- Written on April 1, 1998 by
2996* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2997*
2998* =====================================================================
2999*
3000* .. Parameters ..
3001 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3002 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3003 $ rsrc_
3004 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3005 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3006 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3007 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3008 REAL ZERO
3009 PARAMETER ( ZERO = 0.0e+0 )
3010* ..
3011* .. Local Scalars ..
3012 LOGICAL COLREP, ROWREP
3013 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
3014 $ j, jb, jj, kk, ldpx, ldx, ll, mbx, mpall,
3015 $ mycol, mycoldist, myrow, myrowdist, nbx, npcol,
3016 $ nprow, nqall
3017 REAL EPS, ERR, ERRMAX
3018* ..
3019* .. External Subroutines ..
3020 EXTERNAL blacs_gridinfo, pserrset, sgamx2d
3021* ..
3022* .. External Functions ..
3023 INTEGER PB_NUMROC
3024 REAL PSLAMCH
3025 EXTERNAL pslamch, pb_numroc
3026* ..
3027* .. Intrinsic Functions ..
3028 INTRINSIC abs, max, min, mod
3029* ..
3030* .. Executable Statements ..
3031*
3032 info = 0
3033 errmax = zero
3034*
3035* Quick return if possible
3036*
3037 IF( ( descx( m_ ).LE.0 ).OR.( descx( n_ ).LE.0 ) )
3038 $ RETURN
3039*
3040* Start the operations
3041*
3042 ictxt = descx( ctxt_ )
3043 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3044*
3045 eps = pslamch( ictxt, 'eps' )
3046*
3047 mpall = pb_numroc( descx( m_ ), 1, descx( imb_ ), descx( mb_ ),
3048 $ myrow, descx( rsrc_ ), nprow )
3049 nqall = pb_numroc( descx( n_ ), 1, descx( inb_ ), descx( nb_ ),
3050 $ mycol, descx( csrc_ ), npcol )
3051*
3052 mbx = descx( mb_ )
3053 nbx = descx( nb_ )
3054 ldx = descx( m_ )
3055 ldpx = descx( lld_ )
3056 icurrow = descx( rsrc_ )
3057 icurcol = descx( csrc_ )
3058 rowrep = ( icurrow.EQ.-1 )
3059 colrep = ( icurcol.EQ.-1 )
3060 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3061 imbx = descx( imb_ )
3062 ELSE
3063 imbx = mbx
3064 END IF
3065 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3066 inbx = descx( inb_ )
3067 ELSE
3068 inbx = nbx
3069 END IF
3070 IF( rowrep ) THEN
3071 myrowdist = 0
3072 ELSE
3073 myrowdist = mod( myrow - icurrow + nprow, nprow )
3074 END IF
3075 IF( colrep ) THEN
3076 mycoldist = 0
3077 ELSE
3078 mycoldist = mod( mycol - icurcol + npcol, npcol )
3079 END IF
3080 ii = 1
3081 jj = 1
3082*
3083 IF( incx.EQ.descx( m_ ) ) THEN
3084*
3085* sub( X ) is a row vector
3086*
3087 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3088*
3089 i = 1
3090 IF( mycoldist.EQ.0 ) THEN
3091 j = 1
3092 ELSE
3093 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3094 END IF
3095 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3096 ib = min( descx( m_ ), descx( imb_ ) )
3097*
3098 DO 20 kk = 0, jb-1
3099 DO 10 ll = 0, ib-1
3100 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR. j+kk.GT.jx+n-1 )
3101 $ CALL pserrset( err, errmax,
3102 $ x( i+ll+(j+kk-1)*ldx ),
3103 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3104 10 CONTINUE
3105 20 CONTINUE
3106 IF( colrep ) THEN
3107 j = j + inbx
3108 ELSE
3109 j = j + inbx + ( npcol - 1 ) * nbx
3110 END IF
3111*
3112 DO 50 jj = inbx+1, nqall, nbx
3113 jb = min( nqall-jj+1, nbx )
3114*
3115 DO 40 kk = 0, jb-1
3116 DO 30 ll = 0, ib-1
3117 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3118 $ j+kk.GT.jx+n-1 )
3119 $ CALL pserrset( err, errmax,
3120 $ x( i+ll+(j+kk-1)*ldx ),
3121 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3122 30 CONTINUE
3123 40 CONTINUE
3124*
3125 IF( colrep ) THEN
3126 j = j + nbx
3127 ELSE
3128 j = j + npcol * nbx
3129 END IF
3130*
3131 50 CONTINUE
3132*
3133 ii = ii + ib
3134*
3135 END IF
3136*
3137 icurrow = mod( icurrow + 1, nprow )
3138*
3139 DO 110 i = descx( imb_ ) + 1, descx( m_ ), mbx
3140 ib = min( descx( m_ ) - i + 1, mbx )
3141*
3142 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3143*
3144 IF( mycoldist.EQ.0 ) THEN
3145 j = 1
3146 ELSE
3147 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3148 END IF
3149*
3150 jj = 1
3151 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3152 DO 70 kk = 0, jb-1
3153 DO 60 ll = 0, ib-1
3154 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3155 $ j+kk.GT.jx+n-1 )
3156 $ CALL pserrset( err, errmax,
3157 $ x( i+ll+(j+kk-1)*ldx ),
3158 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3159 60 CONTINUE
3160 70 CONTINUE
3161 IF( colrep ) THEN
3162 j = j + inbx
3163 ELSE
3164 j = j + inbx + ( npcol - 1 ) * nbx
3165 END IF
3166*
3167 DO 100 jj = inbx+1, nqall, nbx
3168 jb = min( nqall-jj+1, nbx )
3169*
3170 DO 90 kk = 0, jb-1
3171 DO 80 ll = 0, ib-1
3172 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3173 $ j+kk.GT.jx+n-1 )
3174 $ CALL pserrset( err, errmax,
3175 $ x( i+ll+(j+kk-1)*ldx ),
3176 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3177 80 CONTINUE
3178 90 CONTINUE
3179*
3180 IF( colrep ) THEN
3181 j = j + nbx
3182 ELSE
3183 j = j + npcol * nbx
3184 END IF
3185*
3186 100 CONTINUE
3187*
3188 ii = ii + ib
3189*
3190 END IF
3191*
3192 icurrow = mod( icurrow + 1, nprow )
3193*
3194 110 CONTINUE
3195*
3196 ELSE
3197*
3198* sub( X ) is a column vector
3199*
3200 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3201*
3202 j = 1
3203 IF( myrowdist.EQ.0 ) THEN
3204 i = 1
3205 ELSE
3206 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3207 END IF
3208 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3209 jb = min( descx( n_ ), descx( inb_ ) )
3210*
3211 DO 130 kk = 0, jb-1
3212 DO 120 ll = 0, ib-1
3213 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR. i+ll.GT.ix+n-1 )
3214 $ CALL pserrset( err, errmax,
3215 $ x( i+ll+(j+kk-1)*ldx ),
3216 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3217 120 CONTINUE
3218 130 CONTINUE
3219 IF( rowrep ) THEN
3220 i = i + imbx
3221 ELSE
3222 i = i + imbx + ( nprow - 1 ) * mbx
3223 END IF
3224*
3225 DO 160 ii = imbx+1, mpall, mbx
3226 ib = min( mpall-ii+1, mbx )
3227*
3228 DO 150 kk = 0, jb-1
3229 DO 140 ll = 0, ib-1
3230 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3231 $ i+ll.GT.ix+n-1 )
3232 $ CALL pserrset( err, errmax,
3233 $ x( i+ll+(j+kk-1)*ldx ),
3234 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3235 140 CONTINUE
3236 150 CONTINUE
3237*
3238 IF( rowrep ) THEN
3239 i = i + mbx
3240 ELSE
3241 i = i + nprow * mbx
3242 END IF
3243*
3244 160 CONTINUE
3245*
3246 jj = jj + jb
3247*
3248 END IF
3249*
3250 icurcol = mod( icurcol + 1, npcol )
3251*
3252 DO 220 j = descx( inb_ ) + 1, descx( n_ ), nbx
3253 jb = min( descx( n_ ) - j + 1, nbx )
3254*
3255 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3256*
3257 IF( myrowdist.EQ.0 ) THEN
3258 i = 1
3259 ELSE
3260 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3261 END IF
3262*
3263 ii = 1
3264 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3265 DO 180 kk = 0, jb-1
3266 DO 170 ll = 0, ib-1
3267 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3268 $ i+ll.GT.ix+n-1 )
3269 $ CALL pserrset( err, errmax,
3270 $ x( i+ll+(j+kk-1)*ldx ),
3271 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3272 170 CONTINUE
3273 180 CONTINUE
3274 IF( rowrep ) THEN
3275 i = i + imbx
3276 ELSE
3277 i = i + imbx + ( nprow - 1 ) * mbx
3278 END IF
3279*
3280 DO 210 ii = imbx+1, mpall, mbx
3281 ib = min( mpall-ii+1, mbx )
3282*
3283 DO 200 kk = 0, jb-1
3284 DO 190 ll = 0, ib-1
3285 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3286 $ i+ll.GT.ix+n-1 )
3287 $ CALL pserrset( err, errmax,
3288 $ x( i+ll+(j+kk-1)*ldx ),
3289 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3290 190 CONTINUE
3291 200 CONTINUE
3292*
3293 IF( rowrep ) THEN
3294 i = i + mbx
3295 ELSE
3296 i = i + nprow * mbx
3297 END IF
3298*
3299 210 CONTINUE
3300*
3301 jj = jj + jb
3302*
3303 END IF
3304*
3305 icurcol = mod( icurcol + 1, npcol )
3306*
3307 220 CONTINUE
3308*
3309 END IF
3310*
3311 CALL sgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3312 $ -1, -1 )
3313*
3314 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3315 info = 1
3316 ELSE IF( errmax.GT.eps ) THEN
3317 info = -1
3318 END IF
3319*
3320 RETURN
3321*
3322* End of PSCHKVOUT
3323*
3324 END
3325 SUBROUTINE pschkmin( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO )
3326*
3327* -- PBLAS test routine (version 2.0) --
3328* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3329* and University of California, Berkeley.
3330* April 1, 1998
3331*
3332* .. Scalar Arguments ..
3333 INTEGER IA, INFO, JA, M, N
3334 REAL ERRMAX
3335* ..
3336* .. Array Arguments ..
3337 INTEGER DESCA( * )
3338 REAL PA( * ), A( * )
3339* ..
3340*
3341* Purpose
3342* =======
3343*
3344* PSCHKMIN checks that the submatrix sub( PA ) remained unchanged. The
3345* local array entries are compared element by element, and their dif-
3346* ference is tested against 0.0 as well as the epsilon machine. Notice
3347* that this difference should be numerically exactly the zero machine,
3348* but because of the possible fluctuation of some of the data we flag-
3349* ged differently a difference less than twice the epsilon machine. The
3350* largest error is also returned.
3351*
3352* Notes
3353* =====
3354*
3355* A description vector is associated with each 2D block-cyclicly dis-
3356* tributed matrix. This vector stores the information required to
3357* establish the mapping between a matrix entry and its corresponding
3358* process and memory location.
3359*
3360* In the following comments, the character _ should be read as
3361* "of the distributed matrix". Let A be a generic term for any 2D
3362* block cyclicly distributed matrix. Its description vector is DESCA:
3363*
3364* NOTATION STORED IN EXPLANATION
3365* ---------------- --------------- ------------------------------------
3366* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3367* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3368* the NPROW x NPCOL BLACS process grid
3369* A is distributed over. The context
3370* itself is global, but the handle
3371* (the integer value) may vary.
3372* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3373* ted matrix A, M_A >= 0.
3374* N_A (global) DESCA( N_ ) The number of columns in the distri-
3375* buted matrix A, N_A >= 0.
3376* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3377* block of the matrix A, IMB_A > 0.
3378* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3379* left block of the matrix A,
3380* INB_A > 0.
3381* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3382* bute the last M_A-IMB_A rows of A,
3383* MB_A > 0.
3384* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3385* bute the last N_A-INB_A columns of
3386* A, NB_A > 0.
3387* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3388* row of the matrix A is distributed,
3389* NPROW > RSRC_A >= 0.
3390* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3391* first column of A is distributed.
3392* NPCOL > CSRC_A >= 0.
3393* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3394* array storing the local blocks of
3395* the distributed matrix A,
3396* IF( Lc( 1, N_A ) > 0 )
3397* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3398* ELSE
3399* LLD_A >= 1.
3400*
3401* Let K be the number of rows of a matrix A starting at the global in-
3402* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3403* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3404* receive if these K rows were distributed over NPROW processes. If K
3405* is the number of columns of a matrix A starting at the global index
3406* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3407* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3408* these K columns were distributed over NPCOL processes.
3409*
3410* The values of Lr() and Lc() may be determined via a call to the func-
3411* tion PB_NUMROC:
3412* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3413* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3414*
3415* Arguments
3416* =========
3417*
3418* ERRMAX (global output) REAL
3419* On exit, ERRMAX specifies the largest absolute element-wise
3420* difference between sub( A ) and sub( PA ).
3421*
3422* M (global input) INTEGER
3423* On entry, M specifies the number of rows of the submatrix
3424* operand sub( A ). M must be at least zero.
3425*
3426* N (global input) INTEGER
3427* On entry, N specifies the number of columns of the submatrix
3428* operand sub( A ). N must be at least zero.
3429*
3430* A (local input) REAL array
3431* On entry, A is an array of dimension (DESCA( M_ ),*). This
3432* array contains a local copy of the initial entire matrix PA.
3433*
3434* PA (local input) REAL array
3435* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3436* array contains the local entries of the matrix PA.
3437*
3438* IA (global input) INTEGER
3439* On entry, IA specifies A's global row index, which points to
3440* the beginning of the submatrix sub( A ).
3441*
3442* JA (global input) INTEGER
3443* On entry, JA specifies A's global column index, which points
3444* to the beginning of the submatrix sub( A ).
3445*
3446* DESCA (global and local input) INTEGER array
3447* On entry, DESCA is an integer array of dimension DLEN_. This
3448* is the array descriptor for the matrix A.
3449*
3450* INFO (global output) INTEGER
3451* On exit, if INFO = 0, no error has been found,
3452* If INFO > 0, the maximum abolute error found is in (0,eps],
3453* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3454*
3455* -- Written on April 1, 1998 by
3456* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3457*
3458* =====================================================================
3459*
3460* .. Parameters ..
3461 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3462 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3463 $ rsrc_
3464 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3465 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3466 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3467 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3468 REAL ZERO
3469 PARAMETER ( ZERO = 0.0e+0 )
3470* ..
3471* .. Local Scalars ..
3472 LOGICAL COLREP, ROWREP
3473 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
3474 $ icurrow, ii, iia, in, j, jb, jj, jja, jn, k,
3475 $ kk, lda, ldpa, ll, mycol, myrow, npcol, nprow
3476 REAL ERR, EPS
3477* ..
3478* .. External Subroutines ..
3479 EXTERNAL blacs_gridinfo, pb_infog2l, pserrset, sgamx2d
3480* ..
3481* .. External Functions ..
3482 REAL PSLAMCH
3483 EXTERNAL PSLAMCH
3484* ..
3485* .. Intrinsic Functions ..
3486 INTRINSIC abs, max, min, mod
3487* ..
3488* .. Executable Statements ..
3489*
3490 info = 0
3491 errmax = zero
3492*
3493* Quick return if posssible
3494*
3495 IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )
3496 $ RETURN
3497*
3498* Start the operations
3499*
3500 ictxt = desca( ctxt_ )
3501 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3502*
3503 eps = pslamch( ictxt, 'eps' )
3504*
3505 CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia,
3506 $ jja, iarow, iacol )
3507*
3508 ii = iia
3509 jj = jja
3510 lda = desca( m_ )
3511 ldpa = desca( lld_ )
3512 icurrow = iarow
3513 icurcol = iacol
3514 rowrep = ( iarow.EQ.-1 )
3515 colrep = ( iacol.EQ.-1 )
3516*
3517* Handle the first block of column separately
3518*
3519 jb = desca( inb_ ) - ja + 1
3520 IF( jb.LE.0 )
3521 $ jb = ( ( -jb ) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
3522 jb = min( jb, n )
3523 jn = ja + jb - 1
3524*
3525 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3526*
3527 DO 40 h = 0, jb-1
3528 ib = desca( imb_ ) - ia + 1
3529 IF( ib.LE.0 )
3530 $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
3531 ib = min( ib, m )
3532 in = ia + ib - 1
3533 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3534 DO 10 k = 0, ib-1
3535 CALL pserrset( err, errmax, a( ia+k+(ja+h-1)*lda ),
3536 $ pa( ii+k+(jj+h-1)*ldpa ) )
3537 10 CONTINUE
3538 ii = ii + ib
3539 END IF
3540 icurrow = mod( icurrow+1, nprow )
3541*
3542* Loop over remaining block of rows
3543*
3544 DO 30 i = in+1, ia+m-1, desca( mb_ )
3545 ib = min( desca( mb_ ), ia+m-i )
3546 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3547 DO 20 k = 0, ib-1
3548 CALL pserrset( err, errmax, a( i+k+(ja+h-1)*lda ),
3549 $ pa( ii+k+(jj+h-1)*ldpa ) )
3550 20 CONTINUE
3551 ii = ii + ib
3552 END IF
3553 icurrow = mod( icurrow+1, nprow )
3554 30 CONTINUE
3555*
3556 ii = iia
3557 icurrow = iarow
3558 40 CONTINUE
3559*
3560 jj = jj + jb
3561*
3562 END IF
3563*
3564 icurcol = mod( icurcol+1, npcol )
3565*
3566* Loop over remaining column blocks
3567*
3568 DO 90 j = jn+1, ja+n-1, desca( nb_ )
3569 jb = min( desca( nb_ ), ja+n-j )
3570 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3571 DO 80 h = 0, jb-1
3572 ib = desca( imb_ ) - ia + 1
3573 IF( ib.LE.0 )
3574 $ ib = ( ( -ib ) / desca( mb_ ) + 1 )*desca( mb_ ) + ib
3575 ib = min( ib, m )
3576 in = ia + ib - 1
3577 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3578 DO 50 k = 0, ib-1
3579 CALL pserrset( err, errmax, a( ia+k+(j+h-1)*lda ),
3580 $ pa( ii+k+(jj+h-1)*ldpa ) )
3581 50 CONTINUE
3582 ii = ii + ib
3583 END IF
3584 icurrow = mod( icurrow+1, nprow )
3585*
3586* Loop over remaining block of rows
3587*
3588 DO 70 i = in+1, ia+m-1, desca( mb_ )
3589 ib = min( desca( mb_ ), ia+m-i )
3590 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3591 DO 60 k = 0, ib-1
3592 CALL pserrset( err, errmax,
3593 $ a( i+k+(j+h-1)*lda ),
3594 $ pa( ii+k+(jj+h-1)*ldpa ) )
3595 60 CONTINUE
3596 ii = ii + ib
3597 END IF
3598 icurrow = mod( icurrow+1, nprow )
3599 70 CONTINUE
3600*
3601 ii = iia
3602 icurrow = iarow
3603 80 CONTINUE
3604*
3605 jj = jj + jb
3606 END IF
3607*
3608 icurcol = mod( icurcol+1, npcol )
3609*
3610 90 CONTINUE
3611*
3612 CALL sgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3613 $ -1, -1 )
3614*
3615 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3616 info = 1
3617 ELSE IF( errmax.GT.eps ) THEN
3618 info = -1
3619 END IF
3620*
3621 RETURN
3622*
3623* End of PSCHKMIN
3624*
3625 END
3626 SUBROUTINE pschkmout( M, N, A, PA, IA, JA, DESCA, INFO )
3627*
3628* -- PBLAS test routine (version 2.0) --
3629* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3630* and University of California, Berkeley.
3631* April 1, 1998
3632*
3633* .. Scalar Arguments ..
3634 INTEGER IA, INFO, JA, M, N
3635* ..
3636* .. Array Arguments ..
3637 INTEGER DESCA( * )
3638 REAL A( * ), PA( * )
3639* ..
3640*
3641* Purpose
3642* =======
3643*
3644* PSCHKMOUT checks that the matrix PA \ sub( PA ) remained unchanged.
3645* The local array entries are compared element by element, and their
3646* difference is tested against 0.0 as well as the epsilon machine. No-
3647* tice that this difference should be numerically exactly the zero ma-
3648* chine, but because of the possible movement of some of the data we
3649* flagged differently a difference less than twice the epsilon machine.
3650* The largest error is reported.
3651*
3652* Notes
3653* =====
3654*
3655* A description vector is associated with each 2D block-cyclicly dis-
3656* tributed matrix. This vector stores the information required to
3657* establish the mapping between a matrix entry and its corresponding
3658* process and memory location.
3659*
3660* In the following comments, the character _ should be read as
3661* "of the distributed matrix". Let A be a generic term for any 2D
3662* block cyclicly distributed matrix. Its description vector is DESCA:
3663*
3664* NOTATION STORED IN EXPLANATION
3665* ---------------- --------------- ------------------------------------
3666* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3667* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3668* the NPROW x NPCOL BLACS process grid
3669* A is distributed over. The context
3670* itself is global, but the handle
3671* (the integer value) may vary.
3672* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3673* ted matrix A, M_A >= 0.
3674* N_A (global) DESCA( N_ ) The number of columns in the distri-
3675* buted matrix A, N_A >= 0.
3676* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3677* block of the matrix A, IMB_A > 0.
3678* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3679* left block of the matrix A,
3680* INB_A > 0.
3681* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3682* bute the last M_A-IMB_A rows of A,
3683* MB_A > 0.
3684* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3685* bute the last N_A-INB_A columns of
3686* A, NB_A > 0.
3687* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3688* row of the matrix A is distributed,
3689* NPROW > RSRC_A >= 0.
3690* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3691* first column of A is distributed.
3692* NPCOL > CSRC_A >= 0.
3693* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3694* array storing the local blocks of
3695* the distributed matrix A,
3696* IF( Lc( 1, N_A ) > 0 )
3697* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3698* ELSE
3699* LLD_A >= 1.
3700*
3701* Let K be the number of rows of a matrix A starting at the global in-
3702* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3703* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3704* receive if these K rows were distributed over NPROW processes. If K
3705* is the number of columns of a matrix A starting at the global index
3706* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3707* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3708* these K columns were distributed over NPCOL processes.
3709*
3710* The values of Lr() and Lc() may be determined via a call to the func-
3711* tion PB_NUMROC:
3712* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3713* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3714*
3715* Arguments
3716* =========
3717*
3718* M (global input) INTEGER
3719* On entry, M specifies the number of rows of the submatrix
3720* sub( PA ). M must be at least zero.
3721*
3722* N (global input) INTEGER
3723* On entry, N specifies the number of columns of the submatrix
3724* sub( PA ). N must be at least zero.
3725*
3726* A (local input) REAL array
3727* On entry, A is an array of dimension (DESCA( M_ ),*). This
3728* array contains a local copy of the initial entire matrix PA.
3729*
3730* PA (local input) REAL array
3731* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3732* array contains the local entries of the matrix PA.
3733*
3734* IA (global input) INTEGER
3735* On entry, IA specifies A's global row index, which points to
3736* the beginning of the submatrix sub( A ).
3737*
3738* JA (global input) INTEGER
3739* On entry, JA specifies A's global column index, which points
3740* to the beginning of the submatrix sub( A ).
3741*
3742* DESCA (global and local input) INTEGER array
3743* On entry, DESCA is an integer array of dimension DLEN_. This
3744* is the array descriptor for the matrix A.
3745*
3746* INFO (global output) INTEGER
3747* On exit, if INFO = 0, no error has been found,
3748* If INFO > 0, the maximum abolute error found is in (0,eps],
3749* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3750*
3751* -- Written on April 1, 1998 by
3752* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3753*
3754* =====================================================================
3755*
3756* .. Parameters ..
3757 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3758 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3759 $ rsrc_
3760 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3761 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3762 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3763 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3764 REAL ZERO
3765 PARAMETER ( ZERO = 0.0e+0 )
3766* ..
3767* .. Local Scalars ..
3768 LOGICAL COLREP, ROWREP
3769 INTEGER I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
3770 $ lda, ldpa, ll, mpall, mycol, myrow, myrowdist,
3771 $ npcol, nprow
3772 REAL EPS, ERR, ERRMAX
3773* ..
3774* .. External Subroutines ..
3775 EXTERNAL blacs_gridinfo, pserrset, sgamx2d
3776* ..
3777* .. External Functions ..
3778 INTEGER PB_NUMROC
3779 REAL PSLAMCH
3780 EXTERNAL pslamch, pb_numroc
3781* ..
3782* .. Intrinsic Functions ..
3783 INTRINSIC max, min, mod
3784* ..
3785* .. Executable Statements ..
3786*
3787 info = 0
3788 errmax = zero
3789*
3790* Quick return if possible
3791*
3792 IF( ( desca( m_ ).LE.0 ).OR.( desca( n_ ).LE.0 ) )
3793 $ RETURN
3794*
3795* Start the operations
3796*
3797 ictxt = desca( ctxt_ )
3798 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3799*
3800 eps = pslamch( ictxt, 'eps' )
3801*
3802 mpall = pb_numroc( desca( m_ ), 1, desca( imb_ ), desca( mb_ ),
3803 $ myrow, desca( rsrc_ ), nprow )
3804*
3805 lda = desca( m_ )
3806 ldpa = desca( lld_ )
3807*
3808 ii = 1
3809 jj = 1
3810 rowrep = ( desca( rsrc_ ).EQ.-1 )
3811 colrep = ( desca( csrc_ ).EQ.-1 )
3812 icurcol = desca( csrc_ )
3813 IF( myrow.EQ.desca( rsrc_ ) .OR. rowrep ) THEN
3814 imba = desca( imb_ )
3815 ELSE
3816 imba = desca( mb_ )
3817 END IF
3818 IF( rowrep ) THEN
3819 myrowdist = 0
3820 ELSE
3821 myrowdist = mod( myrow - desca( rsrc_ ) + nprow, nprow )
3822 END IF
3823*
3824 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3825*
3826 j = 1
3827 IF( myrowdist.EQ.0 ) THEN
3828 i = 1
3829 ELSE
3830 i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3831 END IF
3832 ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3833 jb = min( desca( n_ ), desca( inb_ ) )
3834*
3835 DO 20 kk = 0, jb-1
3836 DO 10 ll = 0, ib-1
3837 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3838 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3839 $ CALL pserrset( err, errmax, a( i+ll+(j+kk-1)*lda ),
3840 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3841 10 CONTINUE
3842 20 CONTINUE
3843 IF( rowrep ) THEN
3844 i = i + imba
3845 ELSE
3846 i = i + imba + ( nprow - 1 ) * desca( mb_ )
3847 END IF
3848*
3849 DO 50 ii = imba + 1, mpall, desca( mb_ )
3850 ib = min( mpall-ii+1, desca( mb_ ) )
3851*
3852 DO 40 kk = 0, jb-1
3853 DO 30 ll = 0, ib-1
3854 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3855 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3856 $ CALL pserrset( err, errmax,
3857 $ a( i+ll+(j+kk-1)*lda ),
3858 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3859 30 CONTINUE
3860 40 CONTINUE
3861*
3862 IF( rowrep ) THEN
3863 i = i + desca( mb_ )
3864 ELSE
3865 i = i + nprow * desca( mb_ )
3866 END IF
3867*
3868 50 CONTINUE
3869*
3870 jj = jj + jb
3871*
3872 END IF
3873*
3874 icurcol = mod( icurcol + 1, npcol )
3875*
3876 DO 110 j = desca( inb_ ) + 1, desca( n_ ), desca( nb_ )
3877 jb = min( desca( n_ ) - j + 1, desca( nb_ ) )
3878*
3879 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3880*
3881 IF( myrowdist.EQ.0 ) THEN
3882 i = 1
3883 ELSE
3884 i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3885 END IF
3886*
3887 ii = 1
3888 ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3889 DO 70 kk = 0, jb-1
3890 DO 60 ll = 0, ib-1
3891 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3892 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3893 $ CALL pserrset( err, errmax,
3894 $ a( i+ll+(j+kk-1)*lda ),
3895 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3896 60 CONTINUE
3897 70 CONTINUE
3898 IF( rowrep ) THEN
3899 i = i + imba
3900 ELSE
3901 i = i + imba + ( nprow - 1 ) * desca( mb_ )
3902 END IF
3903*
3904 DO 100 ii = imba+1, mpall, desca( mb_ )
3905 ib = min( mpall-ii+1, desca( mb_ ) )
3906*
3907 DO 90 kk = 0, jb-1
3908 DO 80 ll = 0, ib-1
3909 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3910 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3911 $ CALL pserrset( err, errmax,
3912 $ a( i+ll+(j+kk-1)*lda ),
3913 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3914 80 CONTINUE
3915 90 CONTINUE
3916*
3917 IF( rowrep ) THEN
3918 i = i + desca( mb_ )
3919 ELSE
3920 i = i + nprow * desca( mb_ )
3921 END IF
3922*
3923 100 CONTINUE
3924*
3925 jj = jj + jb
3926*
3927 END IF
3928*
3929 icurcol = mod( icurcol + 1, npcol )
3930* INSERT MODE
3931 110 CONTINUE
3932*
3933 CALL sgamx2d( ictxt, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
3934 $ -1, -1 )
3935*
3936.GT..AND..LE. IF( ERRMAXZERO ERRMAXEPS ) THEN
3937 INFO = 1
3938.GT. ELSE IF( ERRMAXEPS ) THEN
3939 INFO = -1
3940 END IF
3941*
3942 RETURN
3943*
3944* End of PSCHKMOUT
3945*
3946 END
3947 SUBROUTINE PSMPRNT( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT,
3948 $ CMATNM )
3949*
3950* -- PBLAS test routine (version 2.0) --
3951* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3952* and University of California, Berkeley.
3953* April 1, 1998
3954*
3955* .. Scalar Arguments ..
3956 INTEGER ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
3957* ..
3958* .. Array Arguments ..
3959 CHARACTER*(*) CMATNM
3960 REAL A( LDA, * )
3961* ..
3962*
3963* Purpose
3964* =======
3965*
3966* PSMPRNT prints to the standard output an array A of size m by n. Only
3967* the process of coordinates ( IRPRNT, ICPRNT ) is printing.
3968*
3969* Arguments
3970* =========
3971*
3972* ICTXT (local input) INTEGER
3973* On entry, ICTXT specifies the BLACS context handle, indica-
3974* ting the global context of the operation. The context itself
3975* is global, but the value of ICTXT is local.
3976*
3977* NOUT (global input) INTEGER
3978* On entry, NOUT specifies the unit number for the output file.
3979* When NOUT is 6, output to screen, when NOUT is 0, output to
3980* stderr. NOUT is only defined for process 0.
3981*
3982* M (global input) INTEGER
3983* On entry, M specifies the number of rows of the matrix A. M
3984* must be at least zero.
3985*
3986* N (global input) INTEGER
3987* On entry, N specifies the number of columns of the matrix A.
3988* N must be at least zero.
3989*
3990* A (local input) REAL array
3991* On entry, A is an array of dimension (LDA,N). The leading m
3992* by n part of this array is printed.
3993*
3994* LDA (local input) INTEGER
3995* On entry, LDA specifies the leading dimension of the local
3996* array A to be printed. LDA must be at least MAX( 1, M ).
3997*
3998* IRPRNT (global input) INTEGER
3999* On entry, IRPRNT specifies the process row coordinate of the
4000* printing process.
4001*
4002* ICPRNT (global input) INTEGER
4003* On entry, ICPRNT specifies the process column coordinate of
4004* the printing process.
4005*
4006* CMATNM (global input) CHARACTER*(*)
4007* On entry, CMATNM specifies the identifier of the matrix to be
4008* printed.
4009*
4010* -- Written on April 1, 1998 by
4011* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4012*
4013* =====================================================================
4014*
4015* .. Local Scalars ..
4016 INTEGER I, J, MYCOL, MYROW, NPCOL, NPROW
4017* ..
4018* .. External Subroutines ..
4019 EXTERNAL BLACS_GRIDINFO
4020* ..
4021* .. Executable Statements ..
4022*
4023* Quick return if possible
4024*
4025.LE..OR..LE. IF( ( M0 )( N0 ) )
4026 $ RETURN
4027*
4028* Get grid parameters
4029*
4030 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4031*
4032.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
4033*
4034 WRITE( NOUT, FMT = * )
4035 DO 20 J = 1, N
4036*
4037 DO 10 I = 1, M
4038*
4039 WRITE( NOUT, FMT = 9999 ) CMATNM, I, J, A( I, J )
4040*
4041 10 CONTINUE
4042*
4043 20 CONTINUE
4044*
4045 END IF
4046*
4047 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8 )
4048*
4049 RETURN
4050*
4051* End of PSMPRNT
4052*
4053 END
4054 SUBROUTINE PSVPRNT( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT,
4055 $ CVECNM )
4056*
4057* -- PBLAS test routine (version 2.0) --
4058* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4059* and University of California, Berkeley.
4060* April 1, 1998
4061*
4062* .. Scalar Arguments ..
4063 INTEGER ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
4064* ..
4065* .. Array Arguments ..
4066 CHARACTER*(*) CVECNM
4067 REAL X( * )
4068* ..
4069*
4070* Purpose
4071* =======
4072*
4073* PSVPRNT prints to the standard output an vector x of length n. Only
4074* the process of coordinates ( IRPRNT, ICPRNT ) is printing.
4075*
4076* Arguments
4077* =========
4078*
4079* ICTXT (local input) INTEGER
4080* On entry, ICTXT specifies the BLACS context handle, indica-
4081* ting the global context of the operation. The context itself
4082* is global, but the value of ICTXT is local.
4083*
4084* NOUT (global input) INTEGER
4085* On entry, NOUT specifies the unit number for the output file.
4086* When NOUT is 6, output to screen, when NOUT is 0, output to
4087* stderr. NOUT is only defined for process 0.
4088*
4089* N (global input) INTEGER
4090* On entry, N specifies the length of the vector X. N must be
4091* at least zero.
4092*
4093* X (global input) REAL array
4094* On entry, X is an array of dimension at least
4095* ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
4096* ted array X must contain the vector x.
4097*
4098* INCX (global input) INTEGER.
4099* On entry, INCX specifies the increment for the elements of X.
4100* INCX must not be zero.
4101*
4102* IRPRNT (global input) INTEGER
4103* On entry, IRPRNT specifies the process row coordinate of the
4104* printing process.
4105*
4106* ICPRNT (global input) INTEGER
4107* On entry, ICPRNT specifies the process column coordinate of
4108* the printing process.
4109*
4110* CVECNM (global input) CHARACTER*(*)
4111* On entry, CVECNM specifies the identifier of the vector to be
4112* printed.
4113*
4114* -- Written on April 1, 1998 by
4115* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4116*
4117* =====================================================================
4118*
4119* .. Local Scalars ..
4120 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
4121* ..
4122* .. External Subroutines ..
4123 EXTERNAL BLACS_GRIDINFO
4124* ..
4125* .. Executable Statements ..
4126*
4127* Quick return if possible
4128*
4129.LE. IF( N0 )
4130 $ RETURN
4131*
4132* Get grid parameters
4133*
4134 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4135*
4136.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
4137*
4138 WRITE( NOUT, FMT = * )
4139 DO 10 I = 1, 1 + ( N-1 )*INCX, INCX
4140*
4141 WRITE( NOUT, FMT = 9999 ) CVECNM, I, X( I )
4142*
4143 10 CONTINUE
4144*
4145 END IF
4146*
4147 9999 FORMAT( 1X, A, '(', I6, ')=', E16.8 )
4148*
4149 RETURN
4150*
4151* End of PSVPRNT
4152*
4153 END
4154 SUBROUTINE PSMVCH( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
4155 $ X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY,
4156 $ DESCY, INCY, G, ERR, INFO )
4157*
4158* -- PBLAS test routine (version 2.0) --
4159* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4160* and University of California, Berkeley.
4161* April 1, 1998
4162*
4163* .. Scalar Arguments ..
4164 CHARACTER*1 TRANS
4165 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4166 $ JY, M, N
4167 REAL ALPHA, BETA, ERR
4168* ..
4169* .. Array Arguments ..
4170 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4171 REAL A( * ), G( * ), PY( * ), X( * ), Y( * )
4172* ..
4173*
4174* Purpose
4175* =======
4176*
4177* PSMVCH checks the results of the computational tests.
4178*
4179* Notes
4180* =====
4181*
4182* A description vector is associated with each 2D block-cyclicly dis-
4183* tributed matrix. This vector stores the information required to
4184* establish the mapping between a matrix entry and its corresponding
4185* process and memory location.
4186*
4187* In the following comments, the character _ should be read as
4188* "of the distributed matrix". Let A be a generic term for any 2D
4189* block cyclicly distributed matrix. Its description vector is DESCA:
4190*
4191* NOTATION STORED IN EXPLANATION
4192* ---------------- --------------- ------------------------------------
4193* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4194* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4195* the NPROW x NPCOL BLACS process grid
4196* A is distributed over. The context
4197* itself is global, but the handle
4198* (the integer value) may vary.
4199* M_A (global) DESCA( M_ ) The number of rows in the distribu-
4200* ted matrix A, M_A >= 0.
4201* N_A (global) DESCA( N_ ) The number of columns in the distri-
4202* buted matrix A, N_A >= 0.
4203* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4204* block of the matrix A, IMB_A > 0.
4205* INB_A (global) DESCA( INB_ ) The number of columns of the upper
4206* left block of the matrix A,
4207* INB_A > 0.
4208* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4209* bute the last M_A-IMB_A rows of A,
4210* MB_A > 0.
4211* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4212* bute the last N_A-INB_A columns of
4213* A, NB_A > 0.
4214* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4215* row of the matrix A is distributed,
4216* NPROW > RSRC_A >= 0.
4217* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4218* first column of A is distributed.
4219* NPCOL > CSRC_A >= 0.
4220* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4221* array storing the local blocks of
4222* the distributed matrix A,
4223* IF( Lc( 1, N_A ) > 0 )
4224* LLD_A >= MAX( 1, Lr( 1, M_A ) )
4225* ELSE
4226* LLD_A >= 1.
4227*
4228* Let K be the number of rows of a matrix A starting at the global in-
4229* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4230* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4231* receive if these K rows were distributed over NPROW processes. If K
4232* is the number of columns of a matrix A starting at the global index
4233* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4234* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4235* these K columns were distributed over NPCOL processes.
4236*
4237* The values of Lr() and Lc() may be determined via a call to the func-
4238* tion PB_NUMROC:
4239* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4240* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4241*
4242* Arguments
4243* =========
4244*
4245* ICTXT (local input) INTEGER
4246* On entry, ICTXT specifies the BLACS context handle, indica-
4247* ting the global context of the operation. The context itself
4248* is global, but the value of ICTXT is local.
4249*
4250* TRANS (global input) CHARACTER*1
4251* On entry, TRANS specifies which matrix-vector product is to
4252* be computed as follows:
4253* If TRANS = 'N',
4254* sub( Y ) = BETA * sub( Y ) + sub( A ) * sub( X ),
4255* otherwise
4256* sub( Y ) = BETA * sub( Y ) + sub( A )' * sub( X ).
4257*
4258* M (global input) INTEGER
4259* On entry, M specifies the number of rows of the submatrix
4260* operand matrix A. M must be at least zero.
4261*
4262* N (global input) INTEGER
4263* On entry, N specifies the number of columns of the subma-
4264* trix operand matrix A. N must be at least zero.
4265*
4266* ALPHA (global input) REAL
4267* On entry, ALPHA specifies the scalar alpha.
4268*
4269* A (local input) REAL array
4270* On entry, A is an array of dimension (DESCA( M_ ),*). This
4271* array contains a local copy of the initial entire matrix PA.
4272*
4273* IA (global input) INTEGER
4274* On entry, IA specifies A's global row index, which points to
4275* the beginning of the submatrix sub( A ).
4276*
4277* JA (global input) INTEGER
4278* On entry, JA specifies A's global column index, which points
4279* to the beginning of the submatrix sub( A ).
4280*
4281* DESCA (global and local input) INTEGER array
4282* On entry, DESCA is an integer array of dimension DLEN_. This
4283* is the array descriptor for the matrix A.
4284*
4285* X (local input) REAL array
4286* On entry, X is an array of dimension (DESCX( M_ ),*). This
4287* array contains a local copy of the initial entire matrix PX.
4288*
4289* IX (global input) INTEGER
4290* On entry, IX specifies X's global row index, which points to
4291* the beginning of the submatrix sub( X ).
4292*
4293* JX (global input) INTEGER
4294* On entry, JX specifies X's global column index, which points
4295* to the beginning of the submatrix sub( X ).
4296*
4297* DESCX (global and local input) INTEGER array
4298* On entry, DESCX is an integer array of dimension DLEN_. This
4299* is the array descriptor for the matrix X.
4300*
4301* INCX (global input) INTEGER
4302* On entry, INCX specifies the global increment for the
4303* elements of X. Only two values of INCX are supported in
4304* this version, namely 1 and M_X. INCX must not be zero.
4305*
4306* BETA (global input) REAL
4307* On entry, BETA specifies the scalar beta.
4308*
4309* Y (local input/local output) REAL array
4310* On entry, Y is an array of dimension (DESCY( M_ ),*). This
4311* array contains a local copy of the initial entire matrix PY.
4312*
4313* PY (local input) REAL array
4314* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
4315* array contains the local entries of the matrix PY.
4316*
4317* IY (global input) INTEGER
4318* On entry, IY specifies Y's global row index, which points to
4319* the beginning of the submatrix sub( Y ).
4320*
4321* JY (global input) INTEGER
4322* On entry, JY specifies Y's global column index, which points
4323* to the beginning of the submatrix sub( Y ).
4324*
4325* DESCY (global and local input) INTEGER array
4326* On entry, DESCY is an integer array of dimension DLEN_. This
4327* is the array descriptor for the matrix Y.
4328*
4329* INCY (global input) INTEGER
4330* On entry, INCY specifies the global increment for the
4331* elements of Y. Only two values of INCY are supported in
4332* this version, namely 1 and M_Y. INCY must not be zero.
4333*
4334* G (workspace) REAL array
4335* On entry, G is an array of dimension at least MAX( M, N ). G
4336* is used to compute the gauges.
4337*
4338* ERR (global output) REAL
4339* On exit, ERR specifies the largest error in absolute value.
4340*
4341* INFO (global output) INTEGER
4342* On exit, if INFO <> 0, the result is less than half accurate.
4343*
4344* -- Written on April 1, 1998 by
4345* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4346*
4347* =====================================================================
4348*
4349* .. Parameters ..
4350 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4351 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4352 $ RSRC_
4353 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
4354 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
4355 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
4356 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
4357 REAL ZERO, ONE
4358 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
4359* ..
4360* .. Local Scalars ..
4361 LOGICAL COLREP, ROWREP, TRAN
4362 INTEGER I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
4363 $ IOFFY, IYCOL, IYROW, J, JB, JJY, JN, KK, LDA,
4364 $ LDPY, LDX, LDY, ML, MYCOL, MYROW, NL, NPCOL,
4365 $ NPROW
4366 REAL EPS, ERRI, GTMP, TBETA, YTMP
4367* ..
4368* .. External Subroutines ..
4369 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
4370* ..
4371* .. External Functions ..
4372 LOGICAL LSAME
4373 REAL PSLAMCH
4374 EXTERNAL LSAME, PSLAMCH
4375* ..
4376* .. Intrinsic Functions ..
4377 INTRINSIC ABS, MAX, MIN, MOD, SQRT
4378* ..
4379* .. Executable Statements ..
4380*
4381 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4382*
4383 EPS = PSLAMCH( ICTXT, 'eps' )
4384*
4385.EQ..OR..EQ. IF( M0 N0 ) THEN
4386 TBETA = ONE
4387 ELSE
4388 TBETA = BETA
4389 END IF
4390*
4391 TRAN = LSAME( TRANS, 't.OR.' )LSAME( TRANS, 'c' )
4392 IF( TRAN ) THEN
4393 ML = N
4394 NL = M
4395 ELSE
4396 ML = M
4397 NL = N
4398 END IF
4399*
4400 LDA = MAX( 1, DESCA( M_ ) )
4401 LDX = MAX( 1, DESCX( M_ ) )
4402 LDY = MAX( 1, DESCY( M_ ) )
4403*
4404* Compute expected result in Y using data in A, X and Y.
4405* Compute gauges in G. This part of the computation is performed
4406* by every process in the grid.
4407*
4408 IOFFY = IY + ( JY - 1 ) * LDY
4409 DO 30 I = 1, ML
4410 YTMP = ZERO
4411 GTMP = ZERO
4412 IOFFX = IX + ( JX - 1 ) * LDX
4413 IF( TRAN )THEN
4414 IOFFA = IA + ( JA + I - 2 ) * LDA
4415 DO 10 J = 1, NL
4416 YTMP = YTMP + A( IOFFA ) * X( IOFFX )
4417 GTMP = GTMP + ABS( A( IOFFA ) * X( IOFFX ) )
4418 IOFFA = IOFFA + 1
4419 IOFFX = IOFFX + INCX
4420 10 CONTINUE
4421 ELSE
4422 IOFFA = IA + I - 1 + ( JA - 1 ) * LDA
4423 DO 20 J = 1, NL
4424 YTMP = YTMP + A( IOFFA ) * X( IOFFX )
4425 GTMP = GTMP + ABS( A( IOFFA ) * X( IOFFX ) )
4426 IOFFA = IOFFA + LDA
4427 IOFFX = IOFFX + INCX
4428 20 CONTINUE
4429 END IF
4430 G( I ) = ABS( ALPHA ) * GTMP + ABS( TBETA * Y( IOFFY ) )
4431 Y( IOFFY ) = ALPHA * YTMP + TBETA * Y( IOFFY )
4432 IOFFY = IOFFY + INCY
4433 30 CONTINUE
4434*
4435* Compute the error ratio for this result.
4436*
4437 ERR = ZERO
4438 INFO = 0
4439 LDPY = DESCY( LLD_ )
4440 IOFFY = IY + ( JY - 1 ) * LDY
4441 CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL, IIY,
4442 $ JJY, IYROW, IYCOL )
4443 ICURROW = IYROW
4444 ICURCOL = IYCOL
4445.EQ. ROWREP = ( IYROW-1 )
4446.EQ. COLREP = ( IYCOL-1 )
4447*
4448.EQ. IF( INCYDESCY( M_ ) ) THEN
4449*
4450* sub( Y ) is a row vector
4451*
4452 JB = DESCY( INB_ ) - JY + 1
4453.LE. IF( JB0 )
4454 $ JB = ( ( -JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB
4455 JB = MIN( JB, ML )
4456 JN = JY + JB - 1
4457*
4458 DO 50 J = JY, JN
4459*
4460.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4461.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4462 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
4463.NE. IF( G( J-JY+1 )ZERO )
4464 $ ERRI = ERRI / G( J-JY+1 )
4465 ERR = MAX( ERR, ERRI )
4466.GE. IF( ERR*SQRT( EPS )ONE )
4467 $ INFO = 1
4468 JJY = JJY + 1
4469 END IF
4470*
4471 IOFFY = IOFFY + INCY
4472*
4473 50 CONTINUE
4474*
4475 ICURCOL = MOD( ICURCOL+1, NPCOL )
4476*
4477 DO 70 J = JN+1, JY+ML-1, DESCY( NB_ )
4478 JB = MIN( JY+ML-J, DESCY( NB_ ) )
4479*
4480 DO 60 KK = 0, JB-1
4481*
4482.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4483.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4484 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
4485.NE. IF( G( J+KK-JY+1 )ZERO )
4486 $ ERRI = ERRI / G( J+KK-JY+1 )
4487 ERR = MAX( ERR, ERRI )
4488.GE. IF( ERR*SQRT( EPS )ONE )
4489 $ INFO = 1
4490 JJY = JJY + 1
4491 END IF
4492*
4493 IOFFY = IOFFY + INCY
4494*
4495 60 CONTINUE
4496*
4497 ICURCOL = MOD( ICURCOL+1, NPCOL )
4498*
4499 70 CONTINUE
4500*
4501 ELSE
4502*
4503* sub( Y ) is a column vector
4504*
4505 IB = DESCY( IMB_ ) - IY + 1
4506.LE. IF( IB0 )
4507 $ IB = ( ( -IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB
4508 IB = MIN( IB, ML )
4509 IN = IY + IB - 1
4510*
4511 DO 80 I = IY, IN
4512*
4513.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4514.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4515 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
4516.NE. IF( G( I-IY+1 )ZERO )
4517 $ ERRI = ERRI / G( I-IY+1 )
4518 ERR = MAX( ERR, ERRI )
4519.GE. IF( ERR*SQRT( EPS )ONE )
4520 $ INFO = 1
4521 IIY = IIY + 1
4522 END IF
4523*
4524 IOFFY = IOFFY + INCY
4525*
4526 80 CONTINUE
4527*
4528 ICURROW = MOD( ICURROW+1, NPROW )
4529*
4530 DO 100 I = IN+1, IY+ML-1, DESCY( MB_ )
4531 IB = MIN( IY+ML-I, DESCY( MB_ ) )
4532*
4533 DO 90 KK = 0, IB-1
4534*
4535.EQ..OR..AND. IF( ( MYROWICURROW ROWREP )
4536.EQ..OR. $ ( MYCOLICURCOL COLREP ) ) THEN
4537 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
4538.NE. IF( G( I+KK-IY+1 )ZERO )
4539 $ ERRI = ERRI / G( I+KK-IY+1 )
4540 ERR = MAX( ERR, ERRI )
4541.GE. IF( ERR*SQRT( EPS )ONE )
4542 $ INFO = 1
4543 IIY = IIY + 1
4544 END IF
4545*
4546 IOFFY = IOFFY + INCY
4547*
4548 90 CONTINUE
4549*
4550 ICURROW = MOD( ICURROW+1, NPROW )
4551*
4552 100 CONTINUE
4553*
4554 END IF
4555*
4556* If INFO = 0, all results are at least half accurate.
4557*
4558 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
4559 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
4560 $ MYCOL )
4561*
4562 RETURN
4563*
4564* End of PSMVCH
4565*
4566 END
4567 SUBROUTINE PSVMCH( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
4568 $ INCX, Y, IY, JY, DESCY, INCY, A, PA, IA, JA,
4569 $ DESCA, G, ERR, INFO )
4570*
4571* -- PBLAS test routine (version 2.0) --
4572* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4573* and University of California, Berkeley.
4574* April 1, 1998
4575*
4576* .. Scalar Arguments ..
4577 CHARACTER*1 UPLO
4578 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4579 $ JY, M, N
4580 REAL ALPHA, ERR
4581* ..
4582* .. Array Arguments ..
4583 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4584 REAL A( * ), G( * ), PA( * ), X( * ), Y( * )
4585* ..
4586*
4587* Purpose
4588* =======
4589*
4590* PSVMCH checks the results of the computational tests.
4591*
4592* Notes
4593* =====
4594*
4595* A description vector is associated with each 2D block-cyclicly dis-
4596* tributed matrix. This vector stores the information required to
4597* establish the mapping between a matrix entry and its corresponding
4598* process and memory location.
4599*
4600* In the following comments, the character _ should be read as
4601* "of the distributed matrix". Let A be a generic term for any 2D
4602* block cyclicly distributed matrix. Its description vector is DESCA:
4603*
4604* NOTATION STORED IN EXPLANATION
4605* ---------------- --------------- ------------------------------------
4606* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4607* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4608* the NPROW x NPCOL BLACS process grid
4609* A is distributed over. The context
4610* itself is global, but the handle
4611* (the integer value) may vary.
4612* M_A (global) DESCA( M_ ) The number of rows in the distribu-
4613* ted matrix A, M_A >= 0.
4614* N_A (global) DESCA( N_ ) The number of columns in the distri-
4615* buted matrix A, N_A >= 0.
4616* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4617* block of the matrix A, IMB_A > 0.
4618* INB_A (global) DESCA( INB_ ) The number of columns of the upper
4619* left block of the matrix A,
4620* INB_A > 0.
4621* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4622* bute the last M_A-IMB_A rows of A,
4623* MB_A > 0.
4624* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4625* bute the last N_A-INB_A columns of
4626* A, NB_A > 0.
4627* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4628* row of the matrix A is distributed,
4629* NPROW > RSRC_A >= 0.
4630* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4631* first column of A is distributed.
4632* NPCOL > CSRC_A >= 0.
4633* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4634* array storing the local blocks of
4635* the distributed matrix A,
4636* IF( Lc( 1, N_A ) > 0 )
4637* LLD_A >= MAX( 1, Lr( 1, M_A ) )
4638* ELSE
4639* LLD_A >= 1.
4640*
4641* Let K be the number of rows of a matrix A starting at the global in-
4642* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4643* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4644* receive if these K rows were distributed over NPROW processes. If K
4645* is the number of columns of a matrix A starting at the global index
4646* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4647* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4648* these K columns were distributed over NPCOL processes.
4649*
4650* The values of Lr() and Lc() may be determined via a call to the func-
4651* tion PB_NUMROC:
4652* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4653* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4654*
4655* Arguments
4656* =========
4657*
4658* ICTXT (local input) INTEGER
4659* On entry, ICTXT specifies the BLACS context handle, indica-
4660* ting the global context of the operation. The context itself
4661* is global, but the value of ICTXT is local.
4662*
4663* UPLO (global input) CHARACTER*1
4664* On entry, UPLO specifies which part of the submatrix sub( A )
4665* is to be referenced as follows:
4666* If UPLO = 'L', only the lower triangular part,
4667* If UPLO = 'U', only the upper triangular part,
4668* else the entire matrix is to be referenced.
4669*
4670* M (global input) INTEGER
4671* On entry, M specifies the number of rows of the submatrix
4672* operand matrix A. M must be at least zero.
4673*
4674* N (global input) INTEGER
4675* On entry, N specifies the number of columns of the subma-
4676* trix operand matrix A. N must be at least zero.
4677*
4678* ALPHA (global input) REAL
4679* On entry, ALPHA specifies the scalar alpha.
4680*
4681* X (local input) REAL array
4682* On entry, X is an array of dimension (DESCX( M_ ),*). This
4683* array contains a local copy of the initial entire matrix PX.
4684*
4685* IX (global input) INTEGER
4686* On entry, IX specifies X's global row index, which points to
4687* the beginning of the submatrix sub( X ).
4688*
4689* JX (global input) INTEGER
4690* On entry, JX specifies X's global column index, which points
4691* to the beginning of the submatrix sub( X ).
4692*
4693* DESCX (global and local input) INTEGER array
4694* On entry, DESCX is an integer array of dimension DLEN_. This
4695* is the array descriptor for the matrix X.
4696*
4697* INCX (global input) INTEGER
4698* On entry, INCX specifies the global increment for the
4699* elements of X. Only two values of INCX are supported in
4700* this version, namely 1 and M_X. INCX must not be zero.
4701*
4702* Y (local input) REAL array
4703* On entry, Y is an array of dimension (DESCY( M_ ),*). This
4704* array contains a local copy of the initial entire matrix PY.
4705*
4706* IY (global input) INTEGER
4707* On entry, IY specifies Y's global row index, which points to
4708* the beginning of the submatrix sub( Y ).
4709*
4710* JY (global input) INTEGER
4711* On entry, JY specifies Y's global column index, which points
4712* to the beginning of the submatrix sub( Y ).
4713*
4714* DESCY (global and local input) INTEGER array
4715* On entry, DESCY is an integer array of dimension DLEN_. This
4716* is the array descriptor for the matrix Y.
4717*
4718* INCY (global input) INTEGER
4719* On entry, INCY specifies the global increment for the
4720* elements of Y. Only two values of INCY are supported in
4721* this version, namely 1 and M_Y. INCY must not be zero.
4722*
4723* A (local input/local output) REAL array
4724* On entry, A is an array of dimension (DESCA( M_ ),*). This
4725* array contains a local copy of the initial entire matrix PA.
4726*
4727* PA (local input) REAL array
4728* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
4729* array contains the local entries of the matrix PA.
4730*
4731* IA (global input) INTEGER
4732* On entry, IA specifies A's global row index, which points to
4733* the beginning of the submatrix sub( A ).
4734*
4735* JA (global input) INTEGER
4736* On entry, JA specifies A's global column index, which points
4737* to the beginning of the submatrix sub( A ).
4738*
4739* DESCA (global and local input) INTEGER array
4740* On entry, DESCA is an integer array of dimension DLEN_. This
4741* is the array descriptor for the matrix A.
4742*
4743* G (workspace) REAL array
4744* On entry, G is an array of dimension at least MAX( M, N ). G
4745* is used to compute the gauges.
4746*
4747* ERR (global output) REAL
4748* On exit, ERR specifies the largest error in absolute value.
4749*
4750* INFO (global output) INTEGER
4751* On exit, if INFO <> 0, the result is less than half accurate.
4752*
4753* -- Written on April 1, 1998 by
4754* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4755*
4756* =====================================================================
4757*
4758* .. Parameters ..
4759 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4760 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4761 $ RSRC_
4762 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
4763 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
4764 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
4765 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
4766 REAL ZERO, ONE
4767 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
4768* ..
4769* .. Local Scalars ..
4770 LOGICAL COLREP, LOWER, ROWREP, UPPER
4771 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
4772 $ IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA,
4773 $ LDX, LDY, MYCOL, MYROW, NPCOL, NPROW
4774 REAL ATMP, EPS, ERRI, GTMP
4775* ..
4776* .. External Subroutines ..
4777 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
4778* ..
4779* .. External Functions ..
4780 LOGICAL LSAME
4781 REAL PSLAMCH
4782 EXTERNAL LSAME, PSLAMCH
4783* ..
4784* .. Intrinsic Functions ..
4785 INTRINSIC ABS, MAX, MIN, MOD, SQRT
4786* ..
4787* .. Executable Statements ..
4788*
4789 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
4790*
4791 EPS = PSLAMCH( ICTXT, 'eps' )
4792*
4793 UPPER = LSAME( UPLO, 'u' )
4794 LOWER = LSAME( UPLO, 'l' )
4795*
4796 LDA = MAX( 1, DESCA( M_ ) )
4797 LDX = MAX( 1, DESCX( M_ ) )
4798 LDY = MAX( 1, DESCY( M_ ) )
4799*
4800* Compute expected result in A using data in A, X and Y.
4801* Compute gauges in G. This part of the computation is performed
4802* by every process in the grid.
4803*
4804 DO 70 J = 1, N
4805*
4806 IOFFY = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
4807*
4808 IF( LOWER ) THEN
4809 IBEG = J
4810 IEND = M
4811 DO 10 I = 1, J-1
4812 G( I ) = ZERO
4813 10 CONTINUE
4814 ELSE IF( UPPER ) THEN
4815 IBEG = 1
4816 IEND = J
4817 DO 20 I = J+1, M
4818 G( I ) = ZERO
4819 20 CONTINUE
4820 ELSE
4821 IBEG = 1
4822 IEND = M
4823 END IF
4824*
4825 DO 30 I = IBEG, IEND
4826*
4827 IOFFX = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
4828 IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
4829 ATMP = X( IOFFX ) * Y( IOFFY )
4830 GTMP = ABS( X( IOFFX ) * Y( IOFFY ) )
4831 G( I ) = ABS( ALPHA ) * GTMP + ABS( A( IOFFA ) )
4832 A( IOFFA ) = ALPHA * ATMP + A( IOFFA )
4833*
4834 30 CONTINUE
4835*
4836* Compute the error ratio for this result.
4837*
4838 INFO = 0
4839 ERR = ZERO
4840 LDPA = DESCA( LLD_ )
4841 IOFFA = IA + ( JA + J - 2 ) * LDA
4842 CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
4843 $ IIA, JJA, IAROW, IACOL )
4844.EQ. ROWREP = ( IAROW-1 )
4845.EQ. COLREP = ( IACOL-1 )
4846*
4847.EQ..OR. IF( MYCOLIACOL COLREP ) THEN
4848*
4849 ICURROW = IAROW
4850 IB = DESCA( IMB_ ) - IA + 1
4851.LE. IF( IB0 )
4852 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
4853 IB = MIN( IB, M )
4854 IN = IA + IB - 1
4855*
4856 DO 40 I = IA, IN
4857*
4858.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
4859 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
4860.NE. IF( G( I-IA+1 )ZERO )
4861 $ ERRI = ERRI / G( I-IA+1 )
4862 ERR = MAX( ERR, ERRI )
4863.GE. IF( ERR*SQRT( EPS )ONE )
4864 $ INFO = 1
4865 IIA = IIA + 1
4866 END IF
4867*
4868 IOFFA = IOFFA + 1
4869*
4870 40 CONTINUE
4871*
4872 ICURROW = MOD( ICURROW+1, NPROW )
4873*
4874 DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
4875 IB = MIN( IA+M-I, DESCA( MB_ ) )
4876*
4877 DO 50 KK = 0, IB-1
4878*
4879.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
4880 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
4881.NE. IF( G( I+KK-IA+1 )ZERO )
4882 $ ERRI = ERRI / G( I+KK-IA+1 )
4883 ERR = MAX( ERR, ERRI )
4884.GE. IF( ERR*SQRT( EPS )ONE )
4885 $ INFO = 1
4886 IIA = IIA + 1
4887 END IF
4888*
4889 IOFFA = IOFFA + 1
4890*
4891 50 CONTINUE
4892*
4893 ICURROW = MOD( ICURROW+1, NPROW )
4894*
4895 60 CONTINUE
4896*
4897 END IF
4898*
4899* If INFO = 0, all results are at least half accurate.
4900*
4901 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
4902 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
4903 $ MYCOL )
4904.NE. IF( INFO0 )
4905 $ GO TO 80
4906*
4907 70 CONTINUE
4908*
4909 80 CONTINUE
4910*
4911 RETURN
4912*
4913* End of PSVMCH
4914*
4915 END
4916 SUBROUTINE PSVMCH2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
4917 $ INCX, Y, IY, JY, DESCY, INCY, A, PA, IA,
4918 $ JA, DESCA, G, ERR, INFO )
4919*
4920* -- PBLAS test routine (version 2.0) --
4921* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4922* and University of California, Berkeley.
4923* April 1, 1998
4924*
4925* .. Scalar Arguments ..
4926 CHARACTER*1 UPLO
4927 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4928 $ JY, M, N
4929 REAL ALPHA, ERR
4930* ..
4931* .. Array Arguments ..
4932 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4933 REAL A( * ), G( * ), PA( * ), X( * ), Y( * )
4934* ..
4935*
4936* Purpose
4937* =======
4938*
4939* PSVMCH2 checks the results of the computational tests.
4940*
4941* Notes
4942* =====
4943*
4944* A description vector is associated with each 2D block-cyclicly dis-
4945* tributed matrix. This vector stores the information required to
4946* establish the mapping between a matrix entry and its corresponding
4947* process and memory location.
4948*
4949* In the following comments, the character _ should be read as
4950* "of the distributed matrix". Let A be a generic term for any 2D
4951* block cyclicly distributed matrix. Its description vector is DESCA:
4952*
4953* NOTATION STORED IN EXPLANATION
4954* ---------------- --------------- ------------------------------------
4955* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4956* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4957* the NPROW x NPCOL BLACS process grid
4958* A is distributed over. The context
4959* itself is global, but the handle
4960* (the integer value) may vary.
4961* M_A (global) DESCA( M_ ) The number of rows in the distribu-
4962* ted matrix A, M_A >= 0.
4963* N_A (global) DESCA( N_ ) The number of columns in the distri-
4964* buted matrix A, N_A >= 0.
4965* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4966* block of the matrix A, IMB_A > 0.
4967* INB_A (global) DESCA( INB_ ) The number of columns of the upper
4968* left block of the matrix A,
4969* INB_A > 0.
4970* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4971* bute the last M_A-IMB_A rows of A,
4972* MB_A > 0.
4973* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4974* bute the last N_A-INB_A columns of
4975* A, NB_A > 0.
4976* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4977* row of the matrix A is distributed,
4978* NPROW > RSRC_A >= 0.
4979* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4980* first column of A is distributed.
4981* NPCOL > CSRC_A >= 0.
4982* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4983* array storing the local blocks of
4984* the distributed matrix A,
4985* IF( Lc( 1, N_A ) > 0 )
4986* LLD_A >= MAX( 1, Lr( 1, M_A ) )
4987* ELSE
4988* LLD_A >= 1.
4989*
4990* Let K be the number of rows of a matrix A starting at the global in-
4991* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4992* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4993* receive if these K rows were distributed over NPROW processes. If K
4994* is the number of columns of a matrix A starting at the global index
4995* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4996* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4997* these K columns were distributed over NPCOL processes.
4998*
4999* The values of Lr() and Lc() may be determined via a call to the func-
5000* tion PB_NUMROC:
5001* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5002* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5003*
5004* Arguments
5005* =========
5006*
5007* ICTXT (local input) INTEGER
5008* On entry, ICTXT specifies the BLACS context handle, indica-
5009* ting the global context of the operation. The context itself
5010* is global, but the value of ICTXT is local.
5011*
5012* UPLO (global input) CHARACTER*1
5013* On entry, UPLO specifies which part of the submatrix sub( A )
5014* is to be referenced as follows:
5015* If UPLO = 'L', only the lower triangular part,
5016* If UPLO = 'U', only the upper triangular part,
5017* else the entire matrix is to be referenced.
5018*
5019* M (global input) INTEGER
5020* On entry, M specifies the number of rows of the submatrix
5021* operand matrix A. M must be at least zero.
5022*
5023* N (global input) INTEGER
5024* On entry, N specifies the number of columns of the subma-
5025* trix operand matrix A. N must be at least zero.
5026*
5027* ALPHA (global input) REAL
5028* On entry, ALPHA specifies the scalar alpha.
5029*
5030* X (local input) REAL array
5031* On entry, X is an array of dimension (DESCX( M_ ),*). This
5032* array contains a local copy of the initial entire matrix PX.
5033*
5034* IX (global input) INTEGER
5035* On entry, IX specifies X's global row index, which points to
5036* the beginning of the submatrix sub( X ).
5037*
5038* JX (global input) INTEGER
5039* On entry, JX specifies X's global column index, which points
5040* to the beginning of the submatrix sub( X ).
5041*
5042* DESCX (global and local input) INTEGER array
5043* On entry, DESCX is an integer array of dimension DLEN_. This
5044* is the array descriptor for the matrix X.
5045*
5046* INCX (global input) INTEGER
5047* On entry, INCX specifies the global increment for the
5048* elements of X. Only two values of INCX are supported in
5049* this version, namely 1 and M_X. INCX must not be zero.
5050*
5051* Y (local input) REAL array
5052* On entry, Y is an array of dimension (DESCY( M_ ),*). This
5053* array contains a local copy of the initial entire matrix PY.
5054*
5055* IY (global input) INTEGER
5056* On entry, IY specifies Y's global row index, which points to
5057* the beginning of the submatrix sub( Y ).
5058*
5059* JY (global input) INTEGER
5060* On entry, JY specifies Y's global column index, which points
5061* to the beginning of the submatrix sub( Y ).
5062*
5063* DESCY (global and local input) INTEGER array
5064* On entry, DESCY is an integer array of dimension DLEN_. This
5065* is the array descriptor for the matrix Y.
5066*
5067* INCY (global input) INTEGER
5068* On entry, INCY specifies the global increment for the
5069* elements of Y. Only two values of INCY are supported in
5070* this version, namely 1 and M_Y. INCY must not be zero.
5071*
5072* A (local input/local output) REAL array
5073* On entry, A is an array of dimension (DESCA( M_ ),*). This
5074* array contains a local copy of the initial entire matrix PA.
5075*
5076* PA (local input) REAL array
5077* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
5078* array contains the local entries of the matrix PA.
5079*
5080* IA (global input) INTEGER
5081* On entry, IA specifies A's global row index, which points to
5082* the beginning of the submatrix sub( A ).
5083*
5084* JA (global input) INTEGER
5085* On entry, JA specifies A's global column index, which points
5086* to the beginning of the submatrix sub( A ).
5087*
5088* DESCA (global and local input) INTEGER array
5089* On entry, DESCA is an integer array of dimension DLEN_. This
5090* is the array descriptor for the matrix A.
5091*
5092* G (workspace) REAL array
5093* On entry, G is an array of dimension at least MAX( M, N ). G
5094* is used to compute the gauges.
5095*
5096* ERR (global output) REAL
5097* On exit, ERR specifies the largest error in absolute value.
5098*
5099* INFO (global output) INTEGER
5100* On exit, if INFO <> 0, the result is less than half accurate.
5101*
5102* -- Written on April 1, 1998 by
5103* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5104*
5105* =====================================================================
5106*
5107* .. Parameters ..
5108 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5109 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5110 $ RSRC_
5111 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
5112 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
5113 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
5114 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
5115 REAL ZERO, ONE
5116 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
5117* ..
5118* .. Local Scalars ..
5119 LOGICAL COLREP, LOWER, ROWREP, UPPER
5120 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
5121 $ IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J,
5122 $ JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW,
5123 $ NPCOL, NPROW
5124 REAL EPS, ERRI, GTMP, ATMP
5125* ..
5126* .. External Subroutines ..
5127 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
5128* ..
5129* .. External Functions ..
5130 LOGICAL LSAME
5131 REAL PSLAMCH
5132 EXTERNAL LSAME, PSLAMCH
5133* ..
5134* .. Intrinsic Functions ..
5135 INTRINSIC ABS, MAX, MIN, MOD, SQRT
5136* ..
5137* .. Executable Statements ..
5138*
5139 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
5140*
5141 EPS = PSLAMCH( ICTXT, 'eps' )
5142*
5143 UPPER = LSAME( UPLO, 'u' )
5144 LOWER = LSAME( UPLO, 'l' )
5145*
5146 LDA = MAX( 1, DESCA( M_ ) )
5147 LDX = MAX( 1, DESCX( M_ ) )
5148 LDY = MAX( 1, DESCY( M_ ) )
5149*
5150* Compute expected result in A using data in A, X and Y.
5151* Compute gauges in G. This part of the computation is performed
5152* by every process in the grid.
5153*
5154 DO 70 J = 1, N
5155*
5156 IOFFXJ = IX + ( JX - 1 ) * LDX + ( J - 1 ) * INCX
5157 IOFFYJ = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
5158*
5159 IF( LOWER ) THEN
5160 IBEG = J
5161 IEND = M
5162 DO 10 I = 1, J-1
5163 G( I ) = ZERO
5164 10 CONTINUE
5165 ELSE IF( UPPER ) THEN
5166 IBEG = 1
5167 IEND = J
5168 DO 20 I = J+1, M
5169 G( I ) = ZERO
5170 20 CONTINUE
5171 ELSE
5172 IBEG = 1
5173 IEND = M
5174 END IF
5175*
5176 DO 30 I = IBEG, IEND
5177 IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
5178 IOFFXI = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
5179 IOFFYI = IY + ( JY - 1 ) * LDY + ( I - 1 ) * INCY
5180 ATMP = X( IOFFXI ) * Y( IOFFYJ )
5181 ATMP = ATMP + Y( IOFFYI ) * X( IOFFXJ )
5182 GTMP = ABS( X( IOFFXI ) * Y( IOFFYJ ) )
5183 GTMP = GTMP + ABS( Y( IOFFYI ) * X( IOFFXJ ) )
5184 G( I ) = ABS( ALPHA ) * GTMP + ABS( A( IOFFA ) )
5185 A( IOFFA ) = ALPHA*ATMP + A( IOFFA )
5186*
5187 30 CONTINUE
5188*
5189* Compute the error ratio for this result.
5190*
5191 INFO = 0
5192 ERR = ZERO
5193 LDPA = DESCA( LLD_ )
5194 IOFFA = IA + ( JA + J - 2 ) * LDA
5195 CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
5196 $ IIA, JJA, IAROW, IACOL )
5197.EQ. ROWREP = ( IAROW-1 )
5198.EQ. COLREP = ( IACOL-1 )
5199*
5200.EQ..OR. IF( MYCOLIACOL COLREP ) THEN
5201*
5202 ICURROW = IAROW
5203 IB = DESCA( IMB_ ) - IA + 1
5204.LE. IF( IB0 )
5205 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
5206 IB = MIN( IB, M )
5207 IN = IA + IB - 1
5208*
5209 DO 40 I = IA, IN
5210*
5211.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5212 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
5213.NE. IF( G( I-IA+1 )ZERO )
5214 $ ERRI = ERRI / G( I-IA+1 )
5215 ERR = MAX( ERR, ERRI )
5216.GE. IF( ERR*SQRT( EPS )ONE )
5217 $ INFO = 1
5218 IIA = IIA + 1
5219 END IF
5220*
5221 IOFFA = IOFFA + 1
5222*
5223 40 CONTINUE
5224*
5225 ICURROW = MOD( ICURROW+1, NPROW )
5226*
5227 DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
5228 IB = MIN( IA+M-I, DESCA( MB_ ) )
5229*
5230 DO 50 KK = 0, IB-1
5231*
5232.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5233 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
5234.NE. IF( G( I+KK-IA+1 )ZERO )
5235 $ ERRI = ERRI / G( I+KK-IA+1 )
5236 ERR = MAX( ERR, ERRI )
5237.GE. IF( ERR*SQRT( EPS )ONE )
5238 $ INFO = 1
5239 IIA = IIA + 1
5240 END IF
5241*
5242 IOFFA = IOFFA + 1
5243*
5244 50 CONTINUE
5245*
5246 ICURROW = MOD( ICURROW+1, NPROW )
5247*
5248 60 CONTINUE
5249*
5250 END IF
5251*
5252* If INFO = 0, all results are at least half accurate.
5253*
5254 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
5255 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
5256 $ MYCOL )
5257.NE. IF( INFO0 )
5258 $ GO TO 80
5259*
5260 70 CONTINUE
5261*
5262 80 CONTINUE
5263*
5264 RETURN
5265*
5266* End of PSVMCH2
5267*
5268 END
5269 SUBROUTINE PSMMCH( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA,
5270 $ JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
5271 $ JC, DESCC, CT, G, ERR, INFO )
5272*
5273* -- PBLAS test routine (version 2.0) --
5274* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5275* and University of California, Berkeley.
5276* April 1, 1998
5277*
5278* .. Scalar Arguments ..
5279 CHARACTER*1 TRANSA, TRANSB
5280 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
5281 REAL ALPHA, BETA, ERR
5282* ..
5283* .. Array Arguments ..
5284 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
5285 REAL A( * ), B( * ), C( * ), CT( * ), G( * ),
5286 $ PC( * )
5287* ..
5288*
5289* Purpose
5290* =======
5291*
5292* PSMMCH checks the results of the computational tests.
5293*
5294* Notes
5295* =====
5296*
5297* A description vector is associated with each 2D block-cyclicly dis-
5298* tributed matrix. This vector stores the information required to
5299* establish the mapping between a matrix entry and its corresponding
5300* process and memory location.
5301*
5302* In the following comments, the character _ should be read as
5303* "of the distributed matrix". Let A be a generic term for any 2D
5304* block cyclicly distributed matrix. Its description vector is DESCA:
5305*
5306* NOTATION STORED IN EXPLANATION
5307* ---------------- --------------- ------------------------------------
5308* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5309* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5310* the NPROW x NPCOL BLACS process grid
5311* A is distributed over. The context
5312* itself is global, but the handle
5313* (the integer value) may vary.
5314* M_A (global) DESCA( M_ ) The number of rows in the distribu-
5315* ted matrix A, M_A >= 0.
5316* N_A (global) DESCA( N_ ) The number of columns in the distri-
5317* buted matrix A, N_A >= 0.
5318* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5319* block of the matrix A, IMB_A > 0.
5320* INB_A (global) DESCA( INB_ ) The number of columns of the upper
5321* left block of the matrix A,
5322* INB_A > 0.
5323* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5324* bute the last M_A-IMB_A rows of A,
5325* MB_A > 0.
5326* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5327* bute the last N_A-INB_A columns of
5328* A, NB_A > 0.
5329* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5330* row of the matrix A is distributed,
5331* NPROW > RSRC_A >= 0.
5332* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5333* first column of A is distributed.
5334* NPCOL > CSRC_A >= 0.
5335* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5336* array storing the local blocks of
5337* the distributed matrix A,
5338* IF( Lc( 1, N_A ) > 0 )
5339* LLD_A >= MAX( 1, Lr( 1, M_A ) )
5340* ELSE
5341* LLD_A >= 1.
5342*
5343* Let K be the number of rows of a matrix A starting at the global in-
5344* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5345* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5346* receive if these K rows were distributed over NPROW processes. If K
5347* is the number of columns of a matrix A starting at the global index
5348* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5349* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5350* these K columns were distributed over NPCOL processes.
5351*
5352* The values of Lr() and Lc() may be determined via a call to the func-
5353* tion PB_NUMROC:
5354* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5355* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5356*
5357* Arguments
5358* =========
5359*
5360* ICTXT (local input) INTEGER
5361* On entry, ICTXT specifies the BLACS context handle, indica-
5362* ting the global context of the operation. The context itself
5363* is global, but the value of ICTXT is local.
5364*
5365* TRANSA (global input) CHARACTER*1
5366* On entry, TRANSA specifies if the matrix operand A is to be
5367* transposed.
5368*
5369* TRANSB (global input) CHARACTER*1
5370* On entry, TRANSB specifies if the matrix operand B is to be
5371* transposed.
5372*
5373* M (global input) INTEGER
5374* On entry, M specifies the number of rows of C.
5375*
5376* N (global input) INTEGER
5377* On entry, N specifies the number of columns of C.
5378*
5379* K (global input) INTEGER
5380* On entry, K specifies the number of columns (resp. rows) of A
5381* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
5382* PxSYR2K, PxHERK and PxHER2K.
5383*
5384* ALPHA (global input) REAL
5385* On entry, ALPHA specifies the scalar alpha.
5386*
5387* A (local input) REAL array
5388* On entry, A is an array of dimension (DESCA( M_ ),*). This
5389* array contains a local copy of the initial entire matrix PA.
5390*
5391* IA (global input) INTEGER
5392* On entry, IA specifies A's global row index, which points to
5393* the beginning of the submatrix sub( A ).
5394*
5395* JA (global input) INTEGER
5396* On entry, JA specifies A's global column index, which points
5397* to the beginning of the submatrix sub( A ).
5398*
5399* DESCA (global and local input) INTEGER array
5400* On entry, DESCA is an integer array of dimension DLEN_. This
5401* is the array descriptor for the matrix A.
5402*
5403* B (local input) REAL array
5404* On entry, B is an array of dimension (DESCB( M_ ),*). This
5405* array contains a local copy of the initial entire matrix PB.
5406*
5407* IB (global input) INTEGER
5408* On entry, IB specifies B's global row index, which points to
5409* the beginning of the submatrix sub( B ).
5410*
5411* JB (global input) INTEGER
5412* On entry, JB specifies B's global column index, which points
5413* to the beginning of the submatrix sub( B ).
5414*
5415* DESCB (global and local input) INTEGER array
5416* On entry, DESCB is an integer array of dimension DLEN_. This
5417* is the array descriptor for the matrix B.
5418*
5419* BETA (global input) REAL
5420* On entry, BETA specifies the scalar beta.
5421*
5422* C (local input/local output) REAL array
5423* On entry, C is an array of dimension (DESCC( M_ ),*). This
5424* array contains a local copy of the initial entire matrix PC.
5425*
5426* PC (local input) REAL array
5427* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5428* array contains the local pieces of the matrix PC.
5429*
5430* IC (global input) INTEGER
5431* On entry, IC specifies C's global row index, which points to
5432* the beginning of the submatrix sub( C ).
5433*
5434* JC (global input) INTEGER
5435* On entry, JC specifies C's global column index, which points
5436* to the beginning of the submatrix sub( C ).
5437*
5438* DESCC (global and local input) INTEGER array
5439* On entry, DESCC is an integer array of dimension DLEN_. This
5440* is the array descriptor for the matrix C.
5441*
5442* CT (workspace) REAL array
5443* On entry, CT is an array of dimension at least MAX(M,N,K). CT
5444* holds a copy of the current column of C.
5445*
5446* G (workspace) REAL array
5447* On entry, G is an array of dimension at least MAX(M,N,K). G
5448* is used to compute the gauges.
5449*
5450* ERR (global output) REAL
5451* On exit, ERR specifies the largest error in absolute value.
5452*
5453* INFO (global output) INTEGER
5454* On exit, if INFO <> 0, the result is less than half accurate.
5455*
5456* -- Written on April 1, 1998 by
5457* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5458*
5459* =====================================================================
5460*
5461* .. Parameters ..
5462 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5463 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5464 $ RSRC_
5465 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
5466 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
5467 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
5468 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
5469 REAL ZERO, ONE
5470 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
5471* ..
5472* .. Local Scalars ..
5473 LOGICAL COLREP, ROWREP, TRANA, TRANB
5474 INTEGER I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
5475 $ IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC,
5476 $ MYCOL, MYROW, NPCOL, NPROW
5477 REAL EPS, ERRI
5478* ..
5479* .. External Subroutines ..
5480 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
5481* ..
5482* .. External Functions ..
5483 LOGICAL LSAME
5484 REAL PSLAMCH
5485 EXTERNAL LSAME, PSLAMCH
5486* ..
5487* .. Intrinsic Functions ..
5488 INTRINSIC ABS, MAX, MIN, MOD, SQRT
5489* ..
5490* .. Executable Statements ..
5491*
5492 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
5493*
5494 EPS = PSLAMCH( ICTXT, 'eps' )
5495*
5496 TRANA = LSAME( TRANSA, 't.OR.' )LSAME( TRANSA, 'c' )
5497 TRANB = LSAME( TRANSB, 't.OR.' )LSAME( TRANSB, 'c' )
5498*
5499 LDA = MAX( 1, DESCA( M_ ) )
5500 LDB = MAX( 1, DESCB( M_ ) )
5501 LDC = MAX( 1, DESCC( M_ ) )
5502*
5503* Compute expected result in C using data in A, B and C.
5504* Compute gauges in G. This part of the computation is performed
5505* by every process in the grid.
5506*
5507 DO 240 J = 1, N
5508*
5509 IOFFC = IC + ( JC + J - 2 ) * LDC
5510 DO 10 I = 1, M
5511 CT( I ) = ZERO
5512 G( I ) = ZERO
5513 10 CONTINUE
5514*
5515.NOT..AND..NOT. IF( TRANA TRANB ) THEN
5516 DO 30 KK = 1, K
5517 IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
5518 DO 20 I = 1, M
5519 IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
5520 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
5521 G( I ) = G( I ) + ABS( A( IOFFA ) ) *
5522 $ ABS( B( IOFFB ) )
5523 20 CONTINUE
5524 30 CONTINUE
5525.AND..NOT. ELSE IF( TRANA TRANB ) THEN
5526 DO 50 KK = 1, K
5527 IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
5528 DO 40 I = 1, M
5529 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
5530 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
5531 G( I ) = G( I ) + ABS( A( IOFFA ) ) *
5532 $ ABS( B( IOFFB ) )
5533 40 CONTINUE
5534 50 CONTINUE
5535.NOT..AND. ELSE IF( TRANA TRANB ) THEN
5536 DO 70 KK = 1, K
5537 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
5538 DO 60 I = 1, M
5539 IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
5540 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
5541 G( I ) = G( I ) + ABS( A( IOFFA ) ) *
5542 $ ABS( B( IOFFB ) )
5543 60 CONTINUE
5544 70 CONTINUE
5545.AND. ELSE IF( TRANA TRANB ) THEN
5546 DO 90 KK = 1, K
5547 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
5548 DO 80 I = 1, M
5549 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
5550 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
5551 G( I ) = G( I ) + ABS( A( IOFFA ) ) *
5552 $ ABS( B( IOFFB ) )
5553 80 CONTINUE
5554 90 CONTINUE
5555 END IF
5556*
5557 DO 200 I = 1, M
5558 CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
5559 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
5560 C( IOFFC ) = CT( I )
5561 IOFFC = IOFFC + 1
5562 200 CONTINUE
5563*
5564* Compute the error ratio for this result.
5565*
5566 ERR = ZERO
5567 INFO = 0
5568 LDPC = DESCC( LLD_ )
5569 IOFFC = IC + ( JC + J - 2 ) * LDC
5570 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
5571 $ IIC, JJC, ICROW, ICCOL )
5572 ICURROW = ICROW
5573.EQ. ROWREP = ( ICROW-1 )
5574.EQ. COLREP = ( ICCOL-1 )
5575*
5576.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
5577*
5578 IBB = DESCC( IMB_ ) - IC + 1
5579.LE. IF( IBB0 )
5580 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
5581 IBB = MIN( IBB, M )
5582 IN = IC + IBB - 1
5583*
5584 DO 210 I = IC, IN
5585*
5586.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5587 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5588 $ C( IOFFC ) ) / EPS
5589.NE. IF( G( I-IC+1 )ZERO )
5590 $ ERRI = ERRI / G( I-IC+1 )
5591 ERR = MAX( ERR, ERRI )
5592.GE. IF( ERR*SQRT( EPS )ONE )
5593 $ INFO = 1
5594 IIC = IIC + 1
5595 END IF
5596*
5597 IOFFC = IOFFC + 1
5598*
5599 210 CONTINUE
5600*
5601 ICURROW = MOD( ICURROW+1, NPROW )
5602*
5603 DO 230 I = IN+1, IC+M-1, DESCC( MB_ )
5604 IBB = MIN( IC+M-I, DESCC( MB_ ) )
5605*
5606 DO 220 KK = 0, IBB-1
5607*
5608.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5609 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5610 $ C( IOFFC ) )/EPS
5611.NE. IF( G( I+KK-IC+1 )ZERO )
5612 $ ERRI = ERRI / G( I+KK-IC+1 )
5613 ERR = MAX( ERR, ERRI )
5614.GE. IF( ERR*SQRT( EPS )ONE )
5615 $ INFO = 1
5616 IIC = IIC + 1
5617 END IF
5618*
5619 IOFFC = IOFFC + 1
5620*
5621 220 CONTINUE
5622*
5623 ICURROW = MOD( ICURROW+1, NPROW )
5624*
5625 230 CONTINUE
5626*
5627 END IF
5628*
5629* If INFO = 0, all results are at least half accurate.
5630*
5631 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
5632 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
5633 $ MYCOL )
5634.NE. IF( INFO0 )
5635 $ GO TO 250
5636*
5637 240 CONTINUE
5638*
5639 250 CONTINUE
5640*
5641 RETURN
5642*
5643* End of PSMMCH
5644*
5645 END
5646 SUBROUTINE PSMMCH1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
5647 $ DESCA, BETA, C, PC, IC, JC, DESCC, CT, G,
5648 $ ERR, INFO )
5649*
5650* -- PBLAS test routine (version 2.0) --
5651* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5652* and University of California, Berkeley.
5653* April 1, 1998
5654*
5655* .. Scalar Arguments ..
5656 CHARACTER*1 TRANS, UPLO
5657 INTEGER IA, IC, ICTXT, INFO, JA, JC, K, N
5658 REAL ALPHA, BETA, ERR
5659* ..
5660* .. Array Arguments ..
5661 INTEGER DESCA( * ), DESCC( * )
5662 REAL A( * ), C( * ), CT( * ), G( * ), PC( * )
5663* ..
5664*
5665* Purpose
5666* =======
5667*
5668* PSMMCH1 checks the results of the computational tests.
5669*
5670* Notes
5671* =====
5672*
5673* A description vector is associated with each 2D block-cyclicly dis-
5674* tributed matrix. This vector stores the information required to
5675* establish the mapping between a matrix entry and its corresponding
5676* process and memory location.
5677*
5678* In the following comments, the character _ should be read as
5679* "of the distributed matrix". Let A be a generic term for any 2D
5680* block cyclicly distributed matrix. Its description vector is DESCA:
5681*
5682* NOTATION STORED IN EXPLANATION
5683* ---------------- --------------- ------------------------------------
5684* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5685* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5686* the NPROW x NPCOL BLACS process grid
5687* A is distributed over. The context
5688* itself is global, but the handle
5689* (the integer value) may vary.
5690* M_A (global) DESCA( M_ ) The number of rows in the distribu-
5691* ted matrix A, M_A >= 0.
5692* N_A (global) DESCA( N_ ) The number of columns in the distri-
5693* buted matrix A, N_A >= 0.
5694* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5695* block of the matrix A, IMB_A > 0.
5696* INB_A (global) DESCA( INB_ ) The number of columns of the upper
5697* left block of the matrix A,
5698* INB_A > 0.
5699* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5700* bute the last M_A-IMB_A rows of A,
5701* MB_A > 0.
5702* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5703* bute the last N_A-INB_A columns of
5704* A, NB_A > 0.
5705* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5706* row of the matrix A is distributed,
5707* NPROW > RSRC_A >= 0.
5708* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5709* first column of A is distributed.
5710* NPCOL > CSRC_A >= 0.
5711* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5712* array storing the local blocks of
5713* the distributed matrix A,
5714* IF( Lc( 1, N_A ) > 0 )
5715* LLD_A >= MAX( 1, Lr( 1, M_A ) )
5716* ELSE
5717* LLD_A >= 1.
5718*
5719* Let K be the number of rows of a matrix A starting at the global in-
5720* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5721* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5722* receive if these K rows were distributed over NPROW processes. If K
5723* is the number of columns of a matrix A starting at the global index
5724* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5725* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5726* these K columns were distributed over NPCOL processes.
5727*
5728* The values of Lr() and Lc() may be determined via a call to the func-
5729* tion PB_NUMROC:
5730* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5731* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5732*
5733* Arguments
5734* =========
5735*
5736* ICTXT (local input) INTEGER
5737* On entry, ICTXT specifies the BLACS context handle, indica-
5738* ting the global context of the operation. The context itself
5739* is global, but the value of ICTXT is local.
5740*
5741* UPLO (global input) CHARACTER*1
5742* On entry, UPLO specifies which part of C should contain the
5743* result.
5744*
5745* TRANS (global input) CHARACTER*1
5746* On entry, TRANS specifies whether the matrix A has to be
5747* transposed or not before computing the matrix-matrix product.
5748*
5749* N (global input) INTEGER
5750* On entry, N specifies the order the submatrix operand C. N
5751* must be at least zero.
5752*
5753* K (global input) INTEGER
5754* On entry, K specifies the number of columns (resp. rows) of A
5755* when TRANS = 'N' (resp. TRANS <> 'N'). K must be at least
5756* zero.
5757*
5758* ALPHA (global input) REAL
5759* On entry, ALPHA specifies the scalar alpha.
5760*
5761* A (local input) REAL array
5762* On entry, A is an array of dimension (DESCA( M_ ),*). This
5763* array contains a local copy of the initial entire matrix PA.
5764*
5765* IA (global input) INTEGER
5766* On entry, IA specifies A's global row index, which points to
5767* the beginning of the submatrix sub( A ).
5768*
5769* JA (global input) INTEGER
5770* On entry, JA specifies A's global column index, which points
5771* to the beginning of the submatrix sub( A ).
5772*
5773* DESCA (global and local input) INTEGER array
5774* On entry, DESCA is an integer array of dimension DLEN_. This
5775* is the array descriptor for the matrix A.
5776*
5777* BETA (global input) REAL
5778* On entry, BETA specifies the scalar beta.
5779*
5780* C (local input/local output) REAL array
5781* On entry, C is an array of dimension (DESCC( M_ ),*). This
5782* array contains a local copy of the initial entire matrix PC.
5783*
5784* PC (local input) REAL array
5785* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5786* array contains the local pieces of the matrix PC.
5787*
5788* IC (global input) INTEGER
5789* On entry, IC specifies C's global row index, which points to
5790* the beginning of the submatrix sub( C ).
5791*
5792* JC (global input) INTEGER
5793* On entry, JC specifies C's global column index, which points
5794* to the beginning of the submatrix sub( C ).
5795*
5796* DESCC (global and local input) INTEGER array
5797* On entry, DESCC is an integer array of dimension DLEN_. This
5798* is the array descriptor for the matrix C.
5799*
5800* CT (workspace) REAL array
5801* On entry, CT is an array of dimension at least MAX(M,N,K). CT
5802* holds a copy of the current column of C.
5803*
5804* G (workspace) REAL array
5805* On entry, G is an array of dimension at least MAX(M,N,K). G
5806* is used to compute the gauges.
5807*
5808* ERR (global output) REAL
5809* On exit, ERR specifies the largest error in absolute value.
5810*
5811* INFO (global output) INTEGER
5812* On exit, if INFO <> 0, the result is less than half accurate.
5813*
5814* -- Written on April 1, 1998 by
5815* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5816*
5817* =====================================================================
5818*
5819* .. Parameters ..
5820 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5821 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5822 $ RSRC_
5823 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
5824 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
5825 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
5826 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
5827 REAL ZERO, ONE
5828 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
5829* ..
5830* .. Local Scalars ..
5831 LOGICAL COLREP, NOTRAN, ROWREP, TRAN, UPPER
5832 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
5833 $ IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
5834 $ LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW
5835 REAL EPS, ERRI
5836* ..
5837* .. External Subroutines ..
5838 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
5839* ..
5840* .. External Functions ..
5841 LOGICAL LSAME
5842 REAL PSLAMCH
5843 EXTERNAL LSAME, PSLAMCH
5844* ..
5845* .. Intrinsic Functions ..
5846 INTRINSIC ABS, MAX, MIN, MOD, SQRT
5847* ..
5848* .. Executable Statements ..
5849*
5850 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
5851*
5852 EPS = PSLAMCH( ICTXT, 'eps' )
5853*
5854 UPPER = LSAME( UPLO, 'u' )
5855 NOTRAN = LSAME( TRANS, 'n' )
5856 TRAN = LSAME( TRANS, 't' )
5857*
5858 LDA = MAX( 1, DESCA( M_ ) )
5859 LDC = MAX( 1, DESCC( M_ ) )
5860*
5861* Compute expected result in C using data in A, B and C.
5862* Compute gauges in G. This part of the computation is performed
5863* by every process in the grid.
5864*
5865 DO 140 J = 1, N
5866*
5867 IF( UPPER ) THEN
5868 IBEG = 1
5869 IEND = J
5870 ELSE
5871 IBEG = J
5872 IEND = N
5873 END IF
5874*
5875 DO 10 I = 1, N
5876 CT( I ) = ZERO
5877 G( I ) = ZERO
5878 10 CONTINUE
5879*
5880 IF( NOTRAN ) THEN
5881 DO 30 KK = 1, K
5882 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
5883 DO 20 I = IBEG, IEND
5884 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
5885 CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
5886 G( I ) = G( I ) + ABS( A( IOFFAK ) ) *
5887 $ ABS( A( IOFFAN ) )
5888 20 CONTINUE
5889 30 CONTINUE
5890 ELSE IF( TRAN ) THEN
5891 DO 50 KK = 1, K
5892 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
5893 DO 40 I = IBEG, IEND
5894 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
5895 CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
5896 G( I ) = G( I ) + ABS( A( IOFFAK ) ) *
5897 $ ABS( A( IOFFAN ) )
5898 40 CONTINUE
5899 50 CONTINUE
5900 END IF
5901*
5902 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
5903*
5904 DO 100 I = IBEG, IEND
5905 CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
5906 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
5907 C( IOFFC ) = CT( I )
5908 IOFFC = IOFFC + 1
5909 100 CONTINUE
5910*
5911* Compute the error ratio for this result.
5912*
5913 ERR = ZERO
5914 INFO = 0
5915 LDPC = DESCC( LLD_ )
5916 IOFFC = IC + ( JC + J - 2 ) * LDC
5917 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
5918 $ IIC, JJC, ICROW, ICCOL )
5919 ICURROW = ICROW
5920.EQ. ROWREP = ( ICROW-1 )
5921.EQ. COLREP = ( ICCOL-1 )
5922*
5923.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
5924*
5925 IBB = DESCC( IMB_ ) - IC + 1
5926.LE. IF( IBB0 )
5927 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
5928 IBB = MIN( IBB, N )
5929 IN = IC + IBB - 1
5930*
5931 DO 110 I = IC, IN
5932*
5933.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5934 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5935 $ C( IOFFC ) ) / EPS
5936.NE. IF( G( I-IC+1 )ZERO )
5937 $ ERRI = ERRI / G( I-IC+1 )
5938 ERR = MAX( ERR, ERRI )
5939.GE. IF( ERR*SQRT( EPS )ONE )
5940 $ INFO = 1
5941 IIC = IIC + 1
5942 END IF
5943*
5944 IOFFC = IOFFC + 1
5945*
5946 110 CONTINUE
5947*
5948 ICURROW = MOD( ICURROW+1, NPROW )
5949*
5950 DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
5951 IBB = MIN( IC+N-I, DESCC( MB_ ) )
5952*
5953 DO 120 KK = 0, IBB-1
5954*
5955.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
5956 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
5957 $ C( IOFFC ) )/EPS
5958.NE. IF( G( I+KK-IC+1 )ZERO )
5959 $ ERRI = ERRI / G( I+KK-IC+1 )
5960 ERR = MAX( ERR, ERRI )
5961.GE. IF( ERR*SQRT( EPS )ONE )
5962 $ INFO = 1
5963 IIC = IIC + 1
5964 END IF
5965*
5966 IOFFC = IOFFC + 1
5967*
5968 120 CONTINUE
5969*
5970 ICURROW = MOD( ICURROW+1, NPROW )
5971*
5972 130 CONTINUE
5973*
5974 END IF
5975*
5976* If INFO = 0, all results are at least half accurate.
5977*
5978 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
5979 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
5980 $ MYCOL )
5981.NE. IF( INFO0 )
5982 $ GO TO 150
5983*
5984 140 CONTINUE
5985*
5986 150 CONTINUE
5987*
5988 RETURN
5989*
5990* End of PSMMCH1
5991*
5992 END
5993 SUBROUTINE PSMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
5994 $ DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
5995 $ JC, DESCC, CT, G, ERR, INFO )
5996*
5997* -- PBLAS test routine (version 2.0) --
5998* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5999* and University of California, Berkeley.
6000* April 1, 1998
6001*
6002* .. Scalar Arguments ..
6003 CHARACTER*1 TRANS, UPLO
6004 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
6005 REAL ALPHA, BETA, ERR
6006* ..
6007* .. Array Arguments ..
6008 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
6009 REAL A( * ), B( * ), C( * ), CT( * ), G( * ),
6010 $ PC( * )
6011* ..
6012*
6013* Purpose
6014* =======
6015*
6016* PSMMCH2 checks the results of the computational tests.
6017*
6018* Notes
6019* =====
6020*
6021* A description vector is associated with each 2D block-cyclicly dis-
6022* tributed matrix. This vector stores the information required to
6023* establish the mapping between a matrix entry and its corresponding
6024* process and memory location.
6025*
6026* In the following comments, the character _ should be read as
6027* "of the distributed matrix". Let A be a generic term for any 2D
6028* block cyclicly distributed matrix. Its description vector is DESCA:
6029*
6030* NOTATION STORED IN EXPLANATION
6031* ---------------- --------------- ------------------------------------
6032* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6033* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6034* the NPROW x NPCOL BLACS process grid
6035* A is distributed over. The context
6036* itself is global, but the handle
6037* (the integer value) may vary.
6038* M_A (global) DESCA( M_ ) The number of rows in the distribu-
6039* ted matrix A, M_A >= 0.
6040* N_A (global) DESCA( N_ ) The number of columns in the distri-
6041* buted matrix A, N_A >= 0.
6042* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6043* block of the matrix A, IMB_A > 0.
6044* INB_A (global) DESCA( INB_ ) The number of columns of the upper
6045* left block of the matrix A,
6046* INB_A > 0.
6047* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6048* bute the last M_A-IMB_A rows of A,
6049* MB_A > 0.
6050* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6051* bute the last N_A-INB_A columns of
6052* A, NB_A > 0.
6053* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6054* row of the matrix A is distributed,
6055* NPROW > RSRC_A >= 0.
6056* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6057* first column of A is distributed.
6058* NPCOL > CSRC_A >= 0.
6059* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6060* array storing the local blocks of
6061* the distributed matrix A,
6062* IF( Lc( 1, N_A ) > 0 )
6063* LLD_A >= MAX( 1, Lr( 1, M_A ) )
6064* ELSE
6065* LLD_A >= 1.
6066*
6067* Let K be the number of rows of a matrix A starting at the global in-
6068* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6069* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6070* receive if these K rows were distributed over NPROW processes. If K
6071* is the number of columns of a matrix A starting at the global index
6072* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6073* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6074* these K columns were distributed over NPCOL processes.
6075*
6076* The values of Lr() and Lc() may be determined via a call to the func-
6077* tion PB_NUMROC:
6078* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6079* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6080*
6081* Arguments
6082* =========
6083*
6084* ICTXT (local input) INTEGER
6085* On entry, ICTXT specifies the BLACS context handle, indica-
6086* ting the global context of the operation. The context itself
6087* is global, but the value of ICTXT is local.
6088*
6089* UPLO (global input) CHARACTER*1
6090* On entry, UPLO specifies which part of C should contain the
6091* result.
6092*
6093* TRANS (global input) CHARACTER*1
6094* On entry, TRANS specifies whether the matrices A and B have
6095* to be transposed or not before computing the matrix-matrix
6096* product.
6097*
6098* N (global input) INTEGER
6099* On entry, N specifies the order the submatrix operand C. N
6100* must be at least zero.
6101*
6102* K (global input) INTEGER
6103* On entry, K specifies the number of columns (resp. rows) of A
6104* and B when TRANS = 'N' (resp. TRANS <> 'N'). K must be at
6105* least zero.
6106*
6107* ALPHA (global input) REAL
6108* On entry, ALPHA specifies the scalar alpha.
6109*
6110* A (local input) REAL array
6111* On entry, A is an array of dimension (DESCA( M_ ),*). This
6112* array contains a local copy of the initial entire matrix PA.
6113*
6114* IA (global input) INTEGER
6115* On entry, IA specifies A's global row index, which points to
6116* the beginning of the submatrix sub( A ).
6117*
6118* JA (global input) INTEGER
6119* On entry, JA specifies A's global column index, which points
6120* to the beginning of the submatrix sub( A ).
6121*
6122* DESCA (global and local input) INTEGER array
6123* On entry, DESCA is an integer array of dimension DLEN_. This
6124* is the array descriptor for the matrix A.
6125*
6126* B (local input) REAL array
6127* On entry, B is an array of dimension (DESCB( M_ ),*). This
6128* array contains a local copy of the initial entire matrix PB.
6129*
6130* IB (global input) INTEGER
6131* On entry, IB specifies B's global row index, which points to
6132* the beginning of the submatrix sub( B ).
6133*
6134* JB (global input) INTEGER
6135* On entry, JB specifies B's global column index, which points
6136* to the beginning of the submatrix sub( B ).
6137*
6138* DESCB (global and local input) INTEGER array
6139* On entry, DESCB is an integer array of dimension DLEN_. This
6140* is the array descriptor for the matrix B.
6141*
6142* BETA (global input) REAL
6143* On entry, BETA specifies the scalar beta.
6144*
6145* C (local input/local output) REAL array
6146* On entry, C is an array of dimension (DESCC( M_ ),*). This
6147* array contains a local copy of the initial entire matrix PC.
6148*
6149* PC (local input) REAL array
6150* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6151* array contains the local pieces of the matrix PC.
6152*
6153* IC (global input) INTEGER
6154* On entry, IC specifies C's global row index, which points to
6155* the beginning of the submatrix sub( C ).
6156*
6157* JC (global input) INTEGER
6158* On entry, JC specifies C's global column index, which points
6159* to the beginning of the submatrix sub( C ).
6160*
6161* DESCC (global and local input) INTEGER array
6162* On entry, DESCC is an integer array of dimension DLEN_. This
6163* is the array descriptor for the matrix C.
6164*
6165* CT (workspace) REAL array
6166* On entry, CT is an array of dimension at least MAX(M,N,K). CT
6167* holds a copy of the current column of C.
6168*
6169* G (workspace) REAL array
6170* On entry, G is an array of dimension at least MAX(M,N,K). G
6171* is used to compute the gauges.
6172*
6173* ERR (global output) REAL
6174* On exit, ERR specifies the largest error in absolute value.
6175*
6176* INFO (global output) INTEGER
6177* On exit, if INFO <> 0, the result is less than half accurate.
6178*
6179* -- Written on April 1, 1998 by
6180* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6181*
6182* =====================================================================
6183*
6184* .. Parameters ..
6185 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6186 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6187 $ RSRC_
6188 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
6189 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
6190 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
6191 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
6192 REAL ZERO, ONE
6193 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
6194* ..
6195* .. Local Scalars ..
6196 LOGICAL COLREP, NOTRAN, ROWREP, TRAN, UPPER
6197 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
6198 $ IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
6199 $ JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
6200 $ NPCOL, NPROW
6201 REAL EPS, ERRI
6202* ..
6203* .. External Subroutines ..
6204 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
6205* ..
6206* .. External Functions ..
6207 LOGICAL LSAME
6208 REAL PSLAMCH
6209 EXTERNAL LSAME, PSLAMCH
6210* ..
6211* .. Intrinsic Functions ..
6212 INTRINSIC ABS, MAX, MIN, MOD, SQRT
6213* ..
6214* .. Executable Statements ..
6215*
6216 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
6217*
6218 EPS = PSLAMCH( ICTXT, 'eps' )
6219*
6220 UPPER = LSAME( UPLO, 'u' )
6221 NOTRAN = LSAME( TRANS, 'n' )
6222 TRAN = LSAME( TRANS, 't' )
6223*
6224 LDA = MAX( 1, DESCA( M_ ) )
6225 LDB = MAX( 1, DESCB( M_ ) )
6226 LDC = MAX( 1, DESCC( M_ ) )
6227*
6228* Compute expected result in C using data in A, B and C.
6229* Compute gauges in G. This part of the computation is performed
6230* by every process in the grid.
6231*
6232 DO 140 J = 1, N
6233*
6234 IF( UPPER ) THEN
6235 IBEG = 1
6236 IEND = J
6237 ELSE
6238 IBEG = J
6239 IEND = N
6240 END IF
6241*
6242 DO 10 I = 1, N
6243 CT( I ) = ZERO
6244 G( I ) = ZERO
6245 10 CONTINUE
6246*
6247 IF( NOTRAN ) THEN
6248 DO 30 KK = 1, K
6249 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
6250 IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
6251 DO 20 I = IBEG, IEND
6252 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
6253 IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
6254 CT( I ) = CT( I ) + ALPHA * (
6255 $ A( IOFFAN ) * B( IOFFBK ) +
6256 $ B( IOFFBN ) * A( IOFFAK ) )
6257 G( I ) = G( I ) + ABS( ALPHA ) * (
6258 $ ABS( A( IOFFAN ) ) * ABS( B( IOFFBK ) ) +
6259 $ ABS( B( IOFFBN ) ) * ABS( A( IOFFAK ) ) )
6260 20 CONTINUE
6261 30 CONTINUE
6262 ELSE IF( TRAN ) THEN
6263 DO 50 KK = 1, K
6264 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
6265 IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
6266 DO 40 I = IBEG, IEND
6267 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
6268 IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
6269 CT( I ) = CT( I ) + ALPHA * (
6270 $ A( IOFFAN ) * B( IOFFBK ) +
6271 $ B( IOFFBN ) * A( IOFFAK ) )
6272 G( I ) = G( I ) + ABS( ALPHA ) * (
6273 $ ABS( A( IOFFAN ) ) * ABS( B( IOFFBK ) ) +
6274 $ ABS( B( IOFFBN ) ) * ABS( A( IOFFAK ) ) )
6275 40 CONTINUE
6276 50 CONTINUE
6277 END IF
6278*
6279 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
6280*
6281 DO 100 I = IBEG, IEND
6282 CT( I ) = CT( I ) + BETA * C( IOFFC )
6283 G( I ) = G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
6284 C( IOFFC ) = CT( I )
6285 IOFFC = IOFFC + 1
6286 100 CONTINUE
6287*
6288* Compute the error ratio for this result.
6289*
6290 ERR = ZERO
6291 INFO = 0
6292 LDPC = DESCC( LLD_ )
6293 IOFFC = IC + ( JC + J - 2 ) * LDC
6294 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
6295 $ IIC, JJC, ICROW, ICCOL )
6296 ICURROW = ICROW
6297.EQ. ROWREP = ( ICROW-1 )
6298.EQ. COLREP = ( ICCOL-1 )
6299*
6300.EQ..OR. IF( MYCOLICCOL COLREP ) THEN
6301*
6302 IBB = DESCC( IMB_ ) - IC + 1
6303.LE. IF( IBB0 )
6304 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
6305 IBB = MIN( IBB, N )
6306 IN = IC + IBB - 1
6307*
6308 DO 110 I = IC, IN
6309*
6310.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6311 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6312 $ C( IOFFC ) ) / EPS
6313.NE. IF( G( I-IC+1 )ZERO )
6314 $ ERRI = ERRI / G( I-IC+1 )
6315 ERR = MAX( ERR, ERRI )
6316.GE. IF( ERR*SQRT( EPS )ONE )
6317 $ INFO = 1
6318 IIC = IIC + 1
6319 END IF
6320*
6321 IOFFC = IOFFC + 1
6322*
6323 110 CONTINUE
6324*
6325 ICURROW = MOD( ICURROW+1, NPROW )
6326*
6327 DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
6328 IBB = MIN( IC+N-I, DESCC( MB_ ) )
6329*
6330 DO 120 KK = 0, IBB-1
6331*
6332.EQ..OR. IF( MYROWICURROW ROWREP ) THEN
6333 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
6334 $ C( IOFFC ) )/EPS
6335.NE. IF( G( I+KK-IC+1 )ZERO )
6336 $ ERRI = ERRI / G( I+KK-IC+1 )
6337 ERR = MAX( ERR, ERRI )
6338.GE. IF( ERR*SQRT( EPS )ONE )
6339 $ INFO = 1
6340 IIC = IIC + 1
6341 END IF
6342*
6343 IOFFC = IOFFC + 1
6344*
6345 120 CONTINUE
6346*
6347 ICURROW = MOD( ICURROW+1, NPROW )
6348*
6349 130 CONTINUE
6350*
6351 END IF
6352*
6353* If INFO = 0, all results are at least half accurate.
6354*
6355 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
6356 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
6357 $ MYCOL )
6358.NE. IF( INFO0 )
6359 $ GO TO 150
6360*
6361 140 CONTINUE
6362*
6363 150 CONTINUE
6364*
6365 RETURN
6366*
6367* End of PSMMCH2
6368*
6369 END
6370 SUBROUTINE PSMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
6371 $ BETA, C, PC, IC, JC, DESCC, ERR, INFO )
6372*
6373* -- PBLAS test routine (version 2.0) --
6374* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6375* and University of California, Berkeley.
6376* April 1, 1998
6377*
6378* .. Scalar Arguments ..
6379 CHARACTER*1 TRANS, UPLO
6380 INTEGER IA, IC, INFO, JA, JC, M, N
6381 REAL ALPHA, BETA, ERR
6382* ..
6383* .. Array Arguments ..
6384 INTEGER DESCA( * ), DESCC( * )
6385 REAL A( * ), C( * ), PC( * )
6386* ..
6387*
6388* Purpose
6389* =======
6390*
6391* PSMMCH3 checks the results of the computational tests.
6392*
6393* Notes
6394* =====
6395*
6396* A description vector is associated with each 2D block-cyclicly dis-
6397* tributed matrix. This vector stores the information required to
6398* establish the mapping between a matrix entry and its corresponding
6399* process and memory location.
6400*
6401* In the following comments, the character _ should be read as
6402* "of the distributed matrix". Let A be a generic term for any 2D
6403* block cyclicly distributed matrix. Its description vector is DESCA:
6404*
6405* NOTATION STORED IN EXPLANATION
6406* ---------------- --------------- ------------------------------------
6407* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6408* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6409* the NPROW x NPCOL BLACS process grid
6410* A is distributed over. The context
6411* itself is global, but the handle
6412* (the integer value) may vary.
6413* M_A (global) DESCA( M_ ) The number of rows in the distribu-
6414* ted matrix A, M_A >= 0.
6415* N_A (global) DESCA( N_ ) The number of columns in the distri-
6416* buted matrix A, N_A >= 0.
6417* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6418* block of the matrix A, IMB_A > 0.
6419* INB_A (global) DESCA( INB_ ) The number of columns of the upper
6420* left block of the matrix A,
6421* INB_A > 0.
6422* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6423* bute the last M_A-IMB_A rows of A,
6424* MB_A > 0.
6425* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6426* bute the last N_A-INB_A columns of
6427* A, NB_A > 0.
6428* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6429* row of the matrix A is distributed,
6430* NPROW > RSRC_A >= 0.
6431* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6432* first column of A is distributed.
6433* NPCOL > CSRC_A >= 0.
6434* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6435* array storing the local blocks of
6436* the distributed matrix A,
6437* IF( Lc( 1, N_A ) > 0 )
6438* LLD_A >= MAX( 1, Lr( 1, M_A ) )
6439* ELSE
6440* LLD_A >= 1.
6441*
6442* Let K be the number of rows of a matrix A starting at the global in-
6443* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6444* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6445* receive if these K rows were distributed over NPROW processes. If K
6446* is the number of columns of a matrix A starting at the global index
6447* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6448* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6449* these K columns were distributed over NPCOL processes.
6450*
6451* The values of Lr() and Lc() may be determined via a call to the func-
6452* tion PB_NUMROC:
6453* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6454* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6455*
6456* Arguments
6457* =========
6458*
6459* UPLO (global input) CHARACTER*1
6460* On entry, UPLO specifies which part of C should contain the
6461* result.
6462*
6463* TRANS (global input) CHARACTER*1
6464* On entry, TRANS specifies whether the matrix A has to be
6465* transposed or not before computing the matrix-matrix addi-
6466* tion.
6467*
6468* M (global input) INTEGER
6469* On entry, M specifies the number of rows of C.
6470*
6471* N (global input) INTEGER
6472* On entry, N specifies the number of columns of C.
6473*
6474* ALPHA (global input) REAL
6475* On entry, ALPHA specifies the scalar alpha.
6476*
6477* A (local input) REAL array
6478* On entry, A is an array of dimension (DESCA( M_ ),*). This
6479* array contains a local copy of the initial entire matrix PA.
6480*
6481* IA (global input) INTEGER
6482* On entry, IA specifies A's global row index, which points to
6483* the beginning of the submatrix sub( A ).
6484*
6485* JA (global input) INTEGER
6486* On entry, JA specifies A's global column index, which points
6487* to the beginning of the submatrix sub( A ).
6488*
6489* DESCA (global and local input) INTEGER array
6490* On entry, DESCA is an integer array of dimension DLEN_. This
6491* is the array descriptor for the matrix A.
6492*
6493* BETA (global input) REAL
6494* On entry, BETA specifies the scalar beta.
6495*
6496* C (local input/local output) REAL array
6497* On entry, C is an array of dimension (DESCC( M_ ),*). This
6498* array contains a local copy of the initial entire matrix PC.
6499*
6500* PC (local input) REAL array
6501* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6502* array contains the local pieces of the matrix PC.
6503*
6504* IC (global input) INTEGER
6505* On entry, IC specifies C's global row index, which points to
6506* the beginning of the submatrix sub( C ).
6507*
6508* JC (global input) INTEGER
6509* On entry, JC specifies C's global column index, which points
6510* to the beginning of the submatrix sub( C ).
6511*
6512* DESCC (global and local input) INTEGER array
6513* On entry, DESCC is an integer array of dimension DLEN_. This
6514* is the array descriptor for the matrix C.
6515*
6516* ERR (global output) REAL
6517* On exit, ERR specifies the largest error in absolute value.
6518*
6519* INFO (global output) INTEGER
6520* On exit, if INFO <> 0, the result is less than half accurate.
6521*
6522* -- Written on April 1, 1998 by
6523* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6524*
6525* =====================================================================
6526*
6527* .. Parameters ..
6528 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6529 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6530 $ RSRC_
6531 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
6532 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
6533 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
6534 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
6535 REAL ZERO
6536 PARAMETER ( ZERO = 0.0E+0 )
6537* ..
6538* .. Local Scalars ..
6539 LOGICAL COLREP, LOWER, NOTRAN, ROWREP, UPPER
6540 INTEGER I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
6541 $ JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
6542 $ NPROW
6543 REAL ERR0, ERRI, PREC
6544* ..
6545* .. External Subroutines ..
6546 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L,
6547 $ PSERRAXPBY, SGAMX2D
6548* ..
6549* .. External Functions ..
6550 LOGICAL LSAME
6551 REAL PSLAMCH
6552 EXTERNAL LSAME, PSLAMCH
6553* ..
6554* .. Intrinsic Functions ..
6555 INTRINSIC ABS, MAX
6556* ..
6557* .. Executable Statements ..
6558*
6559 ICTXT = DESCC( CTXT_ )
6560 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
6561*
6562 PREC = PSLAMCH( ICTXT, 'eps' )
6563*
6564 UPPER = LSAME( UPLO, 'u' )
6565 LOWER = LSAME( UPLO, 'l' )
6566 NOTRAN = LSAME( TRANS, 'n' )
6567*
6568* Compute expected result in C using data in A and C. This part of
6569* the computation is performed by every process in the grid.
6570*
6571 INFO = 0
6572 ERR = ZERO
6573*
6574 LDA = MAX( 1, DESCA( M_ ) )
6575 LDC = MAX( 1, DESCC( M_ ) )
6576 LDPC = MAX( 1, DESCC( LLD_ ) )
6577.EQ. ROWREP = ( DESCC( RSRC_ )-1 )
6578.EQ. COLREP = ( DESCC( CSRC_ )-1 )
6579*
6580 IF( NOTRAN ) THEN
6581*
6582 DO 20 J = JC, JC + N - 1
6583*
6584 IOFFC = IC + ( J - 1 ) * LDC
6585 IOFFA = IA + ( JA - 1 + J - JC ) * LDA
6586*
6587 DO 10 I = IC, IC + M - 1
6588*
6589 IF( UPPER ) THEN
6590.GE. IF( ( J - JC )( I - IC ) ) THEN
6591 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6592 $ C( IOFFC ), PREC )
6593 ELSE
6594 ERRI = ZERO
6595 END IF
6596 ELSE IF( LOWER ) THEN
6597.LE. IF( ( J - JC )( I - IC ) ) THEN
6598 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6599 $ C( IOFFC ), PREC )
6600 ELSE
6601 ERRI = ZERO
6602 END IF
6603 ELSE
6604 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6605 $ C( IOFFC ), PREC )
6606 END IF
6607*
6608 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
6609 $ IIC, JJC, ICROW, ICCOL )
6610.EQ..OR..AND. IF( ( MYROWICROW ROWREP )
6611.EQ..OR. $ ( MYCOLICCOL COLREP ) ) THEN
6612 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
6613.GT. IF( ERR0ERRI )
6614 $ INFO = 1
6615 ERR = MAX( ERR, ERR0 )
6616 END IF
6617*
6618 IOFFA = IOFFA + 1
6619 IOFFC = IOFFC + 1
6620*
6621 10 CONTINUE
6622*
6623 20 CONTINUE
6624*
6625 ELSE
6626*
6627 DO 40 J = JC, JC + N - 1
6628*
6629 IOFFC = IC + ( J - 1 ) * LDC
6630 IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
6631*
6632 DO 30 I = IC, IC + M - 1
6633*
6634 IF( UPPER ) THEN
6635.GE. IF( ( J - JC )( I - IC ) ) THEN
6636 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6637 $ C( IOFFC ), PREC )
6638 ELSE
6639 ERRI = ZERO
6640 END IF
6641 ELSE IF( LOWER ) THEN
6642.LE. IF( ( J - JC )( I - IC ) ) THEN
6643 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6644 $ C( IOFFC ), PREC )
6645 ELSE
6646 ERRI = ZERO
6647 END IF
6648 ELSE
6649 CALL PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
6650 $ C( IOFFC ), PREC )
6651 END IF
6652*
6653 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
6654 $ IIC, JJC, ICROW, ICCOL )
6655.EQ..OR..AND. IF( ( MYROWICROW ROWREP )
6656.EQ..OR. $ ( MYCOLICCOL COLREP ) ) THEN
6657 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
6658.GT. IF( ERR0ERRI )
6659 $ INFO = 1
6660 ERR = MAX( ERR, ERR0 )
6661 END IF
6662*
6663 IOFFC = IOFFC + 1
6664 IOFFA = IOFFA + LDA
6665*
6666 30 CONTINUE
6667*
6668 40 CONTINUE
6669*
6670 END IF
6671*
6672* If INFO = 0, all results are at least half accurate.
6673*
6674 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
6675 CALL SGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
6676 $ MYCOL )
6677*
6678 RETURN
6679*
6680* End of PSMMCH3
6681*
6682 END
6683 SUBROUTINE PSERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC )
6684*
6685* -- PBLAS test routine (version 2.0) --
6686* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6687* and University of California, Berkeley.
6688* April 1, 1998
6689*
6690* .. Scalar Arguments ..
6691 REAL ALPHA, BETA, ERRBND, PREC, X, Y
6692* ..
6693*
6694* Purpose
6695* =======
6696*
6697* PSERRAXPBY serially computes y := beta*y + alpha * x and returns a
6698* scaled relative acceptable error bound on the result.
6699*
6700* Arguments
6701* =========
6702*
6703* ERRBND (global output) REAL
6704* On exit, ERRBND specifies the scaled relative acceptable er-
6705* ror bound.
6706*
6707* ALPHA (global input) REAL
6708* On entry, ALPHA specifies the scalar alpha.
6709*
6710* X (global input) REAL
6711* On entry, X specifies the scalar x to be scaled.
6712*
6713* BETA (global input) REAL
6714* On entry, BETA specifies the scalar beta.
6715*
6716* Y (global input/global output) REAL
6717* On entry, Y specifies the scalar y to be added. On exit, Y
6718* contains the resulting scalar y.
6719*
6720* PREC (global input) REAL
6721* On entry, PREC specifies the machine precision.
6722*
6723* -- Written on April 1, 1998 by
6724* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6725*
6726* =====================================================================
6727*
6728* .. Parameters ..
6729 REAL ONE, TWO, ZERO
6730 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0,
6731 $ ZERO = 0.0E+0 )
6732* ..
6733* .. Local Scalars ..
6734 REAL ADDBND, FACT, SUMPOS, SUMNEG, TMP
6735* ..
6736* .. Intrinsic Functions ..
6737* ..
6738* .. Executable Statements ..
6739*
6740 SUMPOS = ZERO
6741 SUMNEG = ZERO
6742 FACT = ONE + TWO * PREC
6743 ADDBND = TWO * TWO * TWO * PREC
6744*
6745 TMP = ALPHA * X
6746.GE. IF( TMPZERO ) THEN
6747 SUMPOS = SUMPOS + TMP * FACT
6748 ELSE
6749 SUMNEG = SUMNEG - TMP * FACT
6750 END IF
6751*
6752 TMP = BETA * Y
6753.GE. IF( TMPZERO ) THEN
6754 SUMPOS = SUMPOS + TMP * FACT
6755 ELSE
6756 SUMNEG = SUMNEG - TMP * FACT
6757 END IF
6758*
6759 Y = ( BETA * Y ) + ( ALPHA * X )
6760*
6761 ERRBND = ADDBND * MAX( SUMPOS, SUMNEG )
6762*
6763 RETURN
6764*
6765* End of PSERRAXPBY
6766*
6767 END
6768 REAL FUNCTION PSLAMCH( ICTXT, CMACH )
6769*
6770* -- PBLAS test routine (version 2.0) --
6771* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6772* and University of California, Berkeley.
6773* April 1, 1998
6774*
6775* .. Scalar Arguments ..
6776 CHARACTER*1 CMACH
6777 INTEGER ICTXT
6778* ..
6779*
6780* Purpose
6781* =======
6782*
6783* PSLAMCH determines single precision machine parameters.
6784*
6785* Arguments
6786* =========
6787*
6788* ICTXT (local input) INTEGER
6789* On entry, ICTXT specifies the BLACS context handle, indica-
6790* ting the global context of the operation. The context itself
6791* is global, but the value of ICTXT is local.
6792*
6793* CMACH (global input) CHARACTER*1
6794* On entry, CMACH specifies the value to be returned by PSLAMCH
6795* as follows:
6796* = 'E' or 'e', PSLAMCH := eps,
6797* = 'S' or 's , PSLAMCH := sfmin,
6798* = 'B' or 'b', PSLAMCH := base,
6799* = 'P' or 'p', PSLAMCH := eps*base,
6800* = 'N' or 'n', PSLAMCH := t,
6801* = 'R' or 'r', PSLAMCH := rnd,
6802* = 'M' or 'm', PSLAMCH := emin,
6803* = 'U' or 'u', PSLAMCH := rmin,
6804* = 'L' or 'l', PSLAMCH := emax,
6805* = 'O' or 'o', PSLAMCH := rmax,
6806*
6807* where
6808*
6809* eps = relative machine precision,
6810* sfmin = safe minimum, such that 1/sfmin does not overflow,
6811* base = base of the machine,
6812* prec = eps*base,
6813* t = number of (base) digits in the mantissa,
6814* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise,
6815* emin = minimum exponent before (gradual) underflow,
6816* rmin = underflow threshold - base**(emin-1),
6817* emax = largest exponent before overflow,
6818* rmax = overflow threshold - (base**emax)*(1-eps).
6819*
6820* -- Written on April 1, 1998 by
6821* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6822*
6823* =====================================================================
6824*
6825* .. Local Scalars ..
6826 CHARACTER*1 TOP
6827 INTEGER IDUMM
6828 REAL TEMP
6829* ..
6830* .. External Subroutines ..
6831 EXTERNAL PB_TOPGET, SGAMN2D, SGAMX2D
6832* ..
6833* .. External Functions ..
6834 LOGICAL LSAME
6835 REAL SLAMCH
6836 EXTERNAL LSAME, SLAMCH
6837* ..
6838* .. Executable Statements ..
6839*
6840 TEMP = SLAMCH( CMACH )
6841*
6842 IF( LSAME( CMACH, 'e.OR.' )LSAME( CMACH, 's.OR.' )
6843 $ LSAME( CMACH, 'm.OR.' )LSAME( CMACH, 'u' ) ) THEN
6844 CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
6845 IDUMM = 0
6846 CALL SGAMX2D( ICTXT, 'all', TOP, 1, 1, TEMP, 1, IDUMM,
6847 $ IDUMM, -1, -1, IDUMM )
6848 ELSE IF( LSAME( CMACH, 'l.OR.' )LSAME( CMACH, 'o' ) ) THEN
6849 CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
6850 IDUMM = 0
6851 CALL SGAMN2D( ICTXT, 'all', TOP, 1, 1, TEMP, 1, IDUMM,
6852 $ IDUMM, -1, -1, IDUMM )
6853 END IF
6854*
6855 PSLAMCH = TEMP
6856*
6857 RETURN
6858*
6859* End of PSLAMCH
6860*
6861 END
6862 SUBROUTINE PSLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
6863*
6864* -- PBLAS test routine (version 2.0) --
6865* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6866* and University of California, Berkeley.
6867* April 1, 1998
6868*
6869* .. Scalar Arguments ..
6870 CHARACTER*1 UPLO
6871 INTEGER IA, JA, M, N
6872 REAL ALPHA, BETA
6873* ..
6874* .. Array Arguments ..
6875 INTEGER DESCA( * )
6876 REAL A( * )
6877* ..
6878*
6879* Purpose
6880* =======
6881*
6882* PSLASET initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
6883* ted by sub( A ) to beta on the diagonal and alpha on the offdiago-
6884* nals.
6885*
6886* Notes
6887* =====
6888*
6889* A description vector is associated with each 2D block-cyclicly dis-
6890* tributed matrix. This vector stores the information required to
6891* establish the mapping between a matrix entry and its corresponding
6892* process and memory location.
6893*
6894* In the following comments, the character _ should be read as
6895* "of the distributed matrix". Let A be a generic term for any 2D
6896* block cyclicly distributed matrix. Its description vector is DESCA:
6897*
6898* NOTATION STORED IN EXPLANATION
6899* ---------------- --------------- ------------------------------------
6900* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6901* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6902* the NPROW x NPCOL BLACS process grid
6903* A is distributed over. The context
6904* itself is global, but the handle
6905* (the integer value) may vary.
6906* M_A (global) DESCA( M_ ) The number of rows in the distribu-
6907* ted matrix A, M_A >= 0.
6908* N_A (global) DESCA( N_ ) The number of columns in the distri-
6909* buted matrix A, N_A >= 0.
6910* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6911* block of the matrix A, IMB_A > 0.
6912* INB_A (global) DESCA( INB_ ) The number of columns of the upper
6913* left block of the matrix A,
6914* INB_A > 0.
6915* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6916* bute the last M_A-IMB_A rows of A,
6917* MB_A > 0.
6918* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6919* bute the last N_A-INB_A columns of
6920* A, NB_A > 0.
6921* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6922* row of the matrix A is distributed,
6923* NPROW > RSRC_A >= 0.
6924* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6925* first column of A is distributed.
6926* NPCOL > CSRC_A >= 0.
6927* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6928* array storing the local blocks of
6929* the distributed matrix A,
6930* IF( Lc( 1, N_A ) > 0 )
6931* LLD_A >= MAX( 1, Lr( 1, M_A ) )
6932* ELSE
6933* LLD_A >= 1.
6934*
6935* Let K be the number of rows of a matrix A starting at the global in-
6936* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6937* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6938* receive if these K rows were distributed over NPROW processes. If K
6939* is the number of columns of a matrix A starting at the global index
6940* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6941* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6942* these K columns were distributed over NPCOL processes.
6943*
6944* The values of Lr() and Lc() may be determined via a call to the func-
6945* tion PB_NUMROC:
6946* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6947* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6948*
6949* Arguments
6950* =========
6951*
6952* UPLO (global input) CHARACTER*1
6953* On entry, UPLO specifies the part of the submatrix sub( A )
6954* to be set:
6955* = 'L' or 'l': Lower triangular part is set; the strictly
6956* upper triangular part of sub( A ) is not changed;
6957* = 'U' or 'u': Upper triangular part is set; the strictly
6958* lower triangular part of sub( A ) is not changed;
6959* Otherwise: All of the matrix sub( A ) is set.
6960*
6961* M (global input) INTEGER
6962* On entry, M specifies the number of rows of the submatrix
6963* sub( A ). M must be at least zero.
6964*
6965* N (global input) INTEGER
6966* On entry, N specifies the number of columns of the submatrix
6967* sub( A ). N must be at least zero.
6968*
6969* ALPHA (global input) REAL
6970* On entry, ALPHA specifies the scalar alpha, i.e., the cons-
6971* tant to which the offdiagonal elements are to be set.
6972*
6973* BETA (global input) REAL
6974* On entry, BETA specifies the scalar beta, i.e., the constant
6975* to which the diagonal elements are to be set.
6976*
6977* A (local input/local output) REAL array
6978* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
6979* at least Lc( 1, JA+N-1 ). Before entry, this array contains
6980* the local entries of the matrix A to be set. On exit, the
6981* leading m by n submatrix sub( A ) is set as follows:
6982*
6983* if UPLO = 'U', A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
6984* if UPLO = 'L', A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
6985* otherwise, A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M, 1<=j<=N,
6986* and IA+i.NE.JA+j,
6987* and, for all UPLO, A(IA+i-1,JA+i-1) = BETA, 1<=i<=min(M,N).
6988*
6989* IA (global input) INTEGER
6990* On entry, IA specifies A's global row index, which points to
6991* the beginning of the submatrix sub( A ).
6992*
6993* JA (global input) INTEGER
6994* On entry, JA specifies A's global column index, which points
6995* to the beginning of the submatrix sub( A ).
6996*
6997* DESCA (global and local input) INTEGER array
6998* On entry, DESCA is an integer array of dimension DLEN_. This
6999* is the array descriptor for the matrix A.
7000*
7001* -- Written on April 1, 1998 by
7002* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7003*
7004* =====================================================================
7005*
7006* .. Parameters ..
7007 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7008 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7009 $ RSRC_
7010 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
7011 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
7012 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
7013 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
7014* ..
7015* .. Local Scalars ..
7016 LOGICAL GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
7017 $ UPPER
7018 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
7019 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
7020 $ JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
7021 $ LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
7022 $ MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
7023 $ NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
7024 $ UPP
7025* ..
7026* .. Local Arrays ..
7027 INTEGER DESCA2( DLEN_ )
7028* ..
7029* .. External Subroutines ..
7030 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
7031 $ PB_DESCTRANS, PB_SLASET
7032* ..
7033* .. External Functions ..
7034 LOGICAL LSAME
7035 EXTERNAL LSAME
7036* ..
7037* .. Intrinsic Functions ..
7038 INTRINSIC MIN
7039* ..
7040* .. Executable Statements ..
7041*
7042.EQ..OR..EQ. IF( M0 N0 )
7043 $ RETURN
7044*
7045* Convert descriptor
7046*
7047 CALL PB_DESCTRANS( DESCA, DESCA2 )
7048*
7049* Get grid parameters
7050*
7051 ICTXT = DESCA2( CTXT_ )
7052 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
7053*
7054 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
7055 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
7056 $ IACOL, MRROW, MRCOL )
7057*
7058.LE..OR..LE. IF( MP0 NQ0 )
7059 $ RETURN
7060*
7061.LT. ISROWREP = ( DESCA2( RSRC_ )0 )
7062.LT. ISCOLREP = ( DESCA2( CSRC_ )0 )
7063 LDA = DESCA2( LLD_ )
7064*
7065.NOT. UPPER = ( LSAME( UPLO, 'l' ) )
7066.NOT. LOWER = ( LSAME( UPLO, 'u' ) )
7067*
7068.AND..AND..EQ..OR. IF( ( ( LOWERUPPER )( ALPHABETA ) )
7069.AND. $ ( ISROWREP ISCOLREP ) ) THEN
7070.GT..AND..GT. IF( ( MP0 )( NQ0 ) )
7071 $ CALL PB_SLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
7072 $ A( IIA + ( JJA - 1 ) * LDA ), LDA )
7073 RETURN
7074 END IF
7075*
7076* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
7077* ILOW, LOW, IUPP, and UPP.
7078*
7079 MB = DESCA2( MB_ )
7080 NB = DESCA2( NB_ )
7081 CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
7082 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
7083 $ LNBLOC, ILOW, LOW, IUPP, UPP )
7084*
7085 IOFFA = IIA - 1
7086 JOFFA = JJA - 1
7087 IIMAX = IOFFA + MP
7088 JJMAX = JOFFA + NQ
7089*
7090 IF( ISROWREP ) THEN
7091 PMB = MB
7092 ELSE
7093 PMB = NPROW * MB
7094 END IF
7095 IF( ISCOLREP ) THEN
7096 QNB = NB
7097 ELSE
7098 QNB = NPCOL * NB
7099 END IF
7100*
7101 M1 = MP
7102 N1 = NQ
7103*
7104* Handle the first block of rows or columns separately, and update
7105* LCMT00, MBLKS and NBLKS.
7106*
7107.GT. GODOWN = ( LCMT00IUPP )
7108.LT. GOLEFT = ( LCMT00ILOW )
7109*
7110.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
7111*
7112* LCMT00 >= ILOW && LCMT00 <= IUPP
7113*
7114.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
7115.NOT. GODOWN = GOLEFT
7116*
7117 CALL PB_SLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
7118 $ A( IIA+JOFFA*LDA ), LDA )
7119 IF( GODOWN ) THEN
7120.AND..GT. IF( UPPER NQINBLOC )
7121 $ CALL PB_SLASET( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
7122 $ ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
7123 IIA = IIA + IMBLOC
7124 M1 = M1 - IMBLOC
7125 ELSE
7126.AND..GT. IF( LOWER MPIMBLOC )
7127 $ CALL PB_SLASET( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
7128 $ ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
7129 JJA = JJA + INBLOC
7130 N1 = N1 - INBLOC
7131 END IF
7132*
7133 END IF
7134*
7135 IF( GODOWN ) THEN
7136*
7137 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7138 MBLKS = MBLKS - 1
7139 IOFFA = IOFFA + IMBLOC
7140*
7141 10 CONTINUE
7142.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7143 LCMT00 = LCMT00 - PMB
7144 MBLKS = MBLKS - 1
7145 IOFFA = IOFFA + MB
7146 GO TO 10
7147 END IF
7148*
7149 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7150.AND..GT. IF( UPPER TMP10 ) THEN
7151 CALL PB_SLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7152 $ A( IIA+JOFFA*LDA ), LDA )
7153 IIA = IIA + TMP1
7154 M1 = M1 - TMP1
7155 END IF
7156*
7157.LE. IF( MBLKS0 )
7158 $ RETURN
7159*
7160 LCMT = LCMT00
7161 MBLKD = MBLKS
7162 IOFFD = IOFFA
7163*
7164 MBLOC = MB
7165 20 CONTINUE
7166.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
7167.EQ. IF( MBLKD1 )
7168 $ MBLOC = LMBLOC
7169 CALL PB_SLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
7170 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7171 LCMT00 = LCMT
7172 LCMT = LCMT - PMB
7173 MBLKS = MBLKD
7174 MBLKD = MBLKD - 1
7175 IOFFA = IOFFD
7176 IOFFD = IOFFD + MBLOC
7177 GO TO 20
7178 END IF
7179*
7180 TMP1 = M1 - IOFFD + IIA - 1
7181.AND..GT. IF( LOWER TMP10 )
7182 $ CALL PB_SLASET( 'all', TMP1, INBLOC, 0, ALPHA, ALPHA,
7183 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7184*
7185 TMP1 = IOFFA - IIA + 1
7186 M1 = M1 - TMP1
7187 N1 = N1 - INBLOC
7188 LCMT00 = LCMT00 + LOW - ILOW + QNB
7189 NBLKS = NBLKS - 1
7190 JOFFA = JOFFA + INBLOC
7191*
7192.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7193 $ CALL PB_SLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7194 $ A( IIA+JOFFA*LDA ), LDA )
7195*
7196 IIA = IOFFA + 1
7197 JJA = JOFFA + 1
7198*
7199 ELSE IF( GOLEFT ) THEN
7200*
7201 LCMT00 = LCMT00 + LOW - ILOW + QNB
7202 NBLKS = NBLKS - 1
7203 JOFFA = JOFFA + INBLOC
7204*
7205 30 CONTINUE
7206.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) THEN
7207 LCMT00 = LCMT00 + QNB
7208 NBLKS = NBLKS - 1
7209 JOFFA = JOFFA + NB
7210 GO TO 30
7211 END IF
7212*
7213 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
7214.AND..GT. IF( LOWER TMP10 ) THEN
7215 CALL PB_SLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
7216 $ A( IIA+(JJA-1)*LDA ), LDA )
7217 JJA = JJA + TMP1
7218 N1 = N1 - TMP1
7219 END IF
7220*
7221.LE. IF( NBLKS0 )
7222 $ RETURN
7223*
7224 LCMT = LCMT00
7225 NBLKD = NBLKS
7226 JOFFD = JOFFA
7227*
7228 NBLOC = NB
7229 40 CONTINUE
7230.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
7231.EQ. IF( NBLKD1 )
7232 $ NBLOC = LNBLOC
7233 CALL PB_SLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
7234 $ A( IIA+JOFFD*LDA ), LDA )
7235 LCMT00 = LCMT
7236 LCMT = LCMT + QNB
7237 NBLKS = NBLKD
7238 NBLKD = NBLKD - 1
7239 JOFFA = JOFFD
7240 JOFFD = JOFFD + NBLOC
7241 GO TO 40
7242 END IF
7243*
7244 TMP1 = N1 - JOFFD + JJA - 1
7245.AND..GT. IF( UPPER TMP10 )
7246 $ CALL PB_SLASET( 'all', IMBLOC, TMP1, 0, ALPHA, ALPHA,
7247 $ A( IIA+JOFFD*LDA ), LDA )
7248*
7249 TMP1 = JOFFA - JJA + 1
7250 M1 = M1 - IMBLOC
7251 N1 = N1 - TMP1
7252 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7253 MBLKS = MBLKS - 1
7254 IOFFA = IOFFA + IMBLOC
7255*
7256.AND..GT..AND..GT. IF( LOWER M10 TMP10 )
7257 $ CALL PB_SLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
7258 $ A( IOFFA+1+(JJA-1)*LDA ), LDA )
7259*
7260 IIA = IOFFA + 1
7261 JJA = JOFFA + 1
7262*
7263 END IF
7264*
7265 NBLOC = NB
7266 50 CONTINUE
7267.GT. IF( NBLKS0 ) THEN
7268.EQ. IF( NBLKS1 )
7269 $ NBLOC = LNBLOC
7270 60 CONTINUE
7271.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7272 LCMT00 = LCMT00 - PMB
7273 MBLKS = MBLKS - 1
7274 IOFFA = IOFFA + MB
7275 GO TO 60
7276 END IF
7277*
7278 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7279.AND..GT. IF( UPPER TMP10 ) THEN
7280 CALL PB_SLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7281 $ A( IIA+JOFFA*LDA ), LDA )
7282 IIA = IIA + TMP1
7283 M1 = M1 - TMP1
7284 END IF
7285*
7286.LE. IF( MBLKS0 )
7287 $ RETURN
7288*
7289 LCMT = LCMT00
7290 MBLKD = MBLKS
7291 IOFFD = IOFFA
7292*
7293 MBLOC = MB
7294 70 CONTINUE
7295.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
7296.EQ. IF( MBLKD1 )
7297 $ MBLOC = LMBLOC
7298 CALL PB_SLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
7299 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7300 LCMT00 = LCMT
7301 LCMT = LCMT - PMB
7302 MBLKS = MBLKD
7303 MBLKD = MBLKD - 1
7304 IOFFA = IOFFD
7305 IOFFD = IOFFD + MBLOC
7306 GO TO 70
7307 END IF
7308*
7309 TMP1 = M1 - IOFFD + IIA - 1
7310.AND..GT. IF( LOWER TMP10 )
7311 $ CALL PB_SLASET( 'all', TMP1, NBLOC, 0, ALPHA, ALPHA,
7312 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7313*
7314 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7315 M1 = M1 - TMP1
7316 N1 = N1 - NBLOC
7317 LCMT00 = LCMT00 + QNB
7318 NBLKS = NBLKS - 1
7319 JOFFA = JOFFA + NBLOC
7320*
7321.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7322 $ CALL PB_SLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
7323 $ A( IIA+JOFFA*LDA ), LDA )
7324*
7325 IIA = IOFFA + 1
7326 JJA = JOFFA + 1
7327*
7328 GO TO 50
7329*
7330 END IF
7331*
7332 RETURN
7333*
7334* End of PSLASET
7335*
7336 END
7337 SUBROUTINE PSLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
7338*
7339* -- PBLAS test routine (version 2.0) --
7340* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7341* and University of California, Berkeley.
7342* April 1, 1998
7343*
7344* .. Scalar Arguments ..
7345 CHARACTER*1 TYPE
7346 INTEGER IA, JA, M, N
7347 REAL ALPHA
7348* ..
7349* .. Array Arguments ..
7350 INTEGER DESCA( * )
7351 REAL A( * )
7352* ..
7353*
7354* Purpose
7355* =======
7356*
7357* PSLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
7358* by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full,
7359* upper triangular, lower triangular or upper Hessenberg.
7360*
7361* Notes
7362* =====
7363*
7364* A description vector is associated with each 2D block-cyclicly dis-
7365* tributed matrix. This vector stores the information required to
7366* establish the mapping between a matrix entry and its corresponding
7367* process and memory location.
7368*
7369* In the following comments, the character _ should be read as
7370* "of the distributed matrix". Let A be a generic term for any 2D
7371* block cyclicly distributed matrix. Its description vector is DESCA:
7372*
7373* NOTATION STORED IN EXPLANATION
7374* ---------------- --------------- ------------------------------------
7375* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7376* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7377* the NPROW x NPCOL BLACS process grid
7378* A is distributed over. The context
7379* itself is global, but the handle
7380* (the integer value) may vary.
7381* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7382* ted matrix A, M_A >= 0.
7383* N_A (global) DESCA( N_ ) The number of columns in the distri-
7384* buted matrix A, N_A >= 0.
7385* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7386* block of the matrix A, IMB_A > 0.
7387* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7388* left block of the matrix A,
7389* INB_A > 0.
7390* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7391* bute the last M_A-IMB_A rows of A,
7392* MB_A > 0.
7393* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7394* bute the last N_A-INB_A columns of
7395* A, NB_A > 0.
7396* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7397* row of the matrix A is distributed,
7398* NPROW > RSRC_A >= 0.
7399* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7400* first column of A is distributed.
7401* NPCOL > CSRC_A >= 0.
7402* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7403* array storing the local blocks of
7404* the distributed matrix A,
7405* IF( Lc( 1, N_A ) > 0 )
7406* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7407* ELSE
7408* LLD_A >= 1.
7409*
7410* Let K be the number of rows of a matrix A starting at the global in-
7411* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7412* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7413* receive if these K rows were distributed over NPROW processes. If K
7414* is the number of columns of a matrix A starting at the global index
7415* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7416* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7417* these K columns were distributed over NPCOL processes.
7418*
7419* The values of Lr() and Lc() may be determined via a call to the func-
7420* tion PB_NUMROC:
7421* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7422* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7423*
7424* Arguments
7425* =========
7426*
7427* TYPE (global input) CHARACTER*1
7428* On entry, TYPE specifies the type of the input submatrix as
7429* follows:
7430* = 'L' or 'l': sub( A ) is a lower triangular matrix,
7431* = 'U' or 'u': sub( A ) is an upper triangular matrix,
7432* = 'H' or 'h': sub( A ) is an upper Hessenberg matrix,
7433* otherwise sub( A ) is a full matrix.
7434*
7435* M (global input) INTEGER
7436* On entry, M specifies the number of rows of the submatrix
7437* sub( A ). M must be at least zero.
7438*
7439* N (global input) INTEGER
7440* On entry, N specifies the number of columns of the submatrix
7441* sub( A ). N must be at least zero.
7442*
7443* ALPHA (global input) REAL
7444* On entry, ALPHA specifies the scalar alpha.
7445*
7446* A (local input/local output) REAL array
7447* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7448* at least Lc( 1, JA+N-1 ). Before entry, this array contains
7449* the local entries of the matrix A.
7450* On exit, the local entries of this array corresponding to the
7451* to the entries of the submatrix sub( A ) are overwritten by
7452* the local entries of the m by n scaled submatrix.
7453*
7454* IA (global input) INTEGER
7455* On entry, IA specifies A's global row index, which points to
7456* the beginning of the submatrix sub( A ).
7457*
7458* JA (global input) INTEGER
7459* On entry, JA specifies A's global column index, which points
7460* to the beginning of the submatrix sub( A ).
7461*
7462* DESCA (global and local input) INTEGER array
7463* On entry, DESCA is an integer array of dimension DLEN_. This
7464* is the array descriptor for the matrix A.
7465*
7466* -- Written on April 1, 1998 by
7467* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7468*
7469* =====================================================================
7470*
7471* .. Parameters ..
7472 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7473 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7474 $ RSRC_
7475 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
7476 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
7477 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
7478 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
7479* ..
7480* .. Local Scalars ..
7481 CHARACTER*1 UPLO
7482 LOGICAL GODOWN, GOLEFT, LOWER, UPPER
7483 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
7484 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
7485 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
7486 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
7487 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
7488 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
7489 $ QNB, TMP1, UPP
7490* ..
7491* .. Local Arrays ..
7492 INTEGER DESCA2( DLEN_ )
7493* ..
7494* .. External Subroutines ..
7495 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
7496 $ PB_DESCTRANS, PB_INFOG2L, PB_SLASCAL
7497* ..
7498* .. External Functions ..
7499 LOGICAL LSAME
7500 INTEGER PB_NUMROC
7501 EXTERNAL LSAME, PB_NUMROC
7502* ..
7503* .. Intrinsic Functions ..
7504 INTRINSIC MIN
7505* ..
7506* .. Executable Statements ..
7507*
7508* Convert descriptor
7509*
7510 CALL PB_DESCTRANS( DESCA, DESCA2 )
7511*
7512* Get grid parameters
7513*
7514 ICTXT = DESCA2( CTXT_ )
7515 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
7516*
7517* Quick return if possible
7518*
7519.EQ..OR..EQ. IF( M0 N0 )
7520 $ RETURN
7521*
7522 IF( LSAME( TYPE, 'l' ) ) THEN
7523 ITYPE = 1
7524 UPLO = TYPE
7525 UPPER = .FALSE.
7526 LOWER = .TRUE.
7527 IOFFD = 0
7528 ELSE IF( LSAME( TYPE, 'u' ) ) THEN
7529 ITYPE = 2
7530 UPLO = TYPE
7531 UPPER = .TRUE.
7532 LOWER = .FALSE.
7533 IOFFD = 0
7534 ELSE IF( LSAME( TYPE, 'h' ) ) THEN
7535 ITYPE = 3
7536 UPLO = 'u'
7537 UPPER = .TRUE.
7538 LOWER = .FALSE.
7539 IOFFD = 1
7540 ELSE
7541 ITYPE = 0
7542 UPLO = 'a'
7543 UPPER = .TRUE.
7544 LOWER = .TRUE.
7545 IOFFD = 0
7546 END IF
7547*
7548* Compute local indexes
7549*
7550.EQ. IF( ITYPE0 ) THEN
7551*
7552* Full matrix
7553*
7554 CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
7555 $ IIA, JJA, IAROW, IACOL )
7556 MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
7557 $ DESCA2( RSRC_ ), NPROW )
7558 NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
7559 $ DESCA2( CSRC_ ), NPCOL )
7560*
7561.LE..OR..LE. IF( MP0 NQ0 )
7562 $ RETURN
7563*
7564 LDA = DESCA2( LLD_ )
7565 IOFFA = IIA + ( JJA - 1 ) * LDA
7566*
7567 CALL PB_SLASCAL( 'all', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
7568*
7569 ELSE
7570*
7571* Trapezoidal matrix
7572*
7573 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
7574 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
7575 $ IACOL, MRROW, MRCOL )
7576*
7577.LE..OR..LE. IF( MP0 NQ0 )
7578 $ RETURN
7579*
7580* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
7581* LNBLOC, ILOW, LOW, IUPP, and UPP.
7582*
7583 MB = DESCA2( MB_ )
7584 NB = DESCA2( NB_ )
7585 LDA = DESCA2( LLD_ )
7586*
7587 CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
7588 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
7589 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
7590*
7591 M1 = MP
7592 N1 = NQ
7593 IOFFA = IIA - 1
7594 JOFFA = JJA - 1
7595 IIMAX = IOFFA + MP
7596 JJMAX = JOFFA + NQ
7597*
7598.LT. IF( DESCA2( RSRC_ )0 ) THEN
7599 PMB = MB
7600 ELSE
7601 PMB = NPROW * MB
7602 END IF
7603.LT. IF( DESCA2( CSRC_ )0 ) THEN
7604 QNB = NB
7605 ELSE
7606 QNB = NPCOL * NB
7607 END IF
7608*
7609* Handle the first block of rows or columns separately, and
7610* update LCMT00, MBLKS and NBLKS.
7611*
7612.GT. GODOWN = ( LCMT00IUPP )
7613.LT. GOLEFT = ( LCMT00ILOW )
7614*
7615.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
7616*
7617* LCMT00 >= ILOW && LCMT00 <= IUPP
7618*
7619.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
7620.NOT. GODOWN = GOLEFT
7621*
7622 CALL PB_SLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
7623 $ A( IIA+JOFFA*LDA ), LDA )
7624 IF( GODOWN ) THEN
7625.AND..GT. IF( UPPER NQINBLOC )
7626 $ CALL PB_SLASCAL( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
7627 $ A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
7628 IIA = IIA + IMBLOC
7629 M1 = M1 - IMBLOC
7630 ELSE
7631.AND..GT. IF( LOWER MPIMBLOC )
7632 $ CALL PB_SLASCAL( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
7633 $ A( IIA+IMBLOC+JOFFA*LDA ), LDA )
7634 JJA = JJA + INBLOC
7635 N1 = N1 - INBLOC
7636 END IF
7637*
7638 END IF
7639*
7640 IF( GODOWN ) THEN
7641*
7642 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7643 MBLKS = MBLKS - 1
7644 IOFFA = IOFFA + IMBLOC
7645*
7646 10 CONTINUE
7647.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7648 LCMT00 = LCMT00 - PMB
7649 MBLKS = MBLKS - 1
7650 IOFFA = IOFFA + MB
7651 GO TO 10
7652 END IF
7653*
7654 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7655.AND..GT. IF( UPPER TMP10 ) THEN
7656 CALL PB_SLASCAL( 'all', TMP1, N1, 0, ALPHA,
7657 $ A( IIA+JOFFA*LDA ), LDA )
7658 IIA = IIA + TMP1
7659 M1 = M1 - TMP1
7660 END IF
7661*
7662.LE. IF( MBLKS0 )
7663 $ RETURN
7664*
7665 LCMT = LCMT00
7666 MBLKD = MBLKS
7667 IOFFD = IOFFA
7668*
7669 MBLOC = MB
7670 20 CONTINUE
7671.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
7672.EQ. IF( MBLKD1 )
7673 $ MBLOC = LMBLOC
7674 CALL PB_SLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
7675 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7676 LCMT00 = LCMT
7677 LCMT = LCMT - PMB
7678 MBLKS = MBLKD
7679 MBLKD = MBLKD - 1
7680 IOFFA = IOFFD
7681 IOFFD = IOFFD + MBLOC
7682 GO TO 20
7683 END IF
7684*
7685 TMP1 = M1 - IOFFD + IIA - 1
7686.AND..GT. IF( LOWER TMP10 )
7687 $ CALL PB_SLASCAL( 'all', TMP1, INBLOC, 0, ALPHA,
7688 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7689*
7690 TMP1 = IOFFA - IIA + 1
7691 M1 = M1 - TMP1
7692 N1 = N1 - INBLOC
7693 LCMT00 = LCMT00 + LOW - ILOW + QNB
7694 NBLKS = NBLKS - 1
7695 JOFFA = JOFFA + INBLOC
7696*
7697.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7698 $ CALL PB_SLASCAL( 'all', TMP1, N1, 0, ALPHA,
7699 $ A( IIA+JOFFA*LDA ), LDA )
7700*
7701 IIA = IOFFA + 1
7702 JJA = JOFFA + 1
7703*
7704 ELSE IF( GOLEFT ) THEN
7705*
7706 LCMT00 = LCMT00 + LOW - ILOW + QNB
7707 NBLKS = NBLKS - 1
7708 JOFFA = JOFFA + INBLOC
7709*
7710 30 CONTINUE
7711.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) THEN
7712 LCMT00 = LCMT00 + QNB
7713 NBLKS = NBLKS - 1
7714 JOFFA = JOFFA + NB
7715 GO TO 30
7716 END IF
7717*
7718 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
7719.AND..GT. IF( LOWER TMP10 ) THEN
7720 CALL PB_SLASCAL( 'all', M1, TMP1, 0, ALPHA,
7721 $ A( IIA+(JJA-1)*LDA ), LDA )
7722 JJA = JJA + TMP1
7723 N1 = N1 - TMP1
7724 END IF
7725*
7726.LE. IF( NBLKS0 )
7727 $ RETURN
7728*
7729 LCMT = LCMT00
7730 NBLKD = NBLKS
7731 JOFFD = JOFFA
7732*
7733 NBLOC = NB
7734 40 CONTINUE
7735.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
7736.EQ. IF( NBLKD1 )
7737 $ NBLOC = LNBLOC
7738 CALL PB_SLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
7739 $ A( IIA+JOFFD*LDA ), LDA )
7740 LCMT00 = LCMT
7741 LCMT = LCMT + QNB
7742 NBLKS = NBLKD
7743 NBLKD = NBLKD - 1
7744 JOFFA = JOFFD
7745 JOFFD = JOFFD + NBLOC
7746 GO TO 40
7747 END IF
7748*
7749 TMP1 = N1 - JOFFD + JJA - 1
7750.AND..GT. IF( UPPER TMP10 )
7751 $ CALL PB_SLASCAL( 'all', IMBLOC, TMP1, 0, ALPHA,
7752 $ A( IIA+JOFFD*LDA ), LDA )
7753*
7754 TMP1 = JOFFA - JJA + 1
7755 M1 = M1 - IMBLOC
7756 N1 = N1 - TMP1
7757 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
7758 MBLKS = MBLKS - 1
7759 IOFFA = IOFFA + IMBLOC
7760*
7761.AND..GT..AND..GT. IF( LOWER M10 TMP10 )
7762 $ CALL PB_SLASCAL( 'all', M1, TMP1, 0, ALPHA,
7763 $ A( IOFFA+1+(JJA-1)*LDA ), LDA )
7764*
7765 IIA = IOFFA + 1
7766 JJA = JOFFA + 1
7767*
7768 END IF
7769*
7770 NBLOC = NB
7771 50 CONTINUE
7772.GT. IF( NBLKS0 ) THEN
7773.EQ. IF( NBLKS1 )
7774 $ NBLOC = LNBLOC
7775 60 CONTINUE
7776.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
7777 LCMT00 = LCMT00 - PMB
7778 MBLKS = MBLKS - 1
7779 IOFFA = IOFFA + MB
7780 GO TO 60
7781 END IF
7782*
7783 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7784.AND..GT. IF( UPPER TMP10 ) THEN
7785 CALL PB_SLASCAL( 'all', TMP1, N1, 0, ALPHA,
7786 $ A( IIA+JOFFA*LDA ), LDA )
7787 IIA = IIA + TMP1
7788 M1 = M1 - TMP1
7789 END IF
7790*
7791.LE. IF( MBLKS0 )
7792 $ RETURN
7793*
7794 LCMT = LCMT00
7795 MBLKD = MBLKS
7796 IOFFD = IOFFA
7797*
7798 MBLOC = MB
7799 70 CONTINUE
7800.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
7801.EQ. IF( MBLKD1 )
7802 $ MBLOC = LMBLOC
7803 CALL PB_SLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
7804 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7805 LCMT00 = LCMT
7806 LCMT = LCMT - PMB
7807 MBLKS = MBLKD
7808 MBLKD = MBLKD - 1
7809 IOFFA = IOFFD
7810 IOFFD = IOFFD + MBLOC
7811 GO TO 70
7812 END IF
7813*
7814 TMP1 = M1 - IOFFD + IIA - 1
7815.AND..GT. IF( LOWER TMP10 )
7816 $ CALL PB_SLASCAL( 'all', TMP1, NBLOC, 0, ALPHA,
7817 $ A( IOFFD+1+JOFFA*LDA ), LDA )
7818*
7819 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
7820 M1 = M1 - TMP1
7821 N1 = N1 - NBLOC
7822 LCMT00 = LCMT00 + QNB
7823 NBLKS = NBLKS - 1
7824 JOFFA = JOFFA + NBLOC
7825*
7826.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
7827 $ CALL PB_SLASCAL( 'all', TMP1, N1, 0, ALPHA,
7828 $ A( IIA+JOFFA*LDA ), LDA )
7829*
7830 IIA = IOFFA + 1
7831 JJA = JOFFA + 1
7832*
7833 GO TO 50
7834*
7835 END IF
7836*
7837 END IF
7838*
7839 RETURN
7840*
7841* End of PSLASCAL
7842*
7843 END
7844 SUBROUTINE PSLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
7845 $ DESCA, IASEED, A, LDA )
7846*
7847* -- PBLAS test routine (version 2.0) --
7848* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7849* and University of California, Berkeley.
7850* April 1, 1998
7851*
7852* .. Scalar Arguments ..
7853 LOGICAL INPLACE
7854 CHARACTER*1 AFORM, DIAG
7855 INTEGER IA, IASEED, JA, LDA, M, N, OFFA
7856* ..
7857* .. Array Arguments ..
7858 INTEGER DESCA( * )
7859 REAL A( LDA, * )
7860* ..
7861*
7862* Purpose
7863* =======
7864*
7865* PSLAGEN generates (or regenerates) a submatrix sub( A ) denoting
7866* A(IA:IA+M-1,JA:JA+N-1).
7867*
7868* Notes
7869* =====
7870*
7871* A description vector is associated with each 2D block-cyclicly dis-
7872* tributed matrix. This vector stores the information required to
7873* establish the mapping between a matrix entry and its corresponding
7874* process and memory location.
7875*
7876* In the following comments, the character _ should be read as
7877* "of the distributed matrix". Let A be a generic term for any 2D
7878* block cyclicly distributed matrix. Its description vector is DESCA:
7879*
7880* NOTATION STORED IN EXPLANATION
7881* ---------------- --------------- ------------------------------------
7882* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7883* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7884* the NPROW x NPCOL BLACS process grid
7885* A is distributed over. The context
7886* itself is global, but the handle
7887* (the integer value) may vary.
7888* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7889* ted matrix A, M_A >= 0.
7890* N_A (global) DESCA( N_ ) The number of columns in the distri-
7891* buted matrix A, N_A >= 0.
7892* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7893* block of the matrix A, IMB_A > 0.
7894* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7895* left block of the matrix A,
7896* INB_A > 0.
7897* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7898* bute the last M_A-IMB_A rows of A,
7899* MB_A > 0.
7900* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7901* bute the last N_A-INB_A columns of
7902* A, NB_A > 0.
7903* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7904* row of the matrix A is distributed,
7905* NPROW > RSRC_A >= 0.
7906* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7907* first column of A is distributed.
7908* NPCOL > CSRC_A >= 0.
7909* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7910* array storing the local blocks of
7911* the distributed matrix A,
7912* IF( Lc( 1, N_A ) > 0 )
7913* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7914* ELSE
7915* LLD_A >= 1.
7916*
7917* Let K be the number of rows of a matrix A starting at the global in-
7918* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7919* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7920* receive if these K rows were distributed over NPROW processes. If K
7921* is the number of columns of a matrix A starting at the global index
7922* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7923* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7924* these K columns were distributed over NPCOL processes.
7925*
7926* The values of Lr() and Lc() may be determined via a call to the func-
7927* tion PB_NUMROC:
7928* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7929* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7930*
7931* Arguments
7932* =========
7933*
7934* INPLACE (global input) LOGICAL
7935* On entry, INPLACE specifies if the matrix should be generated
7936* in place or not. If INPLACE is .TRUE., the local random array
7937* to be generated will start in memory at the local memory lo-
7938* cation A( 1, 1 ), otherwise it will start at the local posi-
7939* tion induced by IA and JA.
7940*
7941* AFORM (global input) CHARACTER*1
7942* On entry, AFORM specifies the type of submatrix to be genera-
7943* ted as follows:
7944* AFORM = 'S', sub( A ) is a symmetric matrix,
7945* AFORM = 'H', sub( A ) is a Hermitian matrix,
7946* AFORM = 'T', sub( A ) is overrwritten with the transpose
7947* of what would normally be generated,
7948* AFORM = 'C', sub( A ) is overwritten with the conjugate
7949* transpose of what would normally be genera-
7950* ted.
7951* AFORM = 'N', a random submatrix is generated.
7952*
7953* DIAG (global input) CHARACTER*1
7954* On entry, DIAG specifies if the generated submatrix is diago-
7955* nally dominant or not as follows:
7956* DIAG = 'D' : sub( A ) is diagonally dominant,
7957* DIAG = 'N' : sub( A ) is not diagonally dominant.
7958*
7959* OFFA (global input) INTEGER
7960* On entry, OFFA specifies the offdiagonal of the underlying
7961* matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
7962* trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
7963* specifies the main diagonal, OFFA > 0 specifies a subdiago-
7964* nal, and OFFA < 0 specifies a superdiagonal (see further de-
7965* tails).
7966*
7967* M (global input) INTEGER
7968* On entry, M specifies the global number of matrix rows of the
7969* submatrix sub( A ) to be generated. M must be at least zero.
7970*
7971* N (global input) INTEGER
7972* On entry, N specifies the global number of matrix columns of
7973* the submatrix sub( A ) to be generated. N must be at least
7974* zero.
7975*
7976* IA (global input) INTEGER
7977* On entry, IA specifies A's global row index, which points to
7978* the beginning of the submatrix sub( A ).
7979*
7980* JA (global input) INTEGER
7981* On entry, JA specifies A's global column index, which points
7982* to the beginning of the submatrix sub( A ).
7983*
7984* DESCA (global and local input) INTEGER array
7985* On entry, DESCA is an integer array of dimension DLEN_. This
7986* is the array descriptor for the matrix A.
7987*
7988* IASEED (global input) INTEGER
7989* On entry, IASEED specifies the seed number to generate the
7990* matrix A. IASEED must be at least zero.
7991*
7992* A (local output) REAL array
7993* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7994* at least Lc( 1, JA+N-1 ). On exit, this array contains the
7995* local entries of the randomly generated submatrix sub( A ).
7996*
7997* LDA (local input) INTEGER
7998* On entry, LDA specifies the local leading dimension of the
7999* array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
8000* This restriction is however not enforced, and this subroutine
8001* requires only that LDA >= MAX( 1, Mp ) where
8002*
8003* Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
8004*
8005* PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW
8006* and NPCOL can be determined by calling the BLACS subroutine
8007* BLACS_GRIDINFO.
8008*
8009* Further Details
8010* ===============
8011*
8012* OFFD is tied to the matrix described by DESCA, as opposed to the
8013* piece that is currently (re)generated. This is a global information
8014* independent from the distribution parameters. Below are examples of
8015* the meaning of OFFD for a global 7 by 5 matrix:
8016*
8017* ---------------------------------------------------------------------
8018* OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4
8019* -------|-------------------------------------------------------------
8020* | | OFFD=-1 | OFFD=0 OFFD=2
8021* | V V
8022* 0 | . d . . . -> d . . . . . . . . .
8023* 1 | . . d . . . d . . . . . . . .
8024* 2 | . . . d . . . d . . -> d . . . .
8025* 3 | . . . . d . . . d . . d . . .
8026* 4 | . . . . . . . . . d . . d . .
8027* 5 | . . . . . . . . . . . . . d .
8028* 6 | . . . . . . . . . . . . . . d
8029* ---------------------------------------------------------------------
8030*
8031* -- Written on April 1, 1998 by
8032* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8033*
8034* =====================================================================
8035*
8036* .. Parameters ..
8037 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8038 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8039 $ RSRC_
8040 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
8041 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
8042 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
8043 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
8044 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
8045 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
8046 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
8047 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
8048 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
8049 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
8050 $ JMP_NQNB = 10, JMP_NQINBLOC = 11,
8051 $ JMP_LEN = 11 )
8052* ..
8053* .. Local Scalars ..
8054 LOGICAL DIAGDO, SYMM, HERM, NOTRAN
8055 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
8056 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
8057 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
8058 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
8059 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
8060 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
8061 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
8062 REAL ALPHA
8063* ..
8064* .. Local Arrays ..
8065 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
8066 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
8067* ..
8068* .. External Subroutines ..
8069 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
8070 $ PB_CHKMAT, PB_DESCTRANS, PB_INITJMP,
8071 $ PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
8072 $ PB_SETLOCRAN, PB_SETRAN, PB_SLAGEN, PSLADOM,
8073 $ PXERBLA
8074* ..
8075* .. External Functions ..
8076 LOGICAL LSAME
8077 EXTERNAL LSAME
8078* ..
8079* .. Intrinsic Functions ..
8080 INTRINSIC MAX, MIN, REAL
8081* ..
8082* .. Data Statements ..
8083 DATA ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
8084 $ 12345, 0 /
8085* ..
8086* .. Executable Statements ..
8087*
8088* Convert descriptor
8089*
8090 CALL PB_DESCTRANS( DESCA, DESCA2 )
8091*
8092* Test the input arguments
8093*
8094 ICTXT = DESCA2( CTXT_ )
8095 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
8096*
8097* Test the input parameters
8098*
8099 INFO = 0
8100.EQ. IF( NPROW-1 ) THEN
8101 INFO = -( 1000 + CTXT_ )
8102 ELSE
8103 SYMM = LSAME( AFORM, 's' )
8104 HERM = LSAME( AFORM, 'h' )
8105 NOTRAN = LSAME( AFORM, 'n' )
8106 DIAGDO = LSAME( DIAG, 'd' )
8107.NOT..OR..OR..AND. IF( ( SYMMHERMNOTRAN )
8108.NOT. $ ( LSAME( AFORM, 't.AND.' ) )
8109.NOT. $ ( LSAME( AFORM, 'c' ) ) ) THEN
8110 INFO = -2
8111.NOT..AND. ELSE IF( ( DIAGDO )
8112.NOT. $ ( LSAME( DIAG, 'n' ) ) ) THEN
8113 INFO = -3
8114 END IF
8115 CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
8116 END IF
8117*
8118.NE. IF( INFO0 ) THEN
8119 CALL PXERBLA( ICTXT, 'pslagen', -INFO )
8120 RETURN
8121 END IF
8122*
8123* Quick return if possible
8124*
8125.LE..OR..LE. IF( ( M0 )( N0 ) )
8126 $ RETURN
8127*
8128* Start the operations
8129*
8130 MB = DESCA2( MB_ )
8131 NB = DESCA2( NB_ )
8132 IMB = DESCA2( IMB_ )
8133 INB = DESCA2( INB_ )
8134 RSRC = DESCA2( RSRC_ )
8135 CSRC = DESCA2( CSRC_ )
8136*
8137* Figure out local information about the distributed matrix operand
8138*
8139 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
8140 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
8141 $ IACOL, MRROW, MRCOL )
8142*
8143* Decide where the entries shall be stored in memory
8144*
8145 IF( INPLACE ) THEN
8146 IIA = 1
8147 JJA = 1
8148 END IF
8149*
8150* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
8151* ILOW, LOW, IUPP, and UPP.
8152*
8153 IOFFDA = JA + OFFA - IA
8154 CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
8155 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
8156 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
8157*
8158* Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
8159* This values correspond to the square virtual underlying matrix
8160* of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
8161* to set up the random sequence. For practical purposes, the size
8162* of this virtual matrix is upper bounded by M_ + N_ - 1.
8163*
8164 ITMP = MAX( 0, -OFFA )
8165 IVIR = IA + ITMP
8166 IMBVIR = IMB + ITMP
8167 NVIR = DESCA2( M_ ) + ITMP
8168*
8169 CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
8170 $ ILOCOFF, MYRDIST )
8171*
8172 ITMP = MAX( 0, OFFA )
8173 JVIR = JA + ITMP
8174 INBVIR = INB + ITMP
8175 NVIR = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
8176 $ DESCA2( M_ ) + DESCA2( N_ ) - 1 )
8177*
8178 CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
8179 $ JLOCOFF, MYCDIST )
8180*
8181.OR..OR. IF( SYMM HERM NOTRAN ) THEN
8182*
8183 CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
8184 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
8185*
8186* Compute constants to jump JMP( * ) numbers in the sequence
8187*
8188 CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
8189*
8190* Compute and set the random value corresponding to A( IA, JA )
8191*
8192 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
8193 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
8194 $ IMULADD, IRAN )
8195*
8196 CALL PB_SLAGEN( 'lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
8197 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
8198 $ NB, LNBLOC, JMP, IMULADD )
8199*
8200 END IF
8201*
8202.OR..OR..NOT. IF( SYMM HERM ( NOTRAN ) ) THEN
8203*
8204 CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
8205 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
8206*
8207* Compute constants to jump JMP( * ) numbers in the sequence
8208*
8209 CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
8210*
8211* Compute and set the random value corresponding to A( IA, JA )
8212*
8213 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
8214 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
8215 $ IMULADD, IRAN )
8216*
8217 CALL PB_SLAGEN( 'upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
8218 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
8219 $ NB, LNBLOC, JMP, IMULADD )
8220*
8221 END IF
8222*
8223 IF( DIAGDO ) THEN
8224*
8225 MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
8226 ALPHA = REAL( MAXMN )
8227*
8228.GE. IF( IOFFDA0 ) THEN
8229 CALL PSLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
8230 $ A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
8231 ELSE
8232 CALL PSLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
8233 $ A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
8234 END IF
8235*
8236 END IF
8237*
8238 RETURN
8239*
8240* End of PSLAGEN
8241*
8242 END
8243 SUBROUTINE PSLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
8244*
8245* -- PBLAS test routine (version 2.0) --
8246* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8247* and University of California, Berkeley.
8248* April 1, 1998
8249*
8250* .. Scalar Arguments ..
8251 LOGICAL INPLACE
8252 INTEGER IA, JA, N
8253 REAL ALPHA
8254* ..
8255* .. Array Arguments ..
8256 INTEGER DESCA( * )
8257 REAL A( * )
8258* ..
8259*
8260* Purpose
8261* =======
8262*
8263* PSLADOM adds alpha to the diagonal entries of an n by n submatrix
8264* sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
8265*
8266* Notes
8267* =====
8268*
8269* A description vector is associated with each 2D block-cyclicly dis-
8270* tributed matrix. This vector stores the information required to
8271* establish the mapping between a matrix entry and its corresponding
8272* process and memory location.
8273*
8274* In the following comments, the character _ should be read as
8275* "of the distributed matrix". Let A be a generic term for any 2D
8276* block cyclicly distributed matrix. Its description vector is DESCA:
8277*
8278* NOTATION STORED IN EXPLANATION
8279* ---------------- --------------- ------------------------------------
8280* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8281* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8282* the NPROW x NPCOL BLACS process grid
8283* A is distributed over. The context
8284* itself is global, but the handle
8285* (the integer value) may vary.
8286* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8287* ted matrix A, M_A >= 0.
8288* N_A (global) DESCA( N_ ) The number of columns in the distri-
8289* buted matrix A, N_A >= 0.
8290* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8291* block of the matrix A, IMB_A > 0.
8292* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8293* left block of the matrix A,
8294* INB_A > 0.
8295* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8296* bute the last M_A-IMB_A rows of A,
8297* MB_A > 0.
8298* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8299* bute the last N_A-INB_A columns of
8300* A, NB_A > 0.
8301* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8302* row of the matrix A is distributed,
8303* NPROW > RSRC_A >= 0.
8304* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8305* first column of A is distributed.
8306* NPCOL > CSRC_A >= 0.
8307* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8308* array storing the local blocks of
8309* the distributed matrix A,
8310* IF( Lc( 1, N_A ) > 0 )
8311* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8312* ELSE
8313* LLD_A >= 1.
8314*
8315* Let K be the number of rows of a matrix A starting at the global in-
8316* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8317* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8318* receive if these K rows were distributed over NPROW processes. If K
8319* is the number of columns of a matrix A starting at the global index
8320* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8321* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8322* these K columns were distributed over NPCOL processes.
8323*
8324* The values of Lr() and Lc() may be determined via a call to the func-
8325* tion PB_NUMROC:
8326* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8327* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8328*
8329* Arguments
8330* =========
8331*
8332* INPLACE (global input) LOGICAL
8333* On entry, INPLACE specifies if the matrix should be generated
8334* in place or not. If INPLACE is .TRUE., the local random array
8335* to be generated will start in memory at the local memory lo-
8336* cation A( 1, 1 ), otherwise it will start at the local posi-
8337* tion induced by IA and JA.
8338*
8339* N (global input) INTEGER
8340* On entry, N specifies the global order of the submatrix
8341* sub( A ) to be modified. N must be at least zero.
8342*
8343* ALPHA (global input) REAL
8344* On entry, ALPHA specifies the scalar alpha.
8345*
8346* A (local input/local output) REAL array
8347* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8348* at least Lc( 1, JA+N-1 ). Before entry, this array contains
8349* the local entries of the matrix A. On exit, the local entries
8350* of this array corresponding to the main diagonal of sub( A )
8351* have been updated.
8352*
8353* IA (global input) INTEGER
8354* On entry, IA specifies A's global row index, which points to
8355* the beginning of the submatrix sub( A ).
8356*
8357* JA (global input) INTEGER
8358* On entry, JA specifies A's global column index, which points
8359* to the beginning of the submatrix sub( A ).
8360*
8361* DESCA (global and local input) INTEGER array
8362* On entry, DESCA is an integer array of dimension DLEN_. This
8363* is the array descriptor for the matrix A.
8364*
8365* -- Written on April 1, 1998 by
8366* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8367*
8368* =====================================================================
8369*
8370* .. Parameters ..
8371 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8372 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8373 $ RSRC_
8374 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
8375 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
8376 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
8377 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
8378* ..
8379* .. Local Scalars ..
8380 LOGICAL GODOWN, GOLEFT
8381 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
8382 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
8383 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
8384 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
8385 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
8386 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
8387 REAL ATMP
8388* ..
8389* .. Local Scalars ..
8390 INTEGER DESCA2( DLEN_ )
8391* ..
8392* .. External Subroutines ..
8393 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
8394 $ PB_DESCTRANS
8395* ..
8396* .. Intrinsic Functions ..
8397 INTRINSIC ABS, MAX, MIN
8398* ..
8399* .. Executable Statements ..
8400*
8401* Convert descriptor
8402*
8403 CALL PB_DESCTRANS( DESCA, DESCA2 )
8404*
8405* Get grid parameters
8406*
8407 ICTXT = DESCA2( CTXT_ )
8408 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
8409*
8410.EQ. IF( N0 )
8411 $ RETURN
8412*
8413 CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
8414 $ MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
8415 $ IACOL, MRROW, MRCOL )
8416*
8417* Decide where the entries shall be stored in memory
8418*
8419 IF( INPLACE ) THEN
8420 IIA = 1
8421 JJA = 1
8422 END IF
8423*
8424* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
8425* ILOW, LOW, IUPP, and UPP.
8426*
8427 MB = DESCA2( MB_ )
8428 NB = DESCA2( NB_ )
8429*
8430 CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
8431 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
8432 $ LNBLOC, ILOW, LOW, IUPP, UPP )
8433*
8434 IOFFA = IIA - 1
8435 JOFFA = JJA - 1
8436 LDA = DESCA2( LLD_ )
8437 LDAP1 = LDA + 1
8438*
8439.LT. IF( DESCA2( RSRC_ )0 ) THEN
8440 PMB = MB
8441 ELSE
8442 PMB = NPROW * MB
8443 END IF
8444.LT. IF( DESCA2( CSRC_ )0 ) THEN
8445 QNB = NB
8446 ELSE
8447 QNB = NPCOL * NB
8448 END IF
8449*
8450* Handle the first block of rows or columns separately, and update
8451* LCMT00, MBLKS and NBLKS.
8452*
8453.GT. GODOWN = ( LCMT00IUPP )
8454.LT. GOLEFT = ( LCMT00ILOW )
8455*
8456.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
8457*
8458* LCMT00 >= ILOW && LCMT00 <= IUPP
8459*
8460.GE. IF( LCMT000 ) THEN
8461 IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
8462 DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
8463 ATMP = A( IJOFFA + I*LDAP1 )
8464 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8465 10 CONTINUE
8466 ELSE
8467 IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
8468 DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
8469 ATMP = A( IJOFFA + I*LDAP1 )
8470 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8471 20 CONTINUE
8472 END IF
8473.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
8474.NOT. GODOWN = GOLEFT
8475*
8476 END IF
8477*
8478 IF( GODOWN ) THEN
8479*
8480 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
8481 MBLKS = MBLKS - 1
8482 IOFFA = IOFFA + IMBLOC
8483*
8484 30 CONTINUE
8485.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
8486 LCMT00 = LCMT00 - PMB
8487 MBLKS = MBLKS - 1
8488 IOFFA = IOFFA + MB
8489 GO TO 30
8490 END IF
8491*
8492 LCMT = LCMT00
8493 MBLKD = MBLKS
8494 IOFFD = IOFFA
8495*
8496 MBLOC = MB
8497 40 CONTINUE
8498.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
8499.EQ. IF( MBLKD1 )
8500 $ MBLOC = LMBLOC
8501.GE. IF( LCMT0 ) THEN
8502 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
8503 DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
8504 ATMP = A( IJOFFA + I*LDAP1 )
8505 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8506 50 CONTINUE
8507 ELSE
8508 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
8509 DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
8510 ATMP = A( IJOFFA + I*LDAP1 )
8511 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8512 60 CONTINUE
8513 END IF
8514 LCMT00 = LCMT
8515 LCMT = LCMT - PMB
8516 MBLKS = MBLKD
8517 MBLKD = MBLKD - 1
8518 IOFFA = IOFFD
8519 IOFFD = IOFFD + MBLOC
8520 GO TO 40
8521 END IF
8522*
8523 LCMT00 = LCMT00 + LOW - ILOW + QNB
8524 NBLKS = NBLKS - 1
8525 JOFFA = JOFFA + INBLOC
8526*
8527 ELSE IF( GOLEFT ) THEN
8528*
8529 LCMT00 = LCMT00 + LOW - ILOW + QNB
8530 NBLKS = NBLKS - 1
8531 JOFFA = JOFFA + INBLOC
8532*
8533 70 CONTINUE
8534.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) THEN
8535 LCMT00 = LCMT00 + QNB
8536 NBLKS = NBLKS - 1
8537 JOFFA = JOFFA + NB
8538 GO TO 70
8539 END IF
8540*
8541 LCMT = LCMT00
8542 NBLKD = NBLKS
8543 JOFFD = JOFFA
8544*
8545 NBLOC = NB
8546 80 CONTINUE
8547.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
8548.EQ. IF( NBLKD1 )
8549 $ NBLOC = LNBLOC
8550.GE. IF( LCMT0 ) THEN
8551 IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
8552 DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
8553 ATMP = A( IJOFFA + I*LDAP1 )
8554 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8555 90 CONTINUE
8556 ELSE
8557 IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
8558 DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
8559 ATMP = A( IJOFFA + I*LDAP1 )
8560 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8561 100 CONTINUE
8562 END IF
8563 LCMT00 = LCMT
8564 LCMT = LCMT + QNB
8565 NBLKS = NBLKD
8566 NBLKD = NBLKD - 1
8567 JOFFA = JOFFD
8568 JOFFD = JOFFD + NBLOC
8569 GO TO 80
8570 END IF
8571*
8572 LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
8573 MBLKS = MBLKS - 1
8574 IOFFA = IOFFA + IMBLOC
8575*
8576 END IF
8577*
8578 NBLOC = NB
8579 110 CONTINUE
8580.GT. IF( NBLKS0 ) THEN
8581.EQ. IF( NBLKS1 )
8582 $ NBLOC = LNBLOC
8583 120 CONTINUE
8584.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) THEN
8585 LCMT00 = LCMT00 - PMB
8586 MBLKS = MBLKS - 1
8587 IOFFA = IOFFA + MB
8588 GO TO 120
8589 END IF
8590*
8591 LCMT = LCMT00
8592 MBLKD = MBLKS
8593 IOFFD = IOFFA
8594*
8595 MBLOC = MB
8596 130 CONTINUE
8597.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
8598.EQ. IF( MBLKD1 )
8599 $ MBLOC = LMBLOC
8600.GE. IF( LCMT0 ) THEN
8601 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
8602 DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
8603 ATMP = A( IJOFFA + I*LDAP1 )
8604 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8605 140 CONTINUE
8606 ELSE
8607 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
8608 DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
8609 ATMP = A( IJOFFA + I*LDAP1 )
8610 A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
8611 150 CONTINUE
8612 END IF
8613 LCMT00 = LCMT
8614 LCMT = LCMT - PMB
8615 MBLKS = MBLKD
8616 MBLKD = MBLKD - 1
8617 IOFFA = IOFFD
8618 IOFFD = IOFFD + MBLOC
8619 GO TO 130
8620 END IF
8621*
8622 LCMT00 = LCMT00 + QNB
8623 NBLKS = NBLKS - 1
8624 JOFFA = JOFFA + NBLOC
8625 GO TO 110
8626*
8627 END IF
8628*
8629 RETURN
8630*
8631* End of PSLADOM
8632*
8633 END
8634 SUBROUTINE PB_PSLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
8635 $ CMATNM, NOUT, WORK )
8636*
8637* -- PBLAS test routine (version 2.0) --
8638* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8639* and University of California, Berkeley.
8640* April 1, 1998
8641*
8642* .. Scalar Arguments ..
8643 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT
8644* ..
8645* .. Array Arguments ..
8646 CHARACTER*(*) CMATNM
8647 INTEGER DESCA( * )
8648 REAL A( * ), WORK( * )
8649* ..
8650*
8651* Purpose
8652* =======
8653*
8654* PB_PSLAPRNT prints to the standard output a submatrix sub( A ) deno-
8655* ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
8656* the process of coordinates (IRPRNT, ICPRNT).
8657*
8658* Notes
8659* =====
8660*
8661* A description vector is associated with each 2D block-cyclicly dis-
8662* tributed matrix. This vector stores the information required to
8663* establish the mapping between a matrix entry and its corresponding
8664* process and memory location.
8665*
8666* In the following comments, the character _ should be read as
8667* "of the distributed matrix". Let A be a generic term for any 2D
8668* block cyclicly distributed matrix. Its description vector is DESCA:
8669*
8670* NOTATION STORED IN EXPLANATION
8671* ---------------- --------------- ------------------------------------
8672* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8673* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8674* the NPROW x NPCOL BLACS process grid
8675* A is distributed over. The context
8676* itself is global, but the handle
8677* (the integer value) may vary.
8678* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8679* ted matrix A, M_A >= 0.
8680* N_A (global) DESCA( N_ ) The number of columns in the distri-
8681* buted matrix A, N_A >= 0.
8682* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8683* block of the matrix A, IMB_A > 0.
8684* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8685* left block of the matrix A,
8686* INB_A > 0.
8687* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8688* bute the last M_A-IMB_A rows of A,
8689* MB_A > 0.
8690* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8691* bute the last N_A-INB_A columns of
8692* A, NB_A > 0.
8693* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8694* row of the matrix A is distributed,
8695* NPROW > RSRC_A >= 0.
8696* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8697* first column of A is distributed.
8698* NPCOL > CSRC_A >= 0.
8699* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8700* array storing the local blocks of
8701* the distributed matrix A,
8702* IF( Lc( 1, N_A ) > 0 )
8703* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8704* ELSE
8705* LLD_A >= 1.
8706*
8707* Let K be the number of rows of a matrix A starting at the global in-
8708* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8709* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8710* receive if these K rows were distributed over NPROW processes. If K
8711* is the number of columns of a matrix A starting at the global index
8712* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8713* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8714* these K columns were distributed over NPCOL processes.
8715*
8716* The values of Lr() and Lc() may be determined via a call to the func-
8717* tion PB_NUMROC:
8718* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8719* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8720*
8721* Arguments
8722* =========
8723*
8724* M (global input) INTEGER
8725* On entry, M specifies the number of rows of the submatrix
8726* sub( A ). M must be at least zero.
8727*
8728* N (global input) INTEGER
8729* On entry, N specifies the number of columns of the submatrix
8730* sub( A ). N must be at least zero.
8731*
8732* A (local input) REAL array
8733* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8734* at least Lc( 1, JA+N-1 ). Before entry, this array contains
8735* the local entries of the matrix A.
8736*
8737* IA (global input) INTEGER
8738* On entry, IA specifies A's global row index, which points to
8739* the beginning of the submatrix sub( A ).
8740*
8741* JA (global input) INTEGER
8742* On entry, JA specifies A's global column index, which points
8743* to the beginning of the submatrix sub( A ).
8744*
8745* DESCA (global and local input) INTEGER array
8746* On entry, DESCA is an integer array of dimension DLEN_. This
8747* is the array descriptor for the matrix A.
8748*
8749* IRPRNT (global input) INTEGER
8750* On entry, IRPRNT specifies the row index of the printing pro-
8751* cess.
8752*
8753* ICPRNT (global input) INTEGER
8754* On entry, ICPRNT specifies the column index of the printing
8755* process.
8756*
8757* CMATNM (global input) CHARACTER*(*)
8758* On entry, CMATNM is the name of the matrix to be printed.
8759*
8760* NOUT (global input) INTEGER
8761* On entry, NOUT specifies the output unit number. When NOUT is
8762* equal to 6, the submatrix is printed on the screen.
8763*
8764* WORK (local workspace) REAL array
8765* On entry, WORK is a work array of dimension at least equal to
8766* MAX( IMB_A, MB_A ).
8767*
8768* -- Written on April 1, 1998 by
8769* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8770*
8771* =====================================================================
8772*
8773* .. Parameters ..
8774 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8775 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8776 $ RSRC_
8777 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
8778 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
8779 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
8780 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
8781* ..
8782* .. Local Scalars ..
8783 INTEGER MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
8784* ..
8785* .. Local Arrays ..
8786 INTEGER DESCA2( DLEN_ )
8787* ..
8788* .. External Subroutines ..
8789 EXTERNAL BLACS_GRIDINFO, PB_DESCTRANS, PB_PSLAPRN2
8790* ..
8791* .. Executable Statements ..
8792*
8793* Quick return if possible
8794*
8795.LE..OR..LE. IF( ( M0 )( N0 ) )
8796 $ RETURN
8797*
8798* Convert descriptor
8799*
8800 CALL PB_DESCTRANS( DESCA, DESCA2 )
8801*
8802 CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
8803*
8804.GE. IF( DESCA2( RSRC_ )0 ) THEN
8805.GE. IF( DESCA2( CSRC_ )0 ) THEN
8806 CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
8807 $ CMATNM, NOUT, DESCA2( RSRC_ ),
8808 $ DESCA2( CSRC_ ), WORK )
8809 ELSE
8810 DO 10 PCOL = 0, NPCOL - 1
8811.EQ..AND..EQ. IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
8812 $ WRITE( NOUT, * ) 'colum-replicated array -- ' ,
8813 $ 'copy in process column: ', PCOL
8814 CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
8815 $ ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
8816 $ PCOL, WORK )
8817 10 CONTINUE
8818 END IF
8819 ELSE
8820.GE. IF( DESCA2( CSRC_ )0 ) THEN
8821 DO 20 PROW = 0, NPROW - 1
8822.EQ..AND..EQ. IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
8823 $ WRITE( NOUT, * ) 'row-replicated array -- ' ,
8824 $ 'copy in process row: ', PROW
8825 CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
8826 $ ICPRNT, CMATNM, NOUT, PROW,
8827 $ DESCA2( CSRC_ ), WORK )
8828 20 CONTINUE
8829 ELSE
8830 DO 40 PROW = 0, NPROW - 1
8831 DO 30 PCOL = 0, NPCOL - 1
8832.EQ..AND..EQ. IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
8833 $ WRITE( NOUT, * ) 'replicated array -- ' ,
8834 $ 'copy in process(', PROW, ',', PCOL, ')'
8835 CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
8836 $ ICPRNT, CMATNM, NOUT, PROW, PCOL,
8837 $ WORK )
8838 30 CONTINUE
8839 40 CONTINUE
8840 END IF
8841 END IF
8842*
8843 RETURN
8844*
8845* End of PB_PSLAPRNT
8846*
8847 END
8848 SUBROUTINE PB_PSLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
8849 $ CMATNM, NOUT, PROW, PCOL, WORK )
8850*
8851* -- PBLAS test routine (version 2.0) --
8852* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8853* and University of California, Berkeley.
8854* April 1, 1998
8855*
8856* .. Scalar Arguments ..
8857 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
8858* ..
8859* .. Array Arguments ..
8860 CHARACTER*(*) CMATNM
8861 INTEGER DESCA( * )
8862 REAL A( * ), WORK( * )
8863* ..
8864*
8865* .. Parameters ..
8866 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8867 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8868 $ RSRC_
8869 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
8870 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
8871 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
8872 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
8873* ..
8874* .. Local Scalars ..
8875 LOGICAL AISCOLREP, AISROWREP
8876 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
8877 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
8878 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
8879* ..
8880* .. External Subroutines ..
8881 EXTERNAL BLACS_BARRIER, BLACS_GRIDINFO, PB_INFOG2L,
8882 $ SGERV2D, SGESD2D
8883* ..
8884* .. Intrinsic Functions ..
8885 INTRINSIC MIN
8886* ..
8887* .. Executable Statements ..
8888*
8889* Get grid parameters
8890*
8891 ICTXT = DESCA( CTXT_ )
8892 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
8893 CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
8894 $ IIA, JJA, IAROW, IACOL )
8895 II = IIA
8896 JJ = JJA
8897.LT. IF( DESCA( RSRC_ )0 ) THEN
8898 AISROWREP = .TRUE.
8899 IAROW = PROW
8900 ICURROW = PROW
8901 ELSE
8902 AISROWREP = .FALSE.
8903 ICURROW = IAROW
8904 END IF
8905.LT. IF( DESCA( CSRC_ )0 ) THEN
8906 AISCOLREP = .TRUE.
8907 IACOL = PCOL
8908 ICURCOL = PCOL
8909 ELSE
8910 AISCOLREP = .FALSE.
8911 ICURCOL = IACOL
8912 END IF
8913 LDA = DESCA( LLD_ )
8914 LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
8915*
8916* Handle the first block of column separately
8917*
8918 JB = DESCA( INB_ ) - JA + 1
8919.LE. IF( JB0 )
8920 $ JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
8921 JB = MIN( JB, N )
8922 JN = JA+JB-1
8923 DO 60 H = 0, JB-1
8924 IB = DESCA( IMB_ ) - IA + 1
8925.LE. IF( IB0 )
8926 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
8927 IB = MIN( IB, M )
8928 IN = IA+IB-1
8929.EQ..AND..EQ. IF( ICURROWIRPRNT ICURCOLICPRNT ) THEN
8930.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
8931 DO 10 K = 0, IB-1
8932 WRITE( NOUT, FMT = 9999 )
8933 $ CMATNM, IA+K, JA+H, A( II+K+(JJ+H-1)*LDA )
8934 10 CONTINUE
8935 END IF
8936 ELSE
8937.EQ..AND..EQ. IF( MYROWICURROW MYCOLICURCOL ) THEN
8938 CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
8939 $ IRPRNT, ICPRNT )
8940.EQ..AND..EQ. ELSE IF( MYROWIRPRNT MYCOLICPRNT ) THEN
8941 CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
8942 DO 20 K = 1, IB
8943 WRITE( NOUT, FMT = 9999 )
8944 $ CMATNM, IA+K-1, JA+H, WORK( K )
8945 20 CONTINUE
8946 END IF
8947 END IF
8948.EQ. IF( MYROWICURROW )
8949 $ II = II + IB
8950.NOT. IF( AISROWREP )
8951 $ ICURROW = MOD( ICURROW+1, NPROW )
8952 CALL BLACS_BARRIER( ICTXT, 'all' )
8953*
8954* Loop over remaining block of rows
8955*
8956 DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
8957 IB = MIN( DESCA( MB_ ), IA+M-I )
8958.EQ..AND..EQ. IF( ICURROWIRPRNT ICURCOLICPRNT ) THEN
8959.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
8960 DO 30 K = 0, IB-1
8961 WRITE( NOUT, FMT = 9999 )
8962 $ CMATNM, I+K, JA+H, A( II+K+(JJ+H-1)*LDA )
8963 30 CONTINUE
8964 END IF
8965 ELSE
8966.EQ..AND..EQ. IF( MYROWICURROW MYCOLICURCOL ) THEN
8967 CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
8968 $ LDA, IRPRNT, ICPRNT )
8969.EQ..AND..EQ. ELSE IF( MYROWIRPRNT MYCOLICPRNT ) THEN
8970 CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
8971 $ ICURCOL )
8972 DO 40 K = 1, IB
8973 WRITE( NOUT, FMT = 9999 )
8974 $ CMATNM, I+K-1, JA+H, WORK( K )
8975 40 CONTINUE
8976 END IF
8977 END IF
8978.EQ. IF( MYROWICURROW )
8979 $ II = II + IB
8980.NOT. IF( AISROWREP )
8981 $ ICURROW = MOD( ICURROW+1, NPROW )
8982 CALL BLACS_BARRIER( ICTXT, 'all' )
8983 50 CONTINUE
8984*
8985 II = IIA
8986 ICURROW = IAROW
8987 60 CONTINUE
8988*
8989.EQ. IF( MYCOLICURCOL )
8990 $ JJ = JJ + JB
8991.NOT. IF( AISCOLREP )
8992 $ ICURCOL = MOD( ICURCOL+1, NPCOL )
8993 CALL BLACS_BARRIER( ICTXT, 'all' )
8994*
8995* Loop over remaining column blocks
8996*
8997 DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
8998 JB = MIN( DESCA( NB_ ), JA+N-J )
8999 DO 120 H = 0, JB-1
9000 IB = DESCA( IMB_ )-IA+1
9001.LE. IF( IB0 )
9002 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
9003 IB = MIN( IB, M )
9004 IN = IA+IB-1
9005.EQ..AND..EQ. IF( ICURROWIRPRNT ICURCOLICPRNT ) THEN
9006.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
9007 DO 70 K = 0, IB-1
9008 WRITE( NOUT, FMT = 9999 )
9009 $ CMATNM, IA+K, J+H, A( II+K+(JJ+H-1)*LDA )
9010 70 CONTINUE
9011 END IF
9012 ELSE
9013.EQ..AND..EQ. IF( MYROWICURROW MYCOLICURCOL ) THEN
9014 CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
9015 $ LDA, IRPRNT, ICPRNT )
9016.EQ..AND..EQ. ELSE IF( MYROWIRPRNT MYCOLICPRNT ) THEN
9017 CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
9018 $ ICURCOL )
9019 DO 80 K = 1, IB
9020 WRITE( NOUT, FMT = 9999 )
9021 $ CMATNM, IA+K-1, J+H, WORK( K )
9022 80 CONTINUE
9023 END IF
9024 END IF
9025.EQ. IF( MYROWICURROW )
9026 $ II = II + IB
9027 ICURROW = MOD( ICURROW+1, NPROW )
9028 CALL BLACS_BARRIER( ICTXT, 'all' )
9029*
9030* Loop over remaining block of rows
9031*
9032 DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
9033 IB = MIN( DESCA( MB_ ), IA+M-I )
9034.EQ..AND..EQ. IF( ICURROWIRPRNT ICURCOLICPRNT ) THEN
9035.EQ..AND..EQ. IF( MYROWIRPRNT MYCOLICPRNT ) THEN
9036 DO 90 K = 0, IB-1
9037 WRITE( NOUT, FMT = 9999 )
9038 $ CMATNM, I+K, J+H, A( II+K+(JJ+H-1)*LDA )
9039 90 CONTINUE
9040 END IF
9041 ELSE
9042.EQ..AND..EQ. IF( MYROWICURROW MYCOLICURCOL ) THEN
9043 CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
9044 $ LDA, IRPRNT, ICPRNT )
9045.EQ..AND..EQ. ELSE IF( MYROWIRPRNT MYCOLICPRNT ) THEN
9046 CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
9047 $ ICURCOL )
9048 DO 100 K = 1, IB
9049 WRITE( NOUT, FMT = 9999 )
9050 $ CMATNM, I+K-1, J+H, WORK( K )
9051 100 CONTINUE
9052 END IF
9053 END IF
9054.EQ. IF( MYROWICURROW )
9055 $ II = II + IB
9056.NOT. IF( AISROWREP )
9057 $ ICURROW = MOD( ICURROW+1, NPROW )
9058 CALL BLACS_BARRIER( ICTXT, 'all' )
9059 110 CONTINUE
9060*
9061 II = IIA
9062 ICURROW = IAROW
9063 120 CONTINUE
9064*
9065.EQ. IF( MYCOLICURCOL )
9066 $ JJ = JJ + JB
9067.NOT. IF( AISCOLREP )
9068 $ ICURCOL = MOD( ICURCOL+1, NPCOL )
9069 CALL BLACS_BARRIER( ICTXT, 'all' )
9070*
9071 130 CONTINUE
9072*
9073 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8 )
9074*
9075 RETURN
9076*
9077* End of PB_PSLAPRN2
9078*
9079 END
9080 SUBROUTINE PB_SFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
9081*
9082* -- PBLAS test routine (version 2.0) --
9083* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9084* and University of California, Berkeley.
9085* April 1, 1998
9086*
9087* .. Scalar Arguments ..
9088 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9089 REAL CHKVAL
9090* ..
9091* .. Array Arguments ..
9092 REAL A( * )
9093* ..
9094*
9095* Purpose
9096* =======
9097*
9098* PB_SFILLPAD surrounds a two dimensional local array with a guard-zone
9099* initialized to the value CHKVAL. The user may later call the routine
9100* PB_SCHEKPAD to discover if the guardzone has been violated. There are
9101* three guardzones. The first is a buffer of size IPRE that is before
9102* the start of the array. The second is the buffer of size IPOST which
9103* is after the end of the array to be padded. Finally, there is a guard
9104* zone inside every column of the array to be padded, in the elements
9105* of A(M+1:LDA, J).
9106*
9107* Arguments
9108* =========
9109*
9110* ICTXT (local input) INTEGER
9111* On entry, ICTXT specifies the BLACS context handle, indica-
9112* ting the global context of the operation. The context itself
9113* is global, but the value of ICTXT is local.
9114*
9115* M (local input) INTEGER
9116* On entry, M specifies the number of rows in the local array
9117* A. M must be at least zero.
9118*
9119* N (local input) INTEGER
9120* On entry, N specifies the number of columns in the local ar-
9121* ray A. N must be at least zero.
9122*
9123* A (local input/local output) REAL array
9124* On entry, A is an array of dimension (LDA,N). On exit, this
9125* array is the padded array.
9126*
9127* LDA (local input) INTEGER
9128* On entry, LDA specifies the leading dimension of the local
9129* array to be padded. LDA must be at least MAX( 1, M ).
9130*
9131* IPRE (local input) INTEGER
9132* On entry, IPRE specifies the size of the guard zone to put
9133* before the start of the padded array.
9134*
9135* IPOST (local input) INTEGER
9136* On entry, IPOST specifies the size of the guard zone to put
9137* after the end of the padded array.
9138*
9139* CHKVAL (local input) REAL
9140* On entry, CHKVAL specifies the value to pad the array with.
9141*
9142* -- Written on April 1, 1998 by
9143* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9144*
9145* =====================================================================
9146*
9147* .. Local Scalars ..
9148 INTEGER I, J, K
9149* ..
9150* .. Executable Statements ..
9151*
9152* Put check buffer in front of A
9153*
9154.GT. IF( IPRE0 ) THEN
9155 DO 10 I = 1, IPRE
9156 A( I ) = CHKVAL
9157 10 CONTINUE
9158 ELSE
9159 WRITE( *, FMT = '(a)' )
9160 $ 'warning no pre-guardzone in pb_sfillpad'
9161 END IF
9162*
9163* Put check buffer in back of A
9164*
9165.GT. IF( IPOST0 ) THEN
9166 J = IPRE+LDA*N+1
9167 DO 20 I = J, J+IPOST-1
9168 A( I ) = CHKVAL
9169 20 CONTINUE
9170 ELSE
9171 WRITE( *, FMT = '(a)' )
9172 $ 'warning no post-guardzone in pb_sfillpad'
9173 END IF
9174*
9175* Put check buffer in all (LDA-M) gaps
9176*
9177.GT. IF( LDAM ) THEN
9178 K = IPRE + M + 1
9179 DO 40 J = 1, N
9180 DO 30 I = K, K + ( LDA - M ) - 1
9181 A( I ) = CHKVAL
9182 30 CONTINUE
9183 K = K + LDA
9184 40 CONTINUE
9185 END IF
9186*
9187 RETURN
9188*
9189* End of PB_SFILLPAD
9190*
9191 END
9192 SUBROUTINE PB_SCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
9193 $ CHKVAL )
9194*
9195* -- PBLAS test routine (version 2.0) --
9196* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9197* and University of California, Berkeley.
9198* April 1, 1998
9199*
9200* .. Scalar Arguments ..
9201 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9202 REAL CHKVAL
9203* ..
9204* .. Array Arguments ..
9205 CHARACTER*(*) MESS
9206 REAL A( * )
9207* ..
9208*
9209* Purpose
9210* =======
9211*
9212* PB_SCHEKPAD checks that the padding around a local array has not been
9213* overwritten since the call to PB_SFILLPAD. Three types of errors are
9214* reported:
9215*
9216* 1) Overwrite in pre-guardzone. This indicates a memory overwrite has
9217* occurred in the first IPRE elements which form a buffer before the
9218* beginning of A. Therefore, the error message:
9219* 'Overwrite in pre-guardzone: loc( 5) = 18.00000'
9220* tells that the 5th element of the IPRE long buffer has been overwrit-
9221* ten with the value 18, where it should still have the value CHKVAL.
9222*
9223* 2) Overwrite in post-guardzone. This indicates a memory overwrite has
9224* occurred in the last IPOST elements which form a buffer after the end
9225* of A. Error reports are refered from the end of A. Therefore,
9226* 'Overwrite in post-guardzone: loc( 19) = 24.00000'
9227* tells that the 19th element after the end of A was overwritten with
9228* the value 24, where it should still have the value of CHKVAL.
9229*
9230* 3) Overwrite in lda-m gap. Tells you elements between M and LDA were
9231* overwritten. So,
9232* 'Overwrite in lda-m gap: A( 12, 3) = 22.00000'
9233* tells that the element at the 12th row and 3rd column of A was over-
9234* written with the value of 22, where it should still have the value of
9235* CHKVAL.
9236*
9237* Arguments
9238* =========
9239*
9240* ICTXT (local input) INTEGER
9241* On entry, ICTXT specifies the BLACS context handle, indica-
9242* ting the global context of the operation. The context itself
9243* is global, but the value of ICTXT is local.
9244*
9245* MESS (local input) CHARACTER*(*)
9246* On entry, MESS is a ttring containing a user-defined message.
9247*
9248* M (local input) INTEGER
9249* On entry, M specifies the number of rows in the local array
9250* A. M must be at least zero.
9251*
9252* N (local input) INTEGER
9253* On entry, N specifies the number of columns in the local ar-
9254* ray A. N must be at least zero.
9255*
9256* A (local input) REAL array
9257* On entry, A is an array of dimension (LDA,N).
9258*
9259* LDA (local input) INTEGER
9260* On entry, LDA specifies the leading dimension of the local
9261* array to be padded. LDA must be at least MAX( 1, M ).
9262*
9263* IPRE (local input) INTEGER
9264* On entry, IPRE specifies the size of the guard zone to put
9265* before the start of the padded array.
9266*
9267* IPOST (local input) INTEGER
9268* On entry, IPOST specifies the size of the guard zone to put
9269* after the end of the padded array.
9270*
9271* CHKVAL (local input) REAL
9272* On entry, CHKVAL specifies the value to pad the array with.
9273*
9274*
9275* -- Written on April 1, 1998 by
9276* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9277*
9278* =====================================================================
9279*
9280* .. Local Scalars ..
9281 CHARACTER*1 TOP
9282 INTEGER I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
9283 $ NPROW
9284* ..
9285* .. External Subroutines ..
9286 EXTERNAL BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
9287* ..
9288* .. Executable Statements ..
9289*
9290* Get grid parameters
9291*
9292 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
9293 IAM = MYROW*NPCOL + MYCOL
9294 INFO = -1
9295*
9296* Check buffer in front of A
9297*
9298.GT. IF( IPRE0 ) THEN
9299 DO 10 I = 1, IPRE
9300.NE. IF( A( I )CHKVAL ) THEN
9301 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
9302 $ A( I )
9303 INFO = IAM
9304 END IF
9305 10 CONTINUE
9306 ELSE
9307 WRITE( *, FMT = * ) 'warning no pre-guardzone in pb_schekpad'
9308 END IF
9309*
9310* Check buffer after A
9311*
9312.GT. IF( IPOST0 ) THEN
9313 J = IPRE+LDA*N+1
9314 DO 20 I = J, J+IPOST-1
9315.NE. IF( A( I )CHKVAL ) THEN
9316 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
9317 $ I-J+1, A( I )
9318 INFO = IAM
9319 END IF
9320 20 CONTINUE
9321 ELSE
9322 WRITE( *, FMT = * )
9323 $ 'warning no post-guardzone buffer in pb_schekpad'
9324 END IF
9325*
9326* Check all (LDA-M) gaps
9327*
9328.GT. IF( LDAM ) THEN
9329 K = IPRE + M + 1
9330 DO 40 J = 1, N
9331 DO 30 I = K, K + (LDA-M) - 1
9332.NE. IF( A( I )CHKVAL ) THEN
9333 WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
9334 $ I-IPRE-LDA*(J-1), J, A( I )
9335 INFO = IAM
9336 END IF
9337 30 CONTINUE
9338 K = K + LDA
9339 40 CONTINUE
9340 END IF
9341*
9342 CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
9343 CALL IGAMX2D( ICTXT, 'all', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
9344 $ 0, 0 )
9345.EQ..AND..GE. IF( IAM0 INFO0 ) THEN
9346 WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
9347 END IF
9348*
9349 9999 FORMAT( '{', I5, ',', I5, '}: memory overwrite in ', A )
9350 9998 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
9351 $ A4, '-guardzone: loc(', I3, ') = ', G11.4 )
9352 9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
9353 $ 'lda-m gap: loc(', I3, ',', I3, ') = ', G11.4 )
9354*
9355 RETURN
9356*
9357* End of PB_SCHEKPAD
9358*
9359 END
9360 SUBROUTINE PB_SLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
9361*
9362* -- PBLAS test routine (version 2.0) --
9363* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9364* and University of California, Berkeley.
9365* April 1, 1998
9366*
9367* .. Scalar Arguments ..
9368 CHARACTER*1 UPLO
9369 INTEGER IOFFD, LDA, M, N
9370 REAL ALPHA, BETA
9371* ..
9372* .. Array Arguments ..
9373 REAL A( LDA, * )
9374* ..
9375*
9376* Purpose
9377* =======
9378*
9379* PB_SLASET initializes a two-dimensional array A to beta on the diago-
9380* nal specified by IOFFD and alpha on the offdiagonals.
9381*
9382* Arguments
9383* =========
9384*
9385* UPLO (global input) CHARACTER*1
9386* On entry, UPLO specifies which trapezoidal part of the ar-
9387* ray A is to be set as follows:
9388* = 'L' or 'l': Lower triangular part is set; the strictly
9389* upper triangular part of A is not changed,
9390* = 'U' or 'u': Upper triangular part is set; the strictly
9391* lower triangular part of A is not changed,
9392* = 'D' or 'd' Only the diagonal of A is set,
9393* Otherwise: All of the array A is set.
9394*
9395* M (input) INTEGER
9396* On entry, M specifies the number of rows of the array A. M
9397* must be at least zero.
9398*
9399* N (input) INTEGER
9400* On entry, N specifies the number of columns of the array A.
9401* N must be at least zero.
9402*
9403* IOFFD (input) INTEGER
9404* On entry, IOFFD specifies the position of the offdiagonal de-
9405* limiting the upper and lower trapezoidal part of A as follows
9406* (see the notes below):
9407*
9408* IOFFD = 0 specifies the main diagonal A( i, i ),
9409* with i = 1 ... MIN( M, N ),
9410* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
9411* with i = 1 ... MIN( M-IOFFD, N ),
9412* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
9413* with i = 1 ... MIN( M, N+IOFFD ).
9414*
9415* ALPHA (input) REAL
9416* On entry, ALPHA specifies the value to which the offdiagonal
9417* array elements are set to.
9418*
9419* BETA (input) REAL
9420* On entry, BETA specifies the value to which the diagonal ar-
9421* ray elements are set to.
9422*
9423* A (input/output) REAL array
9424* On entry, A is an array of dimension (LDA,N). Before entry
9425* with UPLO = 'U' or 'u', the leading m by n part of the array
9426* A must contain the upper trapezoidal part of the matrix as
9427* specified by IOFFD to be set, and the strictly lower trape-
9428* zoidal part of A is not referenced; When IUPLO = 'L' or 'l',
9429* the leading m by n part of the array A must contain the
9430* lower trapezoidal part of the matrix as specified by IOFFD to
9431* be set, and the strictly upper trapezoidal part of A is
9432* not referenced.
9433*
9434* LDA (input) INTEGER
9435* On entry, LDA specifies the leading dimension of the array A.
9436* LDA must be at least max( 1, M ).
9437*
9438* Notes
9439* =====
9440* N N
9441* ---------------------------- -----------
9442* | d | | |
9443* M | d 'U' | | 'U' |
9444* | 'L' 'D' | |d |
9445* | d | M | d |
9446* ---------------------------- | 'D' |
9447* | d |
9448* IOFFD < 0 | 'L' d |
9449* | d|
9450* N | |
9451* ----------- -----------
9452* | d 'U'|
9453* | d | IOFFD > 0
9454* M | 'D' |
9455* | d| N
9456* | 'L' | ----------------------------
9457* | | | 'U' |
9458* | | |d |
9459* | | | 'D' |
9460* | | | d |
9461* | | |'L' d |
9462* ----------- ----------------------------
9463*
9464* -- Written on April 1, 1998 by
9465* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9466*
9467* =====================================================================
9468*
9469* .. Local Scalars ..
9470 INTEGER I, J, JTMP, MN
9471* ..
9472* .. External Functions ..
9473 LOGICAL LSAME
9474 EXTERNAL LSAME
9475* ..
9476* .. Intrinsic Functions ..
9477 INTRINSIC MAX, MIN
9478* ..
9479* .. Executable Statements ..
9480*
9481* Quick return if possible
9482*
9483.LE..OR..LE. IF( M0 N0 )
9484 $ RETURN
9485*
9486* Start the operations
9487*
9488 IF( LSAME( UPLO, 'l' ) ) THEN
9489*
9490* Set the diagonal to BETA and the strictly lower triangular
9491* part of the array to ALPHA.
9492*
9493 MN = MAX( 0, -IOFFD )
9494 DO 20 J = 1, MIN( MN, N )
9495 DO 10 I = 1, M
9496 A( I, J ) = ALPHA
9497 10 CONTINUE
9498 20 CONTINUE
9499 DO 40 J = MN + 1, MIN( M - IOFFD, N )
9500 JTMP = J + IOFFD
9501 A( JTMP, J ) = BETA
9502 DO 30 I = JTMP + 1, M
9503 A( I, J ) = ALPHA
9504 30 CONTINUE
9505 40 CONTINUE
9506*
9507 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
9508*
9509* Set the diagonal to BETA and the strictly upper triangular
9510* part of the array to ALPHA.
9511*
9512 MN = MIN( M - IOFFD, N )
9513 DO 60 J = MAX( 0, -IOFFD ) + 1, MN
9514 JTMP = J + IOFFD
9515 DO 50 I = 1, JTMP - 1
9516 A( I, J ) = ALPHA
9517 50 CONTINUE
9518 A( JTMP, J ) = BETA
9519 60 CONTINUE
9520 DO 80 J = MAX( 0, MN ) + 1, N
9521 DO 70 I = 1, M
9522 A( I, J ) = ALPHA
9523 70 CONTINUE
9524 80 CONTINUE
9525*
9526 ELSE IF( LSAME( UPLO, 'd' ) ) THEN
9527*
9528* Set the array to BETA on the diagonal.
9529*
9530 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
9531 A( J + IOFFD, J ) = BETA
9532 90 CONTINUE
9533*
9534 ELSE
9535*
9536* Set the array to BETA on the diagonal and ALPHA on the
9537* offdiagonal.
9538*
9539 DO 110 J = 1, N
9540 DO 100 I = 1, M
9541 A( I, J ) = ALPHA
9542 100 CONTINUE
9543 110 CONTINUE
9544.NE..AND..LT..AND..GT. IF( ALPHABETA IOFFDM IOFFD-N ) THEN
9545 DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
9546 A( J + IOFFD, J ) = BETA
9547 120 CONTINUE
9548 END IF
9549*
9550 END IF
9551*
9552 RETURN
9553*
9554* End of PB_SLASET
9555*
9556 END
9557 SUBROUTINE PB_SLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
9558*
9559* -- PBLAS test routine (version 2.0) --
9560* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9561* and University of California, Berkeley.
9562* April 1, 1998
9563*
9564* .. Scalar Arguments ..
9565 CHARACTER*1 UPLO
9566 INTEGER IOFFD, LDA, M, N
9567 REAL ALPHA
9568* ..
9569* .. Array Arguments ..
9570 REAL A( LDA, * )
9571* ..
9572*
9573* Purpose
9574* =======
9575*
9576* PB_SLASCAL scales a two-dimensional array A by the scalar alpha.
9577*
9578* Arguments
9579* =========
9580*
9581* UPLO (input) CHARACTER*1
9582* On entry, UPLO specifies which trapezoidal part of the ar-
9583* ray A is to be scaled as follows:
9584* = 'L' or 'l': the lower trapezoid of A is scaled,
9585* = 'U' or 'u': the upper trapezoid of A is scaled,
9586* = 'D' or 'd': diagonal specified by IOFFD is scaled,
9587* Otherwise: all of the array A is scaled.
9588*
9589* M (input) INTEGER
9590* On entry, M specifies the number of rows of the array A. M
9591* must be at least zero.
9592*
9593* N (input) INTEGER
9594* On entry, N specifies the number of columns of the array A.
9595* N must be at least zero.
9596*
9597* IOFFD (input) INTEGER
9598* On entry, IOFFD specifies the position of the offdiagonal de-
9599* limiting the upper and lower trapezoidal part of A as follows
9600* (see the notes below):
9601*
9602* IOFFD = 0 specifies the main diagonal A( i, i ),
9603* with i = 1 ... MIN( M, N ),
9604* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
9605* with i = 1 ... MIN( M-IOFFD, N ),
9606* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
9607* with i = 1 ... MIN( M, N+IOFFD ).
9608*
9609* ALPHA (input) REAL
9610* On entry, ALPHA specifies the scalar alpha.
9611*
9612* A (input/output) REAL array
9613* On entry, A is an array of dimension (LDA,N). Before entry
9614* with UPLO = 'U' or 'u', the leading m by n part of the array
9615* A must contain the upper trapezoidal part of the matrix as
9616* specified by IOFFD to be scaled, and the strictly lower tra-
9617* pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
9618* the leading m by n part of the array A must contain the lower
9619* trapezoidal part of the matrix as specified by IOFFD to be
9620* scaled, and the strictly upper trapezoidal part of A is not
9621* referenced. On exit, the entries of the trapezoid part of A
9622* determined by UPLO and IOFFD are scaled.
9623*
9624* LDA (input) INTEGER
9625* On entry, LDA specifies the leading dimension of the array A.
9626* LDA must be at least max( 1, M ).
9627*
9628* Notes
9629* =====
9630* N N
9631* ---------------------------- -----------
9632* | d | | |
9633* M | d 'U' | | 'U' |
9634* | 'L' 'D' | |d |
9635* | d | M | d |
9636* ---------------------------- | 'D' |
9637* | d |
9638* IOFFD < 0 | 'L' d |
9639* | d|
9640* N | |
9641* ----------- -----------
9642* | d 'U'|
9643* | d | IOFFD > 0
9644* M | 'D' |
9645* | d| N
9646* | 'L' | ----------------------------
9647* | | | 'U' |
9648* | | |d |
9649* | | | 'D' |
9650* | | | d |
9651* | | |'L' d |
9652* ----------- ----------------------------
9653*
9654* -- Written on April 1, 1998 by
9655* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9656*
9657* =====================================================================
9658*
9659* .. Local Scalars ..
9660 INTEGER I, J, JTMP, MN
9661* ..
9662* .. External Functions ..
9663 LOGICAL LSAME
9664 EXTERNAL LSAME
9665* ..
9666* .. Intrinsic Functions ..
9667 INTRINSIC MAX, MIN
9668* ..
9669* .. Executable Statements ..
9670*
9671* Quick return if possible
9672*
9673.LE..OR..LE. IF( M0 N0 )
9674 $ RETURN
9675*
9676* Start the operations
9677*
9678 IF( LSAME( UPLO, 'l' ) ) THEN
9679*
9680* Scales the lower triangular part of the array by ALPHA.
9681*
9682 MN = MAX( 0, -IOFFD )
9683 DO 20 J = 1, MIN( MN, N )
9684 DO 10 I = 1, M
9685 A( I, J ) = ALPHA * A( I, J )
9686 10 CONTINUE
9687 20 CONTINUE
9688 DO 40 J = MN + 1, MIN( M - IOFFD, N )
9689 DO 30 I = J + IOFFD, M
9690 A( I, J ) = ALPHA * A( I, J )
9691 30 CONTINUE
9692 40 CONTINUE
9693*
9694 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
9695*
9696* Scales the upper triangular part of the array by ALPHA.
9697*
9698 MN = MIN( M - IOFFD, N )
9699 DO 60 J = MAX( 0, -IOFFD ) + 1, MN
9700 DO 50 I = 1, J + IOFFD
9701 A( I, J ) = ALPHA * A( I, J )
9702 50 CONTINUE
9703 60 CONTINUE
9704 DO 80 J = MAX( 0, MN ) + 1, N
9705 DO 70 I = 1, M
9706 A( I, J ) = ALPHA * A( I, J )
9707 70 CONTINUE
9708 80 CONTINUE
9709*
9710 ELSE IF( LSAME( UPLO, 'd' ) ) THEN
9711*
9712* Scales the diagonal entries by ALPHA.
9713*
9714 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
9715 JTMP = J + IOFFD
9716 A( JTMP, J ) = ALPHA * A( JTMP, J )
9717 90 CONTINUE
9718*
9719 ELSE
9720*
9721* Scales the entire array by ALPHA.
9722*
9723 DO 110 J = 1, N
9724 DO 100 I = 1, M
9725 A( I, J ) = ALPHA * A( I, J )
9726 100 CONTINUE
9727 110 CONTINUE
9728*
9729 END IF
9730*
9731 RETURN
9732*
9733* End of PB_SLASCAL
9734*
9735 END
9736 SUBROUTINE PB_SLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
9737 $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
9738 $ LNBLOC, JMP, IMULADD )
9739*
9740* -- PBLAS test routine (version 2.0) --
9741* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9742* and University of California, Berkeley.
9743* April 1, 1998
9744*
9745* .. Scalar Arguments ..
9746 CHARACTER*1 UPLO, AFORM
9747 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
9748 $ MB, MBLKS, NB, NBLKS
9749* ..
9750* .. Array Arguments ..
9751 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
9752 REAL A( LDA, * )
9753* ..
9754*
9755* Purpose
9756* =======
9757*
9758* PB_SLAGEN locally initializes an array A.
9759*
9760* Arguments
9761* =========
9762*
9763* UPLO (global input) CHARACTER*1
9764* On entry, UPLO specifies whether the lower (UPLO='L') trape-
9765* zoidal part or the upper (UPLO='U') trapezoidal part is to be
9766* generated when the matrix to be generated is symmetric or
9767* Hermitian. For all the other values of AFORM, the value of
9768* this input argument is ignored.
9769*
9770* AFORM (global input) CHARACTER*1
9771* On entry, AFORM specifies the type of submatrix to be genera-
9772* ted as follows:
9773* AFORM = 'S', sub( A ) is a symmetric matrix,
9774* AFORM = 'H', sub( A ) is a Hermitian matrix,
9775* AFORM = 'T', sub( A ) is overrwritten with the transpose
9776* of what would normally be generated,
9777* AFORM = 'C', sub( A ) is overwritten with the conjugate
9778* transpose of what would normally be genera-
9779* ted.
9780* AFORM = 'N', a random submatrix is generated.
9781*
9782* A (local output) REAL array
9783* On entry, A is an array of dimension (LLD_A, *). On exit,
9784* this array contains the local entries of the randomly genera-
9785* ted submatrix sub( A ).
9786*
9787* LDA (local input) INTEGER
9788* On entry, LDA specifies the local leading dimension of the
9789* array A. LDA must be at least one.
9790*
9791* LCMT00 (global input) INTEGER
9792* On entry, LCMT00 is the LCM value specifying the off-diagonal
9793* of the underlying matrix of interest. LCMT00=0 specifies the
9794* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
9795* specifies superdiagonals.
9796*
9797* IRAN (local input) INTEGER array
9798* On entry, IRAN is an array of dimension 2 containing respec-
9799* tively the 16-lower and 16-higher bits of the encoding of the
9800* entry of the random sequence corresponding locally to the
9801* first local array entry to generate. Usually, this array is
9802* computed by PB_SETLOCRAN.
9803*
9804* MBLKS (local input) INTEGER
9805* On entry, MBLKS specifies the local number of blocks of rows.
9806* MBLKS is at least zero.
9807*
9808* IMBLOC (local input) INTEGER
9809* On entry, IMBLOC specifies the number of rows (size) of the
9810* local uppest blocks. IMBLOC is at least zero.
9811*
9812* MB (global input) INTEGER
9813* On entry, MB specifies the blocking factor used to partition
9814* the rows of the matrix. MB must be at least one.
9815*
9816* LMBLOC (local input) INTEGER
9817* On entry, LMBLOC specifies the number of rows (size) of the
9818* local lowest blocks. LMBLOC is at least zero.
9819*
9820* NBLKS (local input) INTEGER
9821* On entry, NBLKS specifies the local number of blocks of co-
9822* lumns. NBLKS is at least zero.
9823*
9824* INBLOC (local input) INTEGER
9825* On entry, INBLOC specifies the number of columns (size) of
9826* the local leftmost blocks. INBLOC is at least zero.
9827*
9828* NB (global input) INTEGER
9829* On entry, NB specifies the blocking factor used to partition
9830* the the columns of the matrix. NB must be at least one.
9831*
9832* LNBLOC (local input) INTEGER
9833* On entry, LNBLOC specifies the number of columns (size) of
9834* the local rightmost blocks. LNBLOC is at least zero.
9835*
9836* JMP (local input) INTEGER array
9837* On entry, JMP is an array of dimension JMP_LEN containing the
9838* different jump values used by the random matrix generator.
9839*
9840* IMULADD (local input) INTEGER array
9841* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
9842* jth column of this array contains the encoded initial cons-
9843* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
9844* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
9845* contains respectively the 16-lower and 16-higher bits of the
9846* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
9847* 16-higher bits of the constant c_j.
9848*
9849* -- Written on April 1, 1998 by
9850* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9851*
9852* =====================================================================
9853*
9854* .. Parameters ..
9855 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
9856 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
9857 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
9858 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
9859 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
9860 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
9861 $ JMP_NQNB = 10, JMP_NQINBLOC = 11,
9862 $ JMP_LEN = 11 )
9863* ..
9864* .. Local Scalars ..
9865 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
9866 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
9867 REAL DUMMY
9868* ..
9869* .. Local Arrays ..
9870 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
9871* ..
9872* .. External Subroutines ..
9873 EXTERNAL PB_JUMPIT
9874* ..
9875* .. External Functions ..
9876 LOGICAL LSAME
9877 REAL PB_SRAND
9878 EXTERNAL LSAME, PB_SRAND
9879* ..
9880* .. Intrinsic Functions ..
9881 INTRINSIC MAX, MIN
9882* ..
9883* .. Executable Statements ..
9884*
9885 DO 10 I = 1, 2
9886 IB1( I ) = IRAN( I )
9887 IB2( I ) = IRAN( I )
9888 IB3( I ) = IRAN( I )
9889 10 CONTINUE
9890*
9891 IF( LSAME( AFORM, 'n' ) ) THEN
9892*
9893* Generate random matrix
9894*
9895 JJ = 1
9896*
9897 DO 50 JBLK = 1, NBLKS
9898*
9899.EQ. IF( JBLK1 ) THEN
9900 JB = INBLOC
9901.EQ. ELSE IF( JBLKNBLKS ) THEN
9902 JB = LNBLOC
9903 ELSE
9904 JB = NB
9905 END IF
9906*
9907 DO 40 JK = JJ, JJ + JB - 1
9908*
9909 II = 1
9910*
9911 DO 30 IBLK = 1, MBLKS
9912*
9913.EQ. IF( IBLK1 ) THEN
9914 IB = IMBLOC
9915.EQ. ELSE IF( IBLKMBLKS ) THEN
9916 IB = LMBLOC
9917 ELSE
9918 IB = MB
9919 END IF
9920*
9921* Blocks are IB by JB
9922*
9923 DO 20 IK = II, II + IB - 1
9924 A( IK, JK ) = PB_SRAND( 0 )
9925 20 CONTINUE
9926*
9927 II = II + IB
9928*
9929.EQ. IF( IBLK1 ) THEN
9930*
9931* Jump IMBLOC + ( NPROW - 1 ) * MB rows
9932*
9933 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
9934 $ IB0 )
9935*
9936 ELSE
9937*
9938* Jump NPROW * MB rows
9939*
9940 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
9941*
9942 END IF
9943*
9944 IB1( 1 ) = IB0( 1 )
9945 IB1( 2 ) = IB0( 2 )
9946*
9947 30 CONTINUE
9948*
9949* Jump one column
9950*
9951 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
9952*
9953 IB1( 1 ) = IB0( 1 )
9954 IB1( 2 ) = IB0( 2 )
9955 IB2( 1 ) = IB0( 1 )
9956 IB2( 2 ) = IB0( 2 )
9957*
9958 40 CONTINUE
9959*
9960 JJ = JJ + JB
9961*
9962.EQ. IF( JBLK1 ) THEN
9963*
9964* Jump INBLOC + ( NPCOL - 1 ) * NB columns
9965*
9966 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
9967*
9968 ELSE
9969*
9970* Jump NPCOL * NB columns
9971*
9972 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
9973*
9974 END IF
9975*
9976 IB1( 1 ) = IB0( 1 )
9977 IB1( 2 ) = IB0( 2 )
9978 IB2( 1 ) = IB0( 1 )
9979 IB2( 2 ) = IB0( 2 )
9980 IB3( 1 ) = IB0( 1 )
9981 IB3( 2 ) = IB0( 2 )
9982*
9983 50 CONTINUE
9984*
9985 ELSE IF( LSAME( AFORM, 't.OR.' ) LSAME( AFORM, 'c' ) ) THEN
9986*
9987* Generate the transpose of the matrix that would be normally
9988* generated.
9989*
9990 II = 1
9991*
9992 DO 90 IBLK = 1, MBLKS
9993*
9994.EQ. IF( IBLK1 ) THEN
9995 IB = IMBLOC
9996.EQ. ELSE IF( IBLKMBLKS ) THEN
9997 IB = LMBLOC
9998 ELSE
9999 IB = MB
10000 END IF
10001*
10002 DO 80 IK = II, II + IB - 1
10003*
10004 JJ = 1
10005*
10006 DO 70 JBLK = 1, NBLKS
10007*
10008.EQ. IF( JBLK1 ) THEN
10009 JB = INBLOC
10010.EQ. ELSE IF( JBLKNBLKS ) THEN
10011 JB = LNBLOC
10012 ELSE
10013 JB = NB
10014 END IF
10015*
10016* Blocks are IB by JB
10017*
10018 DO 60 JK = JJ, JJ + JB - 1
10019 A( IK, JK ) = PB_SRAND( 0 )
10020 60 CONTINUE
10021*
10022 JJ = JJ + JB
10023*
10024.EQ. IF( JBLK1 ) THEN
10025*
10026* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10027*
10028 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10029 $ IB0 )
10030*
10031 ELSE
10032*
10033* Jump NPCOL * NB columns
10034*
10035 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
10036*
10037 END IF
10038*
10039 IB1( 1 ) = IB0( 1 )
10040 IB1( 2 ) = IB0( 2 )
10041*
10042 70 CONTINUE
10043*
10044* Jump one row
10045*
10046 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10047*
10048 IB1( 1 ) = IB0( 1 )
10049 IB1( 2 ) = IB0( 2 )
10050 IB2( 1 ) = IB0( 1 )
10051 IB2( 2 ) = IB0( 2 )
10052*
10053 80 CONTINUE
10054*
10055 II = II + IB
10056*
10057.EQ. IF( IBLK1 ) THEN
10058*
10059* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10060*
10061 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10062*
10063 ELSE
10064*
10065* Jump NPROW * MB rows
10066*
10067 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10068*
10069 END IF
10070*
10071 IB1( 1 ) = IB0( 1 )
10072 IB1( 2 ) = IB0( 2 )
10073 IB2( 1 ) = IB0( 1 )
10074 IB2( 2 ) = IB0( 2 )
10075 IB3( 1 ) = IB0( 1 )
10076 IB3( 2 ) = IB0( 2 )
10077*
10078 90 CONTINUE
10079*
10080 ELSE IF( ( LSAME( AFORM, 's.OR.' ) )( LSAME( AFORM, 'h' ) ) ) THEN
10081*
10082* Generate a symmetric matrix
10083*
10084 IF( LSAME( UPLO, 'l' ) ) THEN
10085*
10086* generate lower trapezoidal part
10087*
10088 JJ = 1
10089 LCMTC = LCMT00
10090*
10091 DO 170 JBLK = 1, NBLKS
10092*
10093.EQ. IF( JBLK1 ) THEN
10094 JB = INBLOC
10095 LOW = 1 - INBLOC
10096.EQ. ELSE IF( JBLKNBLKS ) THEN
10097 JB = LNBLOC
10098 LOW = 1 - NB
10099 ELSE
10100 JB = NB
10101 LOW = 1 - NB
10102 END IF
10103*
10104 DO 160 JK = JJ, JJ + JB - 1
10105*
10106 II = 1
10107 LCMTR = LCMTC
10108*
10109 DO 150 IBLK = 1, MBLKS
10110*
10111.EQ. IF( IBLK1 ) THEN
10112 IB = IMBLOC
10113 UPP = IMBLOC - 1
10114.EQ. ELSE IF( IBLKMBLKS ) THEN
10115 IB = LMBLOC
10116 UPP = MB - 1
10117 ELSE
10118 IB = MB
10119 UPP = MB - 1
10120 END IF
10121*
10122* Blocks are IB by JB
10123*
10124.GT. IF( LCMTRUPP ) THEN
10125*
10126 DO 100 IK = II, II + IB - 1
10127 DUMMY = PB_SRAND( 0 )
10128 100 CONTINUE
10129*
10130.GE. ELSE IF( LCMTRLOW ) THEN
10131*
10132 JTMP = JK - JJ + 1
10133 MNB = MAX( 0, -LCMTR )
10134*
10135.LE. IF( JTMPMIN( MNB, JB ) ) THEN
10136*
10137 DO 110 IK = II, II + IB - 1
10138 A( IK, JK ) = PB_SRAND( 0 )
10139 110 CONTINUE
10140*
10141.GE..AND. ELSE IF( ( JTMP( MNB + 1 ) )
10142.LE. $ ( JTMPMIN( IB-LCMTR, JB ) ) ) THEN
10143*
10144 ITMP = II + JTMP + LCMTR - 1
10145*
10146 DO 120 IK = II, ITMP - 1
10147 DUMMY = PB_SRAND( 0 )
10148 120 CONTINUE
10149*
10150 DO 130 IK = ITMP, II + IB - 1
10151 A( IK, JK ) = PB_SRAND( 0 )
10152 130 CONTINUE
10153*
10154 END IF
10155*
10156 ELSE
10157*
10158 DO 140 IK = II, II + IB - 1
10159 A( IK, JK ) = PB_SRAND( 0 )
10160 140 CONTINUE
10161*
10162 END IF
10163*
10164 II = II + IB
10165*
10166.EQ. IF( IBLK1 ) THEN
10167*
10168* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10169*
10170 LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10171 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10172 $ IB0 )
10173*
10174 ELSE
10175*
10176* Jump NPROW * MB rows
10177*
10178 LCMTR = LCMTR - JMP( JMP_NPMB )
10179 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
10180 $ IB0 )
10181*
10182 END IF
10183*
10184 IB1( 1 ) = IB0( 1 )
10185 IB1( 2 ) = IB0( 2 )
10186*
10187 150 CONTINUE
10188*
10189* Jump one column
10190*
10191 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10192*
10193 IB1( 1 ) = IB0( 1 )
10194 IB1( 2 ) = IB0( 2 )
10195 IB2( 1 ) = IB0( 1 )
10196 IB2( 2 ) = IB0( 2 )
10197*
10198 160 CONTINUE
10199*
10200 JJ = JJ + JB
10201*
10202.EQ. IF( JBLK1 ) THEN
10203*
10204* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10205*
10206 LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10207 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10208*
10209 ELSE
10210*
10211* Jump NPCOL * NB columns
10212*
10213 LCMTC = LCMTC + JMP( JMP_NQNB )
10214 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10215*
10216 END IF
10217*
10218 IB1( 1 ) = IB0( 1 )
10219 IB1( 2 ) = IB0( 2 )
10220 IB2( 1 ) = IB0( 1 )
10221 IB2( 2 ) = IB0( 2 )
10222 IB3( 1 ) = IB0( 1 )
10223 IB3( 2 ) = IB0( 2 )
10224*
10225 170 CONTINUE
10226*
10227 ELSE
10228*
10229* generate upper trapezoidal part
10230*
10231 II = 1
10232 LCMTR = LCMT00
10233*
10234 DO 250 IBLK = 1, MBLKS
10235*
10236.EQ. IF( IBLK1 ) THEN
10237 IB = IMBLOC
10238 UPP = IMBLOC - 1
10239.EQ. ELSE IF( IBLKMBLKS ) THEN
10240 IB = LMBLOC
10241 UPP = MB - 1
10242 ELSE
10243 IB = MB
10244 UPP = MB - 1
10245 END IF
10246*
10247 DO 240 IK = II, II + IB - 1
10248*
10249 JJ = 1
10250 LCMTC = LCMTR
10251*
10252 DO 230 JBLK = 1, NBLKS
10253*
10254.EQ. IF( JBLK1 ) THEN
10255 JB = INBLOC
10256 LOW = 1 - INBLOC
10257.EQ. ELSE IF( JBLKNBLKS ) THEN
10258 JB = LNBLOC
10259 LOW = 1 - NB
10260 ELSE
10261 JB = NB
10262 LOW = 1 - NB
10263 END IF
10264*
10265* Blocks are IB by JB
10266*
10267.LT. IF( LCMTCLOW ) THEN
10268*
10269 DO 180 JK = JJ, JJ + JB - 1
10270 DUMMY = PB_SRAND( 0 )
10271 180 CONTINUE
10272*
10273.LE. ELSE IF( LCMTCUPP ) THEN
10274*
10275 ITMP = IK - II + 1
10276 MNB = MAX( 0, LCMTC )
10277*
10278.LE. IF( ITMPMIN( MNB, IB ) ) THEN
10279*
10280 DO 190 JK = JJ, JJ + JB - 1
10281 A( IK, JK ) = PB_SRAND( 0 )
10282 190 CONTINUE
10283*
10284.GE..AND. ELSE IF( ( ITMP( MNB + 1 ) )
10285.LE. $ ( ITMPMIN( JB+LCMTC, IB ) ) ) THEN
10286*
10287 JTMP = JJ + ITMP - LCMTC - 1
10288*
10289 DO 200 JK = JJ, JTMP - 1
10290 DUMMY = PB_SRAND( 0 )
10291 200 CONTINUE
10292*
10293 DO 210 JK = JTMP, JJ + JB - 1
10294 A( IK, JK ) = PB_SRAND( 0 )
10295 210 CONTINUE
10296*
10297 END IF
10298*
10299 ELSE
10300*
10301 DO 220 JK = JJ, JJ + JB - 1
10302 A( IK, JK ) = PB_SRAND( 0 )
10303 220 CONTINUE
10304*
10305 END IF
10306*
10307 JJ = JJ + JB
10308*
10309.EQ. IF( JBLK1 ) THEN
10310*
10311* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10312*
10313 LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10314 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10315 $ IB0 )
10316*
10317 ELSE
10318*
10319* Jump NPCOL * NB columns
10320*
10321 LCMTC = LCMTC + JMP( JMP_NQNB )
10322 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
10323 $ IB0 )
10324*
10325 END IF
10326*
10327 IB1( 1 ) = IB0( 1 )
10328 IB1( 2 ) = IB0( 2 )
10329*
10330 230 CONTINUE
10331*
10332* Jump one row
10333*
10334 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10335*
10336 IB1( 1 ) = IB0( 1 )
10337 IB1( 2 ) = IB0( 2 )
10338 IB2( 1 ) = IB0( 1 )
10339 IB2( 2 ) = IB0( 2 )
10340*
10341 240 CONTINUE
10342*
10343 II = II + IB
10344*
10345.EQ. IF( IBLK1 ) THEN
10346*
10347* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10348*
10349 LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10350 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10351*
10352 ELSE
10353*
10354* Jump NPROW * MB rows
10355*
10356 LCMTR = LCMTR - JMP( JMP_NPMB )
10357 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10358*
10359 END IF
10360*
10361 IB1( 1 ) = IB0( 1 )
10362 IB1( 2 ) = IB0( 2 )
10363 IB2( 1 ) = IB0( 1 )
10364 IB2( 2 ) = IB0( 2 )
10365 IB3( 1 ) = IB0( 1 )
10366 IB3( 2 ) = IB0( 2 )
10367*
10368 250 CONTINUE
10369*
10370 END IF
10371*
10372 END IF
10373*
10374 RETURN
10375*
10376* End of PB_SLAGEN
10377*
10378 END
10379 REAL FUNCTION PB_SRAND( IDUMM )
10380*
10381* -- PBLAS test routine (version 2.0) --
10382* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10383* and University of California, Berkeley.
10384* April 1, 1998
10385*
10386* .. Scalar Arguments ..
10387 INTEGER IDUMM
10388* ..
10389*
10390* Purpose
10391* =======
10392*
10393* PB_SRAND generates the next number in the random sequence. This func-
10394* tion ensures that this number will be in the interval ( -1.0, 1.0 ).
10395*
10396* Arguments
10397* =========
10398*
10399* IDUMM (local input) INTEGER
10400* This argument is ignored, but necessary to a FORTRAN 77 func-
10401* tion.
10402*
10403* Further Details
10404* ===============
10405*
10406* On entry, the array IRAND stored in the common block RANCOM contains
10407* the information (2 integers) required to generate the next number in
10408* the sequence X( n ). This number is computed as
10409*
10410* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10411*
10412* where the constant d is the largest 32 bit positive integer. The
10413* array IRAND is then updated for the generation of the next number
10414* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10415* The constants a and c should have been preliminarily stored in the
10416* array IACS as 2 pairs of integers. The initial set up of IRAND and
10417* IACS is performed by the routine PB_SETRAN.
10418*
10419* -- Written on April 1, 1998 by
10420* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10421*
10422* =====================================================================
10423*
10424* .. Parameters ..
10425 REAL ONE, TWO
10426 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
10427* ..
10428* .. External Functions ..
10429 REAL PB_SRAN
10430 EXTERNAL PB_SRAN
10431* ..
10432* .. Executable Statements ..
10433*
10434 PB_SRAND = ONE - TWO * PB_SRAN( IDUMM )
10435*
10436 RETURN
10437*
10438* End of PB_SRAND
10439*
10440 END
10441 REAL FUNCTION PB_SRAN( IDUMM )
10442*
10443* -- PBLAS test routine (version 2.0) --
10444* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10445* and University of California, Berkeley.
10446* April 1, 1998
10447*
10448* .. Scalar Arguments ..
10449 INTEGER IDUMM
10450* ..
10451*
10452* Purpose
10453* =======
10454*
10455* PB_SRAN generates the next number in the random sequence.
10456*
10457* Arguments
10458* =========
10459*
10460* IDUMM (local input) INTEGER
10461* This argument is ignored, but necessary to a FORTRAN 77 func-
10462* tion.
10463*
10464* Further Details
10465* ===============
10466*
10467* On entry, the array IRAND stored in the common block RANCOM contains
10468* the information (2 integers) required to generate the next number in
10469* the sequence X( n ). This number is computed as
10470*
10471* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10472*
10473* where the constant d is the largest 32 bit positive integer. The
10474* array IRAND is then updated for the generation of the next number
10475* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10476* The constants a and c should have been preliminarily stored in the
10477* array IACS as 2 pairs of integers. The initial set up of IRAND and
10478* IACS is performed by the routine PB_SETRAN.
10479*
10480* -- Written on April 1, 1998 by
10481* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10482*
10483* =====================================================================
10484*
10485* .. Parameters ..
10486 REAL DIVFAC, POW16
10487 PARAMETER ( DIVFAC = 2.147483648E+9,
10488 $ POW16 = 6.5536E+4 )
10489* ..
10490* .. Local Arrays ..
10491 INTEGER J( 2 )
10492* ..
10493* .. External Subroutines ..
10494 EXTERNAL PB_LADD, PB_LMUL
10495* ..
10496* .. Intrinsic Functions ..
10497 INTRINSIC REAL
10498* ..
10499* .. Common Blocks ..
10500 INTEGER IACS( 4 ), IRAND( 2 )
10501 COMMON /RANCOM/ IRAND, IACS
10502* ..
10503* .. Save Statements ..
10504 SAVE /RANCOM/
10505* ..
10506* .. Executable Statements ..
10507*
10508 PB_SRAN = ( REAL( IRAND( 1 ) ) + POW16 * REAL( IRAND( 2 ) ) ) /
10509 $ DIVFAC
10510*
10511 CALL PB_LMUL( IRAND, IACS, J )
10512 CALL PB_LADD( J, IACS( 3 ), IRAND )
10513*
10514 RETURN
10515*
10516* End of PB_SRAN
10517*
10518 END
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pchkpbe
subroutine pchkpbe(ictxt, nout, sname, infot)
Definition pblastst.f:1084
pssetpblas
subroutine pssetpblas(ictxt)
Definition psblastst.f:1478
psdimee
subroutine psdimee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:455
pschkmin
subroutine pschkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition psblastst.f:3326
pschkmout
subroutine pschkmout(m, n, a, pa, ia, ja, desca, info)
Definition psblastst.f:3627
pschkopt
subroutine pschkopt(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition psblastst.f:266
pb_sfillpad
subroutine pb_sfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition psblastst.f:9081
pschkmat
subroutine pschkmat(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition psblastst.f:1674
psvecee
subroutine psvecee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:936
psoptee
subroutine psoptee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:2
pslagen
subroutine pslagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition psblastst.f:7846
pb_schekpad
subroutine pb_schekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition psblastst.f:9194
pserrset
subroutine pserrset(err, errmax, xtrue, x)
Definition psblastst.f:2456
pschkdim
subroutine pschkdim(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition psblastst.f:759
pschkvout
subroutine pschkvout(n, x, px, ix, jx, descx, incx, info)
Definition psblastst.f:2870
pscallsub
subroutine pscallsub(subptr, scode)
Definition psblastst.f:2180