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.LT..OR..LT. IF( ( M0 )( N0 ) ) THEN
346 INFO = 1
347.EQ..OR..EQ. ELSE IF( ( M0 )( N0 ) )THEN
348.LT. IF( DESCA( M_ )0 )
349 $ INFO = 1
350.LT. IF( DESCA( N_ )0 )
351 $ INFO = 1
352 ELSE
353.LT. IF( DESCA( M_ )( IA+M-1 ) )
354 $ INFO = 1
355.LT. IF( DESCA( N_ )( 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.NE. IF( INFO0 ) THEN
364.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) 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.NE. IF( DTXBLOCK_CYCLIC_2D_INB ) THEN
607.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
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.LT. IF( MX0 ) THEN
616.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
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 IF( info.NE.-infot )
1211 $ gerr = 1
1212*
1213 CALL igsum2d( ictxt, 'All', ' ', 1, 1, gerr, 1, -1, 0 )
1214*
1215 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1216 IF( gerr.EQ.( 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 lsame = ca.EQ.cb
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 IF( zcode.EQ.90 .OR. zcode.EQ.122 ) THEN
1422*
1423* ASCII is assumed - ZCODE is the ASCII code of either lower or
1424* upper case 'Z'.
1425*
1426 IF( inta.GE.97 .AND. inta.LE.122 ) inta = inta - 32
1427 IF( intb.GE.97 .AND. intb.LE.122 ) intb = intb - 32
1428*
1429 ELSE IF( zcode.EQ.233 .OR. zcode.EQ.169 ) THEN
1430*
1431* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
1432* upper case 'Z'.
1433*
1434 IF( inta.GE.129 .AND. inta.LE.137 .OR.
1435 $ inta.GE.145 .AND. inta.LE.153 .OR.
1436 $ inta.GE.162 .AND. inta.LE.169 ) inta = inta + 64
1437 IF( intb.GE.129 .AND. intb.LE.137 .OR.
1438 $ intb.GE.145 .AND. intb.LE.153 .OR.
1439 $ intb.GE.162 .AND. intb.LE.169 ) intb = intb + 64
1440*
1441 ELSE IF( zcode.EQ.218 .OR. zcode.EQ.250 ) 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 IF( inta.GE.225 .AND. inta.LE.250 ) inta = inta - 32
1447 IF( intb.GE.225 .AND. intb.LE.250 ) intb = intb - 32
1448 END IF
1449 lsame = inta.EQ.intb
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 IF( len( ca ).LT.n .OR. len( cb ).LT.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 IF( .NOT.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 IF( n.LE.0 )
1573 $ RETURN
1574 IF( incx.EQ.1 .AND. incy.EQ.1 )
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 IF( incx.LT.0 )
1582 $ ix = ( -n+1 )*incx + 1
1583 IF( incy.LT.0 )
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 IF( m.EQ.0 )
1599 $ GO TO 40
1600 DO 30 i = 1, m
1601 sy( i ) = sx( i )
1602 30 CONTINUE
1603 IF( n.LT.7 )
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 IF( ( prow.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
1849*
1850 ii = i
1851*
1852 ELSE IF( i.LE.imb ) THEN
1853*
1854* I is in range of first block
1855*
1856 IF( myrow.EQ.prow ) 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 IF( myrow.EQ.rsrc ) 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 IF( ilocblk.GT.0 ) THEN
1878 IF( ( ilocblk*nprow ).GE.nblocks ) THEN
1879 IF( myrow.EQ.prow ) 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 IF( mydist.LT.0 )
1900 $ mydist = mydist + nprow
1901*
1902 ilocblk = nblocks / nprow
1903*
1904 IF( ilocblk.GT.0 ) THEN
1905 mydist = mydist - nblocks + ilocblk * nprow
1906 IF( mydist.LT.0 ) THEN
1907 ii = mb + ilocblk * mb + 1
1908 ELSE
1909 IF( myrow.EQ.prow ) 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 IF( mydist.LT.0 ) THEN
1918 ii = mb + 1
1919 ELSE IF( myrow.EQ.prow ) 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 IF( ( pcol.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
1935*
1936 jj = j
1937*
1938 ELSE IF( j.LE.inb ) THEN
1939*
1940* J is in range of first block
1941*
1942 IF( mycol.EQ.pcol ) 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 IF( mycol.EQ.csrc ) 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 IF( ilocblk.GT.0 ) THEN
1964 IF( ( ilocblk*npcol ).GE.nblocks ) THEN
1965 IF( mycol.EQ.pcol ) 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 IF( mydist.LT.0 )
1986 $ mydist = mydist + npcol
1987*
1988 ilocblk = nblocks / npcol
1989*
1990 IF( ilocblk.GT.0 ) THEN
1991 mydist = mydist - nblocks + ilocblk * npcol
1992 IF( mydist.LT.0 ) THEN
1993 jj = nb + ilocblk * nb + 1
1994 ELSE
1995 IF( mycol.EQ.pcol ) 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 IF( mydist.LT.0 ) THEN
2004 jj = nb + 1
2005 ELSE IF( mycol.EQ.pcol ) 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 IF( ( rsrc.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
2247*
2248 ii = i
2249 imb1 = imb1 - i + 1
2250 IF( imb1.LE.0 )
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 IF( i.LE.imb1 ) THEN
2262*
2263 prow = rsrc
2264*
2265 IF( myrow.EQ.prow ) 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 IF( myrow.EQ.rsrc ) THEN
2281*
2282 ilocblk = nblocks / nprow
2283*
2284 IF( ilocblk.GT.0 ) THEN
2285 IF( ( ilocblk*nprow ).GE.nblocks ) THEN
2286 IF( myrow.EQ.prow ) 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 IF( mydist.LT.0 )
2302 $ mydist = mydist + nprow
2303*
2304 ilocblk = nblocks / nprow
2305*
2306 IF( ilocblk.GT.0 ) THEN
2307 mydist = mydist - nblocks + ilocblk * nprow
2308 IF( mydist.LT.0 ) THEN
2309 ii = ( ilocblk + 1 ) * mb + 1
2310 ELSE IF( myrow.EQ.prow ) 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 IF( mydist.LT.0 ) THEN
2318 ii = mb + 1
2319 ELSE IF( myrow.EQ.prow ) 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 IF( m.LE.imb1 ) THEN
2334*
2335 IF( myrow.EQ.prow ) 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 IF( myrow.EQ.prow ) THEN
2347 ilocblk = nblocks / nprow
2348 IF( ilocblk.GT.0 ) THEN
2349 IF( ( nblocks - ilocblk * nprow ).GT.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 IF( mydist.LT.0 )
2360 $ mydist = mydist + nprow
2361 ilocblk = nblocks / nprow
2362 IF( ilocblk.GT.0 ) THEN
2363 mydist = mydist - nblocks + ilocblk * nprow
2364 IF( mydist.LT.0 ) THEN
2365 mp = ( ilocblk + 1 ) * mb
2366 ELSE IF( mydist.GT.0 ) THEN
2367 mp = ilocblk * mb
2368 ELSE
2369 mp = m1 + mb * ( ilocblk - nblocks + 1 )
2370 END IF
2371 ELSE
2372 mydist = mydist - nblocks
2373 IF( mydist.LT.0 ) THEN
2374 mp = mb
2375 ELSE IF( mydist.GT.0 ) 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 IF( rprow.LT.0 )
2388 $ rprow = rprow + nprow
2389*
2390 END IF
2391*
2392 nb = desc2( nb_ )
2393 inb1 = desc2( inb_ )
2394 csrc = desc2( csrc_ )
2395*
2396 IF( ( csrc.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
2397*
2398 jj = j
2399 inb1 = inb1 - i + 1
2400 IF( inb1.LE.0 )
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 IF( j.LE.inb1 ) THEN
2412*
2413 pcol = csrc
2414*
2415 IF( mycol.EQ.pcol ) 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 IF( mycol.EQ.csrc ) THEN
2431*
2432 ilocblk = nblocks / npcol
2433*
2434 IF( ilocblk.GT.0 ) THEN
2435 IF( ( ilocblk*npcol ).GE.nblocks ) THEN
2436 IF( mycol.EQ.pcol ) 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 IF( mydist.LT.0 )
2452 $ mydist = mydist + npcol
2453*
2454 ilocblk = nblocks / npcol
2455*
2456 IF( ilocblk.GT.0 ) THEN
2457 mydist = mydist - nblocks + ilocblk * npcol
2458 IF( mydist.LT.0 ) THEN
2459 jj = ( ilocblk + 1 ) * nb + 1
2460 ELSE IF( mycol.EQ.pcol ) 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 IF( mydist.LT.0 ) THEN
2468 jj = nb + 1
2469 ELSE IF( mycol.EQ.pcol ) 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 IF( n.LE.inb1 ) THEN
2484*
2485 IF( mycol.EQ.pcol ) 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 IF( mycol.EQ.pcol ) THEN
2497 ilocblk = nblocks / npcol
2498 IF( ilocblk.GT.0 ) THEN
2499 IF( ( nblocks - ilocblk * npcol ).GT.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 IF( mydist.LT.0 )
2510 $ mydist = mydist + npcol
2511 ilocblk = nblocks / npcol
2512 IF( ilocblk.GT.0 ) THEN
2513 mydist = mydist - nblocks + ilocblk * npcol
2514 IF( mydist.LT.0 ) THEN
2515 nq = ( ilocblk + 1 ) * nb
2516 ELSE IF( mydist.GT.0 ) THEN
2517 nq = ilocblk * nb
2518 ELSE
2519 nq = n1 + nb * ( ilocblk - nblocks + 1 )
2520 END IF
2521 ELSE
2522 mydist = mydist - nblocks
2523 IF( mydist.LT.0 ) THEN
2524 nq = nb
2525 ELSE IF( mydist.GT.0 ) 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 IF( rpcol.LT.0 )
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 IF( ( srcproc.EQ.-1 ).OR.( nprocs.EQ.1 ) ) THEN
2613 pb_numroc = n
2614 RETURN
2615 END IF
2616*
2617* Compute coordinate of process owning I and corresponding INB
2618*
2619 IF( i.LE.inb ) 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 IF( n.LE.inb1 ) THEN
2642 IF( proc.EQ.srcproc1 ) 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 IF( proc.EQ.srcproc1 ) THEN
2654 ilocblk = nblocks / nprocs
2655 IF( ilocblk.GT.0 ) THEN
2656 IF( ( nblocks - ilocblk * nprocs ).GT.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 IF( mydist.LT.0 )
2667 $ mydist = mydist + nprocs
2668 ilocblk = nblocks / nprocs
2669 IF( ilocblk.GT.0 ) THEN
2670 mydist = mydist - nblocks + ilocblk * nprocs
2671 IF( mydist.LT.0 ) THEN
2672 pb_numroc = ( ilocblk + 1 ) * nb
2673 ELSE IF( mydist.GT.0 ) 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 IF( mydist.LT.0 ) THEN
2681 pb_numroc = nb
2682 ELSE IF( mydist.GT.0 ) 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 IF( info.GE.0 ) THEN
2856 info = bignum
2857 ELSE IF( info.LT.-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 IF( m.LT.0 )
2879 $ info = min( info, mpos )
2880 IF( n.LT.0 )
2881 $ info = min( info, npos )
2882 IF( ia.LT.1 )
2883 $ info = min( info, iapos )
2884 IF( ja.LT.1 )
2885 $ info = min( info, japos )
2886 IF( desca2( dtype_ ).NE.block_cyclic_2d_inb )
2887 $ info = min( info, dpos + dtype_ )
2888 IF( desca2( imb_ ).LT.1 )
2889 $ info = min( info, dpos + imb_ )
2890 IF( desca2( inb_ ).LT.1 )
2891 $ info = min( info, dpos + inb_ )
2892 IF( desca2( mb_ ).LT.1 )
2893 $ info = min( info, dpos + mb_ )
2894 IF( desca2( nb_ ).LT.1 )
2895 $ info = min( info, dpos + nb_ )
2896 IF( desca2( rsrc_ ).LT.-1 .OR. desca2( rsrc_ ).GE.nprow )
2897 $ info = min( info, dpos + rsrc_ )
2898 IF( desca2( csrc_ ).LT.-1 .OR. desca2( csrc_ ).GE.npcol )
2899 $ info = min( info, dpos + csrc_ )
2900 IF( desca2( ctxt_ ).NE.ictxt )
2901 $ info = min( info, dpos + ctxt_ )
2902*
2903 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
2904*
2905* NULL matrix, relax some checks
2906*
2907 IF( desca2( m_ ).LT.0 )
2908 $ info = min( info, dpos + m_ )
2909 IF( desca2( n_ ).LT.0 )
2910 $ info = min( info, dpos + n_ )
2911 IF( desca2( lld_ ).LT.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 IF( desca2( m_ ).LT.1 )
2922 $ info = min( info, dpos + m_ )
2923 IF( desca2( n_ ).LT.1 )
2924 $ info = min( info, dpos + n_ )
2925 IF( ia.GT.desca2( m_ ) )
2926 $ info = min( info, iapos )
2927 IF( ja.GT.desca2( n_ ) )
2928 $ info = min( info, japos )
2929 IF( ia+m-1.GT.desca2( m_ ) )
2930 $ info = min( info, mpos )
2931 IF( ja+n-1.GT.desca2( n_ ) )
2932 $ info = min( info, npos )
2933*
2934 IF( desca2( lld_ ).LT.max( 1, mp ) ) THEN
2935 nq = pb_numroc( desca2( n_ ), 1, desca2( inb_ ),
2936 $ desca2( nb_ ), mycol, desca2( csrc_ ),
2937 $ npcol )
2938 IF( desca2( lld_ ).LT.1 ) THEN
2939 info = min( info, dpos + lld_ )
2940 ELSE IF( nq.GT.0 ) 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 IF( info.EQ.bignum ) THEN
2951 info = 0
2952 ELSE IF( mod( info, descmult ).EQ.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 IF( DESCIN( DTYPE_ ).EQ.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 ELSE IF( descin( dtype_ ).EQ.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 IF( m.LT.0 ) THEN
3522 info = -2
3523 ELSE IF( n.LT.0 ) THEN
3524 info = -3
3525 ELSE IF( imb.LT.1 ) THEN
3526 info = -4
3527 ELSE IF( inb.LT.1 ) THEN
3528 info = -5
3529 ELSE IF( mb.LT.1 ) THEN
3530 info = -6
3531 ELSE IF( nb.LT.1 ) THEN
3532 info = -7
3533 ELSE IF( rsrc.LT.-1 .OR. rsrc.GE.nprow ) THEN
3534 info = -8
3535 ELSE IF( csrc.LT.-1 .OR. csrc.GE.npcol ) THEN
3536 info = -9
3537 ELSE IF( nprow.EQ.-1 ) THEN
3538 info = -10
3539 END IF
3540*
3541* Compute minimum LLD if safe (to avoid division by 0)
3542*
3543 IF( info.EQ.0 ) THEN
3544 mp = pb_numroc( m, 1, imb, mb, myrow, rsrc, nprow )
3545 IF( pb_numroc( n, 1, inb, nb, mycol, csrc, npcol ).GT.0 ) THEN
3546 lldmin = max( 1, mp )
3547 ELSE
3548 lldmin = 1
3549 END IF
3550 IF( lld.LT.lldmin )
3551 $ info = -11
3552 END IF
3553*
3554 IF( info.NE.0 )
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 IF( m.LE.0 .OR. n.LE.0 ) THEN
3727*
3728 IF( mrrow.GT.0 ) 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 IF( mrcol.GT.0 ) 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 IF( mrrow.GT.0 ) 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 IF( lmbloc.EQ.0 )
3761 $ lmbloc = mb
3762*
3763 IF( mrcol.GT.0 ) 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 IF( lnbloc.EQ.0 )
3771 $ lnbloc = nb
3772*
3773 ELSE
3774*
3775 inbloc = inb1
3776 ilow = 1 - inb1
3777 tmp1 = n - inb1
3778 IF( tmp1.GT.0 ) THEN
3779*
3780* more than one block
3781*
3782 nblks = ( tmp1 - 1 ) / nb + 2
3783 lnbloc = tmp1 - ( tmp1 / nb ) * nb
3784 IF( lnbloc.EQ.0 )
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 IF( tmp1.GT.0 ) THEN
3802*
3803* more than one block
3804*
3805 mblks = ( tmp1 - 1 ) / mb + 2
3806 lmbloc = tmp1 - ( tmp1 / mb ) * mb
3807 IF( lmbloc.EQ.0 )
3808 $ lmbloc = mb
3809*
3810 ELSE
3811*
3812 mblks = 1
3813 lmbloc = imb1
3814*
3815 END IF
3816*
3817 IF( mrcol.GT.0 ) 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 IF( lnbloc.EQ.0 )
3825 $ lnbloc = nb
3826*
3827 ELSE
3828*
3829 inbloc = inb1
3830 ilow = 1 - inb1
3831 tmp1 = n - inb1
3832 IF( tmp1.GT.0 ) THEN
3833*
3834* more than one block
3835*
3836 nblks = ( tmp1 - 1 ) / nb + 2
3837 lnbloc = tmp1 - ( tmp1 / nb ) * nb
3838 IF( lnbloc.EQ.0 )
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 if( srcproc.LT.0 ) THEN
3989*
3990 mydist = 0
3991*
3992 IF( i.LE.inb ) 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 IF( mydist.LT.0 )
4011 $ mydist = mydist + nprocs
4012*
4013 IF( i.LE.inb ) THEN
4014*
4015 ilocblk = 0
4016 IF( myroc.EQ.proc )
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 IF( ( ilocblk*nprocs ).LT.( mydist-nblocks ) )
4028 $ ilocblk = ilocblk + 1
4029*
4030 IF( myroc.EQ.proc )
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 IF( rsrc.LT.0 ) THEN
4160 npmb = mb
4161 ELSE
4162 npmb = nprow * mb
4163 END IF
4164 IF( csrc.LT.0 ) 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 IF( myrdist.GT.0 ) 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 IF( ilocblk.GT.0 ) 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 IF( mycdist.GT.0 ) 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 IF( jlocblk.GT.0 ) 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 IF( itmp1.LT.0 )
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 IF( itmp1.LT.0 )
4632 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
4633*
4634 itmp1 = itmp2 + itmp1
4635 IF( itmp1.LT.0 )
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 IF( K.GT.0 ) 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
if
if(complex_arithmetic) id
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
pb_ainfog2l
subroutine pb_ainfog2l(m, n, i, j, desc, nprow, npcol, myrow, mycol, imb1, inb1, mp, nq, ii, jj, prow, pcol, rprow, rpcol)
Definition pblastst.f:2023
pvdimchk
subroutine pvdimchk(ictxt, nout, n, matrix, ix, jx, descx, incx, info)
Definition pblastst.f:3
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
pb_descset2
subroutine pb_descset2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
Definition pblastst.f:3172
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastst.f:4480
lsame
logical function lsame(ca, cb)
Definition pblastst.f:1370
pb_binfo
subroutine pb_binfo(offd, m, n, imb1, inb1, mb, nb, mrrow, mrcol, lcmt00, mblks, nblks, imbloc, inbloc, lmbloc, lnbloc, ilow, low, iupp, upp)
Definition pblastst.f:3577
pilaenv
integer function pilaenv(ictxt, prec)
Definition pblastst.f:3858
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastst.f:4759
pxerbla
subroutine pxerbla(ictxt, srname, info)
Definition pblastst.f:1307
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastst.f:3910
pb_fceil
integer function pb_fceil(num, denom)
Definition pblastst.f:2696
pchkpbe
subroutine pchkpbe(ictxt, nout, sname, infot)
Definition pblastst.f:1084
pb_descinit2
subroutine pb_descinit2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld, info)
Definition pblastst.f:3337
pddiff
double precision function pddiff(x, y)
Definition pblastst.f:1269
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastst.f:2742
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastst.f:4559
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastst.f:4648
pb_noabort
integer function pb_noabort(cinfo)
Definition pblastst.f:1622
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastst.f:4302
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastst.f:4196
lsamen
logical function lsamen(n, ca, cb)
Definition pblastst.f:1457
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastst.f:2964
psdiff
real function psdiff(x, y)
Definition pblastst.f:1230
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastst.f:4045
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822
pb_numroc
integer function pb_numroc(n, i, inb, nb, proc, srcproc, nprocs)
Definition pblastst.f:2548