OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pblastst.f
Go to the documentation of this file.
1 SUBROUTINE pvdimchk( ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX,
2 $ INFO )
3*
4* -- PBLAS test routine (version 2.0) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* April 1, 1998
8*
9* .. Scalar Arguments ..
10 CHARACTER*1 MATRIX
11 INTEGER ICTXT, INCX, INFO, IX, JX, N, NOUT
12* ..
13* .. Array Arguments ..
14 INTEGER DESCX( * )
15* ..
16*
17* Purpose
18* =======
19*
20* PVDIMCHK checks the validity of the input test dimensions. In case of
21* an invalid parameter or discrepancy between the parameters, this rou-
22* tine displays error messages and returns an non-zero error code in
23* INFO.
24*
25* Notes
26* =====
27*
28* A description vector is associated with each 2D block-cyclicly dis-
29* tributed matrix. This vector stores the information required to
30* establish the mapping between a matrix entry and its corresponding
31* process and memory location.
32*
33* In the following comments, the character _ should be read as
34* "of the distributed matrix". Let A be a generic term for any 2D
35* block cyclicly distributed matrix. Its description vector is DESCA:
36*
37* NOTATION STORED IN EXPLANATION
38* ---------------- --------------- ------------------------------------
39* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
40* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
41* the NPROW x NPCOL BLACS process grid
42* A is distributed over. The context
43* itself is global, but the handle
44* (the integer value) may vary.
45* M_A (global) DESCA( M_ ) The number of rows in the distribu-
46* ted matrix A, M_A >= 0.
47* N_A (global) DESCA( N_ ) The number of columns in the distri-
48* buted matrix A, N_A >= 0.
49* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
50* block of the matrix A, IMB_A > 0.
51* INB_A (global) DESCA( INB_ ) The number of columns of the upper
52* left block of the matrix A,
53* INB_A > 0.
54* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
55* bute the last M_A-IMB_A rows of A,
56* MB_A > 0.
57* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
58* bute the last N_A-INB_A columns of
59* A, NB_A > 0.
60* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
61* row of the matrix A is distributed,
62* NPROW > RSRC_A >= 0.
63* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
64* first column of A is distributed.
65* NPCOL > CSRC_A >= 0.
66* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
67* array storing the local blocks of
68* the distributed matrix A,
69* IF( Lc( 1, N_A ) > 0 )
70* LLD_A >= MAX( 1, Lr( 1, M_A ) )
71* ELSE
72* LLD_A >= 1.
73*
74* Let K be the number of rows of a matrix A starting at the global in-
75* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
76* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
77* receive if these K rows were distributed over NPROW processes. If K
78* is the number of columns of a matrix A starting at the global index
79* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
80* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
81* these K columns were distributed over NPCOL processes.
82*
83* The values of Lr() and Lc() may be determined via a call to the func-
84* tion PB_NUMROC:
85* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
86* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
87*
88* Arguments
89* =========
90*
91* ICTXT (local input) INTEGER
92* On entry, ICTXT specifies the BLACS context handle, indica-
93* ting the global context of the operation. The context itself
94* is global, but the value of ICTXT is local.
95*
96* NOUT (global input) INTEGER
97* On entry, NOUT specifies the unit number for the output file.
98* When NOUT is 6, output to screen, when NOUT is 0, output to
99* stderr. NOUT is only defined for process 0.
100*
101* MATRIX (global input) CHARACTER*1
102* On entry, MATRIX specifies the one character matrix identi-
103* fier.
104*
105* IX (global input) INTEGER
106* On entry, IX specifies X's global row index, which points to
107* the beginning of the submatrix sub( X ).
108*
109* JX (global input) INTEGER
110* On entry, JX specifies X's global column index, which points
111* to the beginning of the submatrix sub( X ).
112*
113* DESCX (global and local input) INTEGER array
114* On entry, DESCX is an integer array of dimension DLEN_. This
115* is the array descriptor for the matrix X.
116*
117* INCX (global input) INTEGER
118* On entry, INCX specifies the global increment for the
119* elements of X. Only two values of INCX are supported in
120* this version, namely 1 and M_X. INCX must not be zero.
121*
122* INFO (global output) INTEGER
123* On exit, when INFO is zero, no error has been detected,
124* otherwise an error has been detected.
125*
126* -- Written on April 1, 1998 by
127* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
128*
129* =====================================================================
130*
131* .. Parameters ..
132 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
133 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
134 $ rsrc_
135 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
136 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
137 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
138 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
139* ..
140* .. Local Scalars ..
141 INTEGER MYCOL, MYROW, NPCOL, NPROW
142* ..
143* .. External Subroutines ..
144 EXTERNAL blacs_gridinfo, igsum2d
145* ..
146* .. Executable Statements ..
147*
148 info = 0
149 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
150*
151 IF( n.LT.0 ) THEN
152 info = 1
153 ELSE IF( n.EQ.0 ) THEN
154 IF( descx( m_ ).LT.0 )
155 $ info = 1
156 IF( descx( n_ ).LT.0 )
157 $ info = 1
158 ELSE
159 IF( incx.EQ.descx( m_ ) .AND.
160 $ descx( n_ ).LT.( jx+n-1 ) ) THEN
161 info = 1
162 ELSE IF( incx.EQ.1 .AND. incx.NE.descx( m_ ) .AND.
163 $ descx( m_ ).LT.( ix+n-1 ) ) THEN
164 info = 1
165 ELSE
166 IF( ix.GT.descx( m_ ) ) THEN
167 info = 1
168 ELSE IF( jx.GT.descx( n_ ) ) THEN
169 info = 1
170 END IF
171 END IF
172 END IF
173*
174* Check all processes for an error
175*
176 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
177*
178 IF( info.NE.0 ) THEN
179 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
180 WRITE( nout, fmt = 9999 ) matrix
181 WRITE( nout, fmt = 9998 ) n, matrix, ix, matrix, jx, matrix,
182 $ incx
183 WRITE( nout, fmt = 9997 ) matrix, descx( m_ ), matrix,
184 $ descx( n_ )
185 WRITE( nout, fmt = * )
186 END IF
187 END IF
188*
189 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
190 9998 FORMAT( 'N = ', i6, ', I', a1, ' = ', i6, ', J', a1, ' = ',
191 $ i6, ',INC', a1, ' = ', i6 )
192 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
193 $ i6, '.' )
194*
195 RETURN
196*
197* End of PVDIMCHK
198*
199 END
200 SUBROUTINE pmdimchk( ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA,
201 $ INFO )
202*
203* -- PBLAS test routine (version 2.0) --
204* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
205* and University of California, Berkeley.
206* April 1, 1998
207*
208* .. Scalar Arguments ..
209 CHARACTER*1 MATRIX
210 INTEGER ICTXT, INFO, IA, JA, M, N, NOUT
211* ..
212* .. Array Arguments ..
213 INTEGER DESCA( * )
214* ..
215*
216* Purpose
217* =======
218*
219* PMDIMCHK checks the validity of the input test dimensions. In case of
220* an invalid parameter or discrepancy between the parameters, this rou-
221* tine displays error messages and returns an non-zero error code in
222* INFO.
223*
224* Notes
225* =====
226*
227* A description vector is associated with each 2D block-cyclicly dis-
228* tributed matrix. This vector stores the information required to
229* establish the mapping between a matrix entry and its corresponding
230* process and memory location.
231*
232* In the following comments, the character _ should be read as
233* "of the distributed matrix". Let A be a generic term for any 2D
234* block cyclicly distributed matrix. Its description vector is DESCA:
235*
236* NOTATION STORED IN EXPLANATION
237* ---------------- --------------- ------------------------------------
238* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
239* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
240* the NPROW x NPCOL BLACS process grid
241* A is distributed over. The context
242* itself is global, but the handle
243* (the integer value) may vary.
244* M_A (global) DESCA( M_ ) The number of rows in the distribu-
245* ted matrix A, M_A >= 0.
246* N_A (global) DESCA( N_ ) The number of columns in the distri-
247* buted matrix A, N_A >= 0.
248* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
249* block of the matrix A, IMB_A > 0.
250* INB_A (global) DESCA( INB_ ) The number of columns of the upper
251* left block of the matrix A,
252* INB_A > 0.
253* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
254* bute the last M_A-IMB_A rows of A,
255* MB_A > 0.
256* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
257* bute the last N_A-INB_A columns of
258* A, NB_A > 0.
259* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
260* row of the matrix A is distributed,
261* NPROW > RSRC_A >= 0.
262* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
263* first column of A is distributed.
264* NPCOL > CSRC_A >= 0.
265* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
266* array storing the local blocks of
267* the distributed matrix A,
268* IF( Lc( 1, N_A ) > 0 )
269* LLD_A >= MAX( 1, Lr( 1, M_A ) )
270* ELSE
271* LLD_A >= 1.
272*
273* Let K be the number of rows of a matrix A starting at the global in-
274* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
275* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
276* receive if these K rows were distributed over NPROW processes. If K
277* is the number of columns of a matrix A starting at the global index
278* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
279* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
280* these K columns were distributed over NPCOL processes.
281*
282* The values of Lr() and Lc() may be determined via a call to the func-
283* tion PB_NUMROC:
284* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
285* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
286*
287* Arguments
288* =========
289*
290* ICTXT (local input) INTEGER
291* On entry, ICTXT specifies the BLACS context handle, indica-
292* ting the global context of the operation. The context itself
293* is global, but the value of ICTXT is local.
294*
295* NOUT (global input) INTEGER
296* On entry, NOUT specifies the unit number for the output file.
297* When NOUT is 6, output to screen, when NOUT is 0, output to
298* stderr. NOUT is only defined for process 0.
299*
300* MATRIX (global input) CHARACTER*1
301* On entry, MATRIX specifies the one character matrix identi-
302* fier.
303*
304* IA (global input) INTEGER
305* On entry, IA specifies A's global row index, which points to
306* the beginning of the submatrix sub( A ).
307*
308* JA (global input) INTEGER
309* On entry, JA specifies A's global column index, which points
310* to the beginning of the submatrix sub( A ).
311*
312* DESCA (global and local input) INTEGER array
313* On entry, DESCA is an integer array of dimension DLEN_. This
314* is the array descriptor for the matrix A.
315*
316* INFO (global output) INTEGER
317* On exit, when INFO is zero, no error has been detected,
318* otherwise an error has been detected.
319*
320* -- Written on April 1, 1998 by
321* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
322*
323* =====================================================================
324*
325* .. Parameters ..
326 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
327 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
328 $ rsrc_
329 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
330 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
331 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
332 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
333* ..
334* .. Local Scalars ..
335 INTEGER MYCOL, MYROW, NPCOL, NPROW
336* ..
337* .. External Subroutines ..
338 EXTERNAL blacs_gridinfo, igsum2d
339* ..
340* .. Executable Statements ..
341*
342 info = 0
343 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
344*
345 IF( ( m.LT.0 ).OR.( n.LT.0 ) ) THEN
346 info = 1
347 ELSE IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )THEN
348 IF( desca( m_ ).LT.0 )
349 $ info = 1
350 IF( desca( n_ ).LT.0 )
351 $ info = 1
352 ELSE
353 IF( desca( m_ ).LT.( ia+m-1 ) )
354 $ info = 1
355 IF( desca( n_ ).LT.( ja+n-1 ) )
356 $ info = 1
357 END IF
358*
359* Check all processes for an error
360*
361 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
362*
363 IF( info.NE.0 ) THEN
364 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
365 WRITE( nout, fmt = 9999 ) matrix
366 WRITE( nout, fmt = 9998 ) m, n, matrix, ia, matrix, ja
367 WRITE( nout, fmt = 9997 ) matrix, desca( m_ ), matrix,
368 $ desca( n_ )
369 WRITE( nout, fmt = * )
370 END IF
371 END IF
372*
373 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
374 9998 FORMAT( 'M = ', i6, ', N = ', i6, ', I', a1, ' = ', i6,
375 $ ', J', a1, ' = ', i6 )
376 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
377 $ i6, '.' )
378*
379 RETURN
380*
381* End of PMDIMCHK
382*
383 END
384 SUBROUTINE pvdescchk( ICTXT, NOUT, MATRIX, DESCX, DTX, MX, NX,
385 $ IMBX, INBX, MBX, NBX, RSRCX, CSRCX, INCX,
386 $ MPX, NQX, IPREX, IMIDX, IPOSTX, IGAP,
387 $ GAPMUL, INFO )
388*
389* -- PBLAS test routine (version 2.0) --
390* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
391* and University of California, Berkeley.
392* April 1, 1998
393*
394* .. Scalar Arguments ..
395 CHARACTER*1 MATRIX
396 INTEGER CSRCX, DTX, GAPMUL, ICTXT, IGAP, IMBX, IMIDX,
397 $ INBX, INCX, INFO, IPOSTX, IPREX, MBX, MPX, MX,
398 $ NBX, NOUT, NQX, NX, RSRCX
399* ..
400* .. Array Arguments ..
401 INTEGER DESCX( * )
402* ..
403*
404* Purpose
405* =======
406*
407* PVDESCCHK checks the validity of the input test parameters and ini-
408* tializes the descriptor DESCX and the scalar variables MPX, NQX. In
409* case of an invalid parameter, this routine displays error messages
410* and return an non-zero error code in INFO.
411*
412* Notes
413* =====
414*
415* A description vector is associated with each 2D block-cyclicly dis-
416* tributed matrix. This vector stores the information required to
417* establish the mapping between a matrix entry and its corresponding
418* process and memory location.
419*
420* In the following comments, the character _ should be read as
421* "of the distributed matrix". Let A be a generic term for any 2D
422* block cyclicly distributed matrix. Its description vector is DESCA:
423*
424* NOTATION STORED IN EXPLANATION
425* ---------------- --------------- ------------------------------------
426* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
427* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
428* the NPROW x NPCOL BLACS process grid
429* A is distributed over. The context
430* itself is global, but the handle
431* (the integer value) may vary.
432* M_A (global) DESCA( M_ ) The number of rows in the distribu-
433* ted matrix A, M_A >= 0.
434* N_A (global) DESCA( N_ ) The number of columns in the distri-
435* buted matrix A, N_A >= 0.
436* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
437* block of the matrix A, IMB_A > 0.
438* INB_A (global) DESCA( INB_ ) The number of columns of the upper
439* left block of the matrix A,
440* INB_A > 0.
441* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
442* bute the last M_A-IMB_A rows of A,
443* MB_A > 0.
444* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
445* bute the last N_A-INB_A columns of
446* A, NB_A > 0.
447* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
448* row of the matrix A is distributed,
449* NPROW > RSRC_A >= 0.
450* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
451* first column of A is distributed.
452* NPCOL > CSRC_A >= 0.
453* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
454* array storing the local blocks of
455* the distributed matrix A,
456* IF( Lc( 1, N_A ) > 0 )
457* LLD_A >= MAX( 1, Lr( 1, M_A ) )
458* ELSE
459* LLD_A >= 1.
460*
461* Let K be the number of rows of a matrix A starting at the global in-
462* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
463* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
464* receive if these K rows were distributed over NPROW processes. If K
465* is the number of columns of a matrix A starting at the global index
466* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
467* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
468* these K columns were distributed over NPCOL processes.
469*
470* The values of Lr() and Lc() may be determined via a call to the func-
471* tion PB_NUMROC:
472* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
473* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
474*
475* Arguments
476* =========
477*
478* ICTXT (local input) INTEGER
479* On entry, ICTXT specifies the BLACS context handle, indica-
480* ting the global context of the operation. The context itself
481* is global, but the value of ICTXT is local.
482*
483* NOUT (global input) INTEGER
484* On entry, NOUT specifies the unit number for the output file.
485* When NOUT is 6, output to screen, when NOUT is 0, output to
486* stderr. NOUT is only defined for process 0.
487*
488* MATRIX (global input) CHARACTER*1
489* On entry, MATRIX specifies the one character matrix identi-
490* fier.
491*
492* DESCX (global output) INTEGER array
493* On entry, DESCX is an array of dimension DLEN_. DESCX is the
494* array descriptor to be set.
495*
496* DTYPEX (global input) INTEGER
497* On entry, DTYPEX specifies the descriptor type. In this ver-
498* sion, DTYPEX must be BLOCK_CYCLIC_INB_2D.
499*
500* MX (global input) INTEGER
501* On entry, MX specifies the number of rows in the matrix. MX
502* must be at least zero.
503*
504* NX (global input) INTEGER
505* On entry, NX specifies the number of columns in the matrix.
506* NX must be at least zero.
507*
508* IMBX (global input) INTEGER
509* On entry, IMBX specifies the row blocking factor used to dis-
510* tribute the first IMBX rows of the matrix. IMBX must be at
511* least one.
512*
513* INBX (global input) INTEGER
514* On entry, INBX specifies the column blocking factor used to
515* distribute the first INBX columns of the matrix. INBX must
516* be at least one.
517*
518* MBX (global input) INTEGER
519* On entry, MBX specifies the row blocking factor used to dis-
520* tribute the rows of the matrix. MBX must be at least one.
521*
522* NBX (global input) INTEGER
523* On entry, NBX specifies the column blocking factor used to
524* distribute the columns of the matrix. NBX must be at least
525* one.
526*
527* RSRCX (global input) INTEGER
528* On entry, RSRCX specifies the process row in which the first
529* row of the matrix resides. When RSRCX is -1, the matrix is
530* row replicated, otherwise RSCRX must be at least zero and
531* strictly less than NPROW.
532*
533* CSRCX (global input) INTEGER
534* On entry, CSRCX specifies the process column in which the
535* first column of the matrix resides. When CSRCX is -1, the
536* matrix is column replicated, otherwise CSCRX must be at least
537* zero and strictly less than NPCOL.
538*
539* INCX (global input) INTEGER
540* On entry, INCX specifies the global vector increment. INCX
541* must be one or MX.
542*
543* MPX (local output) INTEGER
544* On exit, MPX is Lr( 1, MX ).
545*
546* NQX (local output) INTEGER
547* On exit, NQX is Lc( 1, NX ).
548*
549* IPREX (local output) INTEGER
550* On exit, IPREX specifies the size of the guard zone to put
551* before the start of the local padded array.
552*
553* IMIDX (local output) INTEGER
554* On exit, IMIDX specifies the ldx-gap of the guard zone to
555* put after each column of the local padded array.
556*
557* IPOSTX (local output) INTEGER
558* On exit, IPOSTX specifies the size of the guard zone to put
559* after the local padded array.
560*
561* IGAP (global input) INTEGER
562* On entry, IGAP specifies the size of the ldx-gap.
563*
564* GAPMUL (global input) INTEGER
565* On entry, GAPMUL is a constant factor controlling the size
566* of the pre- and post guardzone.
567*
568* INFO (global output) INTEGER
569* On exit, when INFO is zero, no error has been detected,
570* otherwise an error has been detected.
571*
572* -- Written on April 1, 1998 by
573* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
574*
575* =====================================================================
576*
577* .. Parameters ..
578 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
579 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
580 $ RSRC_
581 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
582 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
583 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
584 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
585* ..
586* .. Local Scalars ..
587 INTEGER LLDX, MYCOL, MYROW, NPCOL, NPROW
588* ..
589* .. External Subroutines ..
590 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_DESCINIT2
591* ..
592* .. External Functions ..
593 INTEGER PB_NUMROC
594 EXTERNAL PB_NUMROC
595* ..
596* .. Intrinsic Functions ..
597 INTRINSIC max
598* ..
599* .. Executable Statements ..
600*
601 info = 0
602 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
603*
604* Verify descriptor type DTYPE_
605*
606 IF( dtx.NE.block_cyclic_2d_inb ) THEN
607 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
608 $ WRITE( nout, fmt = 9999 ) matrix, 'DTYPE', matrix, dtx,
609 $ block_cyclic_2d_inb
610 info = 1
611 END IF
612*
613* Verify global matrix dimensions (M_,N_) are correct
614*
615 IF( mx.LT.0 ) THEN
616 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
617 $ WRITE( nout, fmt = 9998 ) matrix, 'm', MATRIX, MX
618 INFO = 1
619.LT. ELSE IF( NX0 ) THEN
620.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
621 $ WRITE( NOUT, FMT = 9997 ) MATRIX, 'n', MATRIX, NX
622 INFO = 1
623 END IF
624*
625* Verify if blocking factors (IMB_, INB_) are correct
626*
627.LT. IF( IMBX1 ) THEN
628.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
629 $ WRITE( NOUT, FMT = 9996 ) MATRIX, 'imb', MATRIX, IMBX
630 INFO = 1
631.LT. ELSE IF( INBX1 ) THEN
632.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
633 $ WRITE( NOUT, FMT = 9995 ) MATRIX, 'inb', MATRIX, INBX
634 INFO = 1
635 END IF
636*
637* Verify if blocking factors (MB_, NB_) are correct
638*
639.LT. IF( MBX1 ) THEN
640.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
641 $ WRITE( NOUT, FMT = 9994 ) MATRIX, 'mb', MATRIX, MBX
642 INFO = 1
643.LT. ELSE IF( NBX1 ) THEN
644.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
645 $ WRITE( NOUT, FMT = 9993 ) MATRIX, 'nb', MATRIX, NBX
646 INFO = 1
647 END IF
648*
649* Verify if origin process coordinates (RSRC_, CSRC_) are valid
650*
651.LT..OR..GE. IF( RSRCX-1 RSRCXNPROW ) THEN
652.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
653 WRITE( NOUT, FMT = 9992 ) MATRIX
654 WRITE( NOUT, FMT = 9990 ) 'rsrc', MATRIX, RSRCX, NPROW
655 END IF
656 INFO = 1
657.LT..OR..GE. ELSE IF( CSRCX-1 CSRCXNPCOL ) THEN
658.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
659 WRITE( NOUT, FMT = 9991 ) MATRIX
660 WRITE( NOUT, FMT = 9990 ) 'csrc', MATRIX, CSRCX, NPCOL
661 END IF
662 INFO = 1
663 END IF
664*
665* Check input increment value
666*
667.NE..AND..NE. IF( INCX1 INCXMX ) THEN
668.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
669 WRITE( NOUT, FMT = 9989 ) MATRIX
670 WRITE( NOUT, FMT = 9988 ) 'inc', MATRIX, INCX, MATRIX, MX
671 END IF
672 INFO = 1
673 END IF
674*
675* Check all processes for an error
676*
677 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
678*
679.NE. IF( INFO0 ) THEN
680*
681.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
682 WRITE( NOUT, FMT = 9987 ) MATRIX
683 WRITE( NOUT, FMT = * )
684 END IF
685*
686 ELSE
687*
688* Compute local testing leading dimension
689*
690 MPX = PB_NUMROC( MX, 1, IMBX, MBX, MYROW, RSRCX, NPROW )
691 NQX = PB_NUMROC( NX, 1, INBX, NBX, MYCOL, CSRCX, NPCOL )
692 IPREX = MAX( GAPMUL*NBX, MPX )
693 IMIDX = IGAP
694 IPOSTX = MAX( GAPMUL*NBX, NQX )
695 LLDX = MAX( 1, MPX ) + IMIDX
696*
697 CALL PB_DESCINIT2( DESCX, MX, NX, IMBX, INBX, MBX, NBX, RSRCX,
698 $ CSRCX, ICTXT, LLDX, INFO )
699*
700* Check all processes for an error
701*
702 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
703*
704.NE. IF( INFO0 ) THEN
705.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
706 WRITE( NOUT, FMT = 9987 ) MATRIX
707 WRITE( NOUT, FMT = * )
708 END IF
709 END IF
710*
711 END IF
712*
713 9999 FORMAT( 2X, '>> invalid matrix ', A1, ' descriptor type ', A5, A1,
714 $ ': ', I6, ' should be ', I3, '.' )
715 9998 FORMAT( 2X, '>> invalid matrix ', A1, ' row dimension ', A1, A1,
716 $ ': ', I6, ' should be at least 1.' )
717 9997 FORMAT( 2X, '>> invalid matrix ', A1, ' column dimension ', A1,
718 $ A1, ': ', I6, ' should be at least 1.' )
719 9996 FORMAT( 2X, '>> invalid matrix ', A1, ' first row block size ',
720 $ A3, A1, ': ', I6, ' should be at least 1.' )
721 9995 FORMAT( 2X, '>> invalid matrix ', A1, ' first column block size ',
722 $ A3, A1,': ', I6, ' should be at least 1.' )
723 9994 FORMAT( 2X, '>> invalid matrix ', A1, ' row block size ', A2, A1,
724 $ ': ', I6, ' should be at least 1.' )
725 9993 FORMAT( 2X, '>> invalid matrix ', A1, ' column block size ', A2,
726 $ A1,': ', I6, ' should be at least 1.' )
727 9992 FORMAT( 2X, '>> invalid matrix ', A1, ' row process source:' )
728 9991 FORMAT( 2X, '>> invalid matrix ', A1, ' column process source:' )
729 9990 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= -1 and < ',
730 $ I6, '.' )
731 9989 FORMAT( 2X, '>> invalid vector ', A1, ' increment:' )
732 9988 FORMAT( 2X, '>> ', A3, A1, '= ', I6, ' should be 1 or m', A1,
733 $ ' = ', I6, '.' )
734 9987 FORMAT( 2X, '>> invalid matrix ', A1, ' descriptor: going on to ',
735 $ 'next test case.' )
736*
737 RETURN
738*
739* End of PVDESCCHK
740*
741 END
742 SUBROUTINE PMDESCCHK( ICTXT, NOUT, MATRIX, DESCA, DTA, MA, NA,
743 $ IMBA, INBA, MBA, NBA, RSRCA, CSRCA, MPA,
744 $ NQA, IPREA, IMIDA, IPOSTA, IGAP, GAPMUL,
745 $ INFO )
746*
747* -- PBLAS test routine (version 2.0) --
748* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
749* and University of California, Berkeley.
750* April 1, 1998
751*
752* .. Scalar Arguments ..
753 CHARACTER*1 MATRIX
754 INTEGER CSRCA, DTA, GAPMUL, ICTXT, IGAP, IMBA, IMIDA,
755 $ INBA, INFO, IPOSTA, IPREA, MA, MBA, MPA, NA,
756 $ NBA, NOUT, NQA, RSRCA
757* ..
758* .. Array Arguments ..
759 INTEGER DESCA( * )
760* ..
761*
762* Purpose
763* =======
764*
765* PMDESCCHK checks the validity of the input test parameters and ini-
766* tializes the descriptor DESCA and the scalar variables MPA, NQA. In
767* case of an invalid parameter, this routine displays error messages
768* and return an non-zero error code in INFO.
769*
770* Notes
771* =====
772*
773* A description vector is associated with each 2D block-cyclicly dis-
774* tributed matrix. This vector stores the information required to
775* establish the mapping between a matrix entry and its corresponding
776* process and memory location.
777*
778* In the following comments, the character _ should be read as
779* "of the distributed matrix". Let A be a generic term for any 2D
780* block cyclicly distributed matrix. Its description vector is DESCA:
781*
782* NOTATION STORED IN EXPLANATION
783* ---------------- --------------- ------------------------------------
784* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
785* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
786* the NPROW x NPCOL BLACS process grid
787* A is distributed over. The context
788* itself is global, but the handle
789* (the integer value) may vary.
790* M_A (global) DESCA( M_ ) The number of rows in the distribu-
791* ted matrix A, M_A >= 0.
792* N_A (global) DESCA( N_ ) The number of columns in the distri-
793* buted matrix A, N_A >= 0.
794* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
795* block of the matrix A, IMB_A > 0.
796* INB_A (global) DESCA( INB_ ) The number of columns of the upper
797* left block of the matrix A,
798* INB_A > 0.
799* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
800* bute the last M_A-IMB_A rows of A,
801* MB_A > 0.
802* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
803* bute the last N_A-INB_A columns of
804* A, NB_A > 0.
805* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
806* row of the matrix A is distributed,
807* NPROW > RSRC_A >= 0.
808* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
809* first column of A is distributed.
810* NPCOL > CSRC_A >= 0.
811* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
812* array storing the local blocks of
813* the distributed matrix A,
814* IF( Lc( 1, N_A ) > 0 )
815* LLD_A >= MAX( 1, Lr( 1, M_A ) )
816* ELSE
817* LLD_A >= 1.
818*
819* Let K be the number of rows of a matrix A starting at the global in-
820* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
821* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
822* receive if these K rows were distributed over NPROW processes. If K
823* is the number of columns of a matrix A starting at the global index
824* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
825* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
826* these K columns were distributed over NPCOL processes.
827*
828* The values of Lr() and Lc() may be determined via a call to the func-
829* tion PB_NUMROC:
830* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
831* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
832*
833* Arguments
834* =========
835*
836* ICTXT (local input) INTEGER
837* On entry, ICTXT specifies the BLACS context handle, indica-
838* ting the global context of the operation. The context itself
839* is global, but the value of ICTXT is local.
840*
841* NOUT (global input) INTEGER
842* On entry, NOUT specifies the unit number for the output file.
843* When NOUT is 6, output to screen, when NOUT is 0, output to
844* stderr. NOUT is only defined for process 0.
845*
846* MATRIX (global input) CHARACTER*1
847* On entry, MATRIX specifies the one character matrix identi-
848* fier.
849*
850* DESCA (global output) INTEGER array
851* On entry, DESCA is an array of dimension DLEN_. DESCA is the
852* array descriptor to be set.
853*
854* DTYPEA (global input) INTEGER
855* On entry, DTYPEA specifies the descriptor type. In this ver-
856* sion, DTYPEA must be BLOCK_CYCLIC_INB_2D.
857*
858* MA (global input) INTEGER
859* On entry, MA specifies the number of rows in the matrix. MA
860* must be at least zero.
861*
862* NA (global input) INTEGER
863* On entry, NA specifies the number of columns in the matrix.
864* NA must be at least zero.
865*
866* IMBA (global input) INTEGER
867* On entry, IMBA specifies the row blocking factor used to dis-
868* tribute the first IMBA rows of the matrix. IMBA must be at
869* least one.
870*
871* INBA (global input) INTEGER
872* On entry, INBA specifies the column blocking factor used to
873* distribute the first INBA columns of the matrix. INBA must
874* be at least one.
875*
876* MBA (global input) INTEGER
877* On entry, MBA specifies the row blocking factor used to dis-
878* tribute the rows of the matrix. MBA must be at least one.
879*
880* NBA (global input) INTEGER
881* On entry, NBA specifies the column blocking factor used to
882* distribute the columns of the matrix. NBA must be at least
883* one.
884*
885* RSRCA (global input) INTEGER
886* On entry, RSRCA specifies the process row in which the first
887* row of the matrix resides. When RSRCA is -1, the matrix is
888* row replicated, otherwise RSCRA must be at least zero and
889* strictly less than NPROW.
890*
891* CSRCA (global input) INTEGER
892* On entry, CSRCA specifies the process column in which the
893* first column of the matrix resides. When CSRCA is -1, the
894* matrix is column replicated, otherwise CSCRA must be at least
895* zero and strictly less than NPCOL.
896*
897* MPA (local output) INTEGER
898* On exit, MPA is Lr( 1, MA ).
899*
900* NQA (local output) INTEGER
901* On exit, NQA is Lc( 1, NA ).
902*
903* IPREA (local output) INTEGER
904* On exit, IPREA specifies the size of the guard zone to put
905* before the start of the local padded array.
906*
907* IMIDA (local output) INTEGER
908* On exit, IMIDA specifies the lda-gap of the guard zone to
909* put after each column of the local padded array.
910*
911* IPOSTA (local output) INTEGER
912* On exit, IPOSTA specifies the size of the guard zone to put
913* after the local padded array.
914*
915* IGAP (global input) INTEGER
916* On entry, IGAP specifies the size of the lda-gap.
917*
918* GAPMUL (global input) INTEGER
919* On entry, GAPMUL is a constant factor controlling the size
920* of the pre- and post guardzone.
921*
922* INFO (global output) INTEGER
923* On exit, when INFO is zero, no error has been detected,
924* otherwise an error has been detected.
925*
926* -- Written on April 1, 1998 by
927* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
928*
929* =====================================================================
930*
931* .. Parameters ..
932 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
933 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
934 $ RSRC_
935 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
936 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
937 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
938 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
939* ..
940* .. Local Scalars ..
941 INTEGER LLDA, MYCOL, MYROW, NPCOL, NPROW
942* ..
943* .. External Subroutines ..
944 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_DESCINIT2
945* ..
946* .. External Functions ..
947 INTEGER PB_NUMROC
948 EXTERNAL PB_NUMROC
949* ..
950* .. Intrinsic Functions ..
951 INTRINSIC MAX
952* ..
953* .. Executable Statements ..
954*
955 INFO = 0
956 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
957*
958* Verify descriptor type DTYPE_
959*
960.NE. IF( DTABLOCK_CYCLIC_2D_INB ) THEN
961.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
962 $ WRITE( NOUT, FMT = 9999 ) MATRIX, 'dtype', MATRIX, DTA,
963 $ BLOCK_CYCLIC_2D_INB
964 INFO = 1
965 END IF
966*
967* Verify global matrix dimensions (M_,N_) are correct
968*
969.LT. IF( MA0 ) THEN
970.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
971 $ WRITE( NOUT, FMT = 9998 ) MATRIX, 'm', MATRIX, MA
972 INFO = 1
973.LT. ELSE IF( NA0 ) THEN
974.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
975 $ WRITE( NOUT, FMT = 9997 ) MATRIX, 'n', MATRIX, NA
976 INFO = 1
977 END IF
978*
979* Verify if blocking factors (IMB_, INB_) are correct
980*
981.LT. IF( IMBA1 ) THEN
982.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
983 $ WRITE( NOUT, FMT = 9996 ) MATRIX, 'imb', MATRIX, IMBA
984 INFO = 1
985.LT. ELSE IF( INBA1 ) THEN
986.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
987 $ WRITE( NOUT, FMT = 9995 ) MATRIX, 'inb', MATRIX, INBA
988 INFO = 1
989 END IF
990*
991* Verify if blocking factors (MB_, NB_) are correct
992*
993.LT. IF( MBA1 ) THEN
994.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
995 $ WRITE( NOUT, FMT = 9994 ) MATRIX, 'mb', MATRIX, MBA
996 INFO = 1
997.LT. ELSE IF( NBA1 ) THEN
998.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
999 $ WRITE( NOUT, FMT = 9993 ) MATRIX, 'nb', MATRIX, NBA
1000 INFO = 1
1001 END IF
1002*
1003* Verify if origin process coordinates (RSRC_, CSRC_) are valid
1004*
1005.LT..OR..GE. IF( RSRCA-1 RSRCANPROW ) THEN
1006.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1007 WRITE( NOUT, FMT = 9992 ) MATRIX
1008 WRITE( NOUT, FMT = 9990 ) 'rsrc', MATRIX, RSRCA, NPROW
1009 END IF
1010 INFO = 1
1011.LT..OR..GE. ELSE IF( CSRCA-1 CSRCANPCOL ) THEN
1012.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1013 WRITE( NOUT, FMT = 9991 ) MATRIX
1014 WRITE( NOUT, FMT = 9990 ) 'csrc', MATRIX, CSRCA, NPCOL
1015 END IF
1016 INFO = 1
1017 END IF
1018*
1019* Check all processes for an error
1020*
1021 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
1022*
1023.NE. IF( INFO0 ) THEN
1024*
1025.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1026 WRITE( NOUT, FMT = 9989 ) MATRIX
1027 WRITE( NOUT, FMT = * )
1028 END IF
1029*
1030 ELSE
1031*
1032* Compute local testing leading dimension
1033*
1034 MPA = PB_NUMROC( MA, 1, IMBA, MBA, MYROW, RSRCA, NPROW )
1035 NQA = PB_NUMROC( NA, 1, INBA, NBA, MYCOL, CSRCA, NPCOL )
1036 IPREA = MAX( GAPMUL*NBA, MPA )
1037 IMIDA = IGAP
1038 IPOSTA = MAX( GAPMUL*NBA, NQA )
1039 LLDA = MAX( 1, MPA ) + IMIDA
1040*
1041 CALL PB_DESCINIT2( DESCA, MA, NA, IMBA, INBA, MBA, NBA, RSRCA,
1042 $ CSRCA, ICTXT, LLDA, INFO )
1043*
1044* Check all processes for an error
1045*
1046 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
1047*
1048.NE. IF( INFO0 ) THEN
1049.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1050 WRITE( NOUT, FMT = 9989 ) MATRIX
1051 WRITE( NOUT, FMT = * )
1052 END IF
1053 END IF
1054*
1055 END IF
1056*
1057 9999 FORMAT( 2X, '>> invalid matrix ', A1, ' descriptor type ', A5, A1,
1058 $ ': ', I6, ' should be ', I3, '.' )
1059 9998 FORMAT( 2X, '>> invalid matrix ', A1, ' row dimension ', A1, A1,
1060 $ ': ', I6, ' should be at least 1.' )
1061 9997 FORMAT( 2X, '>> invalid matrix ', A1, ' column dimension ', A1,
1062 $ A1, ': ', I6, ' should be at least 1.' )
1063 9996 FORMAT( 2X, '>> invalid matrix ', A1, ' first row block size ',
1064 $ A3, A1, ': ', I6, ' should be at least 1.' )
1065 9995 FORMAT( 2X, '>> invalid matrix ', A1, ' first column block size ',
1066 $ A3, A1,': ', I6, ' should be at least 1.' )
1067 9994 FORMAT( 2X, '>> invalid matrix ', A1, ' row block size ', A2, A1,
1068 $ ': ', I6, ' should be at least 1.' )
1069 9993 FORMAT( 2X, '>> invalid matrix ', A1, ' column block size ', A2,
1070 $ A1,': ', I6, ' should be at least 1.' )
1071 9992 FORMAT( 2X, '>> invalid matrix ', A1, ' row process source:' )
1072 9991 FORMAT( 2X, '>> invalid matrix ', A1, ' column process source:' )
1073 9990 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= -1 and < ',
1074 $ I6, '.' )
1075 9989 FORMAT( 2X, '>> invalid matrix ', A1, ' descriptor: going on to ',
1076 $ 'next test case.' )
1077*
1078 RETURN
1079*
1080* End of PMDESCCHK
1081*
1082 END
1083 SUBROUTINE PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
1084*
1085* -- PBLAS test routine (version 2.0) --
1086* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1087* and University of California, Berkeley.
1088* April 1, 1998
1089*
1090* .. Scalar Arguments ..
1091 INTEGER ICTXT, INFOT, NOUT
1092 CHARACTER*(*) SNAME
1093* ..
1094*
1095* Purpose
1096* =======
1097*
1098* PCHKPBE tests whether a PBLAS routine has detected an error when it
1099* should. This routine does a global operation to ensure all processes
1100* have detected this error. If an error has been detected an error
1101* message is displayed.
1102*
1103* Notes
1104* =====
1105*
1106* A description vector is associated with each 2D block-cyclicly dis-
1107* tributed matrix. This vector stores the information required to
1108* establish the mapping between a matrix entry and its corresponding
1109* process and memory location.
1110*
1111* In the following comments, the character _ should be read as
1112* "of the distributed matrix". Let A be a generic term for any 2D
1113* block cyclicly distributed matrix. Its description vector is DESCA:
1114*
1115* NOTATION STORED IN EXPLANATION
1116* ---------------- --------------- ------------------------------------
1117* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1118* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1119* the NPROW x NPCOL BLACS process grid
1120* A is distributed over. The context
1121* itself is global, but the handle
1122* (the integer value) may vary.
1123* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1124* ted matrix A, M_A >= 0.
1125* N_A (global) DESCA( N_ ) The number of columns in the distri-
1126* buted matrix A, N_A >= 0.
1127* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1128* block of the matrix A, IMB_A > 0.
1129* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1130* left block of the matrix A,
1131* INB_A > 0.
1132* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1133* bute the last M_A-IMB_A rows of A,
1134* MB_A > 0.
1135* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1136* bute the last N_A-INB_A columns of
1137* A, NB_A > 0.
1138* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1139* row of the matrix A is distributed,
1140* NPROW > RSRC_A >= 0.
1141* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1142* first column of A is distributed.
1143* NPCOL > CSRC_A >= 0.
1144* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1145* array storing the local blocks of
1146* the distributed matrix A,
1147* IF( Lc( 1, N_A ) > 0 )
1148* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1149* ELSE
1150* LLD_A >= 1.
1151*
1152* Let K be the number of rows of a matrix A starting at the global in-
1153* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1154* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1155* receive if these K rows were distributed over NPROW processes. If K
1156* is the number of columns of a matrix A starting at the global index
1157* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1158* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1159* these K columns were distributed over NPCOL processes.
1160*
1161* The values of Lr() and Lc() may be determined via a call to the func-
1162* tion PB_NUMROC:
1163* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1164* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1165*
1166* Arguments
1167* =========
1168*
1169* ICTXT (local input) INTEGER
1170* On entry, ICTXT specifies the BLACS context handle, indica-
1171* ting the global context of the operation. The context itself
1172* is global, but the value of ICTXT is local.
1173*
1174* NOUT (global input) INTEGER
1175* On entry, NOUT specifies the unit number for the output file.
1176* When NOUT is 6, output to screen, when NOUT is 0, output to
1177* stderr. NOUT is only defined for process 0.
1178*
1179* SNAME (global input) CHARACTER*(*)
1180* On entry, SNAME specifies the subroutine name calling this
1181* subprogram.
1182*
1183* INFOT (global input) INTEGER
1184* On entry, INFOT specifies the position of the wrong argument.
1185* If the PBLAS error handler is called, INFO will be set to
1186* -INFOT. This routine verifies if the error was reported by
1187* all processes by doing a global sum, and assert the result to
1188* be NPROW * NPCOL.
1189*
1190* -- Written on April 1, 1998 by
1191* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1192*
1193* =====================================================================
1194*
1195* .. Local Scalars ..
1196 INTEGER GERR, MYCOL, MYROW, NPCOL, NPROW
1197* ..
1198* .. External Subroutines ..
1199 EXTERNAL BLACS_GRIDINFO, IGSUM2D
1200* ..
1201* .. Common Blocks ..
1202 INTEGER INFO, NBLOG
1203 COMMON /INFOC/INFO, NBLOG
1204* ..
1205* .. Executable Statements ..
1206*
1207 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
1208*
1209 GERR = 0
1210.NE. IF( INFO-INFOT )
1211 $ GERR = 1
1212*
1213 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, GERR, 1, -1, 0 )
1214*
1215.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
1216.EQ. IF( GERR( NPROW * NPCOL ) ) THEN
1217 WRITE( NOUT, FMT = 9999 ) SNAME, INFO, -INFOT
1218 END IF
1219 END IF
1220*
1221 9999 FORMAT( 1X, A7, ': *** error *** error code returned = ', I6,
1222 $ ' should have been ', I6 )
1223*
1224 RETURN
1225*
1226* End of PCHKPBE
1227*
1228 END
1229 REAL FUNCTION PSDIFF( X, Y )
1230*
1231* -- PBLAS test routine (version 2.0) --
1232* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1233* and University of California, Berkeley.
1234* April 1, 1998
1235*
1236* .. Scalar Arguments ..
1237 REAL X, Y
1238* ..
1239*
1240* Purpose
1241* =======
1242*
1243* PSDIFF returns the scalar difference X - Y. Similarly to the
1244* BLAS tester, this routine allows for the possibility of computing a
1245* more accurate difference if necessary.
1246*
1247* Arguments
1248* =========
1249*
1250* X (input) REAL
1251* The real scalar X.
1252*
1253* Y (input) REAL
1254* The real scalar Y.
1255*
1256* =====================================================================
1257*
1258* .. Executable Statements ..
1259*
1260 PSDIFF = X - Y
1261*
1262 RETURN
1263*
1264* End of PSDIFF
1265*
1266 END
1267*
1268 DOUBLE PRECISION FUNCTION PDDIFF( X, Y )
1269*
1270* -- PBLAS test routine (version 2.0) --
1271* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1272* and University of California, Berkeley.
1273* April 1, 1998
1274*
1275* .. Scalar Arguments ..
1276 DOUBLE PRECISION X, Y
1277* ..
1278*
1279* Purpose
1280* =======
1281*
1282* PDDIFF returns the scalar difference X - Y. Similarly to the
1283* BLAS tester, this routine allows for the possibility of computing a
1284* more accurate difference if necessary.
1285*
1286* Arguments
1287* =========
1288*
1289* X (input) DOUBLE PRECISION
1290* The real scalar X.
1291*
1292* Y (input) DOUBLE PRECISION
1293* The real scalar Y.
1294*
1295* =====================================================================
1296*
1297* .. Executable Statements ..
1298*
1299 PDDIFF = X - Y
1300*
1301 RETURN
1302*
1303* End of PDDIFF
1304*
1305 END
1306 SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO )
1307*
1308* -- PBLAS test routine (version 2.0) --
1309* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1310* and University of California, Berkeley.
1311* April 1, 1998
1312*
1313* .. Scalar Arguments ..
1314 INTEGER ICTXT, INFO
1315* ..
1316* .. Array Arguments ..
1317 CHARACTER*(*) SRNAME
1318* ..
1319*
1320* Purpose
1321* =======
1322*
1323* PXERBLA is an error handler for the ScaLAPACK routines. It is called
1324* by a ScaLAPACK routine if an input parameter has an invalid value. A
1325* message is printed. Installers may consider modifying this routine in
1326* order to call system-specific exception-handling facilities.
1327*
1328* Arguments
1329* =========
1330*
1331* ICTXT (local input) INTEGER
1332* On entry, ICTXT specifies the BLACS context handle, indica-
1333* ting the global context of the operation. The context itself
1334* is global, but the value of ICTXT is local.
1335*
1336* SRNAME (global input) CHARACTER*(*)
1337* On entry, SRNAME specifies the name of the routine which cal-
1338* ling PXERBLA.
1339*
1340* INFO (global input) INTEGER
1341* On entry, INFO specifies the position of the invalid parame-
1342* ter in the parameter list of the calling routine.
1343*
1344* -- Written on April 1, 1998 by
1345* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1346*
1347* =====================================================================
1348*
1349* .. Local Scalars ..
1350 INTEGER MYCOL, MYROW, NPCOL, NPROW
1351* ..
1352* .. External Subroutines ..
1353 EXTERNAL BLACS_GRIDINFO
1354* ..
1355* .. Executable Statements ..
1356*
1357 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
1358*
1359 WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO
1360*
1361 9999 FORMAT( '{', I5, ',', I5, '}: on entry to ', A,
1362 $ ' parameter number ', I4, ' had an illegal value' )
1363*
1364 RETURN
1365*
1366* End of PXERBLA
1367*
1368 END
1369 LOGICAL FUNCTION LSAME( CA, CB )
1370*
1371* -- LAPACK auxiliary routine (version 2.1) --
1372* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1373* Courant Institute, Argonne National Lab, and Rice University
1374* September 30, 1994
1375*
1376* .. Scalar Arguments ..
1377 CHARACTER CA, CB
1378* ..
1379*
1380* Purpose
1381* =======
1382*
1383* LSAME returns .TRUE. if CA is the same letter as CB regardless of
1384* case.
1385*
1386* Arguments
1387* =========
1388*
1389* CA (input) CHARACTER*1
1390* CB (input) CHARACTER*1
1391* CA and CB specify the single characters to be compared.
1392*
1393* =====================================================================
1394*
1395* .. Intrinsic Functions ..
1396 INTRINSIC ICHAR
1397* ..
1398* .. Local Scalars ..
1399 INTEGER INTA, INTB, ZCODE
1400* ..
1401* .. Executable Statements ..
1402*
1403* Test if the characters are equal
1404*
1405.EQ. LSAME = CACB
1406 IF( LSAME )
1407 $ RETURN
1408*
1409* Now test for equivalence if both characters are alphabetic.
1410*
1411 ZCODE = ICHAR( 'z' )
1412*
1413* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
1414* machines, on which ICHAR returns a value with bit 8 set.
1415* ICHAR('A') on Prime machines returns 193 which is the same as
1416* ICHAR('A') on an EBCDIC machine.
1417*
1418 INTA = ICHAR( CA )
1419 INTB = ICHAR( CB )
1420*
1421.EQ..OR..EQ. IF( ZCODE90 ZCODE122 ) THEN
1422*
1423* ASCII is assumed - ZCODE is the ASCII code of either lower or
1424* upper case 'Z'.
1425*
1426.GE..AND..LE. IF( INTA97 INTA122 ) INTA = INTA - 32
1427.GE..AND..LE. IF( INTB97 INTB122 ) INTB = INTB - 32
1428*
1429.EQ..OR..EQ. ELSE IF( ZCODE233 ZCODE169 ) THEN
1430*
1431* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
1432* upper case 'Z'.
1433*
1434.GE..AND..LE..OR. IF( INTA129 INTA137
1435.GE..AND..LE..OR. $ INTA145 INTA153
1436.GE..AND..LE. $ INTA162 INTA169 ) INTA = INTA + 64
1437.GE..AND..LE..OR. IF( INTB129 INTB137
1438.GE..AND..LE..OR. $ INTB145 INTB153
1439.GE..AND..LE. $ INTB162 INTB169 ) INTB = INTB + 64
1440*
1441.EQ..OR..EQ. ELSE IF( ZCODE218 ZCODE250 ) THEN
1442*
1443* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
1444* plus 128 of either lower or upper case 'Z'.
1445*
1446.GE..AND..LE. IF( INTA225 INTA250 ) INTA = INTA - 32
1447.GE..AND..LE. IF( INTB225 INTB250 ) INTB = INTB - 32
1448 END IF
1449.EQ. LSAME = INTAINTB
1450*
1451* RETURN
1452*
1453* End of LSAME
1454*
1455 END
1456 LOGICAL FUNCTION LSAMEN( N, CA, CB )
1457*
1458* -- LAPACK auxiliary routine (version 2.1) --
1459* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1460* Courant Institute, Argonne National Lab, and Rice University
1461* September 30, 1994
1462*
1463* .. Scalar Arguments ..
1464 CHARACTER*( * ) CA, CB
1465 INTEGER N
1466* ..
1467*
1468* Purpose
1469* =======
1470*
1471* LSAMEN tests if the first N letters of CA are the same as the
1472* first N letters of CB, regardless of case.
1473* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
1474* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
1475* or LEN( CB ) is less than N.
1476*
1477* Arguments
1478* =========
1479*
1480* N (input) INTEGER
1481* The number of characters in CA and CB to be compared.
1482*
1483* CA (input) CHARACTER*(*)
1484* CB (input) CHARACTER*(*)
1485* CA and CB specify two character strings of length at least N.
1486* Only the first N characters of each string will be accessed.
1487*
1488* =====================================================================
1489*
1490* .. Local Scalars ..
1491 INTEGER I
1492* ..
1493* .. External Functions ..
1494 LOGICAL LSAME
1495 EXTERNAL LSAME
1496* ..
1497* .. Intrinsic Functions ..
1498 INTRINSIC LEN
1499* ..
1500* .. Executable Statements ..
1501*
1502 LSAMEN = .FALSE.
1503.LT..OR..LT. IF( LEN( CA )N LEN( CB )N )
1504 $ GO TO 20
1505*
1506* Do for each character in the two strings.
1507*
1508 DO 10 I = 1, N
1509*
1510* Test if the characters are equal using LSAME.
1511*
1512.NOT. IF( LSAME( CA( I: I ), CB( I: I ) ) )
1513 $ GO TO 20
1514*
1515 10 CONTINUE
1516 LSAMEN = .TRUE.
1517*
1518 20 CONTINUE
1519 RETURN
1520*
1521* End of LSAMEN
1522*
1523 END
1524 SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
1525*
1526* -- LAPACK auxiliary test routine (version 2.1) --
1527* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1528* Courant Institute, Argonne National Lab, and Rice University
1529* February 29, 1992
1530*
1531* .. Scalar Arguments ..
1532 INTEGER INCX, INCY, N
1533* ..
1534* .. Array Arguments ..
1535 INTEGER SX( * ), SY( * )
1536* ..
1537*
1538* Purpose
1539* =======
1540*
1541* ICOPY copies an integer vector x to an integer vector y.
1542* Uses unrolled loops for increments equal to 1.
1543*
1544* Arguments
1545* =========
1546*
1547* N (input) INTEGER
1548* The length of the vectors SX and SY.
1549*
1550* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
1551* The vector X.
1552*
1553* INCX (input) INTEGER
1554* The spacing between consecutive elements of SX.
1555*
1556* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
1557* The vector Y.
1558*
1559* INCY (input) INTEGER
1560* The spacing between consecutive elements of SY.
1561*
1562* =====================================================================
1563*
1564* .. Local Scalars ..
1565 INTEGER I, IX, IY, M, MP1
1566* ..
1567* .. Intrinsic Functions ..
1568 INTRINSIC MOD
1569* ..
1570* .. Executable Statements ..
1571*
1572.LE. IF( N0 )
1573 $ RETURN
1574.EQ..AND..EQ. IF( INCX1 INCY1 )
1575 $ GO TO 20
1576*
1577* Code for unequal increments or equal increments not equal to 1
1578*
1579 IX = 1
1580 IY = 1
1581.LT. IF( INCX0 )
1582 $ IX = ( -N+1 )*INCX + 1
1583.LT. IF( INCY0 )
1584 $ IY = ( -N+1 )*INCY + 1
1585 DO 10 I = 1, N
1586 SY( IY ) = SX( IX )
1587 IX = IX + INCX
1588 IY = IY + INCY
1589 10 CONTINUE
1590 RETURN
1591*
1592* Code for both increments equal to 1
1593*
1594* Clean-up loop
1595*
1596 20 CONTINUE
1597 M = MOD( N, 7 )
1598.EQ. IF( M0 )
1599 $ GO TO 40
1600 DO 30 I = 1, M
1601 SY( I ) = SX( I )
1602 30 CONTINUE
1603.LT. IF( N7 )
1604 $ RETURN
1605 40 CONTINUE
1606 MP1 = M + 1
1607 DO 50 I = MP1, N, 7
1608 SY( I ) = SX( I )
1609 SY( I+1 ) = SX( I+1 )
1610 SY( I+2 ) = SX( I+2 )
1611 SY( I+3 ) = SX( I+3 )
1612 SY( I+4 ) = SX( I+4 )
1613 SY( I+5 ) = SX( I+5 )
1614 SY( I+6 ) = SX( I+6 )
1615 50 CONTINUE
1616 RETURN
1617*
1618* End of ICOPY
1619*
1620 END
1621 INTEGER FUNCTION PB_NOABORT( CINFO )
1622*
1623* -- PBLAS test routine (version 2.0) --
1624* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1625* and University of California, Berkeley.
1626* April 1, 1998
1627*
1628* .. Scalar Arguments ..
1629 INTEGER CINFO
1630* ..
1631*
1632* Purpose
1633* =======
1634*
1635* PB_NOABORT transmits the info parameter of a PBLAS routine to the
1636* tester and tells the PBLAS error handler to avoid aborting on erro-
1637* neous input arguments.
1638*
1639* Notes
1640* =====
1641*
1642* This routine is necessary because of the CRAY C fortran interface
1643* and the fact that the usual PBLAS error handler routine has been
1644* initially written in C.
1645*
1646* -- Written on April 1, 1998 by
1647* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1648*
1649* =====================================================================
1650*
1651* .. Common Blocks ..
1652 INTEGER INFO, NBLOG, NOUT
1653 LOGICAL ABRTFLG
1654 COMMON /INFOC/INFO, NBLOG
1655 COMMON /PBERRORC/NOUT, ABRTFLG
1656* ..
1657* .. Executable Statements ..
1658*
1659 INFO = CINFO
1660 IF( ABRTFLG ) THEN
1661 PB_NOABORT = 0
1662 ELSE
1663 PB_NOABORT = 1
1664 END IF
1665*
1666 RETURN
1667*
1668* End of PB_NOABORT
1669*
1670 END
1671 SUBROUTINE PB_INFOG2L( I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II,
1672 $ JJ, PROW, PCOL )
1673*
1674* -- PBLAS test routine (version 2.0) --
1675* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1676* and University of California, Berkeley.
1677* April 1, 1998
1678*
1679* .. Scalar Arguments ..
1680 INTEGER I, II, J, JJ, MYCOL, MYROW, NPCOL, NPROW, PCOL,
1681 $ PROW
1682* ..
1683* .. Array Arguments ..
1684 INTEGER DESC( * )
1685* ..
1686*
1687* Purpose
1688* =======
1689*
1690* PB_INFOG2L computes the starting local index II, JJ corresponding to
1691* the submatrix starting globally at the entry pointed by I, J. This
1692* routine returns the coordinates in the grid of the process owning the
1693* matrix entry of global indexes I, J, namely PROW and PCOL.
1694*
1695* Notes
1696* =====
1697*
1698* A description vector is associated with each 2D block-cyclicly dis-
1699* tributed matrix. This vector stores the information required to
1700* establish the mapping between a matrix entry and its corresponding
1701* process and memory location.
1702*
1703* In the following comments, the character _ should be read as
1704* "of the distributed matrix". Let A be a generic term for any 2D
1705* block cyclicly distributed matrix. Its description vector is DESCA:
1706*
1707* NOTATION STORED IN EXPLANATION
1708* ---------------- --------------- ------------------------------------
1709* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1710* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1711* the NPROW x NPCOL BLACS process grid
1712* A is distributed over. The context
1713* itself is global, but the handle
1714* (the integer value) may vary.
1715* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1716* ted matrix A, M_A >= 0.
1717* N_A (global) DESCA( N_ ) The number of columns in the distri-
1718* buted matrix A, N_A >= 0.
1719* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1720* block of the matrix A, IMB_A > 0.
1721* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1722* left block of the matrix A,
1723* INB_A > 0.
1724* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1725* bute the last M_A-IMB_A rows of A,
1726* MB_A > 0.
1727* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1728* bute the last N_A-INB_A columns of
1729* A, NB_A > 0.
1730* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1731* row of the matrix A is distributed,
1732* NPROW > RSRC_A >= 0.
1733* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1734* first column of A is distributed.
1735* NPCOL > CSRC_A >= 0.
1736* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1737* array storing the local blocks of
1738* the distributed matrix A,
1739* IF( Lc( 1, N_A ) > 0 )
1740* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1741* ELSE
1742* LLD_A >= 1.
1743*
1744* Let K be the number of rows of a matrix A starting at the global in-
1745* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1746* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1747* receive if these K rows were distributed over NPROW processes. If K
1748* is the number of columns of a matrix A starting at the global index
1749* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1750* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1751* these K columns were distributed over NPCOL processes.
1752*
1753* The values of Lr() and Lc() may be determined via a call to the func-
1754* tion PB_NUMROC:
1755* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1756* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1757*
1758* Arguments
1759* =========
1760*
1761* I (global input) INTEGER
1762* On entry, I specifies the global starting row index of the
1763* submatrix. I must at least one.
1764*
1765* J (global input) INTEGER
1766* On entry, J specifies the global starting column index of
1767* the submatrix. J must at least one.
1768*
1769* DESC (global and local input) INTEGER array
1770* On entry, DESC is an integer array of dimension DLEN_. This
1771* is the array descriptor of the underlying matrix.
1772*
1773* NPROW (global input) INTEGER
1774* On entry, NPROW specifies the total number of process rows
1775* over which the matrix is distributed. NPROW must be at least
1776* one.
1777*
1778* NPCOL (global input) INTEGER
1779* On entry, NPCOL specifies the total number of process columns
1780* over which the matrix is distributed. NPCOL must be at least
1781* one.
1782*
1783* MYROW (local input) INTEGER
1784* On entry, MYROW specifies the row coordinate of the process
1785* whose local index II is determined. MYROW must be at least
1786* zero and strictly less than NPROW.
1787*
1788* MYCOL (local input) INTEGER
1789* On entry, MYCOL specifies the column coordinate of the pro-
1790* cess whose local index JJ is determined. MYCOL must be at
1791* least zero and strictly less than NPCOL.
1792*
1793* II (local output) INTEGER
1794* On exit, II specifies the local starting row index of the
1795* submatrix. On exit, II is at least one.
1796*
1797* JJ (local output) INTEGER
1798* On exit, JJ specifies the local starting column index of the
1799* submatrix. On exit, JJ is at least one.
1800*
1801* PROW (global output) INTEGER
1802* On exit, PROW specifies the row coordinate of the process
1803* that possesses the first row of the submatrix. On exit, PROW
1804* is -1 if DESC( RSRC_ ) is -1 on input, and, at least zero
1805* and strictly less than NPROW otherwise.
1806*
1807* PCOL (global output) INTEGER
1808* On exit, PCOL specifies the column coordinate of the process
1809* that possesses the first column of the submatrix. On exit,
1810* PCOL is -1 if DESC( CSRC_ ) is -1 on input, and, at least
1811* zero and strictly less than NPCOL otherwise.
1812*
1813* -- Written on April 1, 1998 by
1814* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1815*
1816* =====================================================================
1817*
1818* .. Parameters ..
1819 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1820 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1821 $ RSRC_
1822 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
1823 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
1824 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
1825 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
1826* ..
1827* .. Local Scalars ..
1828 INTEGER CSRC, I1, ILOCBLK, IMB, INB, J1, MB, MYDIST,
1829 $ NB, NBLOCKS, RSRC
1830* ..
1831* .. Local Arrays ..
1832 INTEGER DESC2( DLEN_ )
1833* ..
1834* .. External Subroutines ..
1835 EXTERNAL PB_DESCTRANS
1836* ..
1837* .. Executable Statements ..
1838*
1839* Convert descriptor
1840*
1841 CALL PB_DESCTRANS( DESC, DESC2 )
1842*
1843 IMB = DESC2( IMB_ )
1844 PROW = DESC2( RSRC_ )
1845*
1846* Has every process row I ?
1847*
1848.EQ..OR..EQ. IF( ( PROW-1 )( NPROW1 ) ) THEN
1849*
1850 II = I
1851*
1852.LE. ELSE IF( IIMB ) THEN
1853*
1854* I is in range of first block
1855*
1856.EQ. IF( MYROWPROW ) THEN
1857 II = I
1858 ELSE
1859 II = 1
1860 END IF
1861*
1862 ELSE
1863*
1864* I is not in first block of matrix, figure out who has it.
1865*
1866 RSRC = PROW
1867 MB = DESC2( MB_ )
1868*
1869.EQ. IF( MYROWRSRC ) THEN
1870*
1871 NBLOCKS = ( I - IMB - 1 ) / MB + 1
1872 PROW = PROW + NBLOCKS
1873 PROW = PROW - ( PROW / NPROW ) * NPROW
1874*
1875 ILOCBLK = NBLOCKS / NPROW
1876*
1877.GT. IF( ILOCBLK0 ) THEN
1878.GE. IF( ( ILOCBLK*NPROW )NBLOCKS ) THEN
1879.EQ. IF( MYROWPROW ) THEN
1880 II = I + ( ILOCBLK - NBLOCKS ) * MB
1881 ELSE
1882 II = IMB + ( ILOCBLK - 1 ) * MB + 1
1883 END IF
1884 ELSE
1885 II = IMB + ILOCBLK * MB + 1
1886 END IF
1887 ELSE
1888 II = IMB + 1
1889 END IF
1890*
1891 ELSE
1892*
1893 I1 = I - IMB
1894 NBLOCKS = ( I1 - 1 ) / MB + 1
1895 PROW = PROW + NBLOCKS
1896 PROW = PROW - ( PROW / NPROW ) * NPROW
1897*
1898 MYDIST = MYROW - RSRC
1899.LT. IF( MYDIST0 )
1900 $ MYDIST = MYDIST + NPROW
1901*
1902 ILOCBLK = NBLOCKS / NPROW
1903*
1904.GT. IF( ILOCBLK0 ) THEN
1905 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
1906.LT. IF( MYDIST0 ) THEN
1907 II = MB + ILOCBLK * MB + 1
1908 ELSE
1909.EQ. IF( MYROWPROW ) THEN
1910 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB
1911 ELSE
1912 II = ILOCBLK * MB + 1
1913 END IF
1914 END IF
1915 ELSE
1916 MYDIST = MYDIST - NBLOCKS
1917.LT. IF( MYDIST0 ) THEN
1918 II = MB + 1
1919.EQ. ELSE IF( MYROWPROW ) THEN
1920 II = I1 + ( 1 - NBLOCKS ) * MB
1921 ELSE
1922 II = 1
1923 END IF
1924 END IF
1925 END IF
1926*
1927 END IF
1928*
1929 INB = DESC2( INB_ )
1930 PCOL = DESC2( CSRC_ )
1931*
1932* Has every process column J ?
1933*
1934.EQ..OR..EQ. IF( ( PCOL-1 )( NPCOL1 ) ) THEN
1935*
1936 JJ = J
1937*
1938.LE. ELSE IF( JINB ) THEN
1939*
1940* J is in range of first block
1941*
1942.EQ. IF( MYCOLPCOL ) THEN
1943 JJ = J
1944 ELSE
1945 JJ = 1
1946 END IF
1947*
1948 ELSE
1949*
1950* J is not in first block of matrix, figure out who has it.
1951*
1952 CSRC = PCOL
1953 NB = DESC2( NB_ )
1954*
1955.EQ. IF( MYCOLCSRC ) THEN
1956*
1957 NBLOCKS = ( J - INB - 1 ) / NB + 1
1958 PCOL = PCOL + NBLOCKS
1959 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
1960*
1961 ILOCBLK = NBLOCKS / NPCOL
1962*
1963.GT. IF( ILOCBLK0 ) THEN
1964.GE. IF( ( ILOCBLK*NPCOL )NBLOCKS ) THEN
1965.EQ. IF( MYCOLPCOL ) THEN
1966 JJ = J + ( ILOCBLK - NBLOCKS ) * NB
1967 ELSE
1968 JJ = INB + ( ILOCBLK - 1 ) * NB + 1
1969 END IF
1970 ELSE
1971 JJ = INB + ILOCBLK * NB + 1
1972 END IF
1973 ELSE
1974 JJ = INB + 1
1975 END IF
1976*
1977 ELSE
1978*
1979 J1 = J - INB
1980 NBLOCKS = ( J1 - 1 ) / NB + 1
1981 PCOL = PCOL + NBLOCKS
1982 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
1983*
1984 MYDIST = MYCOL - CSRC
1985.LT. IF( MYDIST0 )
1986 $ MYDIST = MYDIST + NPCOL
1987*
1988 ILOCBLK = NBLOCKS / NPCOL
1989*
1990.GT. IF( ILOCBLK0 ) THEN
1991 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
1992.LT. IF( MYDIST0 ) THEN
1993 JJ = NB + ILOCBLK * NB + 1
1994 ELSE
1995.EQ. IF( MYCOLPCOL ) THEN
1996 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB
1997 ELSE
1998 JJ = ILOCBLK * NB + 1
1999 END IF
2000 END IF
2001 ELSE
2002 MYDIST = MYDIST - NBLOCKS
2003.LT. IF( MYDIST0 ) THEN
2004 JJ = NB + 1
2005.EQ. ELSE IF( MYCOLPCOL ) THEN
2006 JJ = J1 + ( 1 - NBLOCKS ) * NB
2007 ELSE
2008 JJ = 1
2009 END IF
2010 END IF
2011 END IF
2012*
2013 END IF
2014*
2015 RETURN
2016*
2017* End of PB_INFOG2L
2018*
2019 END
2020 SUBROUTINE PB_AINFOG2L( M, N, I, J, DESC, NPROW, NPCOL, MYROW,
2021 $ MYCOL, IMB1, INB1, MP, NQ, II, JJ, PROW,
2022 $ PCOL, RPROW, RPCOL )
2023*
2024* -- PBLAS test routine (version 2.0) --
2025* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2026* and University of California, Berkeley.
2027* April 1, 1998
2028*
2029* .. Scalar Arguments ..
2030 INTEGER I, II, IMB1, INB1, J, JJ, M, MP, MYCOL, MYROW,
2031 $ N, NPCOL, NPROW, NQ, PCOL, PROW, RPCOL, RPROW
2032* ..
2033* .. Array Arguments ..
2034 INTEGER DESC( * )
2035* ..
2036*
2037* Purpose
2038* =======
2039*
2040* PB_AINFOG2L computes the starting local row and column indexes II,
2041* JJ corresponding to the submatrix starting globally at the entry
2042* pointed by I, J. This routine returns the coordinates in the grid of
2043* the process owning the matrix entry of global indexes I, J, namely
2044* PROW and PCOL. In addition, this routine computes the quantities MP
2045* and NQ, which are respectively the local number of rows and columns
2046* owned by the process of coordinate MYROW, MYCOL corresponding to the
2047* global submatrix A(I:I+M-1,J:J+N-1). Finally, the size of the first
2048* partial block and the relative process coordinates are also returned
2049* respectively in IMB, INB and RPROW, RPCOL.
2050*
2051* Notes
2052* =====
2053*
2054* A description vector is associated with each 2D block-cyclicly dis-
2055* tributed matrix. This vector stores the information required to
2056* establish the mapping between a matrix entry and its corresponding
2057* process and memory location.
2058*
2059* In the following comments, the character _ should be read as
2060* "of the distributed matrix". Let A be a generic term for any 2D
2061* block cyclicly distributed matrix. Its description vector is DESCA:
2062*
2063* NOTATION STORED IN EXPLANATION
2064* ---------------- --------------- ------------------------------------
2065* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2066* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2067* the NPROW x NPCOL BLACS process grid
2068* A is distributed over. The context
2069* itself is global, but the handle
2070* (the integer value) may vary.
2071* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2072* ted matrix A, M_A >= 0.
2073* N_A (global) DESCA( N_ ) The number of columns in the distri-
2074* buted matrix A, N_A >= 0.
2075* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2076* block of the matrix A, IMB_A > 0.
2077* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2078* left block of the matrix A,
2079* INB_A > 0.
2080* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2081* bute the last M_A-IMB_A rows of A,
2082* MB_A > 0.
2083* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2084* bute the last N_A-INB_A columns of
2085* A, NB_A > 0.
2086* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2087* row of the matrix A is distributed,
2088* NPROW > RSRC_A >= 0.
2089* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2090* first column of A is distributed.
2091* NPCOL > CSRC_A >= 0.
2092* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2093* array storing the local blocks of
2094* the distributed matrix A,
2095* IF( Lc( 1, N_A ) > 0 )
2096* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2097* ELSE
2098* LLD_A >= 1.
2099*
2100* Let K be the number of rows of a matrix A starting at the global in-
2101* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2102* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2103* receive if these K rows were distributed over NPROW processes. If K
2104* is the number of columns of a matrix A starting at the global index
2105* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2106* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2107* these K columns were distributed over NPCOL processes.
2108*
2109* The values of Lr() and Lc() may be determined via a call to the func-
2110* tion PB_NUMROC:
2111* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2112* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2113*
2114* Arguments
2115* =========
2116*
2117* M (global input) INTEGER
2118* On entry, M specifies the global number of rows of the subma-
2119* trix. M must be at least zero.
2120*
2121* N (global input) INTEGER
2122* On entry, N specifies the global number of columns of the
2123* submatrix. N must be at least zero.
2124*
2125* I (global input) INTEGER
2126* On entry, I specifies the global starting row index of the
2127* submatrix. I must at least one.
2128*
2129* J (global input) INTEGER
2130* On entry, J specifies the global starting column index of
2131* the submatrix. J must at least one.
2132*
2133* DESC (global and local input) INTEGER array
2134* On entry, DESC is an integer array of dimension DLEN_. This
2135* is the array descriptor of the underlying matrix.
2136*
2137* NPROW (global input) INTEGER
2138* On entry, NPROW specifies the total number of process rows
2139* over which the matrix is distributed. NPROW must be at least
2140* one.
2141*
2142* NPCOL (global input) INTEGER
2143* On entry, NPCOL specifies the total number of process columns
2144* over which the matrix is distributed. NPCOL must be at least
2145* one.
2146*
2147* MYROW (local input) INTEGER
2148* On entry, MYROW specifies the row coordinate of the process
2149* whose local index II is determined. MYROW must be at least
2150* zero and strictly less than NPROW.
2151*
2152* MYCOL (local input) INTEGER
2153* On entry, MYCOL specifies the column coordinate of the pro-
2154* cess whose local index JJ is determined. MYCOL must be at
2155* least zero and strictly less than NPCOL.
2156*
2157* IMB1 (global output) INTEGER
2158* On exit, IMB1 specifies the number of rows of the upper left
2159* block of the submatrix. On exit, IMB1 is less or equal than
2160* M and greater or equal than MIN( 1, M ).
2161*
2162* INB1 (global output) INTEGER
2163* On exit, INB1 specifies the number of columns of the upper
2164* left block of the submatrix. On exit, INB1 is less or equal
2165* than N and greater or equal than MIN( 1, N ).
2166*
2167* MP (local output) INTEGER
2168* On exit, MP specifies the local number of rows of the subma-
2169* trix, that the processes of row coordinate MYROW own. MP is
2170* at least zero.
2171*
2172* NQ (local output) INTEGER
2173* On exit, NQ specifies the local number of columns of the
2174* submatrix, that the processes of column coordinate MYCOL
2175* own. NQ is at least zero.
2176*
2177* II (local output) INTEGER
2178* On exit, II specifies the local starting row index of the
2179* submatrix. On exit, II is at least one.
2180*
2181* JJ (local output) INTEGER
2182* On exit, JJ specifies the local starting column index of
2183* the submatrix. On exit, II is at least one.
2184*
2185* PROW (global output) INTEGER
2186* On exit, PROW specifies the row coordinate of the process
2187* that possesses the first row of the submatrix. On exit, PROW
2188* is -1 if DESC(RSRC_) is -1 on input, and, at least zero and
2189* strictly less than NPROW otherwise.
2190*
2191* PCOL (global output) INTEGER
2192* On exit, PCOL specifies the column coordinate of the process
2193* that possesses the first column of the submatrix. On exit,
2194* PCOL is -1 if DESC(CSRC_) is -1 on input, and, at least zero
2195* and strictly less than NPCOL otherwise.
2196*
2197* RPROW (global output) INTEGER
2198* On exit, RPROW specifies the relative row coordinate of the
2199* process that possesses the first row I of the submatrix. On
2200* exit, RPROW is -1 if DESC(RSRC_) is -1 on input, and, at
2201* least zero and strictly less than NPROW otherwise.
2202*
2203* RPCOL (global output) INTEGER
2204* On exit, RPCOL specifies the relative column coordinate of
2205* the process that possesses the first column J of the subma-
2206* trix. On exit, RPCOL is -1 if DESC(CSRC_) is -1 on input,
2207* and, at least zero and strictly less than NPCOL otherwise.
2208*
2209* -- Written on April 1, 1998 by
2210* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2211*
2212* =====================================================================
2213*
2214* .. Parameters ..
2215 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2216 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2217 $ RSRC_
2218 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2219 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2220 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2221 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2222* ..
2223* .. Local Scalars ..
2224 INTEGER CSRC, I1, ILOCBLK, J1, M1, MB, MYDIST, N1, NB,
2225 $ NBLOCKS, RSRC
2226* ..
2227* .. Local Arrays ..
2228 INTEGER DESC2( DLEN_ )
2229* ..
2230* .. External Subroutines ..
2231 EXTERNAL PB_DESCTRANS
2232* ..
2233* .. Intrinsic Functions ..
2234 INTRINSIC MIN
2235* ..
2236* .. Executable Statements ..
2237*
2238* Convert descriptor
2239*
2240 CALL PB_DESCTRANS( DESC, DESC2 )
2241*
2242 MB = DESC2( MB_ )
2243 IMB1 = DESC2( IMB_ )
2244 RSRC = DESC2( RSRC_ )
2245*
2246.EQ..OR..EQ. IF( ( RSRC-1 )( NPROW1 ) ) THEN
2247*
2248 II = I
2249 IMB1 = IMB1 - I + 1
2250.LE. IF( IMB10 )
2251 $ IMB1 = ( ( -IMB1 ) / MB + 1 ) * MB + IMB1
2252 IMB1 = MIN( IMB1, M )
2253 MP = M
2254 PROW = RSRC
2255 RPROW = 0
2256*
2257 ELSE
2258*
2259* Figure out PROW, II and IMB1 first
2260*
2261.LE. IF( IIMB1 ) THEN
2262*
2263 PROW = RSRC
2264*
2265.EQ. IF( MYROWPROW ) THEN
2266 II = I
2267 ELSE
2268 II = 1
2269 END IF
2270*
2271 IMB1 = IMB1 - I + 1
2272*
2273 ELSE
2274*
2275 I1 = I - IMB1 - 1
2276 NBLOCKS = I1 / MB + 1
2277 PROW = RSRC + NBLOCKS
2278 PROW = PROW - ( PROW / NPROW ) * NPROW
2279*
2280.EQ. IF( MYROWRSRC ) THEN
2281*
2282 ILOCBLK = NBLOCKS / NPROW
2283*
2284.GT. IF( ILOCBLK0 ) THEN
2285.GE. IF( ( ILOCBLK*NPROW )NBLOCKS ) THEN
2286.EQ. IF( MYROWPROW ) THEN
2287 II = I + ( ILOCBLK - NBLOCKS ) * MB
2288 ELSE
2289 II = IMB1 + ( ILOCBLK - 1 ) * MB + 1
2290 END IF
2291 ELSE
2292 II = IMB1 + ILOCBLK * MB + 1
2293 END IF
2294 ELSE
2295 II = IMB1 + 1
2296 END IF
2297*
2298 ELSE
2299*
2300 MYDIST = MYROW - RSRC
2301.LT. IF( MYDIST0 )
2302 $ MYDIST = MYDIST + NPROW
2303*
2304 ILOCBLK = NBLOCKS / NPROW
2305*
2306.GT. IF( ILOCBLK0 ) THEN
2307 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
2308.LT. IF( MYDIST0 ) THEN
2309 II = ( ILOCBLK + 1 ) * MB + 1
2310.EQ. ELSE IF( MYROWPROW ) THEN
2311 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB + 1
2312 ELSE
2313 II = ILOCBLK * MB + 1
2314 END IF
2315 ELSE
2316 MYDIST = MYDIST - NBLOCKS
2317.LT. IF( MYDIST0 ) THEN
2318 II = MB + 1
2319.EQ. ELSE IF( MYROWPROW ) THEN
2320 II = I1 + ( 1 - NBLOCKS ) * MB + 1
2321 ELSE
2322 II = 1
2323 END IF
2324 END IF
2325 END IF
2326*
2327 IMB1 = NBLOCKS * MB - I1
2328*
2329 END IF
2330*
2331* Figure out MP
2332*
2333.LE. IF( MIMB1 ) THEN
2334*
2335.EQ. IF( MYROWPROW ) THEN
2336 MP = M
2337 ELSE
2338 MP = 0
2339 END IF
2340*
2341 ELSE
2342*
2343 M1 = M - IMB1
2344 NBLOCKS = M1 / MB + 1
2345*
2346.EQ. IF( MYROWPROW ) THEN
2347 ILOCBLK = NBLOCKS / NPROW
2348.GT. IF( ILOCBLK0 ) THEN
2349.GT. IF( ( NBLOCKS - ILOCBLK * NPROW )0 ) THEN
2350 MP = IMB1 + ILOCBLK * MB
2351 ELSE
2352 MP = M + MB * ( ILOCBLK - NBLOCKS )
2353 END IF
2354 ELSE
2355 MP = IMB1
2356 END IF
2357 ELSE
2358 MYDIST = MYROW - PROW
2359.LT. IF( MYDIST0 )
2360 $ MYDIST = MYDIST + NPROW
2361 ILOCBLK = NBLOCKS / NPROW
2362.GT. IF( ILOCBLK0 ) THEN
2363 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
2364.LT. IF( MYDIST0 ) THEN
2365 MP = ( ILOCBLK + 1 ) * MB
2366.GT. ELSE IF( MYDIST0 ) THEN
2367 MP = ILOCBLK * MB
2368 ELSE
2369 MP = M1 + MB * ( ILOCBLK - NBLOCKS + 1 )
2370 END IF
2371 ELSE
2372 MYDIST = MYDIST - NBLOCKS
2373.LT. IF( MYDIST0 ) THEN
2374 MP = MB
2375.GT. ELSE IF( MYDIST0 ) THEN
2376 MP = 0
2377 ELSE
2378 MP = M1 + MB * ( 1 - NBLOCKS )
2379 END IF
2380 END IF
2381 END IF
2382*
2383 END IF
2384*
2385 IMB1 = MIN( IMB1, M )
2386 RPROW = MYROW - PROW
2387.LT. IF( RPROW0 )
2388 $ RPROW = RPROW + NPROW
2389*
2390 END IF
2391*
2392 NB = DESC2( NB_ )
2393 INB1 = DESC2( INB_ )
2394 CSRC = DESC2( CSRC_ )
2395*
2396.EQ..OR..EQ. IF( ( CSRC-1 )( NPCOL1 ) ) THEN
2397*
2398 JJ = J
2399 INB1 = INB1 - I + 1
2400.LE. IF( INB10 )
2401 $ INB1 = ( ( -INB1 ) / NB + 1 ) * NB + INB1
2402 INB1 = MIN( INB1, N )
2403 NQ = N
2404 PCOL = CSRC
2405 RPCOL = 0
2406*
2407 ELSE
2408*
2409* Figure out PCOL, JJ and INB1 first
2410*
2411.LE. IF( JINB1 ) THEN
2412*
2413 PCOL = CSRC
2414*
2415.EQ. IF( MYCOLPCOL ) THEN
2416 JJ = J
2417 ELSE
2418 JJ = 1
2419 END IF
2420*
2421 INB1 = INB1 - J + 1
2422*
2423 ELSE
2424*
2425 J1 = J - INB1 - 1
2426 NBLOCKS = J1 / NB + 1
2427 PCOL = CSRC + NBLOCKS
2428 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
2429*
2430.EQ. IF( MYCOLCSRC ) THEN
2431*
2432 ILOCBLK = NBLOCKS / NPCOL
2433*
2434.GT. IF( ILOCBLK0 ) THEN
2435.GE. IF( ( ILOCBLK*NPCOL )NBLOCKS ) THEN
2436.EQ. IF( MYCOLPCOL ) THEN
2437 JJ = J + ( ILOCBLK - NBLOCKS ) * NB
2438 ELSE
2439 JJ = INB1 + ( ILOCBLK - 1 ) * NB + 1
2440 END IF
2441 ELSE
2442 JJ = INB1 + ILOCBLK * NB + 1
2443 END IF
2444 ELSE
2445 JJ = INB1 + 1
2446 END IF
2447*
2448 ELSE
2449*
2450 MYDIST = MYCOL - CSRC
2451.LT. IF( MYDIST0 )
2452 $ MYDIST = MYDIST + NPCOL
2453*
2454 ILOCBLK = NBLOCKS / NPCOL
2455*
2456.GT. IF( ILOCBLK0 ) THEN
2457 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
2458.LT. IF( MYDIST0 ) THEN
2459 JJ = ( ILOCBLK + 1 ) * NB + 1
2460.EQ. ELSE IF( MYCOLPCOL ) THEN
2461 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB + 1
2462 ELSE
2463 JJ = ILOCBLK * NB + 1
2464 END IF
2465 ELSE
2466 MYDIST = MYDIST - NBLOCKS
2467.LT. IF( MYDIST0 ) THEN
2468 JJ = NB + 1
2469.EQ. ELSE IF( MYCOLPCOL ) THEN
2470 JJ = J1 + ( 1 - NBLOCKS ) * NB + 1
2471 ELSE
2472 JJ = 1
2473 END IF
2474 END IF
2475 END IF
2476*
2477 INB1 = NBLOCKS * NB - J1
2478*
2479 END IF
2480*
2481* Figure out NQ
2482*
2483.LE. IF( NINB1 ) THEN
2484*
2485.EQ. IF( MYCOLPCOL ) THEN
2486 NQ = N
2487 ELSE
2488 NQ = 0
2489 END IF
2490*
2491 ELSE
2492*
2493 N1 = N - INB1
2494 NBLOCKS = N1 / NB + 1
2495*
2496.EQ. IF( MYCOLPCOL ) THEN
2497 ILOCBLK = NBLOCKS / NPCOL
2498.GT. IF( ILOCBLK0 ) THEN
2499.GT. IF( ( NBLOCKS - ILOCBLK * NPCOL )0 ) THEN
2500 NQ = INB1 + ILOCBLK * NB
2501 ELSE
2502 NQ = N + NB * ( ILOCBLK - NBLOCKS )
2503 END IF
2504 ELSE
2505 NQ = INB1
2506 END IF
2507 ELSE
2508 MYDIST = MYCOL - PCOL
2509.LT. IF( MYDIST0 )
2510 $ MYDIST = MYDIST + NPCOL
2511 ILOCBLK = NBLOCKS / NPCOL
2512.GT. IF( ILOCBLK0 ) THEN
2513 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
2514.LT. IF( MYDIST0 ) THEN
2515 NQ = ( ILOCBLK + 1 ) * NB
2516.GT. ELSE IF( MYDIST0 ) THEN
2517 NQ = ILOCBLK * NB
2518 ELSE
2519 NQ = N1 + NB * ( ILOCBLK - NBLOCKS + 1 )
2520 END IF
2521 ELSE
2522 MYDIST = MYDIST - NBLOCKS
2523.LT. IF( MYDIST0 ) THEN
2524 NQ = NB
2525.GT. ELSE IF( MYDIST0 ) THEN
2526 NQ = 0
2527 ELSE
2528 NQ = N1 + NB * ( 1 - NBLOCKS )
2529 END IF
2530 END IF
2531 END IF
2532*
2533 END IF
2534*
2535 INB1 = MIN( INB1, N )
2536 RPCOL = MYCOL - PCOL
2537.LT. IF( RPCOL0 )
2538 $ RPCOL = RPCOL + NPCOL
2539*
2540 END IF
2541*
2542 RETURN
2543*
2544* End of PB_AINFOG2L
2545*
2546 END
2547 INTEGER FUNCTION PB_NUMROC( N, I, INB, NB, PROC, SRCPROC, NPROCS )
2548*
2549* -- PBLAS test routine (version 2.0) --
2550* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2551* and University of California, Berkeley.
2552* April 1, 1998
2553*
2554* .. Scalar Arguments ..
2555 INTEGER I, INB, N, NB, NPROCS, PROC, SRCPROC
2556* ..
2557*
2558* Purpose
2559* =======
2560*
2561* PB_NUMROC returns the local number of matrix rows/columns process
2562* PROC will get if we give out N rows/columns starting from global in-
2563* dex I.
2564*
2565* Arguments
2566* =========
2567*
2568* N (global input) INTEGER
2569* On entry, N specifies the number of rows/columns being dealt
2570* out. N must be at least zero.
2571*
2572* I (global input) INTEGER
2573* On entry, I specifies the global index of the matrix entry.
2574* I must be at least one.
2575*
2576* INB (global input) INTEGER
2577* On entry, INB specifies the size of the first block of the
2578* global matrix. INB must be at least one.
2579*
2580* NB (global input) INTEGER
2581* On entry, NB specifies the size of the blocks used to parti-
2582* tion the matrix. NB must be at least one.
2583*
2584* PROC (local input) INTEGER
2585* On entry, PROC specifies the coordinate of the process whose
2586* local portion is determined. PROC must be at least zero and
2587* strictly less than NPROCS.
2588*
2589* SRCPROC (global input) INTEGER
2590* On entry, SRCPROC specifies the coordinate of the process
2591* that possesses the first row or column of the matrix. When
2592* SRCPROC = -1, the data is not distributed but replicated,
2593* otherwise SRCPROC must be at least zero and strictly less
2594* than NPROCS.
2595*
2596* NPROCS (global input) INTEGER
2597* On entry, NPROCS specifies the total number of process rows
2598* or columns over which the matrix is distributed. NPROCS must
2599* be at least one.
2600*
2601* -- Written on April 1, 1998 by
2602* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2603*
2604* =====================================================================
2605*
2606* .. Local Scalars ..
2607 INTEGER I1, ILOCBLK, INB1, MYDIST, N1, NBLOCKS,
2608 $ SRCPROC1
2609* ..
2610* .. Executable Statements ..
2611*
2612.EQ..OR..EQ. IF( ( SRCPROC-1 )( NPROCS1 ) ) THEN
2613 PB_NUMROC = N
2614 RETURN
2615 END IF
2616*
2617* Compute coordinate of process owning I and corresponding INB
2618*
2619.LE. IF( IINB ) THEN
2620*
2621* I is in range of first block, i.e SRCPROC owns I.
2622*
2623 SRCPROC1 = SRCPROC
2624 INB1 = INB - I + 1
2625*
2626 ELSE
2627*
2628* I is not in first block of matrix, figure out who has it
2629*
2630 I1 = I - 1 - INB
2631 NBLOCKS = I1 / NB + 1
2632 SRCPROC1 = SRCPROC + NBLOCKS
2633 SRCPROC1 = SRCPROC1 - ( SRCPROC1 / NPROCS ) * NPROCS
2634 INB1 = NBLOCKS*NB - I1
2635*
2636 END IF
2637*
2638* Now everything is just like I=1. Search now who has N-1, Is N-1
2639* in the first block ?
2640*
2641.LE. IF( NINB1 ) THEN
2642.EQ. IF( PROCSRCPROC1 ) THEN
2643 PB_NUMROC = N
2644 ELSE
2645 PB_NUMROC = 0
2646 END IF
2647 RETURN
2648 END IF
2649*
2650 N1 = N - INB1
2651 NBLOCKS = N1 / NB + 1
2652*
2653.EQ. IF( PROCSRCPROC1 ) THEN
2654 ILOCBLK = NBLOCKS / NPROCS
2655.GT. IF( ILOCBLK0 ) THEN
2656.GT. IF( ( NBLOCKS - ILOCBLK * NPROCS )0 ) THEN
2657 PB_NUMROC = INB1 + ILOCBLK * NB
2658 ELSE
2659 PB_NUMROC = N + NB * ( ILOCBLK - NBLOCKS )
2660 END IF
2661 ELSE
2662 PB_NUMROC = INB1
2663 END IF
2664 ELSE
2665 MYDIST = PROC - SRCPROC1
2666.LT. IF( MYDIST0 )
2667 $ MYDIST = MYDIST + NPROCS
2668 ILOCBLK = NBLOCKS / NPROCS
2669.GT. IF( ILOCBLK0 ) THEN
2670 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROCS
2671.LT. IF( MYDIST0 ) THEN
2672 PB_NUMROC = ( ILOCBLK + 1 ) * NB
2673.GT. ELSE IF( MYDIST0 ) THEN
2674 PB_NUMROC = ILOCBLK * NB
2675 ELSE
2676 PB_NUMROC = N1 + NB * ( ILOCBLK - NBLOCKS + 1 )
2677 END IF
2678 ELSE
2679 MYDIST = MYDIST - NBLOCKS
2680.LT. IF( MYDIST0 ) THEN
2681 PB_NUMROC = NB
2682.GT. ELSE IF( MYDIST0 ) THEN
2683 PB_NUMROC = 0
2684 ELSE
2685 PB_NUMROC = N1 + NB * ( 1 - NBLOCKS )
2686 END IF
2687 END IF
2688 END IF
2689*
2690 RETURN
2691*
2692* End of PB_NUMROC
2693*
2694 END
2695 INTEGER FUNCTION PB_FCEIL( NUM, DENOM )
2696*
2697* -- PBLAS test routine (version 2.0) --
2698* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2699* and University of California, Berkeley.
2700* April 1, 1998
2701*
2702* .. Scalar Arguments ..
2703 REAL DENOM, NUM
2704* ..
2705*
2706* Purpose
2707* =======
2708*
2709* PB_FCEIL returns the ceiling of the division of two integers. The
2710* integer operands are passed as real to avoid integer overflow.
2711*
2712* Arguments
2713* =========
2714*
2715* NUM (local input) REAL
2716* On entry, NUM specifies the numerator of the fraction to be
2717* evaluated.
2718*
2719* DENOM (local input) REAL
2720* On entry, DENOM specifies the denominator of the fraction to
2721* be evaluated.
2722*
2723* -- Written on April 1, 1998 by
2724* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2725*
2726* =====================================================================
2727*
2728* .. Intrinsic Functions ..
2729 INTRINSIC NINT
2730* ..
2731* .. Executable Statements ..
2732*
2733 PB_FCEIL = NINT( ( ( NUM + DENOM - 1.0E+0 ) / DENOM ) - 0.5E+0 )
2734*
2735 RETURN
2736*
2737* End of PB_FCEIL
2738*
2739 END
2740 SUBROUTINE PB_CHKMAT( ICTXT, M, MPOS0, N, NPOS0, IA, JA, DESCA,
2741 $ DPOS0, INFO )
2742*
2743* -- PBLAS test routine (version 2.0) --
2744* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2745* and University of California, Berkeley.
2746* April 1, 1998
2747*
2748* .. Scalar Arguments ..
2749 INTEGER DPOS0, IA, ICTXT, INFO, JA, M, MPOS0, N, NPOS0
2750* ..
2751* .. Array Arguments ..
2752 INTEGER DESCA( * )
2753* ..
2754*
2755* Purpose
2756* =======
2757*
2758* PB_CHKMAT checks the validity of a descriptor vector DESCA, the re-
2759* lated global indexes IA, JA from a local view point. If an inconsis-
2760* tency is found among its parameters IA, JA and DESCA, the routine re-
2761* turns an error code in INFO.
2762*
2763* Arguments
2764* =========
2765*
2766* ICTXT (local input) INTEGER
2767* On entry, ICTXT specifies the BLACS context handle, indica-
2768* ting the global context of the operation. The context itself
2769* is global, but the value of ICTXT is local.
2770*
2771* M (global input) INTEGER
2772* On entry, M specifies the number of rows the submatrix
2773* sub( A ).
2774*
2775* MPOS0 (global input) INTEGER
2776* On entry, MPOS0 specifies the position in the calling rou-
2777* tine's parameter list where the formal parameter M appears.
2778*
2779* N (global input) INTEGER
2780* On entry, N specifies the number of columns the submatrix
2781* sub( A ).
2782*
2783* NPOS0 (global input) INTEGER
2784* On entry, NPOS0 specifies the position in the calling rou-
2785* tine's parameter list where the formal parameter N appears.
2786*
2787* IA (global input) INTEGER
2788* On entry, IA specifies A's global row index, which points to
2789* the beginning of the submatrix sub( A ).
2790*
2791* JA (global input) INTEGER
2792* On entry, JA specifies A's global column index, which points
2793* to the beginning of the submatrix sub( A ).
2794*
2795* DESCA (global and local input) INTEGER array
2796* On entry, DESCA is an integer array of dimension DLEN_. This
2797* is the array descriptor for the matrix A.
2798*
2799* DPOS0 (global input) INTEGER
2800* On entry, DPOS0 specifies the position in the calling rou-
2801* tine's parameter list where the formal parameter DESCA ap-
2802* pears. Note that it is assumed that IA and JA are respecti-
2803* vely 2 and 1 entries behind DESCA.
2804*
2805* INFO (local input/local output) INTEGER
2806* = 0: successful exit
2807* < 0: If the i-th argument is an array and the j-entry had an
2808* illegal value, then INFO = -(i*100+j), if the i-th
2809* argument is a scalar and had an illegal value, then
2810* INFO = -i.
2811*
2812* -- Written on April 1, 1998 by
2813* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
2814*
2815* =====================================================================
2816*
2817* .. Parameters ..
2818 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2819 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2820 $ RSRC_
2821 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2822 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2823 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2824 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2825 INTEGER DESCMULT, BIGNUM
2826 PARAMETER ( DESCMULT = 100, BIGNUM = DESCMULT*DESCMULT )
2827* ..
2828* .. Local Scalars ..
2829 INTEGER DPOS, IAPOS, JAPOS, MP, MPOS, MYCOL, MYROW,
2830 $ NPCOL, NPOS, NPROW, NQ
2831* ..
2832* .. Local Arrays ..
2833 INTEGER DESCA2( DLEN_ )
2834* ..
2835* .. External Subroutines ..
2836 EXTERNAL BLACS_GRIDINFO, PB_DESCTRANS
2837* ..
2838* .. External Functions ..
2839 INTEGER PB_NUMROC
2840 EXTERNAL PB_NUMROC
2841* ..
2842* .. Intrinsic Functions ..
2843 INTRINSIC MIN, MAX
2844* ..
2845* .. Executable Statements ..
2846*
2847* Convert descriptor
2848*
2849 CALL PB_DESCTRANS( DESCA, DESCA2 )
2850*
2851* Want to find errors with MIN( ), so if no error, set it to a big
2852* number. If there already is an error, multiply by the the des-
2853* criptor multiplier
2854*
2855.GE. IF( INFO0 ) THEN
2856 INFO = BIGNUM
2857.LT. ELSE IF( INFO-DESCMULT ) THEN
2858 INFO = -INFO
2859 ELSE
2860 INFO = -INFO * DESCMULT
2861 END IF
2862*
2863* Figure where in parameter list each parameter was, factoring in
2864* descriptor multiplier
2865*
2866 MPOS = MPOS0 * DESCMULT
2867 NPOS = NPOS0 * DESCMULT
2868 IAPOS = ( DPOS0 - 2 ) * DESCMULT
2869 JAPOS = ( DPOS0 - 1 ) * DESCMULT
2870 DPOS = DPOS0 * DESCMULT
2871*
2872* Get grid parameters
2873*
2874 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
2875*
2876* Check that matrix values make sense from local viewpoint
2877*
2878.LT. IF( M0 )
2879 $ INFO = MIN( INFO, MPOS )
2880.LT. IF( N0 )
2881 $ INFO = MIN( INFO, NPOS )
2882.LT. IF( IA1 )
2883 $ INFO = MIN( INFO, IAPOS )
2884.LT. IF( JA1 )
2885 $ INFO = MIN( INFO, JAPOS )
2886.NE. IF( DESCA2( DTYPE_ )BLOCK_CYCLIC_2D_INB )
2887 $ INFO = MIN( INFO, DPOS + DTYPE_ )
2888.LT. IF( DESCA2( IMB_ )1 )
2889 $ INFO = MIN( INFO, DPOS + IMB_ )
2890.LT. IF( DESCA2( INB_ )1 )
2891 $ INFO = MIN( INFO, DPOS + INB_ )
2892.LT. IF( DESCA2( MB_ )1 )
2893 $ INFO = MIN( INFO, DPOS + MB_ )
2894.LT. IF( DESCA2( NB_ )1 )
2895 $ INFO = MIN( INFO, DPOS + NB_ )
2896.LT..OR..GE. IF( DESCA2( RSRC_ )-1 DESCA2( RSRC_ )NPROW )
2897 $ INFO = MIN( INFO, DPOS + RSRC_ )
2898.LT..OR..GE. IF( DESCA2( CSRC_ )-1 DESCA2( CSRC_ )NPCOL )
2899 $ INFO = MIN( INFO, DPOS + CSRC_ )
2900.NE. IF( DESCA2( CTXT_ )ICTXT )
2901 $ INFO = MIN( INFO, DPOS + CTXT_ )
2902*
2903.EQ..OR..EQ. IF( M0 N0 ) THEN
2904*
2905* NULL matrix, relax some checks
2906*
2907.LT. IF( DESCA2( M_ )0 )
2908 $ INFO = MIN( INFO, DPOS + M_ )
2909.LT. IF( DESCA2( N_ )0 )
2910 $ INFO = MIN( INFO, DPOS + N_ )
2911.LT. IF( DESCA2( LLD_ )1 )
2912 $ INFO = MIN( INFO, DPOS + LLD_ )
2913*
2914 ELSE
2915*
2916* more rigorous checks for non-degenerate matrices
2917*
2918 MP = PB_NUMROC( DESCA2( M_ ), 1, DESCA2( IMB_ ), DESCA2( MB_ ),
2919 $ MYROW, DESCA2( RSRC_ ), NPROW )
2920*
2921.LT. IF( DESCA2( M_ )1 )
2922 $ INFO = MIN( INFO, DPOS + M_ )
2923.LT. IF( DESCA2( N_ )1 )
2924 $ INFO = MIN( INFO, DPOS + N_ )
2925.GT. IF( IADESCA2( M_ ) )
2926 $ INFO = MIN( INFO, IAPOS )
2927.GT. IF( JADESCA2( N_ ) )
2928 $ INFO = MIN( INFO, JAPOS )
2929.GT. IF( IA+M-1DESCA2( M_ ) )
2930 $ INFO = MIN( INFO, MPOS )
2931.GT. IF( JA+N-1DESCA2( N_ ) )
2932 $ INFO = MIN( INFO, NPOS )
2933*
2934.LT. IF( DESCA2( LLD_ )MAX( 1, MP ) ) THEN
2935 NQ = PB_NUMROC( DESCA2( N_ ), 1, DESCA2( INB_ ),
2936 $ DESCA2( NB_ ), MYCOL, DESCA2( CSRC_ ),
2937 $ NPCOL )
2938.LT. IF( DESCA2( LLD_ )1 ) THEN
2939 INFO = MIN( INFO, DPOS + LLD_ )
2940.GT. ELSE IF( NQ0 ) THEN
2941 INFO = MIN( INFO, DPOS + LLD_ )
2942 END IF
2943 END IF
2944*
2945 END IF
2946*
2947* Prepare output: set info = 0 if no error, and divide by
2948* DESCMULT if error is not in a descriptor entry
2949*
2950.EQ. IF( INFOBIGNUM ) THEN
2951 INFO = 0
2952.EQ. ELSE IF( MOD( INFO, DESCMULT )0 ) THEN
2953 INFO = -( INFO / DESCMULT )
2954 ELSE
2955 INFO = -INFO
2956 END IF
2957*
2958 RETURN
2959*
2960* End of PB_CHKMAT
2961*
2962 END
2963 SUBROUTINE PB_DESCTRANS( DESCIN, DESCOUT )
2964*
2965* -- PBLAS test routine (version 2.0) --
2966* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2967* and University of California, Berkeley.
2968* April 1, 1998
2969*
2970* .. Array Arguments ..
2971 INTEGER DESCIN( * ), DESCOUT( * )
2972* ..
2973*
2974* Purpose
2975* =======
2976*
2977* PB_DESCTRANS converts a descriptor DESCIN of type BLOCK_CYCLIC_2D
2978* or BLOCK_CYCLIC_INB_2D into a descriptor DESCOUT of type
2979* BLOCK_CYCLIC_INB_2D.
2980*
2981* Notes
2982* =====
2983*
2984* A description vector is associated with each 2D block-cyclicly dis-
2985* tributed matrix. This vector stores the information required to
2986* establish the mapping between a matrix entry and its corresponding
2987* process and memory location.
2988*
2989* In the following comments, the character _ should be read as
2990* "of the distributed matrix". Let A be a generic term for any 2D
2991* block cyclicly distributed matrix. Its description vector is DESCA:
2992*
2993* NOTATION STORED IN EXPLANATION
2994* ---------------- --------------- -----------------------------------
2995* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
2996* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
2997* the NPROW x NPCOL BLACS process
2998* grid A is distributed over. The
2999* context itself is global, but the
3000* handle (the integer value) may
3001* vary.
3002* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3003* buted matrix A, M_A >= 0.
3004* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3005* tributed matrix A, N_A >= 0.
3006* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3007* bute the rows of A, MB_A > 0.
3008* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3009* bute the columns of A, NB_A > 0.
3010* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3011* first row of the matrix A is dis-
3012* tributed, NPROW > RSRC_A >= 0.
3013* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3014* first column of A is distributed.
3015* NPCOL > CSRC_A >= 0.
3016* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3017* array storing the local blocks of
3018* the distributed matrix A,
3019* IF( Lc( 1, N_A ) > 0 )
3020* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3021* ELSE
3022* LLD_A >= 1.
3023*
3024* Let K be the number of rows of a matrix A starting at the global in-
3025* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3026* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3027* receive if these K rows were distributed over NPROW processes. If K
3028* is the number of columns of a matrix A starting at the global index
3029* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3030* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3031* these K columns were distributed over NPCOL processes.
3032*
3033* The values of Lr() and Lc() may be determined via a call to the func-
3034* tion PB_NUMROC:
3035* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3036* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3037*
3038* A description vector is associated with each 2D block-cyclicly dis-
3039* tributed matrix. This vector stores the information required to
3040* establish the mapping between a matrix entry and its corresponding
3041* process and memory location.
3042*
3043* In the following comments, the character _ should be read as
3044* "of the distributed matrix". Let A be a generic term for any 2D
3045* block cyclicly distributed matrix. Its description vector is DESCA:
3046*
3047* NOTATION STORED IN EXPLANATION
3048* ---------------- --------------- ------------------------------------
3049* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3050* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3051* the NPROW x NPCOL BLACS process grid
3052* A is distributed over. The context
3053* itself is global, but the handle
3054* (the integer value) may vary.
3055* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3056* ted matrix A, M_A >= 0.
3057* N_A (global) DESCA( N_ ) The number of columns in the distri-
3058* buted matrix A, N_A >= 0.
3059* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3060* block of the matrix A, IMB_A > 0.
3061* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3062* left block of the matrix A,
3063* INB_A > 0.
3064* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3065* bute the last M_A-IMB_A rows of A,
3066* MB_A > 0.
3067* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3068* bute the last N_A-INB_A columns of
3069* A, NB_A > 0.
3070* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3071* row of the matrix A is distributed,
3072* NPROW > RSRC_A >= 0.
3073* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3074* first column of A is distributed.
3075* NPCOL > CSRC_A >= 0.
3076* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3077* array storing the local blocks of
3078* the distributed matrix A,
3079* IF( Lc( 1, N_A ) > 0 )
3080* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3081* ELSE
3082* LLD_A >= 1.
3083*
3084* Let K be the number of rows of a matrix A starting at the global in-
3085* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3086* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3087* receive if these K rows were distributed over NPROW processes. If K
3088* is the number of columns of a matrix A starting at the global index
3089* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3090* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3091* these K columns were distributed over NPCOL processes.
3092*
3093* The values of Lr() and Lc() may be determined via a call to the func-
3094* tion PB_NUMROC:
3095* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3096* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3097*
3098* Arguments
3099* =========
3100*
3101* DESCIN (global and local input) INTEGER array
3102* On entry, DESCIN is an array of dimension DLEN1_ or DLEN_ as
3103* specified by its first entry DESCIN( DTYPE_ ). DESCIN is the
3104* source array descriptor of type BLOCK_CYCLIC_2D or of type
3105* BLOCK_CYCLIC_2D_INB.
3106*
3107* DESCOUT (global and local output) INTEGER array
3108* On entry, DESCOUT is an array of dimension DLEN_. DESCOUT is
3109* the target array descriptor of type BLOCK_CYCLIC_2D_INB.
3110*
3111* -- Written on April 1, 1998 by
3112* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3113*
3114* =====================================================================
3115*
3116* .. Parameters ..
3117 INTEGER BLOCK_CYCLIC_2D, CSRC1_, CTXT1_, DLEN1_,
3118 $ DTYPE1_, LLD1_, M1_, MB1_, N1_, NB1_, RSRC1_
3119 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN1_ = 9, DTYPE1_ = 1,
3120 $ CTXT1_ = 2, M1_ = 3, N1_ = 4, MB1_ = 5,
3121 $ NB1_ = 6, RSRC1_ = 7, CSRC1_ = 8, LLD1_ = 9 )
3122 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3123 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3124 $ RSRC_
3125 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
3126 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
3127 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
3128 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
3129* ..
3130* .. Local Scalars ..
3131 INTEGER I
3132* ..
3133* .. Executable Statements ..
3134*
3135.EQ. IF( DESCIN( DTYPE_ )BLOCK_CYCLIC_2D ) THEN
3136 DESCOUT( DTYPE_ ) = BLOCK_CYCLIC_2D_INB
3137 DESCOUT( CTXT_ ) = DESCIN( CTXT1_ )
3138 DESCOUT( M_ ) = DESCIN( M1_ )
3139 DESCOUT( N_ ) = DESCIN( N1_ )
3140 DESCOUT( IMB_ ) = DESCIN( MB1_ )
3141 DESCOUT( INB_ ) = DESCIN( NB1_ )
3142 DESCOUT( MB_ ) = DESCIN( MB1_ )
3143 DESCOUT( NB_ ) = DESCIN( NB1_ )
3144 DESCOUT( RSRC_ ) = DESCIN( RSRC1_ )
3145 DESCOUT( CSRC_ ) = DESCIN( CSRC1_ )
3146 DESCOUT( LLD_ ) = DESCIN( LLD1_ )
3147.EQ. ELSE IF( DESCIN( DTYPE_ )BLOCK_CYCLIC_2D_INB ) THEN
3148 DO 10 I = 1, DLEN_
3149 DESCOUT( I ) = DESCIN( I )
3150 10 CONTINUE
3151 ELSE
3152 DESCOUT( DTYPE_ ) = DESCIN( 1 )
3153 DESCOUT( CTXT_ ) = DESCIN( 2 )
3154 DESCOUT( M_ ) = 0
3155 DESCOUT( N_ ) = 0
3156 DESCOUT( IMB_ ) = 1
3157 DESCOUT( INB_ ) = 1
3158 DESCOUT( MB_ ) = 1
3159 DESCOUT( NB_ ) = 1
3160 DESCOUT( RSRC_ ) = 0
3161 DESCOUT( CSRC_ ) = 0
3162 DESCOUT( LLD_ ) = 1
3163 END IF
3164*
3165 RETURN
3166*
3167* End of PB_DESCTRANS
3168*
3169 END
3170 SUBROUTINE PB_DESCSET2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC,
3171 $ CTXT, LLD )
3172*
3173* -- PBLAS test routine (version 2.0) --
3174* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3175* and University of California, Berkeley.
3176* April 1, 1998
3177*
3178* .. Scalar Arguments ..
3179 INTEGER CSRC, CTXT, IMB, INB, LLD, M, MB, N, NB, RSRC
3180* ..
3181* .. Array Arguments ..
3182 INTEGER DESC( * )
3183* ..
3184*
3185* Purpose
3186* =======
3187*
3188* PB_DESCSET2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3189* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3190* BLOCK_CYCLIC_2D_INB.
3191*
3192* Notes
3193* =====
3194*
3195* A description vector is associated with each 2D block-cyclicly dis-
3196* tributed matrix. This vector stores the information required to
3197* establish the mapping between a matrix entry and its corresponding
3198* process and memory location.
3199*
3200* In the following comments, the character _ should be read as
3201* "of the distributed matrix". Let A be a generic term for any 2D
3202* block cyclicly distributed matrix. Its description vector is DESCA:
3203*
3204* NOTATION STORED IN EXPLANATION
3205* ---------------- --------------- -----------------------------------
3206* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
3207* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
3208* the NPROW x NPCOL BLACS process
3209* grid A is distributed over. The
3210* context itself is global, but the
3211* handle (the integer value) may
3212* vary.
3213* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3214* buted matrix A, M_A >= 0.
3215* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3216* tributed matrix A, N_A >= 0.
3217* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3218* bute the rows of A, MB_A > 0.
3219* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3220* bute the columns of A, NB_A > 0.
3221* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3222* first row of the matrix A is dis-
3223* tributed, NPROW > RSRC_A >= 0.
3224* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3225* first column of A is distributed.
3226* NPCOL > CSRC_A >= 0.
3227* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3228* array storing the local blocks of
3229* the distributed matrix A,
3230* IF( Lc( 1, N_A ) > 0 )
3231* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3232* ELSE
3233* LLD_A >= 1.
3234*
3235* Let K be the number of rows of a matrix A starting at the global in-
3236* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3237* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3238* receive if these K rows were distributed over NPROW processes. If K
3239* is the number of columns of a matrix A starting at the global index
3240* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3241* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3242* these K columns were distributed over NPCOL processes.
3243*
3244* The values of Lr() and Lc() may be determined via a call to the func-
3245* tion PB_NUMROC:
3246* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3247* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3248*
3249* Arguments
3250* =========
3251*
3252* DESC (global and local output) INTEGER array
3253* On entry, DESC is an array of dimension DLEN_. DESC is the
3254* array descriptor to be set.
3255*
3256* M (global input) INTEGER
3257* On entry, M specifies the number of rows of the matrix.
3258* M must be at least zero.
3259*
3260* N (global input) INTEGER
3261* On entry, N specifies the number of columns of the matrix.
3262* N must be at least zero.
3263*
3264* IMB (global input) INTEGER
3265* On entry, IMB specifies the row size of the first block of
3266* the global matrix distribution. IMB must be at least one.
3267*
3268* INB (global input) INTEGER
3269* On entry, INB specifies the column size of the first block
3270* of the global matrix distribution. INB must be at least one.
3271*
3272* MB (global input) INTEGER
3273* On entry, MB specifies the row size of the blocks used to
3274* partition the matrix. MB must be at least one.
3275*
3276* NB (global input) INTEGER
3277* On entry, NB specifies the column size of the blocks used to
3278* partition the matrix. NB must be at least one.
3279*
3280* RSRC (global input) INTEGER
3281* On entry, RSRC specifies the row coordinate of the process
3282* that possesses the first row of the matrix. When RSRC = -1,
3283* the data is not distributed but replicated, otherwise RSRC
3284* must be at least zero and strictly less than NPROW.
3285*
3286* CSRC (global input) INTEGER
3287* On entry, CSRC specifies the column coordinate of the pro-
3288* cess that possesses the first column of the matrix. When
3289* CSRC = -1, the data is not distributed but replicated, other-
3290* wise CSRC must be at least zero and strictly less than NPCOL.
3291*
3292* CTXT (local input) INTEGER
3293* On entry, CTXT specifies the BLACS context handle, indicating
3294* the global communication context. The value of the context
3295* itself is local.
3296*
3297* LLD (local input) INTEGER
3298* On entry, LLD specifies the leading dimension of the local
3299* array storing the local entries of the matrix. LLD must be at
3300* least MAX( 1, Lr(1,M) ).
3301*
3302* -- Written on April 1, 1998 by
3303* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3304*
3305* =====================================================================
3306*
3307* .. Parameters ..
3308 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3309 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3310 $ RSRC_
3311 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
3312 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
3313 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
3314 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
3315* ..
3316* .. Executable Statements ..
3317*
3318 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D_INB
3319 DESC( CTXT_ ) = CTXT
3320 DESC( M_ ) = M
3321 DESC( N_ ) = N
3322 DESC( IMB_ ) = IMB
3323 DESC( INB_ ) = INB
3324 DESC( MB_ ) = MB
3325 DESC( NB_ ) = NB
3326 DESC( RSRC_ ) = RSRC
3327 DESC( CSRC_ ) = CSRC
3328 DESC( LLD_ ) = LLD
3329*
3330 RETURN
3331*
3332* End of PB_DESCSET2
3333*
3334 END
3335 SUBROUTINE PB_DESCINIT2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC,
3336 $ CTXT, LLD, INFO )
3337*
3338* -- PBLAS test routine (version 2.0) --
3339* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3340* and University of California, Berkeley.
3341* April 1, 1998
3342*
3343* .. Scalar Arguments ..
3344 INTEGER CSRC, CTXT, IMB, INB, INFO, LLD, M, MB, N, NB,
3345 $ RSRC
3346* ..
3347* .. Array Arguments ..
3348 INTEGER DESC( * )
3349* ..
3350*
3351* Purpose
3352* =======
3353*
3354* PB_DESCINIT2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3355* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3356* BLOCK_CYCLIC_2D_INB.
3357*
3358* Notes
3359* =====
3360*
3361* A description vector is associated with each 2D block-cyclicly dis-
3362* tributed matrix. This vector stores the information required to
3363* establish the mapping between a matrix entry and its corresponding
3364* process and memory location.
3365*
3366* In the following comments, the character _ should be read as
3367* "of the distributed matrix". Let A be a generic term for any 2D
3368* block cyclicly distributed matrix. Its description vector is DESCA:
3369*
3370* NOTATION STORED IN EXPLANATION
3371* ---------------- --------------- ------------------------------------
3372* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3373* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3374* the NPROW x NPCOL BLACS process grid
3375* A is distributed over. The context
3376* itself is global, but the handle
3377* (the integer value) may vary.
3378* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3379* ted matrix A, M_A >= 0.
3380* N_A (global) DESCA( N_ ) The number of columns in the distri-
3381* buted matrix A, N_A >= 0.
3382* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3383* block of the matrix A, IMB_A > 0.
3384* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3385* left block of the matrix A,
3386* INB_A > 0.
3387* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3388* bute the last M_A-IMB_A rows of A,
3389* MB_A > 0.
3390* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3391* bute the last N_A-INB_A columns of
3392* A, NB_A > 0.
3393* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3394* row of the matrix A is distributed,
3395* NPROW > RSRC_A >= 0.
3396* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3397* first column of A is distributed.
3398* NPCOL > CSRC_A >= 0.
3399* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3400* array storing the local blocks of
3401* the distributed matrix A,
3402* IF( Lc( 1, N_A ) > 0 )
3403* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3404* ELSE
3405* LLD_A >= 1.
3406*
3407* Let K be the number of rows of a matrix A starting at the global in-
3408* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3409* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3410* receive if these K rows were distributed over NPROW processes. If K
3411* is the number of columns of a matrix A starting at the global index
3412* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3413* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3414* these K columns were distributed over NPCOL processes.
3415*
3416* The values of Lr() and Lc() may be determined via a call to the func-
3417* tion PB_NUMROC:
3418* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3419* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3420*
3421* Arguments
3422* =========
3423*
3424* DESC (global and local output) INTEGER array
3425* On entry, DESC is an array of dimension DLEN_. DESC is the
3426* array descriptor to be set.
3427*
3428* M (global input) INTEGER
3429* On entry, M specifies the number of rows of the matrix.
3430* M must be at least zero.
3431*
3432* N (global input) INTEGER
3433* On entry, N specifies the number of columns of the matrix.
3434* N must be at least zero.
3435*
3436* IMB (global input) INTEGER
3437* On entry, IMB specifies the row size of the first block of
3438* the global matrix distribution. IMB must be at least one.
3439*
3440* INB (global input) INTEGER
3441* On entry, INB specifies the column size of the first block
3442* of the global matrix distribution. INB must be at least one.
3443*
3444* MB (global input) INTEGER
3445* On entry, MB specifies the row size of the blocks used to
3446* partition the matrix. MB must be at least one.
3447*
3448* NB (global input) INTEGER
3449* On entry, NB specifies the column size of the blocks used to
3450* partition the matrix. NB must be at least one.
3451*
3452* RSRC (global input) INTEGER
3453* On entry, RSRC specifies the row coordinate of the process
3454* that possesses the first row of the matrix. When RSRC = -1,
3455* the data is not distributed but replicated, otherwise RSRC
3456* must be at least zero and strictly less than NPROW.
3457*
3458* CSRC (global input) INTEGER
3459* On entry, CSRC specifies the column coordinate of the pro-
3460* cess that possesses the first column of the matrix. When
3461* CSRC = -1, the data is not distributed but replicated, other-
3462* wise CSRC must be at least zero and strictly less than NPCOL.
3463*
3464* CTXT (local input) INTEGER
3465* On entry, CTXT specifies the BLACS context handle, indicating
3466* the global communication context. The value of the context
3467* itself is local.
3468*
3469* LLD (local input) INTEGER
3470* On entry, LLD specifies the leading dimension of the local
3471* array storing the local entries of the matrix. LLD must be at
3472* least MAX( 1, Lr(1,M) ).
3473*
3474* INFO (local output) INTEGER
3475* = 0: successful exit
3476* < 0: if INFO = -i, the i-th argument had an illegal value.
3477*
3478* Notes
3479* =====
3480*
3481* If the routine can recover from an erroneous input argument, it will
3482* return an acceptable descriptor vector. For example, if LLD = 0 on
3483* input, DESC( LLD_ ) will contain the smallest leading dimension re-
3484* quired to store the specified m by n matrix, INFO will however be set
3485* to -11 on exit in that case.
3486*
3487* -- Written on April 1, 1998 by
3488* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3489*
3490* =====================================================================
3491*
3492* .. Parameters ..
3493 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3494 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3495 $ RSRC_
3496 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
3497 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
3498 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
3499 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
3500* ..
3501* .. Local Scalars ..
3502 INTEGER LLDMIN, MP, MYCOL, MYROW, NPCOL, NPROW
3503* ..
3504* .. External Subroutines ..
3505 EXTERNAL BLACS_GRIDINFO, PXERBLA
3506* ..
3507* .. External Functions ..
3508 INTEGER PB_NUMROC
3509 EXTERNAL PB_NUMROC
3510* ..
3511* .. Intrinsic Functions ..
3512 INTRINSIC MAX, MIN
3513* ..
3514* .. Executable Statements ..
3515*
3516* Get grid parameters
3517*
3518 CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL )
3519*
3520 INFO = 0
3521.LT. IF( M0 ) THEN
3522 INFO = -2
3523.LT. ELSE IF( N0 ) THEN
3524 INFO = -3
3525.LT. ELSE IF( IMB1 ) THEN
3526 INFO = -4
3527.LT. ELSE IF( INB1 ) THEN
3528 INFO = -5
3529.LT. ELSE IF( MB1 ) THEN
3530 INFO = -6
3531.LT. ELSE IF( NB1 ) THEN
3532 INFO = -7
3533.LT..OR..GE. ELSE IF( RSRC-1 RSRCNPROW ) THEN
3534 INFO = -8
3535.LT..OR..GE. ELSE IF( CSRC-1 CSRCNPCOL ) THEN
3536 INFO = -9
3537.EQ. ELSE IF( NPROW-1 ) THEN
3538 INFO = -10
3539 END IF
3540*
3541* Compute minimum LLD if safe (to avoid division by 0)
3542*
3543.EQ. IF( INFO0 ) THEN
3544 MP = PB_NUMROC( M, 1, IMB, MB, MYROW, RSRC, NPROW )
3545.GT. IF( PB_NUMROC( N, 1, INB, NB, MYCOL, CSRC, NPCOL )0 ) THEN
3546 LLDMIN = MAX( 1, MP )
3547 ELSE
3548 LLDMIN = 1
3549 END IF
3550.LT. IF( LLDLLDMIN )
3551 $ INFO = -11
3552 END IF
3553*
3554.NE. IF( INFO0 )
3555 $ CALL PXERBLA( CTXT, 'pb_descinit2', -INFO )
3556*
3557 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D_INB
3558 DESC( CTXT_ ) = CTXT
3559 DESC( M_ ) = MAX( 0, M )
3560 DESC( N_ ) = MAX( 0, N )
3561 DESC( IMB_ ) = MAX( 1, IMB )
3562 DESC( INB_ ) = MAX( 1, INB )
3563 DESC( MB_ ) = MAX( 1, MB )
3564 DESC( NB_ ) = MAX( 1, NB )
3565 DESC( RSRC_ ) = MAX( -1, MIN( RSRC, NPROW-1 ) )
3566 DESC( CSRC_ ) = MAX( -1, MIN( CSRC, NPCOL-1 ) )
3567 DESC( LLD_ ) = MAX( LLD, LLDMIN )
3568*
3569 RETURN
3570*
3571* End of PB_DESCINIT2
3572*
3573 END
3574 SUBROUTINE PB_BINFO( OFFD, M, N, IMB1, INB1, MB, NB, MRROW, MRCOL,
3575 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
3576 $ LNBLOC, ILOW, LOW, IUPP, UPP )
3577*
3578* -- PBLAS test routine (version 2.0) --
3579* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3580* and University of California, Berkeley.
3581* April 1, 1998
3582*
3583* .. Scalar Arguments ..
3584 INTEGER ILOW, IMB1, IMBLOC, INB1, INBLOC, IUPP, LCMT00,
3585 $ LMBLOC, LNBLOC, LOW, M, MB, MBLKS, MRCOL,
3586 $ MRROW, N, NB, NBLKS, OFFD, UPP
3587* ..
3588*
3589* Purpose
3590* =======
3591*
3592* PB_BINFO initializes the local information of an m by n local array
3593* owned by the process of relative coordinates ( MRROW, MRCOL ). Note
3594* that if m or n is less or equal than zero, there is no data, in which
3595* case this process does not need the local information computed by
3596* this routine to proceed.
3597*
3598* Arguments
3599* =========
3600*
3601* OFFD (global input) INTEGER
3602* On entry, OFFD specifies the off-diagonal of the underlying
3603* matrix of interest as follows:
3604* OFFD = 0 specifies the main diagonal,
3605* OFFD > 0 specifies lower subdiagonals, and
3606* OFFD < 0 specifies upper superdiagonals.
3607*
3608* M (local input) INTEGER
3609* On entry, M specifies the local number of rows of the under-
3610* lying matrix owned by the process of relative coordinates
3611* ( MRROW, MRCOL ). M must be at least zero.
3612*
3613* N (local input) INTEGER
3614* On entry, N specifies the local number of columns of the un-
3615* derlying matrix owned by the process of relative coordinates
3616* ( MRROW, MRCOL ). N must be at least zero.
3617*
3618* IMB1 (global input) INTEGER
3619* On input, IMB1 specifies the global true size of the first
3620* block of rows of the underlying global submatrix. IMB1 must
3621* be at least MIN( 1, M ).
3622*
3623* INB1 (global input) INTEGER
3624* On input, INB1 specifies the global true size of the first
3625* block of columns of the underlying global submatrix. INB1
3626* must be at least MIN( 1, N ).
3627*
3628* MB (global input) INTEGER
3629* On entry, MB specifies the blocking factor used to partition
3630* the rows of the matrix. MB must be at least one.
3631*
3632* NB (global input) INTEGER
3633* On entry, NB specifies the blocking factor used to partition
3634* the the columns of the matrix. NB must be at least one.
3635*
3636* MRROW (local input) INTEGER
3637* On entry, MRROW specifies the relative row coordinate of the
3638* process that possesses these M rows. MRROW must be least zero
3639* and strictly less than NPROW.
3640*
3641* MRCOL (local input) INTEGER
3642* On entry, MRCOL specifies the relative column coordinate of
3643* the process that possesses these N columns. MRCOL must be
3644* least zero and strictly less than NPCOL.
3645*
3646* LCMT00 (local output) INTEGER
3647* On exit, LCMT00 is the LCM value of the left upper block of
3648* this m by n local block owned by the process of relative co-
3649* ordinates ( MRROW, MRCOL ).
3650*
3651* MBLKS (local output) INTEGER
3652* On exit, MBLKS specifies the local number of blocks of rows
3653* corresponding to M. MBLKS must be at least zero.
3654*
3655* NBLKS (local output) INTEGER
3656* On exit, NBLKS specifies the local number of blocks of co-
3657* lumns corresponding to N. NBLKS must be at least zero.
3658*
3659* IMBLOC (local output) INTEGER
3660* On exit, IMBLOC specifies the number of rows (size) of the
3661* uppest blocks of this m by n local array owned by the process
3662* of relative coordinates ( MRROW, MRCOL ). IMBLOC is at least
3663* MIN( 1, M ).
3664*
3665* INBLOC (local output) INTEGER
3666* On exit, INBLOC specifies the number of columns (size) of
3667* the leftmost blocks of this m by n local array owned by the
3668* process of relative coordinates ( MRROW, MRCOL ). INBLOC is
3669* at least MIN( 1, N ).
3670*
3671* LMBLOC (local output) INTEGER
3672* On exit, LMBLOC specifies the number of rows (size) of the
3673* lowest blocks of this m by n local array owned by the process
3674* of relative coordinates ( MRROW, MRCOL ). LMBLOC is at least
3675* MIN( 1, M ).
3676*
3677* LNBLOC (local output) INTEGER
3678* On exit, LNBLOC specifies the number of columns (size) of the
3679* rightmost blocks of this m by n local array owned by the
3680* process of relative coordinates ( MRROW, MRCOL ). LNBLOC is
3681* at least MIN( 1, N ).
3682*
3683* ILOW (local output) INTEGER
3684* On exit, ILOW is the lower bound characterizing the first co-
3685* lumn block owning offdiagonals of this m by n array. ILOW
3686* must be less or equal than zero.
3687*
3688* LOW (global output) INTEGER
3689* On exit, LOW is the lower bound characterizing the column
3690* blocks with te exception of the first one (see ILOW) owning
3691* offdiagonals of this m by n array. LOW must be less or equal
3692* than zero.
3693*
3694* IUPP (local output) INTEGER
3695* On exit, IUPP is the upper bound characterizing the first row
3696* block owning offdiagonals of this m by n array. IUPP must be
3697* greater or equal than zero.
3698*
3699* UPP (global output) INTEGER
3700* On exit, UPP is the upper bound characterizing the row
3701* blocks with te exception of the first one (see IUPP) owning
3702* offdiagonals of this m by n array. UPP must be greater or
3703* equal than zero.
3704*
3705* -- Written on April 1, 1998 by
3706* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3707*
3708* =====================================================================
3709*
3710* .. Local Scalars ..
3711 INTEGER TMP1
3712* ..
3713* .. Intrinsic Functions ..
3714 INTRINSIC MAX, MIN
3715* ..
3716* .. Executable Statements ..
3717*
3718* Initialize LOW, ILOW, UPP, IUPP, LMBLOC, LNBLOC, IMBLOC, INBLOC,
3719* MBLKS, NBLKS and LCMT00.
3720*
3721 LOW = 1 - NB
3722 UPP = MB - 1
3723*
3724 LCMT00 = OFFD
3725*
3726.LE..OR..LE. IF( M0 N0 ) THEN
3727*
3728.GT. IF( MRROW0 ) THEN
3729 IUPP = MB - 1
3730 ELSE
3731 IUPP = MAX( 0, IMB1 - 1 )
3732 END IF
3733 IMBLOC = 0
3734 MBLKS = 0
3735 LMBLOC = 0
3736*
3737.GT. IF( MRCOL0 ) THEN
3738 ILOW = 1 - NB
3739 ELSE
3740 ILOW = MIN( 0, 1 - INB1 )
3741 END IF
3742 INBLOC = 0
3743 NBLKS = 0
3744 LNBLOC = 0
3745*
3746 LCMT00 = LCMT00 + ( LOW - ILOW + MRCOL * NB ) -
3747 $ ( IUPP - UPP + MRROW * MB )
3748*
3749 RETURN
3750*
3751 END IF
3752*
3753.GT. IF( MRROW0 ) THEN
3754*
3755 IMBLOC = MIN( M, MB )
3756 IUPP = MB - 1
3757 LCMT00 = LCMT00 - ( IMB1 - MB + MRROW * MB )
3758 MBLKS = ( M - 1 ) / MB + 1
3759 LMBLOC = M - ( M / MB ) * MB
3760.EQ. IF( LMBLOC0 )
3761 $ LMBLOC = MB
3762*
3763.GT. IF( MRCOL0 ) THEN
3764*
3765 INBLOC = MIN( N, NB )
3766 ILOW = 1 - NB
3767 LCMT00 = LCMT00 + INB1 - NB + MRCOL * NB
3768 NBLKS = ( N - 1 ) / NB + 1
3769 LNBLOC = N - ( N / NB ) * NB
3770.EQ. IF( LNBLOC0 )
3771 $ LNBLOC = NB
3772*
3773 ELSE
3774*
3775 INBLOC = INB1
3776 ILOW = 1 - INB1
3777 TMP1 = N - INB1
3778.GT. IF( TMP10 ) THEN
3779*
3780* more than one block
3781*
3782 NBLKS = ( TMP1 - 1 ) / NB + 2
3783 LNBLOC = TMP1 - ( TMP1 / NB ) * NB
3784.EQ. IF( LNBLOC0 )
3785 $ LNBLOC = NB
3786*
3787 ELSE
3788*
3789 NBLKS = 1
3790 LNBLOC = INB1
3791*
3792 END IF
3793*
3794 END IF
3795*
3796 ELSE
3797*
3798 IMBLOC = IMB1
3799 IUPP = IMB1 - 1
3800 TMP1 = M - IMB1
3801.GT. IF( TMP10 ) THEN
3802*
3803* more than one block
3804*
3805 MBLKS = ( TMP1 - 1 ) / MB + 2
3806 LMBLOC = TMP1 - ( TMP1 / MB ) * MB
3807.EQ. IF( LMBLOC0 )
3808 $ LMBLOC = MB
3809*
3810 ELSE
3811*
3812 MBLKS = 1
3813 LMBLOC = IMB1
3814*
3815 END IF
3816*
3817.GT. IF( MRCOL0 ) THEN
3818*
3819 INBLOC = MIN( N, NB )
3820 ILOW = 1 - NB
3821 LCMT00 = LCMT00 + INB1 - NB + MRCOL * NB
3822 NBLKS = ( N - 1 ) / NB + 1
3823 LNBLOC = N - ( N / NB ) * NB
3824.EQ. IF( LNBLOC0 )
3825 $ LNBLOC = NB
3826*
3827 ELSE
3828*
3829 INBLOC = INB1
3830 ILOW = 1 - INB1
3831 TMP1 = N - INB1
3832.GT. IF( TMP10 ) THEN
3833*
3834* more than one block
3835*
3836 NBLKS = ( TMP1 - 1 ) / NB + 2
3837 LNBLOC = TMP1 - ( TMP1 / NB ) * NB
3838.EQ. IF( LNBLOC0 )
3839 $ LNBLOC = NB
3840*
3841 ELSE
3842*
3843 NBLKS = 1
3844 LNBLOC = INB1
3845*
3846 END IF
3847*
3848 END IF
3849*
3850 END IF
3851*
3852 RETURN
3853*
3854* End of PB_BINFO
3855*
3856 END
3857 INTEGER FUNCTION PILAENV( ICTXT, PREC )
3858*
3859* -- PBLAS test routine (version 2.0) --
3860* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3861* and University of California, Berkeley.
3862* April 1, 1998
3863*
3864* .. Scalar Arguments ..
3865 INTEGER ICTXT
3866 CHARACTER*1 PREC
3867* ..
3868*
3869* Purpose
3870* =======
3871*
3872* PILAENV returns the logical computational block size to be used by
3873* the PBLAS routines during testing and timing. This is a special ver-
3874* sion to be used only as part of the testing or timing PBLAS programs
3875* for testing different values of logical computational block sizes for
3876* the PBLAS routines. It is called by the PBLAS routines to retrieve a
3877* logical computational block size value.
3878*
3879* Arguments
3880* =========
3881*
3882* ICTXT (local input) INTEGER
3883* On entry, ICTXT specifies the BLACS context handle, indica-
3884* ting the global context of the operation. The context itself
3885* is global, but the value of ICTXT is local.
3886*
3887* PREC (dummy input) CHARACTER*1
3888* On entry, PREC is a dummy argument.
3889*
3890* -- Written on April 1, 1998 by
3891* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3892*
3893* =====================================================================
3894*
3895* .. Common Blocks ..
3896 INTEGER INFO, NBLOG
3897 COMMON /INFOC/INFO, NBLOG
3898* ..
3899* .. Executable Statements ..
3900*
3901 PILAENV = NBLOG
3902*
3903 RETURN
3904*
3905* End of PILAENV
3906*
3907 END
3908 SUBROUTINE PB_LOCINFO( I, INB, NB, MYROC, SRCPROC, NPROCS,
3909 $ ILOCBLK, ILOCOFF, MYDIST )
3910*
3911* -- PBLAS test routine (version 2.0) --
3912* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3913* and University of California, Berkeley.
3914* April 1, 1998
3915*
3916* .. Scalar Arguments ..
3917 INTEGER I, ILOCBLK, ILOCOFF, INB, MYDIST, MYROC, NB,
3918 $ NPROCS, SRCPROC
3919* ..
3920*
3921* Purpose
3922* =======
3923*
3924* PB_LOCINFO computes local information about the beginning of a sub-
3925* matrix starting at the global index I.
3926*
3927* Arguments
3928* =========
3929*
3930* I (global input) INTEGER
3931* On entry, I specifies the global starting index in the ma-
3932* trix. I must be at least one.
3933*
3934* INB (global input) INTEGER
3935* On entry, INB specifies the size of the first block of rows
3936* or columns of the matrix. INB must be at least one.
3937*
3938* NB (global input) INTEGER
3939* On entry, NB specifies the size of the blocks of rows or co-
3940* lumns of the matrix is partitioned into. NB must be at least
3941* one.
3942*
3943* MYROC (local input) INTEGER
3944* On entry, MYROC is the coordinate of the process whose local
3945* information is determined. MYROC is at least zero and
3946* strictly less than NPROCS.
3947*
3948* SRCPROC (global input) INTEGER
3949* On entry, SRCPROC specifies the coordinate of the process
3950* that possesses the first row or column of the matrix. When
3951* SRCPROC = -1, the data is not distributed but replicated,
3952* otherwise SRCPROC must be at least zero and strictly less
3953* than NPROCS.
3954*
3955* NPROCS (global input) INTEGER
3956* On entry, NPROCS specifies the total number of process rows
3957* or columns over which the submatrix is distributed. NPROCS
3958* must be at least one.
3959*
3960* ILOCBLK (local output) INTEGER
3961* On exit, ILOCBLK specifies the local row or column block
3962* coordinate corresponding to the row or column I of the ma-
3963* trix. ILOCBLK must be at least zero.
3964*
3965* ILOCOFF (local output) INTEGER
3966* On exit, ILOCOFF specifies the local row offset in the block
3967* of local coordinate ILOCBLK corresponding to the row or co-
3968* lumn I of the matrix. ILOCOFF must at least zero.
3969*
3970* MYDIST (local output) INTEGER
3971* On exit, MYDIST specifies the relative process coordinate of
3972* the process specified by MYROC to the process owning the row
3973* or column I. MYDIST is at least zero and strictly less than
3974* NPROCS.
3975*
3976* -- Written on April 1, 1998 by
3977* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3978*
3979* =====================================================================
3980*
3981* .. Local Scalars ..
3982 INTEGER ITMP, NBLOCKS, PROC
3983* ..
3984* .. Executable Statements ..
3985*
3986 ILOCOFF = 0
3987*
3988.LT. IF( SRCPROC0 ) THEN
3989*
3990 MYDIST = 0
3991*
3992.LE. IF( IINB ) THEN
3993*
3994 ILOCBLK = 0
3995 ILOCOFF = I - 1
3996*
3997 ELSE
3998*
3999 ITMP = I - INB
4000 NBLOCKS = ( ITMP - 1 ) / NB + 1
4001 ILOCBLK = NBLOCKS
4002 ILOCOFF = ITMP - 1 - ( NBLOCKS - 1 ) * NB
4003*
4004 END IF
4005*
4006 ELSE
4007*
4008 PROC = SRCPROC
4009 MYDIST = MYROC - PROC
4010.LT. IF( MYDIST0 )
4011 $ MYDIST = MYDIST + NPROCS
4012*
4013.LE. IF( IINB ) THEN
4014*
4015 ILOCBLK = 0
4016.EQ. IF( MYROCPROC )
4017 $ ILOCOFF = I - 1
4018*
4019 ELSE
4020*
4021 ITMP = I - INB
4022 NBLOCKS = ( ITMP - 1 ) / NB + 1
4023 PROC = PROC + NBLOCKS
4024 PROC = PROC - ( PROC / NPROCS ) * NPROCS
4025 ILOCBLK = NBLOCKS / NPROCS
4026*
4027.LT. IF( ( ILOCBLK*NPROCS )( MYDIST-NBLOCKS ) )
4028 $ ILOCBLK = ILOCBLK + 1
4029*
4030.EQ. IF( MYROCPROC )
4031 $ ILOCOFF = ITMP - 1 - ( NBLOCKS - 1 ) * NB
4032*
4033 END IF
4034*
4035 END IF
4036*
4037 RETURN
4038*
4039* End of PB_LOCINFO
4040*
4041 END
4042 SUBROUTINE PB_INITJMP( COLMAJ, NVIR, IMBVIR, INBVIR, IMBLOC,
4043 $ INBLOC, MB, NB, RSRC, CSRC, NPROW, NPCOL,
4044 $ STRIDE, JMP )
4045*
4046* -- PBLAS test routine (version 2.0) --
4047* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4048* and University of California, Berkeley.
4049* April 1, 1998
4050*
4051* .. Scalar Arguments ..
4052 LOGICAL COLMAJ
4053 INTEGER CSRC, IMBLOC, IMBVIR, INBLOC, INBVIR, MB, NB,
4054 $ NPCOL, NPROW, NVIR, RSRC, STRIDE
4055* ..
4056* .. Array Arguments ..
4057 INTEGER JMP( * )
4058* ..
4059*
4060* Purpose
4061* =======
4062*
4063* PB_INITJMP initializes the jump values JMP used by the random matrix
4064* generator.
4065*
4066* Arguments
4067* =========
4068*
4069* COLMAJ (global input) LOGICAL
4070* On entry, COLMAJ specifies the ordering of the random sequen-
4071* ce. When COLMAJ is .TRUE., the random sequence will be used
4072* for a column major ordering, and otherwise a row-major orde-
4073* ring. This impacts on the computation of the jump values.
4074*
4075* NVIR (global input) INTEGER
4076* On entry, NVIR specifies the size of the underlying virtual
4077* matrix. NVIR must be at least zero.
4078*
4079* IMBVIR (local input) INTEGER
4080* On entry, IMBVIR specifies the number of virtual rows of the
4081* upper left block of the underlying virtual submatrix. IMBVIR
4082* must be at least IMBLOC.
4083*
4084* INBVIR (local input) INTEGER
4085* On entry, INBVIR specifies the number of virtual columns of
4086* the upper left block of the underlying virtual submatrix.
4087* INBVIR must be at least INBLOC.
4088*
4089* IMBLOC (local input) INTEGER
4090* On entry, IMBLOC specifies the number of rows (size) of the
4091* local uppest blocks. IMBLOC is at least zero.
4092*
4093* INBLOC (local input) INTEGER
4094* On entry, INBLOC specifies the number of columns (size) of
4095* the local leftmost blocks. INBLOC is at least zero.
4096*
4097* MB (global input) INTEGER
4098* On entry, MB specifies the size of the blocks used to parti-
4099* tion the matrix rows. MB must be at least one.
4100*
4101* NB (global input) INTEGER
4102* On entry, NB specifies the size of the blocks used to parti-
4103* tion the matrix columns. NB must be at least one.
4104*
4105* RSRC (global input) INTEGER
4106* On entry, RSRC specifies the row coordinate of the process
4107* that possesses the first row of the matrix. When RSRC = -1,
4108* the rows are not distributed but replicated, otherwise RSRC
4109* must be at least zero and strictly less than NPROW.
4110*
4111* CSRC (global input) INTEGER
4112* On entry, CSRC specifies the column coordinate of the pro-
4113* cess that possesses the first column of the matrix. When CSRC
4114* is equal to -1, the columns are not distributed but replica-
4115* ted, otherwise CSRC must be at least zero and strictly less
4116* than NPCOL.
4117*
4118* NPROW (global input) INTEGER
4119* On entry, NPROW specifies the total number of process rows
4120* over which the matrix is distributed. NPROW must be at least
4121* one.
4122*
4123* NPCOL (global input) INTEGER
4124* On entry, NPCOL specifies the total number of process co-
4125* lumns over which the matrix is distributed. NPCOL must be at
4126* least one.
4127*
4128* STRIDE (global input) INTEGER
4129* On entry, STRIDE specifies the number of random numbers to be
4130* generated to compute one matrix entry. In the real case,
4131* STRIDE is usually 1, where as in the complex case STRIDE is
4132* usually 2 in order to generate the real and imaginary parts.
4133*
4134* JMP (local output) INTEGER array
4135* On entry, JMP is an array of dimension JMP_LEN. On exit, this
4136* array contains the different jump values used by the random
4137* matrix generator.
4138*
4139* -- Written on April 1, 1998 by
4140* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4141*
4142* =====================================================================
4143*
4144* .. Parameters ..
4145 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4146 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4147 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4148 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
4149 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
4150 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
4151 $ JMP_NQNB = 10, JMP_NQINBLOC = 11,
4152 $ JMP_LEN = 11 )
4153* ..
4154* .. Local Scalars ..
4155 INTEGER NPMB, NQNB
4156* ..
4157* .. Executable Statements ..
4158*
4159.LT. IF( RSRC0 ) THEN
4160 NPMB = MB
4161 ELSE
4162 NPMB = NPROW * MB
4163 END IF
4164.LT. IF( CSRC0 ) THEN
4165 NQNB = NB
4166 ELSE
4167 NQNB = NPCOL * NB
4168 END IF
4169*
4170 JMP( JMP_1 ) = 1
4171*
4172 JMP( JMP_MB ) = MB
4173 JMP( JMP_IMBV ) = IMBVIR
4174 JMP( JMP_NPMB ) = NPMB
4175 JMP( JMP_NPIMBLOC ) = IMBLOC + NPMB - MB
4176*
4177 JMP( JMP_NB ) = NB
4178 JMP( JMP_INBV ) = INBVIR
4179 JMP( JMP_NQNB ) = NQNB
4180 JMP( JMP_NQINBLOC ) = INBLOC + NQNB - NB
4181*
4182 IF( COLMAJ ) THEN
4183 JMP( JMP_ROW ) = STRIDE
4184 JMP( JMP_COL ) = STRIDE * NVIR
4185 ELSE
4186 JMP( JMP_ROW ) = STRIDE * NVIR
4187 JMP( JMP_COL ) = STRIDE
4188 END IF
4189*
4190 RETURN
4191*
4192* End of PB_INITJMP
4193*
4194 END
4195 SUBROUTINE PB_INITMULADD( MULADD0, JMP, IMULADD )
4196*
4197* -- PBLAS test routine (version 2.0) --
4198* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4199* and University of California, Berkeley.
4200* April 1, 1998
4201*
4202* .. Array Arguments ..
4203 INTEGER IMULADD( 4, * ), JMP( * ), MULADD0( * )
4204* ..
4205*
4206* Purpose
4207* =======
4208*
4209* PB_INITMULADD initializes the constants a's and c's corresponding to
4210* the jump values (JMP) used by the matrix generator.
4211*
4212* Arguments
4213* =========
4214*
4215* MULADD0 (local input) INTEGER array
4216* On entry, MULADD0 is an array of dimension 4 containing the
4217* encoded initial constants a and c to jump from X( n ) to
4218* X( n+1 ) = a*X( n ) + c in the random sequence. MULADD0(1:2)
4219* contains respectively the 16-lower and 16-higher bits of the
4220* constant a, and MULADD0(3:4) contains the 16-lower and
4221* 16-higher bits of the constant c.
4222*
4223* JMP (local input) INTEGER array
4224* On entry, JMP is an array of dimension JMP_LEN containing the
4225* different jump values used by the matrix generator.
4226*
4227* IMULADD (local output) INTEGER array
4228* On entry, IMULADD is an array of dimension ( 4, JMP_LEN ). On
4229* exit, the jth column of this array contains the encoded ini-
4230* tial constants a_j and c_j to jump from X( n ) to X(n+JMP(j))
4231* (= a_j*X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4232* contains respectively the 16-lower and 16-higher bits of the
4233* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4234* 16-higher bits of the constant c_j.
4235*
4236* -- Written on April 1, 1998 by
4237* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4238*
4239* =====================================================================
4240*
4241* .. Parameters ..
4242 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4243 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4244 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4245 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
4246 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
4247 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
4248 $ JMP_NQNB = 10, JMP_NQINBLOC = 11,
4249 $ JMP_LEN = 11 )
4250* ..
4251*
4252* .. Local Arrays ..
4253 INTEGER ITMP1( 2 ), ITMP2( 2 )
4254* ..
4255* .. External Subroutines ..
4256 EXTERNAL PB_JUMP
4257* ..
4258* .. Executable Statements ..
4259*
4260 ITMP2( 1 ) = 100
4261 ITMP2( 2 ) = 0
4262*
4263* Compute IMULADD for all JMP values
4264*
4265 CALL PB_JUMP( JMP( JMP_1 ), MULADD0, ITMP2, ITMP1,
4266 $ IMULADD( 1, JMP_1 ) )
4267*
4268 CALL PB_JUMP( JMP( JMP_ROW ), MULADD0, ITMP1, ITMP2,
4269 $ IMULADD( 1, JMP_ROW ) )
4270 CALL PB_JUMP( JMP( JMP_COL ), MULADD0, ITMP1, ITMP2,
4271 $ IMULADD( 1, JMP_COL ) )
4272*
4273* Compute constants a and c to jump JMP( * ) numbers in the
4274* sequence for column- or row-major ordering of the sequence.
4275*
4276 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP1,
4277 $ ITMP2, IMULADD( 1, JMP_IMBV ) )
4278 CALL PB_JUMP( JMP( JMP_MB ), IMULADD( 1, JMP_ROW ), ITMP1,
4279 $ ITMP2, IMULADD( 1, JMP_MB ) )
4280 CALL PB_JUMP( JMP( JMP_NPMB ), IMULADD( 1, JMP_ROW ), ITMP1,
4281 $ ITMP2, IMULADD( 1, JMP_NPMB ) )
4282 CALL PB_JUMP( JMP( JMP_NPIMBLOC ), IMULADD( 1, JMP_ROW ), ITMP1,
4283 $ ITMP2, IMULADD( 1, JMP_NPIMBLOC ) )
4284*
4285 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP1,
4286 $ ITMP2, IMULADD( 1, JMP_INBV ) )
4287 CALL PB_JUMP( JMP( JMP_NB ), IMULADD( 1, JMP_COL ), ITMP1,
4288 $ ITMP2, IMULADD( 1, JMP_NB ) )
4289 CALL PB_JUMP( JMP( JMP_NQNB ), IMULADD( 1, JMP_COL ), ITMP1,
4290 $ ITMP2, IMULADD( 1, JMP_NQNB ) )
4291 CALL PB_JUMP( JMP( JMP_NQINBLOC ), IMULADD( 1, JMP_COL ), ITMP1,
4292 $ ITMP2, IMULADD( 1, JMP_NQINBLOC ) )
4293*
4294 RETURN
4295*
4296* End of PB_INITMULADD
4297*
4298 END
4299 SUBROUTINE PB_SETLOCRAN( SEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
4300 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
4301 $ IMULADD, IRAN )
4302*
4303* -- PBLAS test routine (version 2.0) --
4304* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4305* and University of California, Berkeley.
4306* April 1, 1998
4307*
4308* .. Scalar Arguments ..
4309 INTEGER ILOCBLK, ILOCOFF, JLOCBLK, JLOCOFF, MYCDIST,
4310 $ MYRDIST, NPCOL, NPROW, SEED
4311* ..
4312* .. Array Arguments ..
4313 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
4314* ..
4315*
4316* Purpose
4317* =======
4318*
4319* PB_SETLOCRAN locally initializes the random number generator.
4320*
4321* Arguments
4322* =========
4323*
4324* SEED (global input) INTEGER
4325* On entry, SEED specifies a positive integer used to initiali-
4326* ze the first number in the random sequence used by the matrix
4327* generator. SEED must be at least zero.
4328*
4329* ILOCBLK (local input) INTEGER
4330* On entry, ILOCBLK specifies the local row block coordinate
4331* corresponding to the first row of the submatrix of interest.
4332* ILOCBLK must be at least zero.
4333*
4334* ILOCOFF (local input) INTEGER
4335* On entry, ILOCOFF specifies the local row offset in the block
4336* of local coordinate ILOCBLK corresponding to the first row of
4337* the submatrix of interest. ILOCOFF must at least zero.
4338*
4339* JLOCBLK (local input) INTEGER
4340* On entry, JLOCBLK specifies the local column block coordinate
4341* corresponding to the first column of the submatrix of inte-
4342* rest. JLOCBLK must be at least zero.
4343*
4344* JLOCOFF (local input) INTEGER
4345* On entry, JLOCOFF specifies the local column offset in the
4346* block of local coordinate JLOCBLK corresponding to the first
4347* column of the submatrix of interest. JLOCOFF must be at least
4348* zero.
4349*
4350* MYRDIST (local input) INTEGER
4351* On entry, MYRDIST specifies the relative row process coordi-
4352* nate to the process owning the first row of the submatrix of
4353* interest. MYRDIST must be at least zero and stricly less than
4354* NPROW (see the subroutine PB_LOCINFO).
4355*
4356* MYCDIST (local input) INTEGER
4357* On entry, MYCDIST specifies the relative column process coor-
4358* dinate to the process owning the first column of the subma-
4359* trix of interest. MYCDIST must be at least zero and stricly
4360* less than NPCOL (see the subroutine PB_LOCINFO).
4361*
4362* NPROW (global input) INTEGER
4363* On entry, NPROW specifies the total number of process rows
4364* over which the matrix is distributed. NPROW must be at least
4365* one.
4366*
4367* NPCOL (global input) INTEGER
4368* On entry, NPCOL specifies the total number of process co-
4369* lumns over which the matrix is distributed. NPCOL must be at
4370* least one.
4371*
4372* JMP (local input) INTEGER array
4373* On entry, JMP is an array of dimension JMP_LEN containing the
4374* different jump values used by the matrix generator.
4375*
4376* IMULADD (local input) INTEGER array
4377* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
4378* jth column of this array contains the encoded initial cons-
4379* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
4380* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4381* contains respectively the 16-lower and 16-higher bits of the
4382* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4383* 16-higher bits of the constant c_j.
4384*
4385* IRAN (local output) INTEGER array
4386* On entry, IRAN is an array of dimension 2. On exit, IRAN con-
4387* tains respectively the 16-lower and 32-higher bits of the en-
4388* coding of the entry of the random sequence corresponding lo-
4389* cally to the first local array entry to generate.
4390*
4391* -- Written on April 1, 1998 by
4392* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4393*
4394* =====================================================================
4395*
4396* .. Parameters ..
4397 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4398 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4399 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4400 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
4401 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
4402 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
4403 $ JMP_NQNB = 10, JMP_NQINBLOC = 11,
4404 $ JMP_LEN = 11 )
4405* ..
4406* .. Local Arrays ..
4407 INTEGER IMULADDTMP( 4 ), ITMP( 2 )
4408* ..
4409* .. External Subroutines ..
4410 EXTERNAL PB_JUMP, PB_SETRAN
4411* ..
4412* .. Executable Statements ..
4413*
4414* Compute and set the value of IRAN corresponding to A( IA, JA )
4415*
4416 ITMP( 1 ) = SEED
4417 ITMP( 2 ) = 0
4418*
4419 CALL PB_JUMP( JMP( JMP_1 ), IMULADD( 1, JMP_1 ), ITMP, IRAN,
4420 $ IMULADDTMP )
4421*
4422* Jump ILOCBLK blocks of rows + ILOCOFF rows
4423*
4424 CALL PB_JUMP( ILOCOFF, IMULADD( 1, JMP_ROW ), IRAN, ITMP,
4425 $ IMULADDTMP )
4426.GT. IF( MYRDIST0 ) THEN
4427 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP,
4428 $ IRAN, IMULADDTMP )
4429 CALL PB_JUMP( MYRDIST - 1, IMULADD( 1, JMP_MB ), IRAN,
4430 $ ITMP, IMULADDTMP )
4431 CALL PB_JUMP( ILOCBLK, IMULADD( 1, JMP_NPMB ), ITMP,
4432 $ IRAN, IMULADDTMP )
4433 ELSE
4434.GT. IF( ILOCBLK0 ) THEN
4435 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP,
4436 $ IRAN, IMULADDTMP )
4437 CALL PB_JUMP( NPROW - 1, IMULADD( 1, JMP_MB ), IRAN,
4438 $ ITMP, IMULADDTMP )
4439 CALL PB_JUMP( ILOCBLK - 1, IMULADD( 1, JMP_NPMB ), ITMP,
4440 $ IRAN, IMULADDTMP )
4441 ELSE
4442 CALL PB_JUMP( 0, IMULADD( 1, JMP_1 ), ITMP,
4443 $ IRAN, IMULADDTMP )
4444 END IF
4445 END IF
4446*
4447* Jump JLOCBLK blocks of columns + JLOCOFF columns
4448*
4449 CALL PB_JUMP( JLOCOFF, IMULADD( 1, JMP_COL ), IRAN, ITMP,
4450 $ IMULADDTMP )
4451.GT. IF( MYCDIST0 ) THEN
4452 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP,
4453 $ IRAN, IMULADDTMP )
4454 CALL PB_JUMP( MYCDIST - 1, IMULADD( 1, JMP_NB ), IRAN,
4455 $ ITMP, IMULADDTMP )
4456 CALL PB_JUMP( JLOCBLK, IMULADD( 1, JMP_NQNB ), ITMP,
4457 $ IRAN, IMULADDTMP )
4458 ELSE
4459.GT. IF( JLOCBLK0 ) THEN
4460 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP,
4461 $ IRAN, IMULADDTMP )
4462 CALL PB_JUMP( NPCOL - 1, IMULADD( 1, JMP_NB ), IRAN,
4463 $ ITMP, IMULADDTMP )
4464 CALL PB_JUMP( JLOCBLK - 1, IMULADD( 1, JMP_NQNB ), ITMP,
4465 $ IRAN, IMULADDTMP )
4466 ELSE
4467 CALL PB_JUMP( 0, IMULADD( 1, JMP_1 ), ITMP,
4468 $ IRAN, IMULADDTMP )
4469 END IF
4470 END IF
4471*
4472 CALL PB_SETRAN( IRAN, IMULADD( 1, JMP_1 ) )
4473*
4474 RETURN
4475*
4476* End of PB_SETLOCRAN
4477*
4478 END
4479 SUBROUTINE PB_LADD( J, K, I )
4480*
4481* -- PBLAS test routine (version 2.0) --
4482* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4483* and University of California, Berkeley.
4484* April 1, 1998
4485*
4486* .. Array Arguments ..
4487 INTEGER I( 2 ), J( 2 ), K( 2 )
4488* ..
4489*
4490* Purpose
4491* =======
4492*
4493* PB_LADD adds without carry two long positive integers K and J and put
4494* the result into I. The long integers I, J, K are encoded on 31 bits
4495* using an array of 2 integers. The 16-lower bits are stored in the
4496* first entry of each array, the 15-higher bits in the second entry.
4497* For efficiency purposes, the intrisic modulo function is inlined.
4498*
4499* Arguments
4500* =========
4501*
4502* J (local input) INTEGER array
4503* On entry, J is an array of dimension 2 containing the encoded
4504* long integer J.
4505*
4506* K (local input) INTEGER array
4507* On entry, K is an array of dimension 2 containing the encoded
4508* long integer K.
4509*
4510* I (local output) INTEGER array
4511* On entry, I is an array of dimension 2. On exit, this array
4512* contains the encoded long integer I.
4513*
4514* Further Details
4515* ===============
4516*
4517* K( 2 ) K( 1 )
4518* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
4519* + carry = ( K( 1 ) + J( 1 ) ) / 2**16
4520* J( 2 ) J( 1 )
4521* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
4522* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
4523* I( 2 ) I( 1 )
4524* 0XXXXXXX XXXXXXXX I
4525*
4526* -- Written on April 1, 1998 by
4527* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4528*
4529* =====================================================================
4530*
4531* .. Parameters ..
4532 INTEGER IPOW15, IPOW16
4533 PARAMETER ( IPOW15 = 2**15, IPOW16 = 2**16 )
4534* ..
4535* .. Local Scalars ..
4536 INTEGER ITMP1, ITMP2
4537* ..
4538* .. Executable Statements ..
4539*
4540* I( 1 ) = MOD( K( 1 ) + J( 1 ), IPOW16 )
4541*
4542 ITMP1 = K( 1 ) + J( 1 )
4543 ITMP2 = ITMP1 / IPOW16
4544 I( 1 ) = ITMP1 - ITMP2 * IPOW16
4545*
4546* I( 2 ) = MOD( ( K( 1 ) + J( 1 ) ) / IPOW16 + K( 2 ) + J( 2 ),
4547* IPOW15 )
4548*
4549 ITMP1 = ITMP2 + K( 2 ) + J( 2 )
4550 ITMP2 = ITMP1 / IPOW15
4551 I( 2 ) = ITMP1 - ITMP2 * IPOW15
4552*
4553 RETURN
4554*
4555* End of PB_LADD
4556*
4557 END
4558 SUBROUTINE PB_LMUL( K, J, I )
4559*
4560* -- PBLAS test routine (version 2.0) --
4561* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4562* and University of California, Berkeley.
4563* April 1, 1998
4564*
4565* .. Array Arguments ..
4566 INTEGER I( 2 ), J( 2 ), K( 2 )
4567* ..
4568*
4569* Purpose
4570* =======
4571*
4572* PB_LMUL multiplies without carry two long positive integers K and J
4573* and put the result into I. The long integers I, J, K are encoded on
4574* 31 bits using an array of 2 integers. The 16-lower bits are stored in
4575* the first entry of each array, the 15-higher bits in the second entry
4576* of each array. For efficiency purposes, the intrisic modulo function
4577* is inlined.
4578*
4579* Arguments
4580* =========
4581*
4582* K (local input) INTEGER array
4583* On entry, K is an array of dimension 2 containing the encoded
4584* long integer K.
4585*
4586* J (local input) INTEGER array
4587* On entry, J is an array of dimension 2 containing the encoded
4588* long integer J.
4589*
4590* I (local output) INTEGER array
4591* On entry, I is an array of dimension 2. On exit, this array
4592* contains the encoded long integer I.
4593*
4594* Further Details
4595* ===============
4596*
4597* K( 2 ) K( 1 )
4598* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
4599* * carry = ( K( 1 ) + J( 1 ) ) / 2**16
4600* J( 2 ) J( 1 )
4601* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
4602* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
4603* I( 2 ) I( 1 )
4604* 0XXXXXXX XXXXXXXX I
4605*
4606* -- Written on April 1, 1998 by
4607* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4608*
4609* =====================================================================
4610*
4611* .. Parameters ..
4612 INTEGER IPOW15, IPOW16, IPOW30
4613 PARAMETER ( IPOW15 = 2**15, IPOW16 = 2**16,
4614 $ IPOW30 = 2**30 )
4615* ..
4616* .. Local Scalars ..
4617 INTEGER ITMP1, ITMP2
4618* ..
4619* .. Executable Statements ..
4620*
4621 ITMP1 = K( 1 ) * J( 1 )
4622.LT. IF( ITMP10 )
4623 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30
4624*
4625* I( 1 ) = MOD( ITMP1, IPOW16 )
4626*
4627 ITMP2 = ITMP1 / IPOW16
4628 I( 1 ) = ITMP1 - ITMP2 * IPOW16
4629*
4630 ITMP1 = K( 1 ) * J( 2 ) + K( 2 ) * J( 1 )
4631.LT. IF( ITMP10 )
4632 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30
4633*
4634 ITMP1 = ITMP2 + ITMP1
4635.LT. IF( ITMP10 )
4636 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30
4637*
4638* I( 2 ) = MOD( ITMP1, IPOW15 )
4639*
4640 I( 2 ) = ITMP1 - ( ITMP1 / IPOW15 ) * IPOW15
4641*
4642 RETURN
4643*
4644* End of PB_LMUL
4645*
4646 END
4647 SUBROUTINE PB_JUMP( K, MULADD, IRANN, IRANM, IMA )
4648*
4649* -- PBLAS test routine (version 2.0) --
4650* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4651* and University of California, Berkeley.
4652* April 1, 1998
4653*
4654* .. Scalar Arguments ..
4655 INTEGER K
4656* ..
4657* .. Array Arguments ..
4658 INTEGER IMA( 4 ), IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
4659* ..
4660*
4661* Purpose
4662* =======
4663*
4664* PB_JUMP computes the constants A and C to jump K numbers in the ran-
4665* dom sequence:
4666*
4667* X( n+K ) = A * X( n ) + C.
4668*
4669* The constants encoded in MULADD specify how to jump from entry in the
4670* sequence to the next.
4671*
4672* Arguments
4673* =========
4674*
4675* K (local input) INTEGER
4676* On entry, K specifies the number of entries of the sequence
4677* to jump over. When K is less or equal than zero, A and C are
4678* not computed, and IRANM is set to IRANN corresponding to a
4679* jump of size zero.
4680*
4681* MULADD (local input) INTEGER array
4682* On entry, MULADD is an array of dimension 4 containing the
4683* encoded constants a and c to jump from X( n ) to X( n+1 )
4684* ( = a*X( n )+c) in the random sequence. MULADD(1:2) contains
4685* respectively the 16-lower and 16-higher bits of the constant
4686* a, and MULADD(3:4) contains the 16-lower and 16-higher bits
4687* of the constant c.
4688*
4689* IRANN (local input) INTEGER array
4690* On entry, IRANN is an array of dimension 2. This array con-
4691* tains respectively the 16-lower and 16-higher bits of the en-
4692* coding of X( n ).
4693*
4694* IRANM (local output) INTEGER array
4695* On entry, IRANM is an array of dimension 2. On exit, this
4696* array contains respectively the 16-lower and 16-higher bits
4697* of the encoding of X( n+K ).
4698*
4699* IMA (local output) INTEGER array
4700* On entry, IMA is an array of dimension 4. On exit, when K is
4701* greater than zero, this array contains the encoded constants
4702* A and C to jump from X( n ) to X( n+K ) in the random se-
4703* quence. IMA(1:2) contains respectively the 16-lower and
4704* 16-higher bits of the constant A, and IMA(3:4) contains the
4705* 16-lower and 16-higher bits of the constant C. When K is
4706* less or equal than zero, this array is not referenced.
4707*
4708* -- Written on April 1, 1998 by
4709* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4710*
4711* =====================================================================
4712*
4713* .. Local Scalars ..
4714 INTEGER I
4715* ..
4716* .. Local Arrays ..
4717 INTEGER J( 2 )
4718* ..
4719* .. External Subroutines ..
4720 EXTERNAL PB_LADD, PB_LMUL
4721* ..
4722* .. Executable Statements ..
4723*
4724.GT. IF( K0 ) THEN
4725*
4726 IMA( 1 ) = MULADD( 1 )
4727 IMA( 2 ) = MULADD( 2 )
4728 IMA( 3 ) = MULADD( 3 )
4729 IMA( 4 ) = MULADD( 4 )
4730*
4731 DO 10 I = 1, K - 1
4732*
4733 CALL PB_LMUL( IMA, MULADD, J )
4734*
4735 IMA( 1 ) = J( 1 )
4736 IMA( 2 ) = J( 2 )
4737*
4738 CALL PB_LMUL( IMA( 3 ), MULADD, J )
4739 CALL PB_LADD( MULADD( 3 ), J, IMA( 3 ) )
4740*
4741 10 CONTINUE
4742*
4743 CALL PB_LMUL( IRANN, IMA, J )
4744 CALL PB_LADD( J, IMA( 3 ), IRANM )
4745*
4746 ELSE
4747*
4748 IRANM( 1 ) = IRANN( 1 )
4749 IRANM( 2 ) = IRANN( 2 )
4750*
4751 END IF
4752*
4753 RETURN
4754*
4755* End of PB_JUMP
4756*
4757 END
4758 SUBROUTINE PB_SETRAN( IRAN, IAC )
4759*
4760* -- PBLAS test routine (version 2.0) --
4761* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4762* and University of California, Berkeley.
4763* April 1, 1998
4764*
4765* .. Array Arguments ..
4766 INTEGER IAC( 4 ), IRAN( 2 )
4767* ..
4768*
4769* Purpose
4770* =======
4771*
4772* PB_SETRAN initializes the random generator with the encoding of the
4773* first number X( 1 ) in the sequence, and the constants a and c used
4774* to compute the next element in the sequence:
4775*
4776* X( n+1 ) = a * X( n ) + c.
4777*
4778* X( 1 ), a and c are stored in the common block RANCOM for later use
4779* (see the routines PB_SRAN or PB_DRAN).
4780*
4781* Arguments
4782* =========
4783*
4784* IRAN (local input) INTEGER array
4785* On entry, IRAN is an array of dimension 2. This array con-
4786* tains respectively the 16-lower and 16-higher bits of the en-
4787* coding of X( 1 ).
4788*
4789* IAC (local input) INTEGER array
4790* On entry, IAC is an array of dimension 4. IAC(1:2) contain
4791* respectively the 16-lower and 16-higher bits of the constant
4792* a, and IAC(3:4) contain the 16-lower and 16-higher bits of
4793* the constant c.
4794*
4795* -- Written on April 1, 1998 by
4796* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4797*
4798* =====================================================================
4799*
4800* .. Common Blocks ..
4801 INTEGER IACS( 4 ), IRAND( 2 )
4802 COMMON /RANCOM/ IRAND, IACS
4803* ..
4804* .. Save Statements ..
4805 SAVE /RANCOM/
4806* ..
4807* .. Executable Statements ..
4808*
4809 IRAND( 1 ) = IRAN( 1 )
4810 IRAND( 2 ) = IRAN( 2 )
4811 IACS( 1 ) = IAC( 1 )
4812 IACS( 2 ) = IAC( 2 )
4813 IACS( 3 ) = IAC( 3 )
4814 IACS( 4 ) = IAC( 4 )
4815*
4816 RETURN
4817*
4818* End of PB_SETRAN
4819*
4820 END
4821 SUBROUTINE PB_JUMPIT( MULADD, IRANN, IRANM )
4822*
4823* -- PBLAS test routine (version 2.0) --
4824* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4825* and University of California, Berkeley.
4826* April 1, 1998
4827*
4828* .. Array Arguments ..
4829 INTEGER IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
4830* ..
4831*
4832* Purpose
4833* =======
4834*
4835* PB_JUMPIT jumps in the random sequence from the number X( n ) enco-
4836* ded in IRANN to the number X( m ) encoded in IRANM using the cons-
4837* tants A and C encoded in MULADD:
4838*
4839* X( m ) = A * X( n ) + C.
4840*
4841* The constants A and C obviously depend on m and n, see the subroutine
4842* PB_JUMP in order to set them up.
4843*
4844* Arguments
4845* =========
4846*
4847* MULADD (local input) INTEGER array
4848* On netry, MULADD is an array of dimension 4. MULADD(1:2) con-
4849* tains respectively the 16-lower and 16-higher bits of the
4850* constant A, and MULADD(3:4) contains the 16-lower and
4851* 16-higher bits of the constant C.
4852*
4853* IRANN (local input) INTEGER array
4854* On entry, IRANN is an array of dimension 2. This array con-
4855* tains respectively the 16-lower and 16-higher bits of the en-
4856* coding of X( n ).
4857*
4858* IRANM (local output) INTEGER array
4859* On entry, IRANM is an array of dimension 2. On exit, this
4860* array contains respectively the 16-lower and 16-higher bits
4861* of the encoding of X( m ).
4862*
4863* -- Written on April 1, 1998 by
4864* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4865*
4866* =====================================================================
4867*
4868* .. Local Arrays ..
4869 INTEGER J( 2 )
4870* ..
4871* .. External Subroutines ..
4872 EXTERNAL PB_LADD, PB_LMUL
4873* ..
4874* .. Common Blocks ..
4875 INTEGER IACS( 4 ), IRAND( 2 )
4876 COMMON /RANCOM/ IRAND, IACS
4877* ..
4878* .. Save Statements ..
4879 SAVE /RANCOM/
4880* ..
4881* .. Executable Statements ..
4882*
4883 CALL PB_LMUL( IRANN, MULADD, J )
4884 CALL PB_LADD( J, MULADD( 3 ), IRANM )
4885*
4886 IRAND( 1 ) = IRANM( 1 )
4887 IRAND( 2 ) = IRANM( 2 )
4888*
4889 RETURN
4890*
4891* End of PB_JUMPIT
4892*
4893 END
max
#define max(a, b)
Definition macros.h:21
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pmdimchk
subroutine pmdimchk(ictxt, nout, m, n, matrix, ia, ja, desca, info)
Definition pblastst.f:202
pvdimchk
subroutine pvdimchk(ictxt, nout, n, matrix, ix, jx, descx, incx, info)
Definition pblastst.f:3
pvdescchk
subroutine pvdescchk(ictxt, nout, matrix, descx, dtx, mx, nx, imbx, inbx, mbx, nbx, rsrcx, csrcx, incx, mpx, nqx, iprex, imidx, ipostx, igap, gapmul, info)
Definition pblastst.f:388