OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pblastim.f
Go to the documentation of this file.
1 SUBROUTINE pvdimchk( ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX,
2 $ INFO )
3*
4* -- PBLAS test routine (version 2.0) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* April 1, 1998
8*
9* .. Scalar Arguments ..
10 CHARACTER*1 MATRIX
11 INTEGER ICTXT, INCX, INFO, IX, JX, N, NOUT
12* ..
13* .. Array Arguments ..
14 INTEGER DESCX( * )
15* ..
16*
17* Purpose
18* =======
19*
20* PVDIMCHK checks the validity of the input test dimensions. In case of
21* an invalid parameter or discrepancy between the parameters, this rou-
22* tine displays error messages and returns an non-zero error code in
23* INFO.
24*
25* Notes
26* =====
27*
28* A description vector is associated with each 2D block-cyclicly dis-
29* tributed matrix. This vector stores the information required to
30* establish the mapping between a matrix entry and its corresponding
31* process and memory location.
32*
33* In the following comments, the character _ should be read as
34* "of the distributed matrix". Let A be a generic term for any 2D
35* block cyclicly distributed matrix. Its description vector is DESCA:
36*
37* NOTATION STORED IN EXPLANATION
38* ---------------- --------------- ------------------------------------
39* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
40* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
41* the NPROW x NPCOL BLACS process grid
42* A is distributed over. The context
43* itself is global, but the handle
44* (the integer value) may vary.
45* M_A (global) DESCA( M_ ) The number of rows in the distribu-
46* ted matrix A, M_A >= 0.
47* N_A (global) DESCA( N_ ) The number of columns in the distri-
48* buted matrix A, N_A >= 0.
49* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
50* block of the matrix A, IMB_A > 0.
51* INB_A (global) DESCA( INB_ ) The number of columns of the upper
52* left block of the matrix A,
53* INB_A > 0.
54* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
55* bute the last M_A-IMB_A rows of A,
56* MB_A > 0.
57* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
58* bute the last N_A-INB_A columns of
59* A, NB_A > 0.
60* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
61* row of the matrix A is distributed,
62* NPROW > RSRC_A >= 0.
63* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
64* first column of A is distributed.
65* NPCOL > CSRC_A >= 0.
66* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
67* array storing the local blocks of
68* the distributed matrix A,
69* IF( Lc( 1, N_A ) > 0 )
70* LLD_A >= MAX( 1, Lr( 1, M_A ) )
71* ELSE
72* LLD_A >= 1.
73*
74* Let K be the number of rows of a matrix A starting at the global in-
75* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
76* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
77* receive if these K rows were distributed over NPROW processes. If K
78* is the number of columns of a matrix A starting at the global index
79* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
80* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
81* these K columns were distributed over NPCOL processes.
82*
83* The values of Lr() and Lc() may be determined via a call to the func-
84* tion PB_NUMROC:
85* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
86* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
87*
88* Arguments
89* =========
90*
91* ICTXT (local input) INTEGER
92* On entry, ICTXT specifies the BLACS context handle, indica-
93* ting the global context of the operation. The context itself
94* is global, but the value of ICTXT is local.
95*
96* NOUT (global input) INTEGER
97* On entry, NOUT specifies the unit number for the output file.
98* When NOUT is 6, output to screen, when NOUT is 0, output to
99* stderr. NOUT is only defined for process 0.
100*
101* MATRIX (global input) CHARACTER*1
102* On entry, MATRIX specifies the one character matrix identi-
103* fier.
104*
105* IX (global input) INTEGER
106* On entry, IX specifies X's global row index, which points to
107* the beginning of the submatrix sub( X ).
108*
109* JX (global input) INTEGER
110* On entry, JX specifies X's global column index, which points
111* to the beginning of the submatrix sub( X ).
112*
113* DESCX (global and local input) INTEGER array
114* On entry, DESCX is an integer array of dimension DLEN_. This
115* is the array descriptor for the matrix X.
116*
117* INCX (global input) INTEGER
118* On entry, INCX specifies the global increment for the
119* elements of X. Only two values of INCX are supported in
120* this version, namely 1 and M_X. INCX must not be zero.
121*
122* INFO (global output) INTEGER
123* On exit, when INFO is zero, no error has been detected,
124* otherwise an error has been detected.
125*
126* -- Written on April 1, 1998 by
127* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
128*
129* =====================================================================
130*
131* .. Parameters ..
132 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
133 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
134 $ rsrc_
135 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
136 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
137 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
138 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
139* ..
140* .. Local Scalars ..
141 INTEGER MYCOL, MYROW, NPCOL, NPROW
142* ..
143* .. External Subroutines ..
144 EXTERNAL blacs_gridinfo, igsum2d
145* ..
146* .. Executable Statements ..
147*
148 info = 0
149 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
150*
151 IF( n.LT.0 ) THEN
152 info = 1
153 ELSE IF( n.EQ.0 ) THEN
154 IF( descx( m_ ).LT.0 )
155 $ info = 1
156 IF( descx( n_ ).LT.0 )
157 $ info = 1
158 ELSE
159 IF( incx.EQ.descx( m_ ) .AND.
160 $ descx( n_ ).LT.( jx+n-1 ) ) THEN
161 info = 1
162 ELSE IF( incx.EQ.1 .AND. incx.NE.descx( m_ ) .AND.
163 $ descx( m_ ).LT.( ix+n-1 ) ) THEN
164 info = 1
165 ELSE
166 IF( ix.GT.descx( m_ ) ) THEN
167 info = 1
168 ELSE IF( jx.GT.descx( n_ ) ) THEN
169 info = 1
170 END IF
171 END IF
172 END IF
173*
174* Check all processes for an error
175*
176 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
177*
178 IF( info.NE.0 ) THEN
179 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
180 WRITE( nout, fmt = 9999 ) matrix
181 WRITE( nout, fmt = 9998 ) n, matrix, ix, matrix, jx, matrix,
182 $ incx
183 WRITE( nout, fmt = 9997 ) matrix, descx( m_ ), matrix,
184 $ descx( n_ )
185 WRITE( nout, fmt = * )
186 END IF
187 END IF
188*
189 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
190 9998 FORMAT( 'N = ', i6, ', I', a1, ' = ', i6, ', J', a1, ' = ',
191 $ i6, ',INC', a1, ' = ', i6 )
192 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
193 $ i6, '.' )
194*
195 RETURN
196*
197* End of PVDIMCHK
198*
199 END
200 SUBROUTINE pmdimchk( ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA,
201 $ INFO )
202*
203* -- PBLAS test routine (version 2.0) --
204* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
205* and University of California, Berkeley.
206* April 1, 1998
207*
208* .. Scalar Arguments ..
209 CHARACTER*1 MATRIX
210 INTEGER ICTXT, INFO, IA, JA, M, N, NOUT
211* ..
212* .. Array Arguments ..
213 INTEGER DESCA( * )
214* ..
215*
216* Purpose
217* =======
218*
219* PMDIMCHK checks the validity of the input test dimensions. In case of
220* an invalid parameter or discrepancy between the parameters, this rou-
221* tine displays error messages and returns an non-zero error code in
222* INFO.
223*
224* Notes
225* =====
226*
227* A description vector is associated with each 2D block-cyclicly dis-
228* tributed matrix. This vector stores the information required to
229* establish the mapping between a matrix entry and its corresponding
230* process and memory location.
231*
232* In the following comments, the character _ should be read as
233* "of the distributed matrix". Let A be a generic term for any 2D
234* block cyclicly distributed matrix. Its description vector is DESCA:
235*
236* NOTATION STORED IN EXPLANATION
237* ---------------- --------------- ------------------------------------
238* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
239* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
240* the NPROW x NPCOL BLACS process grid
241* A is distributed over. The context
242* itself is global, but the handle
243* (the integer value) may vary.
244* M_A (global) DESCA( M_ ) The number of rows in the distribu-
245* ted matrix A, M_A >= 0.
246* N_A (global) DESCA( N_ ) The number of columns in the distri-
247* buted matrix A, N_A >= 0.
248* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
249* block of the matrix A, IMB_A > 0.
250* INB_A (global) DESCA( INB_ ) The number of columns of the upper
251* left block of the matrix A,
252* INB_A > 0.
253* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
254* bute the last M_A-IMB_A rows of A,
255* MB_A > 0.
256* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
257* bute the last N_A-INB_A columns of
258* A, NB_A > 0.
259* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
260* row of the matrix A is distributed,
261* NPROW > RSRC_A >= 0.
262* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
263* first column of A is distributed.
264* NPCOL > CSRC_A >= 0.
265* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
266* array storing the local blocks of
267* the distributed matrix A,
268* IF( Lc( 1, N_A ) > 0 )
269* LLD_A >= MAX( 1, Lr( 1, M_A ) )
270* ELSE
271* LLD_A >= 1.
272*
273* Let K be the number of rows of a matrix A starting at the global in-
274* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
275* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
276* receive if these K rows were distributed over NPROW processes. If K
277* is the number of columns of a matrix A starting at the global index
278* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
279* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
280* these K columns were distributed over NPCOL processes.
281*
282* The values of Lr() and Lc() may be determined via a call to the func-
283* tion PB_NUMROC:
284* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
285* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
286*
287* Arguments
288* =========
289*
290* ICTXT (local input) INTEGER
291* On entry, ICTXT specifies the BLACS context handle, indica-
292* ting the global context of the operation. The context itself
293* is global, but the value of ICTXT is local.
294*
295* NOUT (global input) INTEGER
296* On entry, NOUT specifies the unit number for the output file.
297* When NOUT is 6, output to screen, when NOUT is 0, output to
298* stderr. NOUT is only defined for process 0.
299*
300* MATRIX (global input) CHARACTER*1
301* On entry, MATRIX specifies the one character matrix identi-
302* fier.
303*
304* IA (global input) INTEGER
305* On entry, IA specifies A's global row index, which points to
306* the beginning of the submatrix sub( A ).
307*
308* JA (global input) INTEGER
309* On entry, JA specifies A's global column index, which points
310* to the beginning of the submatrix sub( A ).
311*
312* DESCA (global and local input) INTEGER array
313* On entry, DESCA is an integer array of dimension DLEN_. This
314* is the array descriptor for the matrix A.
315*
316* INFO (global output) INTEGER
317* On exit, when INFO is zero, no error has been detected,
318* otherwise an error has been detected.
319*
320* -- Written on April 1, 1998 by
321* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
322*
323* =====================================================================
324*
325* .. Parameters ..
326 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
327 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
328 $ rsrc_
329 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
330 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
331 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
332 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
333* ..
334* .. Local Scalars ..
335 INTEGER MYCOL, MYROW, NPCOL, NPROW
336* ..
337* .. External Subroutines ..
338 EXTERNAL blacs_gridinfo, igsum2d
339* ..
340* .. Executable Statements ..
341*
342 info = 0
343 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
344*
345 IF( ( m.LT.0 ).OR.( n.LT.0 ) ) THEN
346 info = 1
347 ELSE IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )THEN
348 IF( desca( m_ ).LT.0 )
349 $ info = 1
350 IF( desca( n_ ).LT.0 )
351 $ info = 1
352 ELSE
353 IF( desca( m_ ).LT.( ia+m-1 ) )
354 $ info = 1
355 IF( desca( n_ ).LT.( ja+n-1 ) )
356 $ info = 1
357 END IF
358*
359* Check all processes for an error
360*
361 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
362*
363 IF( info.NE.0 ) THEN
364 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
365 WRITE( nout, fmt = 9999 ) matrix
366 WRITE( nout, fmt = 9998 ) m, n, matrix, ia, matrix, ja
367 WRITE( nout, fmt = 9997 ) matrix, desca( m_ ), matrix,
368 $ desca( n_ )
369 WRITE( nout, fmt = * )
370 END IF
371 END IF
372*
373 9999 FORMAT( 'Incompatible arguments for matrix ', a1, ':' )
374 9998 FORMAT( 'M = ', i6, ', N = ', i6, ', I', a1, ' = ', i6,
375 $ ', J', a1, ' = ', i6 )
376 9997 FORMAT( 'DESC', a1, '( M_ ) = ', i6, ', DESC', a1, '( N_ ) = ',
377 $ i6, '.' )
378*
379 RETURN
380*
381* End of PMDIMCHK
382*
383 END
384 SUBROUTINE pvdescchk( ICTXT, NOUT, MATRIX, DESCX, DTX, MX, NX,
385 $ IMBX, INBX, MBX, NBX, RSRCX, CSRCX, INCX,
386 $ MPX, NQX, IPREX, IMIDX, IPOSTX, IGAP,
387 $ GAPMUL, INFO )
388*
389* -- PBLAS test routine (version 2.0) --
390* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
391* and University of California, Berkeley.
392* April 1, 1998
393*
394* .. Scalar Arguments ..
395 CHARACTER*1 MATRIX
396 INTEGER CSRCX, DTX, GAPMUL, ICTXT, IGAP, IMBX, IMIDX,
397 $ INBX, INCX, INFO, IPOSTX, IPREX, MBX, MPX, MX,
398 $ NBX, NOUT, NQX, NX, RSRCX
399* ..
400* .. Array Arguments ..
401 INTEGER DESCX( * )
402* ..
403*
404* Purpose
405* =======
406*
407* PVDESCCHK checks the validity of the input test parameters and ini-
408* tializes the descriptor DESCX and the scalar variables MPX, NQX. In
409* case of an invalid parameter, this routine displays error messages
410* and return an non-zero error code in INFO.
411*
412* Notes
413* =====
414*
415* A description vector is associated with each 2D block-cyclicly dis-
416* tributed matrix. This vector stores the information required to
417* establish the mapping between a matrix entry and its corresponding
418* process and memory location.
419*
420* In the following comments, the character _ should be read as
421* "of the distributed matrix". Let A be a generic term for any 2D
422* block cyclicly distributed matrix. Its description vector is DESCA:
423*
424* NOTATION STORED IN EXPLANATION
425* ---------------- --------------- ------------------------------------
426* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
427* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
428* the NPROW x NPCOL BLACS process grid
429* A is distributed over. The context
430* itself is global, but the handle
431* (the integer value) may vary.
432* M_A (global) DESCA( M_ ) The number of rows in the distribu-
433* ted matrix A, M_A >= 0.
434* N_A (global) DESCA( N_ ) The number of columns in the distri-
435* buted matrix A, N_A >= 0.
436* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
437* block of the matrix A, IMB_A > 0.
438* INB_A (global) DESCA( INB_ ) The number of columns of the upper
439* left block of the matrix A,
440* INB_A > 0.
441* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
442* bute the last M_A-IMB_A rows of A,
443* MB_A > 0.
444* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
445* bute the last N_A-INB_A columns of
446* A, NB_A > 0.
447* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
448* row of the matrix A is distributed,
449* NPROW > RSRC_A >= 0.
450* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
451* first column of A is distributed.
452* NPCOL > CSRC_A >= 0.
453* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
454* array storing the local blocks of
455* the distributed matrix A,
456* IF( Lc( 1, N_A ) > 0 )
457* LLD_A >= MAX( 1, Lr( 1, M_A ) )
458* ELSE
459* LLD_A >= 1.
460*
461* Let K be the number of rows of a matrix A starting at the global in-
462* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
463* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
464* receive if these K rows were distributed over NPROW processes. If K
465* is the number of columns of a matrix A starting at the global index
466* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
467* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
468* these K columns were distributed over NPCOL processes.
469*
470* The values of Lr() and Lc() may be determined via a call to the func-
471* tion PB_NUMROC:
472* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
473* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
474*
475* Arguments
476* =========
477*
478* ICTXT (local input) INTEGER
479* On entry, ICTXT specifies the BLACS context handle, indica-
480* ting the global context of the operation. The context itself
481* is global, but the value of ICTXT is local.
482*
483* NOUT (global input) INTEGER
484* On entry, NOUT specifies the unit number for the output file.
485* When NOUT is 6, output to screen, when NOUT is 0, output to
486* stderr. NOUT is only defined for process 0.
487*
488* MATRIX (global input) CHARACTER*1
489* On entry, MATRIX specifies the one character matrix identi-
490* fier.
491*
492* DESCX (global output) INTEGER array
493* On entry, DESCX is an array of dimension DLEN_. DESCX is the
494* array descriptor to be set.
495*
496* DTYPEX (global input) INTEGER
497* On entry, DTYPEX specifies the descriptor type. In this ver-
498* sion, DTYPEX must be BLOCK_CYCLIC_INB_2D.
499*
500* MX (global input) INTEGER
501* On entry, MX specifies the number of rows in the matrix. MX
502* must be at least zero.
503*
504* NX (global input) INTEGER
505* On entry, NX specifies the number of columns in the matrix.
506* NX must be at least zero.
507*
508* IMBX (global input) INTEGER
509* On entry, IMBX specifies the row blocking factor used to dis-
510* tribute the first IMBX rows of the matrix. IMBX must be at
511* least one.
512*
513* INBX (global input) INTEGER
514* On entry, INBX specifies the column blocking factor used to
515* distribute the first INBX columns of the matrix. INBX must
516* be at least one.
517*
518* MBX (global input) INTEGER
519* On entry, MBX specifies the row blocking factor used to dis-
520* tribute the rows of the matrix. MBX must be at least one.
521*
522* NBX (global input) INTEGER
523* On entry, NBX specifies the column blocking factor used to
524* distribute the columns of the matrix. NBX must be at least
525* one.
526*
527* RSRCX (global input) INTEGER
528* On entry, RSRCX specifies the process row in which the first
529* row of the matrix resides. When RSRCX is -1, the matrix is
530* row replicated, otherwise RSCRX must be at least zero and
531* strictly less than NPROW.
532*
533* CSRCX (global input) INTEGER
534* On entry, CSRCX specifies the process column in which the
535* first column of the matrix resides. When CSRCX is -1, the
536* matrix is column replicated, otherwise CSCRX must be at least
537* zero and strictly less than NPCOL.
538*
539* INCX (global input) INTEGER
540* On entry, INCX specifies the global vector increment. INCX
541* must be one or MX.
542*
543* MPX (local output) INTEGER
544* On exit, MPX is Lr( 1, MX ).
545*
546* NQX (local output) INTEGER
547* On exit, NQX is Lc( 1, NX ).
548*
549* IPREX (local output) INTEGER
550* On exit, IPREX specifies the size of the guard zone to put
551* before the start of the local padded array.
552*
553* IMIDX (local output) INTEGER
554* On exit, IMIDX specifies the ldx-gap of the guard zone to
555* put after each column of the local padded array.
556*
557* IPOSTX (local output) INTEGER
558* On exit, IPOSTX specifies the size of the guard zone to put
559* after the local padded array.
560*
561* IGAP (global input) INTEGER
562* On entry, IGAP specifies the size of the ldx-gap.
563*
564* GAPMUL (global input) INTEGER
565* On entry, GAPMUL is a constant factor controlling the size
566* of the pre- and post guardzone.
567*
568* INFO (global output) INTEGER
569* On exit, when INFO is zero, no error has been detected,
570* otherwise an error has been detected.
571*
572* -- Written on April 1, 1998 by
573* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
574*
575* =====================================================================
576*
577* .. Parameters ..
578 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
579 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
580 $ RSRC_
581 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
582 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
583 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
584 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
585* ..
586* .. Local Scalars ..
587 INTEGER LLDX, MYCOL, MYROW, NPCOL, NPROW
588* ..
589* .. External Subroutines ..
590 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_DESCINIT2
591* ..
592* .. External Functions ..
593 INTEGER PB_NUMROC
594 EXTERNAL PB_NUMROC
595* ..
596* .. Intrinsic Functions ..
597 INTRINSIC max
598* ..
599* .. Executable Statements ..
600*
601 info = 0
602 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
603*
604* Verify descriptor type DTYPE_
605*
606 IF( dtx.NE.block_cyclic_2d_inb ) THEN
607 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
608 $ WRITE( nout, fmt = 9999 ) matrix, 'DTYPE', matrix, dtx,
609 $ block_cyclic_2d_inb
610 info = 1
611 END IF
612*
613* Verify global matrix dimensions (M_,N_) are correct
614*
615 IF( mx.LT.0 ) THEN
616 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
617 $ WRITE( nout, fmt = 9998 ) matrix, 'M', matrix, mx
618 info = 1
619 ELSE IF( nx.LT.0 ) THEN
620 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( imbx.LT.1 ) THEN
628 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
629 $ WRITE( nout, fmt = 9996 ) matrix, 'IMB', matrix, imbx
630 info = 1
631 ELSE IF( inbx.LT.1 ) THEN
632 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( mbx.LT.1 ) THEN
640 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
641 $ WRITE( nout, fmt = 9994 ) matrix, 'MB', matrix, mbx
642 info = 1
643 ELSE IF( nbx.LT.1 ) THEN
644 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( rsrcx.LT.-1 .OR. rsrcx.GE.nprow ) THEN
652 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
653 WRITE( nout, fmt = 9992 ) matrix
654 WRITE( nout, fmt = 9990 ) 'RSRC', matrix, rsrcx, nprow
655 END IF
656 info = 1
657 ELSE IF( csrcx.LT.-1 .OR. csrcx.GE.npcol ) THEN
658 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 IF( incx.NE.1 .AND. incx.NE.mx ) THEN
668 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 IF( info.NE.0 ) THEN
680*
681 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 IF( info.NE.0 ) THEN
705 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 IF( dta.NE.block_cyclic_2d_inb ) THEN
961 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( ma.LT.0 ) THEN
970 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
971 $ WRITE( nout, fmt = 9998 ) matrix, 'M', matrix, ma
972 info = 1
973 ELSE IF( na.LT.0 ) THEN
974 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( imba.LT.1 ) THEN
982 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
983 $ WRITE( nout, fmt = 9996 ) matrix, 'IMB', matrix, imba
984 info = 1
985 ELSE IF( inba.LT.1 ) THEN
986 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( mba.LT.1 ) THEN
994 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
995 $ WRITE( nout, fmt = 9994 ) matrix, 'MB', matrix, mba
996 info = 1
997 ELSE IF( nba.LT.1 ) THEN
998 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
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 IF( rsrca.LT.-1 .OR. rsrca.GE.nprow ) THEN
1006 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
1007 WRITE( nout, fmt = 9992 ) matrix
1008 WRITE( nout, fmt = 9990 ) 'RSRC', matrix, rsrca, nprow
1009 END IF
1010 info = 1
1011 ELSE IF( csrca.LT.-1 .OR. csrca.GE.npcol ) THEN
1012 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 IF( info.NE.0 ) THEN
1024*
1025 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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 DOUBLE PRECISION FUNCTION pdopbl2( SUBNAM, M, N, KKL, KKU )
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 CHARACTER*7 subnam
1092 INTEGER kkl, kku, M, n
1093* ..
1094*
1095* Purpose
1096* =======
1097*
1098* PDOPBL2 computes an approximation of the number of floating point
1099* operations performed by a subroutine SUBNAM with the given values of
1100* the parameters M, N, KL, and KU.
1101*
1102* This version counts operations for the Level 2 PBLAS.
1103*
1104* Arguments
1105* =========
1106*
1107* SUBNAM (input) CHARACTER*7
1108* On entry, SUBNAM specifies the name of the subroutine.
1109*
1110* M (input) INTEGER
1111* On entry, M specifies the number of rows of the coefficient
1112* matrix. M must be at least zero.
1113*
1114* N (input) INTEGER
1115* On entry, N specifies the number of columns of the coeffi-
1116* cient matrix. If the matrix is square (such as in a solve
1117* routine) then N is the number of right hand sides. N must be
1118* at least zero.
1119*
1120* KKL (input) INTEGER
1121* On entry, KKL specifies the lower band width of the coeffi-
1122* cient matrix. KL is set to max( 0, min( M-1, KKL ) ).
1123*
1124* KKU (input) INTEGER
1125* On entry, KKU specifies the upper band width of the coeffi-
1126* cient matrix. KU is set to max( 0, min( N-1, KKU ) ).
1127*
1128* -- Written on April 1, 1998 by
1129* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1130*
1131* =====================================================================
1132*
1133* .. Parameters ..
1134 DOUBLE PRECISION one, six, two, ZERO
1135 PARAMETER ( one = 1.0d+0, six = 6.0d+0, two = 2.0d+0,
1136 $ zero = 0.0d+0 )
1137* ..
1138* .. Local Scalars ..
1139 CHARACTER*1 c1
1140 CHARACTER*2 c2
1141 CHARACTER*3 c3
1142 DOUBLE PRECISION adds, ek, em, en, kl, ku, mults
1143* ..
1144* .. External Functions ..
1145 LOGICAL lsame, lsamen
1146 EXTERNAL lsame, lsamen
1147* ..
1148* .. Intrinsic Functions ..
1149 INTRINSIC dble, max, min
1150* ..
1151* .. Executable Statements ..
1152*
1153* Quick return if possible
1154*
1155 IF( m.LE.0 .OR. .NOT.( lsamen( 2, subnam, 'PS' ) .OR.
1156 $ lsamen( 2, subnam, 'PD' ) .OR.
1157 $ lsamen( 2, subnam, 'PC' ) .OR. lsamen( 2, subnam, 'PZ' ) ) )
1158 $ THEN
1159 pdopbl2 = zero
1160 RETURN
1161 END IF
1162*
1163 c1 = subnam( 2: 2 )
1164 c2 = subnam( 3: 4 )
1165 c3 = subnam( 5: 7 )
1166 mults = zero
1167 adds = zero
1168 kl = max( 0, min( m-1, kkl ) )
1169 ku = max( 0, min( n-1, kku ) )
1170 em = dble( m )
1171 en = dble( n )
1172 ek = dble( kl )
1173*
1174* -------------------------------
1175* Matrix-vector multiply routines
1176* -------------------------------
1177*
1178 IF( lsamen( 3, c3, 'MV ' ) ) THEN
1179*
1180 IF( lsamen( 2, c2, 'GE' ) ) THEN
1181*
1182 mults = em * ( en + one )
1183 adds = em * en
1184*
1185* Assume M <= N + KL and KL < M
1186* N <= M + KU and KU < N
1187* so that the zero sections are triangles.
1188*
1189 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
1190*
1191 mults = em * ( en + one ) -
1192 $ ( em - one - kl ) * ( em - kl ) / two -
1193 $ ( en - one - ku ) * ( en - ku ) / two
1194 adds = em * ( en + one ) -
1195 $ ( em - one - kl ) * ( em - kl ) / two -
1196 $ ( en - one - ku ) * ( en - ku ) / two
1197*
1198 ELSE IF( lsamen( 2, c2, 'SY' ) .OR. lsamen( 2, c2, 'SP' ) .OR.
1199 $ lsamen( 2, c2, 'he.OR.' ) LSAMEN( 2, C2, 'hp' ) )
1200 $ THEN
1201*
1202 MULTS = EM * ( EM + ONE )
1203 ADDS = EM * EM
1204*
1205 ELSE IF( LSAMEN( 2, C2, 'sb.OR.' )
1206 $ LSAMEN( 2, C2, 'hb' ) ) THEN
1207*
1208 MULTS = EM * ( EM + ONE ) - ( EM - ONE - EK ) * ( EM - EK )
1209 ADDS = EM * EM - ( EM - ONE - EK ) * ( EM - EK )
1210*
1211 ELSE IF( LSAMEN( 2, C2, 'tr.OR.' ) LSAMEN( 2, C2, 'tp' ) )
1212 $ THEN
1213*
1214 MULTS = EM * ( EM + ONE ) / TWO
1215 ADDS = ( EM - ONE ) * EM / TWO
1216*
1217 ELSE IF( LSAMEN( 2, C2, 'tb' ) ) THEN
1218*
1219 MULTS = EM * ( EM + ONE ) / TWO -
1220 $ ( EM - EK - ONE ) * ( EM - EK ) / TWO
1221 ADDS = ( EM - ONE ) * EM / TWO -
1222 $ ( EM - EK - ONE ) * ( EM - EK ) / TWO
1223*
1224 END IF
1225*
1226* ---------------------
1227* Matrix solve routines
1228* ---------------------
1229*
1230 ELSE IF( LSAMEN( 3, C3, 'sv ' ) ) THEN
1231*
1232 IF( LSAMEN( 2, C2, 'tr.OR.' ) LSAMEN( 2, C2, 'tp' ) ) THEN
1233*
1234 MULTS = EM * ( EM + ONE ) / TWO
1235 ADDS = ( EM - ONE ) * EM / TWO
1236*
1237 ELSE IF( LSAMEN( 2, C2, 'tb' ) ) THEN
1238*
1239 MULTS = EM * ( EM + ONE ) / TWO -
1240 $ ( EM - EK - ONE ) * ( EM - EK ) / TWO
1241 ADDS = ( EM - ONE ) * EM / TWO -
1242 $ ( EM - EK - ONE ) * ( EM - EK ) / TWO
1243*
1244 END IF
1245*
1246* ----------------
1247* Rank-one updates
1248* ----------------
1249*
1250 ELSE IF( LSAMEN( 3, C3, 'r ' ) ) THEN
1251*
1252 IF( LSAMEN( 2, C2, 'ge' ) ) THEN
1253*
1254 MULTS = EM * EN + MIN( EM, EN )
1255 ADDS = EM * EN
1256*
1257 ELSE IF( LSAMEN( 2, C2, 'sy.OR.' ) LSAMEN( 2, C2, 'sp.OR.' )
1258 $ LSAMEN( 2, C2, 'he.OR.' ) LSAMEN( 2, C2, 'hp' ) )
1259 $ THEN
1260*
1261 MULTS = EM * ( EM + ONE ) / TWO + EM
1262 ADDS = EM * ( EM + ONE ) / TWO
1263*
1264 END IF
1265*
1266 ELSE IF( LSAMEN( 3, C3, 'rc .OR.' ) LSAMEN( 3, C3, 'ru ' ) ) THEN
1267*
1268 IF( LSAMEN( 2, C2, 'ge' ) ) THEN
1269*
1270 MULTS = EM * EN + MIN( EM, EN )
1271 ADDS = EM * EN
1272*
1273 END IF
1274*
1275* ----------------
1276* Rank-two updates
1277* ----------------
1278*
1279 ELSE IF( LSAMEN( 3, C3, 'r2 ' ) ) THEN
1280 IF( LSAMEN( 2, C2, 'sy.OR.' ) LSAMEN( 2, C2, 'sp.OR.' )
1281 $ LSAMEN( 2, C2, 'he.OR.' ) LSAMEN( 2, C2, 'hp' ) ) THEN
1282*
1283 MULTS = EM * ( EM + ONE ) + TWO * EM
1284 ADDS = EM * ( EM + ONE )
1285*
1286 END IF
1287 END IF
1288*
1289* ------------------------------------------------
1290* Compute the total number of operations.
1291* For real and double precision routines, count
1292* 1 for each multiply and 1 for each add.
1293* For complex and complex*16 routines, count
1294* 6 for each multiply and 2 for each add.
1295* ------------------------------------------------
1296*
1297 IF( LSAME( C1, 's.OR.' ) LSAME( C1, 'd' ) ) THEN
1298*
1299 PDOPBL2 = MULTS + ADDS
1300*
1301 ELSE
1302*
1303 PDOPBL2 = SIX * MULTS + TWO * ADDS
1304*
1305 END IF
1306*
1307 RETURN
1308*
1309* End of PDOPBL2
1310*
1311 END
1312 DOUBLE PRECISION FUNCTION PDOPBL3( SUBNAM, M, N, K )
1313*
1314* -- PBLAS test routine (version 2.0) --
1315* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1316* and University of California, Berkeley.
1317* April 1, 1998
1318*
1319* .. Scalar Arguments ..
1320 CHARACTER*7 SUBNAM
1321 INTEGER K, M, N
1322* ..
1323*
1324* Purpose
1325* =======
1326*
1327* PDOPBL3 computes an approximation of the number of floating point
1328* operations performed by a subroutine SUBNAM with the given values of
1329* the parameters M, N and K.
1330*
1331* This version counts operations for the Level 3 PBLAS.
1332*
1333* Arguments
1334* =========
1335*
1336* SUBNAM (input) CHARACTER*7
1337* On entry, SUBNAM specifies the name of the subroutine.
1338*
1339* M (input) INTEGER
1340* N (input) INTEGER
1341* K (input) INTEGER
1342* On entry, M, N, and K contain parameter values used by the
1343* Level 3 PBLAS. The output matrix is always M x N or N x N if
1344* symmetric, but K has different uses in different contexts.
1345* For example, in the matrix-matrix multiply routine, we have
1346* C = A * B where C is M x N, A is M x K, and B is K x N. In
1347* PxSYMM, PxHEMM, PxTRMM, and PxTRSM, K indicates whether the
1348* matrix A is applied on the left or right. If K <= 0, the ma-
1349* trix is applied on the left, and if K > 0, on the right. In
1350* PxTRADD, K indicates whether the matrix C is upper or lower
1351* triangular. If K <= 0, the matrix C is upper triangular, and
1352* lower triangular otherwise.
1353*
1354* -- Written on April 1, 1998 by
1355* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1356*
1357* =====================================================================
1358*
1359* .. Parameters ..
1360 DOUBLE PRECISION ONE, SIX, TWO, ZERO
1361 PARAMETER ( ONE = 1.0D+0, SIX = 6.0D+0, TWO = 2.0D+0,
1362 $ ZERO = 0.0D+0 )
1363* ..
1364* .. Local Scalars ..
1365 CHARACTER*1 C1
1366 CHARACTER*2 C2
1367 CHARACTER*3 C3
1368 DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
1369* ..
1370* .. External Functions ..
1371 LOGICAL LSAME, LSAMEN
1372 EXTERNAL LSAME, LSAMEN
1373* ..
1374* .. Intrinsic Functions ..
1375 INTRINSIC DBLE
1376* ..
1377* .. Executable Statements ..
1378*
1379* Quick return if possible
1380*
1381.LE..OR..NOT. IF( M0 ( LSAMEN( 2, SUBNAM, 'ps.OR.' )
1382 $ LSAMEN( 2, SUBNAM, 'pd.OR.' ) LSAMEN( 2, SUBNAM, 'pc' )
1383.OR. $ LSAMEN( 2, SUBNAM, 'pz' ) ) )
1384 $ THEN
1385 PDOPBL3 = ZERO
1386 RETURN
1387 END IF
1388*
1389 C1 = SUBNAM( 2: 2 )
1390 C2 = SUBNAM( 3: 4 )
1391 C3 = SUBNAM( 5: 7 )
1392 MULTS = ZERO
1393 ADDS = ZERO
1394 EM = DBLE( M )
1395 EN = DBLE( N )
1396 EK = DBLE( K )
1397*
1398* ----------------------
1399* Matrix-matrix products
1400* assume beta = 1
1401* ----------------------
1402*
1403 IF( LSAMEN( 3, C3, 'mm ' ) ) THEN
1404*
1405 IF( LSAMEN( 2, C2, 'ge' ) ) THEN
1406*
1407 MULTS = EM * EK * EN
1408 ADDS = EM * EK * EN
1409*
1410 ELSE IF( LSAMEN( 2, C2, 'sy.OR.' )
1411 $ LSAMEN( 2, C2, 'he' ) ) THEN
1412*
1413* IF K <= 0, assume A multiplies B on the left.
1414*
1415 IF( k.LE.0 ) THEN
1416 mults = em * em * en
1417 adds = em * em * en
1418 ELSE
1419 mults = em * en * en
1420 adds = em * en * en
1421 END IF
1422*
1423 ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
1424*
1425* IF K <= 0, assume A multiplies B on the left.
1426*
1427 IF( k.LE.0 ) THEN
1428 mults = en * em * ( em + one ) / two
1429 adds = en * em * ( em - one ) / two
1430 ELSE
1431 mults = em * en * ( en + one ) / two
1432 adds = em * en * ( en - one ) / two
1433 END IF
1434*
1435 END IF
1436*
1437* ------------------------------------------------
1438* Rank-K update of a symmetric or Hermitian matrix
1439* ------------------------------------------------
1440*
1441 ELSE IF( lsamen( 3, c3, 'RK ' ) ) THEN
1442*
1443 IF( lsamen( 2, c2, 'SY' ) .OR.
1444 $ lsamen( 2, c2, 'HE' ) ) THEN
1445*
1446 mults = ek * em *( em + one ) / two
1447 adds = ek * em *( em + one ) / two
1448 END IF
1449*
1450* -------------------------------------------------
1451* Rank-2K update of a symmetric or Hermitian matrix
1452* -------------------------------------------------
1453*
1454 ELSE IF( lsamen( 3, c3, 'R2K' ) ) THEN
1455*
1456 IF( lsamen( 2, c2, 'sy.OR.' )
1457 $ LSAMEN( 3, C2, 'he' ) ) THEN
1458*
1459 MULTS = EK * EM * EM
1460 ADDS = EK * EM * EM + EM
1461 END IF
1462*
1463* -----------------------------------------
1464* Solving system with many right hand sides
1465* -----------------------------------------
1466*
1467 ELSE IF( LSAMEN( 4, SUBNAM( 3:6 ), 'trsm' ) ) THEN
1468*
1469.LE. IF( K0 ) THEN
1470 MULTS = EN * EM * ( EM + ONE ) / TWO
1471 ADDS = EN * EM * ( EM - ONE ) / TWO
1472 ELSE
1473 MULTS = EM * EN * ( EN + ONE ) / TWO
1474 ADDS = EM * EN * ( EN - ONE ) / TWO
1475 END IF
1476*
1477* --------------------------
1478* Matrix (tranpose) Addition
1479* --------------------------
1480*
1481 ELSE IF( LSAMEN( 3, C3, 'add' ) ) THEN
1482*
1483 IF( LSAMEN( 2, C2, 'ge' ) ) THEN
1484*
1485 MULTS = 2 * EM * EN
1486 ADDS = EM * EN
1487*
1488 ELSE IF( LSAMEN( 2, C2, 'tr' ) ) THEN
1489*
1490* IF K <= 0, assume C is upper triangular.
1491*
1492.LE. IF( K0 ) THEN
1493.LE. IF( MN ) THEN
1494 MULTS = EM * ( TWO * EN - EM + ONE )
1495 ADDS = EM * ( EM + ONE ) / TWO + EM * ( EN - EM )
1496 ELSE
1497 MULTS = EN * ( EN + ONE )
1498 ADDS = EN * ( EN + ONE ) / TWO
1499 END IF
1500 ELSE
1501.GE. IF( MN ) THEN
1502 MULTS = EN * ( TWO * EM - EN + ONE )
1503 ADDS = EN * ( EN + ONE ) / TWO + EN * ( EM - EN )
1504 ELSE
1505 MULTS = EM * ( EM + ONE )
1506 ADDS = EM * ( EM + ONE ) / TWO
1507 END IF
1508 END IF
1509*
1510 END IF
1511*
1512 END IF
1513*
1514* ------------------------------------------------
1515* Compute the total number of operations.
1516* For real and double precision routines, count
1517* 1 for each multiply and 1 for each add.
1518* For complex and complex*16 routines, count
1519* 6 for each multiply and 2 for each add.
1520* ------------------------------------------------
1521*
1522 IF( LSAME( C1, 's.OR.' ) LSAME( C1, 'd' ) ) THEN
1523*
1524 PDOPBL3 = MULTS + ADDS
1525*
1526 ELSE
1527*
1528 PDOPBL3 = SIX * MULTS + TWO * ADDS
1529*
1530 END IF
1531*
1532 RETURN
1533*
1534* End of PDOPBL3
1535*
1536 END
1537 SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO )
1538*
1539* -- PBLAS test routine (version 2.0) --
1540* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1541* and University of California, Berkeley.
1542* April 1, 1998
1543*
1544* .. Scalar Arguments ..
1545 INTEGER ICTXT, INFO
1546* ..
1547* .. Array Arguments ..
1548 CHARACTER*(*) SRNAME
1549* ..
1550*
1551* Purpose
1552* =======
1553*
1554* PXERBLA is an error handler for the ScaLAPACK routines. It is called
1555* by a ScaLAPACK routine if an input parameter has an invalid value. A
1556* message is printed. Installers may consider modifying this routine in
1557* order to call system-specific exception-handling facilities.
1558*
1559* Arguments
1560* =========
1561*
1562* ICTXT (local input) INTEGER
1563* On entry, ICTXT specifies the BLACS context handle, indica-
1564* ting the global context of the operation. The context itself
1565* is global, but the value of ICTXT is local.
1566*
1567* SRNAME (global input) CHARACTER*(*)
1568* On entry, SRNAME specifies the name of the routine which cal-
1569* ling PXERBLA.
1570*
1571* INFO (global input) INTEGER
1572* On entry, INFO specifies the position of the invalid parame-
1573* ter in the parameter list of the calling routine.
1574*
1575* -- Written on April 1, 1998 by
1576* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1577*
1578* =====================================================================
1579*
1580* .. Local Scalars ..
1581 INTEGER MYCOL, MYROW, NPCOL, NPROW
1582* ..
1583* .. External Subroutines ..
1584 EXTERNAL BLACS_GRIDINFO
1585* ..
1586* .. Executable Statements ..
1587*
1588 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
1589*
1590 WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO
1591*
1592 9999 FORMAT( '{', I5, ',', I5, '}: on entry to ', A,
1593 $ ' parameter number ', I4, ' had an illegal value' )
1594*
1595 RETURN
1596*
1597* End of PXERBLA
1598*
1599 END
1600 LOGICAL FUNCTION LSAME( CA, CB )
1601*
1602* -- LAPACK auxiliary routine (version 2.1) --
1603* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1604* Courant Institute, Argonne National Lab, and Rice University
1605* September 30, 1994
1606*
1607* .. Scalar Arguments ..
1608 CHARACTER CA, CB
1609* ..
1610*
1611* Purpose
1612* =======
1613*
1614* LSAME returns .TRUE. if CA is the same letter as CB regardless of
1615* case.
1616*
1617* Arguments
1618* =========
1619*
1620* CA (input) CHARACTER*1
1621* CB (input) CHARACTER*1
1622* CA and CB specify the single characters to be compared.
1623*
1624* =====================================================================
1625*
1626* .. Intrinsic Functions ..
1627 INTRINSIC ICHAR
1628* ..
1629* .. Local Scalars ..
1630 INTEGER INTA, INTB, ZCODE
1631* ..
1632* .. Executable Statements ..
1633*
1634* Test if the characters are equal
1635*
1636.EQ. LSAME = CACB
1637 IF( LSAME )
1638 $ RETURN
1639*
1640* Now test for equivalence if both characters are alphabetic.
1641*
1642 ZCODE = ICHAR( 'z' )
1643*
1644* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
1645* machines, on which ICHAR returns a value with bit 8 set.
1646* ICHAR('A') on Prime machines returns 193 which is the same as
1647* ICHAR('A') on an EBCDIC machine.
1648*
1649 INTA = ICHAR( CA )
1650 INTB = ICHAR( CB )
1651*
1652.EQ..OR..EQ. IF( ZCODE90 ZCODE122 ) THEN
1653*
1654* ASCII is assumed - ZCODE is the ASCII code of either lower or
1655* upper case 'Z'.
1656*
1657.GE..AND..LE. IF( INTA97 INTA122 ) INTA = INTA - 32
1658.GE..AND..LE. IF( INTB97 INTB122 ) INTB = INTB - 32
1659*
1660.EQ..OR..EQ. ELSE IF( ZCODE233 ZCODE169 ) THEN
1661*
1662* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
1663* upper case 'Z'.
1664*
1665.GE..AND..LE..OR. IF( INTA129 INTA137
1666.GE..AND..LE..OR. $ INTA145 INTA153
1667.GE..AND..LE. $ INTA162 INTA169 ) INTA = INTA + 64
1668.GE..AND..LE..OR. IF( INTB129 INTB137
1669.GE..AND..LE..OR. $ INTB145 INTB153
1670.GE..AND..LE. $ INTB162 INTB169 ) INTB = INTB + 64
1671*
1672.EQ..OR..EQ. ELSE IF( ZCODE218 ZCODE250 ) THEN
1673*
1674* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
1675* plus 128 of either lower or upper case 'Z'.
1676*
1677.GE..AND..LE. IF( INTA225 INTA250 ) INTA = INTA - 32
1678.GE..AND..LE. IF( INTB225 INTB250 ) INTB = INTB - 32
1679 END IF
1680.EQ. LSAME = INTAINTB
1681*
1682* RETURN
1683*
1684* End of LSAME
1685*
1686 END
1687 LOGICAL FUNCTION LSAMEN( N, CA, CB )
1688*
1689* -- LAPACK auxiliary routine (version 2.1) --
1690* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1691* Courant Institute, Argonne National Lab, and Rice University
1692* September 30, 1994
1693*
1694* .. Scalar Arguments ..
1695 CHARACTER*( * ) CA, CB
1696 INTEGER N
1697* ..
1698*
1699* Purpose
1700* =======
1701*
1702* LSAMEN tests if the first N letters of CA are the same as the
1703* first N letters of CB, regardless of case.
1704* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
1705* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
1706* or LEN( CB ) is less than N.
1707*
1708* Arguments
1709* =========
1710*
1711* N (input) INTEGER
1712* The number of characters in CA and CB to be compared.
1713*
1714* CA (input) CHARACTER*(*)
1715* CB (input) CHARACTER*(*)
1716* CA and CB specify two character strings of length at least N.
1717* Only the first N characters of each string will be accessed.
1718*
1719* =====================================================================
1720*
1721* .. Local Scalars ..
1722 INTEGER I
1723* ..
1724* .. External Functions ..
1725 LOGICAL LSAME
1726 EXTERNAL LSAME
1727* ..
1728* .. Intrinsic Functions ..
1729 INTRINSIC LEN
1730* ..
1731* .. Executable Statements ..
1732*
1733 LSAMEN = .FALSE.
1734.LT..OR..LT. IF( LEN( CA )N LEN( CB )N )
1735 $ GO TO 20
1736*
1737* Do for each character in the two strings.
1738*
1739 DO 10 I = 1, N
1740*
1741* Test if the characters are equal using LSAME.
1742*
1743.NOT. IF( LSAME( CA( I: I ), CB( I: I ) ) )
1744 $ GO TO 20
1745*
1746 10 CONTINUE
1747 LSAMEN = .TRUE.
1748*
1749 20 CONTINUE
1750 RETURN
1751*
1752* End of LSAMEN
1753*
1754 END
1755 SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
1756*
1757* -- LAPACK auxiliary test routine (version 2.1) --
1758* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1759* Courant Institute, Argonne National Lab, and Rice University
1760* February 29, 1992
1761*
1762* .. Scalar Arguments ..
1763 INTEGER INCX, INCY, N
1764* ..
1765* .. Array Arguments ..
1766 INTEGER SX( * ), SY( * )
1767* ..
1768*
1769* Purpose
1770* =======
1771*
1772* ICOPY copies an integer vector x to an integer vector y.
1773* Uses unrolled loops for increments equal to 1.
1774*
1775* Arguments
1776* =========
1777*
1778* N (input) INTEGER
1779* The length of the vectors SX and SY.
1780*
1781* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
1782* The vector X.
1783*
1784* INCX (input) INTEGER
1785* The spacing between consecutive elements of SX.
1786*
1787* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
1788* The vector Y.
1789*
1790* INCY (input) INTEGER
1791* The spacing between consecutive elements of SY.
1792*
1793* =====================================================================
1794*
1795* .. Local Scalars ..
1796 INTEGER I, IX, IY, M, MP1
1797* ..
1798* .. Intrinsic Functions ..
1799 INTRINSIC MOD
1800* ..
1801* .. Executable Statements ..
1802*
1803.LE. IF( N0 )
1804 $ RETURN
1805.EQ..AND..EQ. IF( INCX1 INCY1 )
1806 $ GO TO 20
1807*
1808* Code for unequal increments or equal increments not equal to 1
1809*
1810 IX = 1
1811 IY = 1
1812.LT. IF( INCX0 )
1813 $ IX = ( -N+1 )*INCX + 1
1814.LT. IF( INCY0 )
1815 $ IY = ( -N+1 )*INCY + 1
1816 DO 10 I = 1, N
1817 SY( IY ) = SX( IX )
1818 IX = IX + INCX
1819 IY = IY + INCY
1820 10 CONTINUE
1821 RETURN
1822*
1823* Code for both increments equal to 1
1824*
1825* Clean-up loop
1826*
1827 20 CONTINUE
1828 M = MOD( N, 7 )
1829.EQ. IF( M0 )
1830 $ GO TO 40
1831 DO 30 I = 1, M
1832 SY( I ) = SX( I )
1833 30 CONTINUE
1834.LT. IF( N7 )
1835 $ RETURN
1836 40 CONTINUE
1837 MP1 = M + 1
1838 DO 50 I = MP1, N, 7
1839 SY( I ) = SX( I )
1840 SY( I+1 ) = SX( I+1 )
1841 SY( I+2 ) = SX( I+2 )
1842 SY( I+3 ) = SX( I+3 )
1843 SY( I+4 ) = SX( I+4 )
1844 SY( I+5 ) = SX( I+5 )
1845 SY( I+6 ) = SX( I+6 )
1846 50 CONTINUE
1847 RETURN
1848*
1849* End of ICOPY
1850*
1851 END
1852 INTEGER FUNCTION PB_NOABORT( CINFO )
1853*
1854* -- PBLAS test routine (version 2.0) --
1855* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1856* and University of California, Berkeley.
1857* April 1, 1998
1858*
1859* .. Scalar Arguments ..
1860 INTEGER CINFO
1861* ..
1862*
1863* Purpose
1864* =======
1865*
1866* PB_NOABORT transmits the info parameter of a PBLAS routine to the
1867* tester and tells the PBLAS error handler to avoid aborting on erro-
1868* neous input arguments.
1869*
1870* Notes
1871* =====
1872*
1873* This routine is necessary because of the CRAY C fortran interface
1874* and the fact that the usual PBLAS error handler routine has been
1875* initially written in C.
1876*
1877* -- Written on April 1, 1998 by
1878* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1879*
1880* =====================================================================
1881*
1882* .. Common Blocks ..
1883 INTEGER INFO, NBLOG, NOUT
1884 LOGICAL ABRTFLG
1885 COMMON /INFOC/INFO, NBLOG
1886 COMMON /PBERRORC/NOUT, ABRTFLG
1887* ..
1888* .. Executable Statements ..
1889*
1890 INFO = CINFO
1891 IF( ABRTFLG ) THEN
1892 PB_NOABORT = 0
1893 ELSE
1894 PB_NOABORT = 1
1895 END IF
1896*
1897 RETURN
1898*
1899* End of PB_NOABORT
1900*
1901 END
1902 SUBROUTINE PB_INFOG2L( I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II,
1903 $ JJ, PROW, PCOL )
1904*
1905* -- PBLAS test routine (version 2.0) --
1906* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1907* and University of California, Berkeley.
1908* April 1, 1998
1909*
1910* .. Scalar Arguments ..
1911 INTEGER I, II, J, JJ, MYCOL, MYROW, NPCOL, NPROW, PCOL,
1912 $ PROW
1913* ..
1914* .. Array Arguments ..
1915 INTEGER DESC( * )
1916* ..
1917*
1918* Purpose
1919* =======
1920*
1921* PB_INFOG2L computes the starting local index II, JJ corresponding to
1922* the submatrix starting globally at the entry pointed by I, J. This
1923* routine returns the coordinates in the grid of the process owning the
1924* matrix entry of global indexes I, J, namely PROW and PCOL.
1925*
1926* Notes
1927* =====
1928*
1929* A description vector is associated with each 2D block-cyclicly dis-
1930* tributed matrix. This vector stores the information required to
1931* establish the mapping between a matrix entry and its corresponding
1932* process and memory location.
1933*
1934* In the following comments, the character _ should be read as
1935* "of the distributed matrix". Let A be a generic term for any 2D
1936* block cyclicly distributed matrix. Its description vector is DESCA:
1937*
1938* NOTATION STORED IN EXPLANATION
1939* ---------------- --------------- ------------------------------------
1940* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1941* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1942* the NPROW x NPCOL BLACS process grid
1943* A is distributed over. The context
1944* itself is global, but the handle
1945* (the integer value) may vary.
1946* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1947* ted matrix A, M_A >= 0.
1948* N_A (global) DESCA( N_ ) The number of columns in the distri-
1949* buted matrix A, N_A >= 0.
1950* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1951* block of the matrix A, IMB_A > 0.
1952* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1953* left block of the matrix A,
1954* INB_A > 0.
1955* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1956* bute the last M_A-IMB_A rows of A,
1957* MB_A > 0.
1958* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1959* bute the last N_A-INB_A columns of
1960* A, NB_A > 0.
1961* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1962* row of the matrix A is distributed,
1963* NPROW > RSRC_A >= 0.
1964* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1965* first column of A is distributed.
1966* NPCOL > CSRC_A >= 0.
1967* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1968* array storing the local blocks of
1969* the distributed matrix A,
1970* IF( Lc( 1, N_A ) > 0 )
1971* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1972* ELSE
1973* LLD_A >= 1.
1974*
1975* Let K be the number of rows of a matrix A starting at the global in-
1976* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1977* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1978* receive if these K rows were distributed over NPROW processes. If K
1979* is the number of columns of a matrix A starting at the global index
1980* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1981* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1982* these K columns were distributed over NPCOL processes.
1983*
1984* The values of Lr() and Lc() may be determined via a call to the func-
1985* tion PB_NUMROC:
1986* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1987* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1988*
1989* Arguments
1990* =========
1991*
1992* I (global input) INTEGER
1993* On entry, I specifies the global starting row index of the
1994* submatrix. I must at least one.
1995*
1996* J (global input) INTEGER
1997* On entry, J specifies the global starting column index of
1998* the submatrix. J must at least one.
1999*
2000* DESC (global and local input) INTEGER array
2001* On entry, DESC is an integer array of dimension DLEN_. This
2002* is the array descriptor of the underlying matrix.
2003*
2004* NPROW (global input) INTEGER
2005* On entry, NPROW specifies the total number of process rows
2006* over which the matrix is distributed. NPROW must be at least
2007* one.
2008*
2009* NPCOL (global input) INTEGER
2010* On entry, NPCOL specifies the total number of process columns
2011* over which the matrix is distributed. NPCOL must be at least
2012* one.
2013*
2014* MYROW (local input) INTEGER
2015* On entry, MYROW specifies the row coordinate of the process
2016* whose local index II is determined. MYROW must be at least
2017* zero and strictly less than NPROW.
2018*
2019* MYCOL (local input) INTEGER
2020* On entry, MYCOL specifies the column coordinate of the pro-
2021* cess whose local index JJ is determined. MYCOL must be at
2022* least zero and strictly less than NPCOL.
2023*
2024* II (local output) INTEGER
2025* On exit, II specifies the local starting row index of the
2026* submatrix. On exit, II is at least one.
2027*
2028* JJ (local output) INTEGER
2029* On exit, JJ specifies the local starting column index of the
2030* submatrix. On exit, JJ is at least one.
2031*
2032* PROW (global output) INTEGER
2033* On exit, PROW specifies the row coordinate of the process
2034* that possesses the first row of the submatrix. On exit, PROW
2035* is -1 if DESC( RSRC_ ) is -1 on input, and, at least zero
2036* and strictly less than NPROW otherwise.
2037*
2038* PCOL (global output) INTEGER
2039* On exit, PCOL specifies the column coordinate of the process
2040* that possesses the first column of the submatrix. On exit,
2041* PCOL is -1 if DESC( CSRC_ ) is -1 on input, and, at least
2042* zero and strictly less than NPCOL otherwise.
2043*
2044* -- Written on April 1, 1998 by
2045* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2046*
2047* =====================================================================
2048*
2049* .. Parameters ..
2050 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2051 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2052 $ RSRC_
2053 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2054 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2055 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2056 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2057* ..
2058* .. Local Scalars ..
2059 INTEGER CSRC, I1, ILOCBLK, IMB, INB, J1, MB, MYDIST,
2060 $ NB, NBLOCKS, RSRC
2061* ..
2062* .. Local Arrays ..
2063 INTEGER DESC2( DLEN_ )
2064* ..
2065* .. External Subroutines ..
2066 EXTERNAL PB_DESCTRANS
2067* ..
2068* .. Executable Statements ..
2069*
2070* Convert descriptor
2071*
2072 CALL PB_DESCTRANS( DESC, DESC2 )
2073*
2074 IMB = DESC2( IMB_ )
2075 PROW = DESC2( RSRC_ )
2076*
2077* Has every process row I ?
2078*
2079.EQ..OR..EQ. IF( ( PROW-1 )( NPROW1 ) ) THEN
2080*
2081 II = I
2082*
2083.LE. ELSE IF( IIMB ) THEN
2084*
2085* I is in range of first block
2086*
2087.EQ. IF( MYROWPROW ) THEN
2088 II = I
2089 ELSE
2090 II = 1
2091 END IF
2092*
2093 ELSE
2094*
2095* I is not in first block of matrix, figure out who has it.
2096*
2097 RSRC = PROW
2098 MB = DESC2( MB_ )
2099*
2100.EQ. IF( MYROWRSRC ) THEN
2101*
2102 NBLOCKS = ( I - IMB - 1 ) / MB + 1
2103 PROW = PROW + NBLOCKS
2104 PROW = PROW - ( PROW / NPROW ) * NPROW
2105*
2106 ILOCBLK = NBLOCKS / NPROW
2107*
2108.GT. IF( ILOCBLK0 ) THEN
2109.GE. IF( ( ILOCBLK*NPROW )NBLOCKS ) THEN
2110.EQ. IF( MYROWPROW ) THEN
2111 II = I + ( ILOCBLK - NBLOCKS ) * MB
2112 ELSE
2113 II = IMB + ( ILOCBLK - 1 ) * MB + 1
2114 END IF
2115 ELSE
2116 II = IMB + ILOCBLK * MB + 1
2117 END IF
2118 ELSE
2119 II = IMB + 1
2120 END IF
2121*
2122 ELSE
2123*
2124 I1 = I - IMB
2125 NBLOCKS = ( I1 - 1 ) / MB + 1
2126 PROW = PROW + NBLOCKS
2127 PROW = PROW - ( PROW / NPROW ) * NPROW
2128*
2129 MYDIST = MYROW - RSRC
2130.LT. IF( MYDIST0 )
2131 $ MYDIST = MYDIST + NPROW
2132*
2133 ILOCBLK = NBLOCKS / NPROW
2134*
2135.GT. IF( ILOCBLK0 ) THEN
2136 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
2137.LT. IF( MYDIST0 ) THEN
2138 II = MB + ILOCBLK * MB + 1
2139 ELSE
2140.EQ. IF( MYROWPROW ) THEN
2141 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB
2142 ELSE
2143 II = ILOCBLK * MB + 1
2144 END IF
2145 END IF
2146 ELSE
2147 MYDIST = MYDIST - NBLOCKS
2148.LT. IF( MYDIST0 ) THEN
2149 II = MB + 1
2150.EQ. ELSE IF( MYROWPROW ) THEN
2151 II = I1 + ( 1 - NBLOCKS ) * MB
2152 ELSE
2153 II = 1
2154 END IF
2155 END IF
2156 END IF
2157*
2158 END IF
2159*
2160 INB = DESC2( INB_ )
2161 PCOL = DESC2( CSRC_ )
2162*
2163* Has every process column J ?
2164*
2165.EQ..OR..EQ. IF( ( PCOL-1 )( NPCOL1 ) ) THEN
2166*
2167 JJ = J
2168*
2169.LE. ELSE IF( JINB ) THEN
2170*
2171* J is in range of first block
2172*
2173.EQ. IF( MYCOLPCOL ) THEN
2174 JJ = J
2175 ELSE
2176 JJ = 1
2177 END IF
2178*
2179 ELSE
2180*
2181* J is not in first block of matrix, figure out who has it.
2182*
2183 CSRC = PCOL
2184 NB = DESC2( NB_ )
2185*
2186.EQ. IF( MYCOLCSRC ) THEN
2187*
2188 NBLOCKS = ( J - INB - 1 ) / NB + 1
2189 PCOL = PCOL + NBLOCKS
2190 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
2191*
2192 ILOCBLK = NBLOCKS / NPCOL
2193*
2194.GT. IF( ILOCBLK0 ) THEN
2195.GE. IF( ( ILOCBLK*NPCOL )NBLOCKS ) THEN
2196.EQ. IF( MYCOLPCOL ) THEN
2197 JJ = J + ( ILOCBLK - NBLOCKS ) * NB
2198 ELSE
2199 JJ = INB + ( ILOCBLK - 1 ) * NB + 1
2200 END IF
2201 ELSE
2202 JJ = INB + ILOCBLK * NB + 1
2203 END IF
2204 ELSE
2205 JJ = INB + 1
2206 END IF
2207*
2208 ELSE
2209*
2210 J1 = J - INB
2211 NBLOCKS = ( J1 - 1 ) / NB + 1
2212 PCOL = PCOL + NBLOCKS
2213 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
2214*
2215 MYDIST = MYCOL - CSRC
2216.LT. IF( MYDIST0 )
2217 $ MYDIST = MYDIST + NPCOL
2218*
2219 ILOCBLK = NBLOCKS / NPCOL
2220*
2221.GT. IF( ILOCBLK0 ) THEN
2222 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
2223.LT. IF( MYDIST0 ) THEN
2224 JJ = NB + ILOCBLK * NB + 1
2225 ELSE
2226.EQ. IF( MYCOLPCOL ) THEN
2227 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB
2228 ELSE
2229 JJ = ILOCBLK * NB + 1
2230 END IF
2231 END IF
2232 ELSE
2233 MYDIST = MYDIST - NBLOCKS
2234.LT. IF( MYDIST0 ) THEN
2235 JJ = NB + 1
2236.EQ. ELSE IF( MYCOLPCOL ) THEN
2237 JJ = J1 + ( 1 - NBLOCKS ) * NB
2238 ELSE
2239 JJ = 1
2240 END IF
2241 END IF
2242 END IF
2243*
2244 END IF
2245*
2246 RETURN
2247*
2248* End of PB_INFOG2L
2249*
2250 END
2251 SUBROUTINE PB_AINFOG2L( M, N, I, J, DESC, NPROW, NPCOL, MYROW,
2252 $ MYCOL, IMB1, INB1, MP, NQ, II, JJ, PROW,
2253 $ PCOL, RPROW, RPCOL )
2254*
2255* -- PBLAS test routine (version 2.0) --
2256* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2257* and University of California, Berkeley.
2258* April 1, 1998
2259*
2260* .. Scalar Arguments ..
2261 INTEGER I, II, IMB1, INB1, J, JJ, M, MP, MYCOL, MYROW,
2262 $ N, NPCOL, NPROW, NQ, PCOL, PROW, RPCOL, RPROW
2263* ..
2264* .. Array Arguments ..
2265 INTEGER DESC( * )
2266* ..
2267*
2268* Purpose
2269* =======
2270*
2271* PB_AINFOG2L computes the starting local row and column indexes II,
2272* JJ corresponding to the submatrix starting globally at the entry
2273* pointed by I, J. This routine returns the coordinates in the grid of
2274* the process owning the matrix entry of global indexes I, J, namely
2275* PROW and PCOL. In addition, this routine computes the quantities MP
2276* and NQ, which are respectively the local number of rows and columns
2277* owned by the process of coordinate MYROW, MYCOL corresponding to the
2278* global submatrix A(I:I+M-1,J:J+N-1). Finally, the size of the first
2279* partial block and the relative process coordinates are also returned
2280* respectively in IMB, INB and RPROW, RPCOL.
2281*
2282* Notes
2283* =====
2284*
2285* A description vector is associated with each 2D block-cyclicly dis-
2286* tributed matrix. This vector stores the information required to
2287* establish the mapping between a matrix entry and its corresponding
2288* process and memory location.
2289*
2290* In the following comments, the character _ should be read as
2291* "of the distributed matrix". Let A be a generic term for any 2D
2292* block cyclicly distributed matrix. Its description vector is DESCA:
2293*
2294* NOTATION STORED IN EXPLANATION
2295* ---------------- --------------- ------------------------------------
2296* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2297* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2298* the NPROW x NPCOL BLACS process grid
2299* A is distributed over. The context
2300* itself is global, but the handle
2301* (the integer value) may vary.
2302* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2303* ted matrix A, M_A >= 0.
2304* N_A (global) DESCA( N_ ) The number of columns in the distri-
2305* buted matrix A, N_A >= 0.
2306* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2307* block of the matrix A, IMB_A > 0.
2308* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2309* left block of the matrix A,
2310* INB_A > 0.
2311* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2312* bute the last M_A-IMB_A rows of A,
2313* MB_A > 0.
2314* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2315* bute the last N_A-INB_A columns of
2316* A, NB_A > 0.
2317* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2318* row of the matrix A is distributed,
2319* NPROW > RSRC_A >= 0.
2320* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2321* first column of A is distributed.
2322* NPCOL > CSRC_A >= 0.
2323* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2324* array storing the local blocks of
2325* the distributed matrix A,
2326* IF( Lc( 1, N_A ) > 0 )
2327* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2328* ELSE
2329* LLD_A >= 1.
2330*
2331* Let K be the number of rows of a matrix A starting at the global in-
2332* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2333* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2334* receive if these K rows were distributed over NPROW processes. If K
2335* is the number of columns of a matrix A starting at the global index
2336* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2337* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2338* these K columns were distributed over NPCOL processes.
2339*
2340* The values of Lr() and Lc() may be determined via a call to the func-
2341* tion PB_NUMROC:
2342* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2343* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2344*
2345* Arguments
2346* =========
2347*
2348* M (global input) INTEGER
2349* On entry, M specifies the global number of rows of the subma-
2350* trix. M must be at least zero.
2351*
2352* N (global input) INTEGER
2353* On entry, N specifies the global number of columns of the
2354* submatrix. N must be at least zero.
2355*
2356* I (global input) INTEGER
2357* On entry, I specifies the global starting row index of the
2358* submatrix. I must at least one.
2359*
2360* J (global input) INTEGER
2361* On entry, J specifies the global starting column index of
2362* the submatrix. J must at least one.
2363*
2364* DESC (global and local input) INTEGER array
2365* On entry, DESC is an integer array of dimension DLEN_. This
2366* is the array descriptor of the underlying matrix.
2367*
2368* NPROW (global input) INTEGER
2369* On entry, NPROW specifies the total number of process rows
2370* over which the matrix is distributed. NPROW must be at least
2371* one.
2372*
2373* NPCOL (global input) INTEGER
2374* On entry, NPCOL specifies the total number of process columns
2375* over which the matrix is distributed. NPCOL must be at least
2376* one.
2377*
2378* MYROW (local input) INTEGER
2379* On entry, MYROW specifies the row coordinate of the process
2380* whose local index II is determined. MYROW must be at least
2381* zero and strictly less than NPROW.
2382*
2383* MYCOL (local input) INTEGER
2384* On entry, MYCOL specifies the column coordinate of the pro-
2385* cess whose local index JJ is determined. MYCOL must be at
2386* least zero and strictly less than NPCOL.
2387*
2388* IMB1 (global output) INTEGER
2389* On exit, IMB1 specifies the number of rows of the upper left
2390* block of the submatrix. On exit, IMB1 is less or equal than
2391* M and greater or equal than MIN( 1, M ).
2392*
2393* INB1 (global output) INTEGER
2394* On exit, INB1 specifies the number of columns of the upper
2395* left block of the submatrix. On exit, INB1 is less or equal
2396* than N and greater or equal than MIN( 1, N ).
2397*
2398* MP (local output) INTEGER
2399* On exit, MP specifies the local number of rows of the subma-
2400* trix, that the processes of row coordinate MYROW own. MP is
2401* at least zero.
2402*
2403* NQ (local output) INTEGER
2404* On exit, NQ specifies the local number of columns of the
2405* submatrix, that the processes of column coordinate MYCOL
2406* own. NQ is at least zero.
2407*
2408* II (local output) INTEGER
2409* On exit, II specifies the local starting row index of the
2410* submatrix. On exit, II is at least one.
2411*
2412* JJ (local output) INTEGER
2413* On exit, JJ specifies the local starting column index of
2414* the submatrix. On exit, II is at least one.
2415*
2416* PROW (global output) INTEGER
2417* On exit, PROW specifies the row coordinate of the process
2418* that possesses the first row of the submatrix. On exit, PROW
2419* is -1 if DESC(RSRC_) is -1 on input, and, at least zero and
2420* strictly less than NPROW otherwise.
2421*
2422* PCOL (global output) INTEGER
2423* On exit, PCOL specifies the column coordinate of the process
2424* that possesses the first column of the submatrix. On exit,
2425* PCOL is -1 if DESC(CSRC_) is -1 on input, and, at least zero
2426* and strictly less than NPCOL otherwise.
2427*
2428* RPROW (global output) INTEGER
2429* On exit, RPROW specifies the relative row coordinate of the
2430* process that possesses the first row I of the submatrix. On
2431* exit, RPROW is -1 if DESC(RSRC_) is -1 on input, and, at
2432* least zero and strictly less than NPROW otherwise.
2433*
2434* RPCOL (global output) INTEGER
2435* On exit, RPCOL specifies the relative column coordinate of
2436* the process that possesses the first column J of the subma-
2437* trix. On exit, RPCOL is -1 if DESC(CSRC_) is -1 on input,
2438* and, at least zero and strictly less than NPCOL otherwise.
2439*
2440* -- Written on April 1, 1998 by
2441* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2442*
2443* =====================================================================
2444*
2445* .. Parameters ..
2446 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2447 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2448 $ RSRC_
2449 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2450 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2451 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2452 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2453* ..
2454* .. Local Scalars ..
2455 INTEGER CSRC, I1, ILOCBLK, J1, M1, MB, MYDIST, N1, NB,
2456 $ NBLOCKS, RSRC
2457* ..
2458* .. Local Arrays ..
2459 INTEGER DESC2( DLEN_ )
2460* ..
2461* .. External Subroutines ..
2462 EXTERNAL PB_DESCTRANS
2463* ..
2464* .. Intrinsic Functions ..
2465 INTRINSIC MIN
2466* ..
2467* .. Executable Statements ..
2468*
2469* Convert descriptor
2470*
2471 CALL PB_DESCTRANS( DESC, DESC2 )
2472*
2473 MB = DESC2( MB_ )
2474 IMB1 = DESC2( IMB_ )
2475 RSRC = DESC2( RSRC_ )
2476*
2477.EQ..OR..EQ. IF( ( RSRC-1 )( NPROW1 ) ) THEN
2478*
2479 II = I
2480 IMB1 = IMB1 - I + 1
2481.LE. IF( IMB10 )
2482 $ IMB1 = ( ( -IMB1 ) / MB + 1 ) * MB + IMB1
2483 IMB1 = MIN( IMB1, M )
2484 MP = M
2485 PROW = RSRC
2486 RPROW = 0
2487*
2488 ELSE
2489*
2490* Figure out PROW, II and IMB1 first
2491*
2492.LE. IF( IIMB1 ) THEN
2493*
2494 PROW = RSRC
2495*
2496.EQ. IF( MYROWPROW ) THEN
2497 II = I
2498 ELSE
2499 II = 1
2500 END IF
2501*
2502 IMB1 = IMB1 - I + 1
2503*
2504 ELSE
2505*
2506 I1 = I - IMB1 - 1
2507 NBLOCKS = I1 / MB + 1
2508 PROW = RSRC + NBLOCKS
2509 PROW = PROW - ( PROW / NPROW ) * NPROW
2510*
2511.EQ. IF( MYROWRSRC ) THEN
2512*
2513 ILOCBLK = NBLOCKS / NPROW
2514*
2515.GT. IF( ILOCBLK0 ) THEN
2516.GE. IF( ( ILOCBLK*NPROW )NBLOCKS ) THEN
2517.EQ. IF( MYROWPROW ) THEN
2518 II = I + ( ILOCBLK - NBLOCKS ) * MB
2519 ELSE
2520 II = IMB1 + ( ILOCBLK - 1 ) * MB + 1
2521 END IF
2522 ELSE
2523 II = IMB1 + ILOCBLK * MB + 1
2524 END IF
2525 ELSE
2526 II = IMB1 + 1
2527 END IF
2528*
2529 ELSE
2530*
2531 MYDIST = MYROW - RSRC
2532.LT. IF( MYDIST0 )
2533 $ MYDIST = MYDIST + NPROW
2534*
2535 ILOCBLK = NBLOCKS / NPROW
2536*
2537.GT. IF( ILOCBLK0 ) THEN
2538 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
2539.LT. IF( MYDIST0 ) THEN
2540 II = ( ILOCBLK + 1 ) * MB + 1
2541.EQ. ELSE IF( MYROWPROW ) THEN
2542 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB + 1
2543 ELSE
2544 II = ILOCBLK * MB + 1
2545 END IF
2546 ELSE
2547 MYDIST = MYDIST - NBLOCKS
2548.LT. IF( MYDIST0 ) THEN
2549 II = MB + 1
2550.EQ. ELSE IF( MYROWPROW ) THEN
2551 II = I1 + ( 1 - NBLOCKS ) * MB + 1
2552 ELSE
2553 II = 1
2554 END IF
2555 END IF
2556 END IF
2557*
2558 IMB1 = NBLOCKS * MB - I1
2559*
2560 END IF
2561*
2562* Figure out MP
2563*
2564.LE. IF( MIMB1 ) THEN
2565*
2566.EQ. IF( MYROWPROW ) THEN
2567 MP = M
2568 ELSE
2569 MP = 0
2570 END IF
2571*
2572 ELSE
2573*
2574 M1 = M - IMB1
2575 NBLOCKS = M1 / MB + 1
2576*
2577.EQ. IF( MYROWPROW ) THEN
2578 ILOCBLK = NBLOCKS / NPROW
2579.GT. IF( ILOCBLK0 ) THEN
2580.GT. IF( ( NBLOCKS - ILOCBLK * NPROW )0 ) THEN
2581 MP = IMB1 + ILOCBLK * MB
2582 ELSE
2583 MP = M + MB * ( ILOCBLK - NBLOCKS )
2584 END IF
2585 ELSE
2586 MP = IMB1
2587 END IF
2588 ELSE
2589 MYDIST = MYROW - PROW
2590.LT. IF( MYDIST0 )
2591 $ MYDIST = MYDIST + NPROW
2592 ILOCBLK = NBLOCKS / NPROW
2593.GT. IF( ILOCBLK0 ) THEN
2594 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW
2595.LT. IF( MYDIST0 ) THEN
2596 MP = ( ILOCBLK + 1 ) * MB
2597.GT. ELSE IF( MYDIST0 ) THEN
2598 MP = ILOCBLK * MB
2599 ELSE
2600 MP = M1 + MB * ( ILOCBLK - NBLOCKS + 1 )
2601 END IF
2602 ELSE
2603 MYDIST = MYDIST - NBLOCKS
2604.LT. IF( MYDIST0 ) THEN
2605 MP = MB
2606.GT. ELSE IF( MYDIST0 ) THEN
2607 MP = 0
2608 ELSE
2609 MP = M1 + MB * ( 1 - NBLOCKS )
2610 END IF
2611 END IF
2612 END IF
2613*
2614 END IF
2615*
2616 IMB1 = MIN( IMB1, M )
2617 RPROW = MYROW - PROW
2618.LT. IF( RPROW0 )
2619 $ RPROW = RPROW + NPROW
2620*
2621 END IF
2622*
2623 NB = DESC2( NB_ )
2624 INB1 = DESC2( INB_ )
2625 CSRC = DESC2( CSRC_ )
2626*
2627.EQ..OR..EQ. IF( ( CSRC-1 )( NPCOL1 ) ) THEN
2628*
2629 JJ = J
2630 INB1 = INB1 - I + 1
2631.LE. IF( INB10 )
2632 $ INB1 = ( ( -INB1 ) / NB + 1 ) * NB + INB1
2633 INB1 = MIN( INB1, N )
2634 NQ = N
2635 PCOL = CSRC
2636 RPCOL = 0
2637*
2638 ELSE
2639*
2640* Figure out PCOL, JJ and INB1 first
2641*
2642.LE. IF( JINB1 ) THEN
2643*
2644 PCOL = CSRC
2645*
2646.EQ. IF( MYCOLPCOL ) THEN
2647 JJ = J
2648 ELSE
2649 JJ = 1
2650 END IF
2651*
2652 INB1 = INB1 - J + 1
2653*
2654 ELSE
2655*
2656 J1 = J - INB1 - 1
2657 NBLOCKS = J1 / NB + 1
2658 PCOL = CSRC + NBLOCKS
2659 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL
2660*
2661.EQ. IF( MYCOLCSRC ) THEN
2662*
2663 ILOCBLK = NBLOCKS / NPCOL
2664*
2665.GT. IF( ILOCBLK0 ) THEN
2666.GE. IF( ( ILOCBLK*NPCOL )NBLOCKS ) THEN
2667.EQ. IF( MYCOLPCOL ) THEN
2668 JJ = J + ( ILOCBLK - NBLOCKS ) * NB
2669 ELSE
2670 JJ = INB1 + ( ILOCBLK - 1 ) * NB + 1
2671 END IF
2672 ELSE
2673 JJ = INB1 + ILOCBLK * NB + 1
2674 END IF
2675 ELSE
2676 JJ = INB1 + 1
2677 END IF
2678*
2679 ELSE
2680*
2681 MYDIST = MYCOL - CSRC
2682.LT. IF( MYDIST0 )
2683 $ MYDIST = MYDIST + NPCOL
2684*
2685 ILOCBLK = NBLOCKS / NPCOL
2686*
2687.GT. IF( ILOCBLK0 ) THEN
2688 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
2689.LT. IF( MYDIST0 ) THEN
2690 JJ = ( ILOCBLK + 1 ) * NB + 1
2691.EQ. ELSE IF( MYCOLPCOL ) THEN
2692 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB + 1
2693 ELSE
2694 JJ = ILOCBLK * NB + 1
2695 END IF
2696 ELSE
2697 MYDIST = MYDIST - NBLOCKS
2698.LT. IF( MYDIST0 ) THEN
2699 JJ = NB + 1
2700.EQ. ELSE IF( MYCOLPCOL ) THEN
2701 JJ = J1 + ( 1 - NBLOCKS ) * NB + 1
2702 ELSE
2703 JJ = 1
2704 END IF
2705 END IF
2706 END IF
2707*
2708 INB1 = NBLOCKS * NB - J1
2709*
2710 END IF
2711*
2712* Figure out NQ
2713*
2714.LE. IF( NINB1 ) THEN
2715*
2716.EQ. IF( MYCOLPCOL ) THEN
2717 NQ = N
2718 ELSE
2719 NQ = 0
2720 END IF
2721*
2722 ELSE
2723*
2724 N1 = N - INB1
2725 NBLOCKS = N1 / NB + 1
2726*
2727.EQ. IF( MYCOLPCOL ) THEN
2728 ILOCBLK = NBLOCKS / NPCOL
2729.GT. IF( ILOCBLK0 ) THEN
2730.GT. IF( ( NBLOCKS - ILOCBLK * NPCOL )0 ) THEN
2731 NQ = INB1 + ILOCBLK * NB
2732 ELSE
2733 NQ = N + NB * ( ILOCBLK - NBLOCKS )
2734 END IF
2735 ELSE
2736 NQ = INB1
2737 END IF
2738 ELSE
2739 MYDIST = MYCOL - PCOL
2740.LT. IF( MYDIST0 )
2741 $ MYDIST = MYDIST + NPCOL
2742 ILOCBLK = NBLOCKS / NPCOL
2743.GT. IF( ILOCBLK0 ) THEN
2744 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL
2745.LT. IF( MYDIST0 ) THEN
2746 NQ = ( ILOCBLK + 1 ) * NB
2747.GT. ELSE IF( MYDIST0 ) THEN
2748 NQ = ILOCBLK * NB
2749 ELSE
2750 NQ = N1 + NB * ( ILOCBLK - NBLOCKS + 1 )
2751 END IF
2752 ELSE
2753 MYDIST = MYDIST - NBLOCKS
2754.LT. IF( MYDIST0 ) THEN
2755 NQ = NB
2756.GT. ELSE IF( MYDIST0 ) THEN
2757 NQ = 0
2758 ELSE
2759 NQ = N1 + NB * ( 1 - NBLOCKS )
2760 END IF
2761 END IF
2762 END IF
2763*
2764 END IF
2765*
2766 INB1 = MIN( INB1, N )
2767 RPCOL = MYCOL - PCOL
2768.LT. IF( RPCOL0 )
2769 $ RPCOL = RPCOL + NPCOL
2770*
2771 END IF
2772*
2773 RETURN
2774*
2775* End of PB_AINFOG2L
2776*
2777 END
2778 INTEGER FUNCTION PB_NUMROC( N, I, INB, NB, PROC, SRCPROC, NPROCS )
2779*
2780* -- PBLAS test routine (version 2.0) --
2781* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2782* and University of California, Berkeley.
2783* April 1, 1998
2784*
2785* .. Scalar Arguments ..
2786 INTEGER I, INB, N, NB, NPROCS, PROC, SRCPROC
2787* ..
2788*
2789* Purpose
2790* =======
2791*
2792* PB_NUMROC returns the local number of matrix rows/columns process
2793* PROC will get if we give out N rows/columns starting from global in-
2794* dex I.
2795*
2796* Arguments
2797* =========
2798*
2799* N (global input) INTEGER
2800* On entry, N specifies the number of rows/columns being dealt
2801* out. N must be at least zero.
2802*
2803* I (global input) INTEGER
2804* On entry, I specifies the global index of the matrix entry.
2805* I must be at least one.
2806*
2807* INB (global input) INTEGER
2808* On entry, INB specifies the size of the first block of the
2809* global matrix. INB must be at least one.
2810*
2811* NB (global input) INTEGER
2812* On entry, NB specifies the size of the blocks used to parti-
2813* tion the matrix. NB must be at least one.
2814*
2815* PROC (local input) INTEGER
2816* On entry, PROC specifies the coordinate of the process whose
2817* local portion is determined. PROC must be at least zero and
2818* strictly less than NPROCS.
2819*
2820* SRCPROC (global input) INTEGER
2821* On entry, SRCPROC specifies the coordinate of the process
2822* that possesses the first row or column of the matrix. When
2823* SRCPROC = -1, the data is not distributed but replicated,
2824* otherwise SRCPROC must be at least zero and strictly less
2825* than NPROCS.
2826*
2827* NPROCS (global input) INTEGER
2828* On entry, NPROCS specifies the total number of process rows
2829* or columns over which the matrix is distributed. NPROCS must
2830* be at least one.
2831*
2832* -- Written on April 1, 1998 by
2833* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2834*
2835* =====================================================================
2836*
2837* .. Local Scalars ..
2838 INTEGER I1, ILOCBLK, INB1, MYDIST, N1, NBLOCKS,
2839 $ SRCPROC1
2840* ..
2841* .. Executable Statements ..
2842*
2843.EQ..OR..EQ. IF( ( SRCPROC-1 )( NPROCS1 ) ) THEN
2844 PB_NUMROC = N
2845 RETURN
2846 END IF
2847*
2848* Compute coordinate of process owning I and corresponding INB
2849*
2850.LE. IF( IINB ) THEN
2851*
2852* I is in range of first block, i.e SRCPROC owns I.
2853*
2854 SRCPROC1 = SRCPROC
2855 INB1 = INB - I + 1
2856*
2857 ELSE
2858*
2859* I is not in first block of matrix, figure out who has it
2860*
2861 I1 = I - 1 - INB
2862 NBLOCKS = I1 / NB + 1
2863 SRCPROC1 = SRCPROC + NBLOCKS
2864 SRCPROC1 = SRCPROC1 - ( SRCPROC1 / NPROCS ) * NPROCS
2865 INB1 = NBLOCKS*NB - I1
2866*
2867 END IF
2868*
2869* Now everything is just like I=1. Search now who has N-1, Is N-1
2870* in the first block ?
2871*
2872.LE. IF( NINB1 ) THEN
2873.EQ. IF( PROCSRCPROC1 ) THEN
2874 PB_NUMROC = N
2875 ELSE
2876 PB_NUMROC = 0
2877 END IF
2878 RETURN
2879 END IF
2880*
2881 N1 = N - INB1
2882 NBLOCKS = N1 / NB + 1
2883*
2884.EQ. IF( PROCSRCPROC1 ) THEN
2885 ILOCBLK = NBLOCKS / NPROCS
2886.GT. IF( ILOCBLK0 ) THEN
2887.GT. IF( ( NBLOCKS - ILOCBLK * NPROCS )0 ) THEN
2888 PB_NUMROC = INB1 + ILOCBLK * NB
2889 ELSE
2890 PB_NUMROC = N + NB * ( ILOCBLK - NBLOCKS )
2891 END IF
2892 ELSE
2893 PB_NUMROC = INB1
2894 END IF
2895 ELSE
2896 MYDIST = PROC - SRCPROC1
2897.LT. IF( MYDIST0 )
2898 $ MYDIST = MYDIST + NPROCS
2899 ILOCBLK = NBLOCKS / NPROCS
2900.GT. IF( ILOCBLK0 ) THEN
2901 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROCS
2902.LT. IF( MYDIST0 ) THEN
2903 PB_NUMROC = ( ILOCBLK + 1 ) * NB
2904.GT. ELSE IF( MYDIST0 ) THEN
2905 PB_NUMROC = ILOCBLK * NB
2906 ELSE
2907 PB_NUMROC = N1 + NB * ( ILOCBLK - NBLOCKS + 1 )
2908 END IF
2909 ELSE
2910 MYDIST = MYDIST - NBLOCKS
2911.LT. IF( MYDIST0 ) THEN
2912 PB_NUMROC = NB
2913.GT. ELSE IF( MYDIST0 ) THEN
2914 PB_NUMROC = 0
2915 ELSE
2916 PB_NUMROC = N1 + NB * ( 1 - NBLOCKS )
2917 END IF
2918 END IF
2919 END IF
2920*
2921 RETURN
2922*
2923* End of PB_NUMROC
2924*
2925 END
2926 SUBROUTINE PB_BOOT()
2927*
2928* -- PBLAS test routine (version 2.0) --
2929* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2930* and University of California, Berkeley.
2931* April 1, 1998
2932*
2933*
2934* Purpose
2935* =======
2936*
2937* PB_BOOT (re)sets all timers to 0, and enables PB_TIMER.
2938*
2939* -- Written on April 1, 1998 by
2940* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
2941*
2942* =====================================================================
2943*
2944* .. Parameters ..
2945 INTEGER NTIMER
2946 PARAMETER ( NTIMER = 64 )
2947 DOUBLE PRECISION STARTFLAG, ZERO
2948 PARAMETER ( STARTFLAG = -5.0D+0, ZERO = 0.0D+0 )
2949* ..
2950* .. Local Scalars ..
2951 INTEGER I
2952* ..
2953* .. Common Blocks ..
2954 LOGICAL DISABLED
2955 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
2956 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
2957 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
2958* ..
2959* .. Executable Statements ..
2960*
2961 DISABLED = .FALSE.
2962 DO 10 I = 1, NTIMER
2963 CPUSEC( I ) = ZERO
2964 WALLSEC( I ) = ZERO
2965 CPUSTART( I ) = STARTFLAG
2966 WALLSTART( I ) = STARTFLAG
2967 10 CONTINUE
2968*
2969 RETURN
2970*
2971* End of PB_BOOT
2972*
2973 END
2974*
2975 SUBROUTINE PB_TIMER( I )
2976*
2977* -- PBLAS test routine (version 2.0) --
2978* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2979* and University of California, Berkeley.
2980* April 1, 1998
2981*
2982* .. Scalar Arguments ..
2983 INTEGER I
2984* ..
2985*
2986* Purpose
2987* =======
2988*
2989* PB_TIMER provides a "stopwatch" functionality cpu/wall timer in se-
2990* conds. Up to 64 separate timers can be functioning at once. The first
2991* call starts the timer, and the second stops it. This routine can be
2992* disenabled, so that calls to the timer are ignored. This feature can
2993* be used to make sure certain sections of code do not affect timings,
2994* even if they call routines which have PB_TIMER calls in them.
2995*
2996* Arguments
2997* =========
2998*
2999* I (global input) INTEGER
3000* On entry, I specifies the timer to stop/start.
3001*
3002* -- Written on April 1, 1998 by
3003* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3004*
3005* =====================================================================
3006*
3007* .. Parameters ..
3008 INTEGER NTIMER
3009 PARAMETER ( NTIMER = 64 )
3010 DOUBLE PRECISION STARTFLAG
3011 PARAMETER ( STARTFLAG = -5.0D+0 )
3012* ..
3013* .. External Functions ..
3014 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3015 EXTERNAL DCPUTIME00, DWALLTIME00
3016* ..
3017* .. Common Blocks ..
3018 LOGICAL DISABLED
3019 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3020 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3021 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
3022* ..
3023* .. Executable Statements ..
3024*
3025* If timing disabled, return
3026*
3027 IF( DISABLED )
3028 $ RETURN
3029*
3030.EQ. IF( WALLSTART( I )STARTFLAG ) THEN
3031*
3032* If timer has not been started, start it
3033*
3034 WALLSTART( I ) = DWALLTIME00()
3035 CPUSTART( I ) = DCPUTIME00()
3036*
3037 ELSE
3038*
3039* Stop timer and add interval to count
3040*
3041 CPUSEC( I ) = CPUSEC( I ) + DCPUTIME00() - CPUSTART( I )
3042 WALLSEC( I ) = WALLSEC( I ) + DWALLTIME00() - WALLSTART( I )
3043 WALLSTART( I ) = STARTFLAG
3044*
3045 END IF
3046*
3047 RETURN
3048*
3049* End of PB_TIMER
3050*
3051 END
3052*
3053 SUBROUTINE PB_ENABLE()
3054*
3055* -- PBLAS test routine (version 2.0) --
3056* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3057* and University of California, Berkeley.
3058* April 1, 1998
3059*
3060*
3061* Purpose
3062* =======
3063*
3064* PB_ENABLE sets it so calls to PB_TIMER are not ignored.
3065*
3066* -- Written on April 1, 1998 by
3067* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3068*
3069* =====================================================================
3070*
3071* .. Parameters ..
3072 INTEGER NTIMER
3073 PARAMETER ( NTIMER = 64 )
3074* ..
3075* .. Common Blocks ..
3076 LOGICAL DISABLED
3077 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3078 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3079 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
3080* ..
3081* .. Executable Statements ..
3082*
3083 DISABLED = .FALSE.
3084*
3085 RETURN
3086*
3087* End of PB_ENABLE
3088*
3089 END
3090*
3091 SUBROUTINE PB_DISABLE()
3092*
3093* -- PBLAS test routine (version 2.0) --
3094* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3095* and University of California, Berkeley.
3096* April 1, 1998
3097*
3098* Purpose
3099* =======
3100*
3101* PB_DISABLE sets it so calls to PB_TIMER are ignored.
3102*
3103* -- Written on April 1, 1998 by
3104* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3105*
3106* =====================================================================
3107*
3108* .. Parameters ..
3109 INTEGER NTIMER
3110 PARAMETER ( NTIMER = 64 )
3111* ..
3112* .. Common Blocks ..
3113 LOGICAL DISABLED
3114 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3115 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3116 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
3117* ..
3118* .. Executable Statements ..
3119*
3120 DISABLED = .TRUE.
3121*
3122 RETURN
3123*
3124* End of PB_DISABLE
3125*
3126 END
3127*
3128 DOUBLE PRECISION FUNCTION PB_INQUIRE( TMTYPE, I )
3129*
3130* -- PBLAS test routine (version 2.0) --
3131* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3132* and University of California, Berkeley.
3133* April 1, 1998
3134*
3135* .. Scalar Arguments ..
3136 CHARACTER*1 TMTYPE
3137 INTEGER I
3138* ..
3139*
3140* Purpose
3141* =======
3142*
3143* PB_INQUIRE returns wall or cpu time that has accumulated in timer I.
3144*
3145* Arguments
3146* =========
3147*
3148* TMTYPE (global input) CHARACTER
3149* On entry, TMTYPE specifies what time will be returned as fol-
3150* lows
3151* = 'W': wall clock time is returned,
3152* = 'C': CPU time is returned (default).
3153*
3154* I (global input) INTEGER
3155* On entry, I specifies the timer to return.
3156*
3157* -- Written on April 1, 1998 by
3158* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3159*
3160* =====================================================================
3161*
3162* .. Parameters ..
3163 INTEGER NTIMER
3164 PARAMETER ( NTIMER = 64 )
3165 DOUBLE PRECISION ERRFLAG
3166 PARAMETER ( ERRFLAG = -1.0D+0 )
3167* ..
3168* .. Local Scalars ..
3169 DOUBLE PRECISION TIME
3170* ..
3171* .. External Functions ..
3172 LOGICAL LSAME
3173 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3174 EXTERNAL DCPUTIME00, DWALLTIME00, LSAME
3175* ..
3176* .. Common Blocks ..
3177 LOGICAL DISABLED
3178 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3179 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3180 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
3181* ..
3182* .. Executable Statements ..
3183*
3184 IF( LSAME( TMTYPE, 'w' ) ) THEN
3185*
3186* If walltime not available on this machine, return -1 flag
3187*
3188.EQ. IF( DWALLTIME00()ERRFLAG ) THEN
3189 TIME = ERRFLAG
3190 ELSE
3191 TIME = WALLSEC( I )
3192 END IF
3193 ELSE
3194.EQ. IF( DCPUTIME00()ERRFLAG ) THEN
3195 TIME = ERRFLAG
3196 ELSE
3197 TIME = CPUSEC( I )
3198 END IF
3199 END IF
3200*
3201 PB_INQUIRE = TIME
3202*
3203 RETURN
3204*
3205* End of PB_INQUIRE
3206*
3207 END
3208*
3209 SUBROUTINE PB_COMBINE( ICTXT, SCOPE, OP, TMTYPE, N, IBEG,
3210 $ TIMES )
3211*
3212* -- PBLAS test routine (version 2.0) --
3213* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3214* and University of California, Berkeley.
3215* April 1, 1998
3216*
3217* .. Scalar Arguments ..
3218 CHARACTER*1 OP, SCOPE, TMTYPE
3219 INTEGER IBEG, ICTXT, N
3220* ..
3221* .. Array Arguments ..
3222 DOUBLE PRECISION TIMES( N )
3223* ..
3224*
3225* Purpose
3226* =======
3227*
3228* PB_COMBINE returns wall or cpu time that has accumulated in timer I.
3229*
3230* Arguments
3231* =========
3232*
3233* TMTYPE (global input) CHARACTER
3234* On entry, TMTYPE specifies what time will be returned as fol-
3235* lows
3236* = 'W': wall clock time is returned,
3237* = 'C': CPU time is returned (default).
3238*
3239* I (global input) INTEGER
3240* On entry, I specifies the timer to return.
3241*
3242* -- Written on April 1, 1998 by
3243* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3244*
3245* =====================================================================
3246*
3247* .. Parameters ..
3248 INTEGER NTIMER
3249 PARAMETER ( NTIMER = 64 )
3250 DOUBLE PRECISION ERRFLAG
3251 PARAMETER ( ERRFLAG = -1.0D+0 )
3252* ..
3253* .. Local Scalars ..
3254 CHARACTER*1 TOP
3255 LOGICAL TMPDIS
3256 INTEGER I
3257* ..
3258* .. External Subroutines ..
3259 EXTERNAL DGAMX2D, DGAMN2D, DGSUM2D, PB_TOPGET
3260* ..
3261* .. External Functions ..
3262 LOGICAL LSAME
3263 DOUBLE PRECISION DCPUTIME00, DWALLTIME00
3264 EXTERNAL DCPUTIME00, DWALLTIME00, LSAME
3265* ..
3266* .. Common Blocks ..
3267 LOGICAL DISABLED
3268 DOUBLE PRECISION CPUSEC( NTIMER ), CPUSTART( NTIMER ),
3269 $ WALLSEC( NTIMER ), WALLSTART( NTIMER )
3270 COMMON /SLTIMER00/ CPUSEC, WALLSEC, CPUSTART, WALLSTART, DISABLED
3271* ..
3272* .. Executable Statements ..
3273*
3274* Disable timer for combine operation
3275*
3276 TMPDIS = DISABLED
3277 DISABLED = .TRUE.
3278*
3279* Copy timer information into user's times array
3280*
3281 IF( LSAME( TMTYPE, 'w' ) ) THEN
3282*
3283* If walltime not available on this machine, fill in times
3284* with -1 flag, and return
3285*
3286.EQ. IF( DWALLTIME00()ERRFLAG ) THEN
3287 DO 10 I = 1, N
3288 TIMES( I ) = ERRFLAG
3289 10 CONTINUE
3290 RETURN
3291 ELSE
3292 DO 20 I = 1, N
3293 TIMES( I ) = WALLSEC( IBEG + I - 1 )
3294 20 CONTINUE
3295 END IF
3296 ELSE
3297.EQ. IF( DCPUTIME00()ERRFLAG ) THEN
3298 DO 30 I = 1, N
3299 TIMES( I ) = ERRFLAG
3300 30 CONTINUE
3301 RETURN
3302 ELSE
3303 DO 40 I = 1, N
3304 TIMES( I ) = CPUSEC( IBEG + I - 1 )
3305 40 CONTINUE
3306 END IF
3307 ENDIF
3308*
3309* Combine all nodes' information, restore disabled, and return
3310*
3311.EQ. IF( OP'>' ) THEN
3312 CALL PB_TOPGET( ICTXT, 'combine', SCOPE, TOP )
3313 CALL DGAMX2D( ICTXT, SCOPE, TOP, N, 1, TIMES, N, -1, -1,
3314 $ -1, -1, 0 )
3315.EQ. ELSE IF( OP'<' ) THEN
3316 CALL PB_TOPGET( ICTXT, 'combine', SCOPE, TOP )
3317 CALL DGAMN2D( ICTXT, SCOPE, TOP, N, 1, TIMES, N, -1, -1,
3318 $ -1, -1, 0 )
3319.EQ. ELSE IF( OP'+' ) THEN
3320 CALL pb_topget( ictxt, 'Combine', scope, top )
3321 CALL dgsum2d( ictxt, scope, top, n, 1, times, n, -1, 0 )
3322 ELSE
3323 CALL pb_topget( ictxt, 'Combine', scope, top )
3324 CALL dgamx2d( ictxt, scope, top, n, 1, times, n, -1, -1,
3325 $ -1, -1, 0 )
3326 END IF
3327*
3328 disabled = tmpdis
3329*
3330 RETURN
3331*
3332* End of PB_COMBINE
3333*
3334 END
3335 SUBROUTINE pb_chkmat( ICTXT, M, MPOS0, N, NPOS0, IA, JA, DESCA,
3336 $ DPOS0, 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 DPOS0, IA, ICTXT, INFO, JA, M, MPOS0, N, NPOS0
3345* ..
3346* .. Array Arguments ..
3347 INTEGER DESCA( * )
3348* ..
3349*
3350* Purpose
3351* =======
3352*
3353* PB_CHKMAT checks the validity of a descriptor vector DESCA, the re-
3354* lated global indexes IA, JA from a local view point. If an inconsis-
3355* tency is found among its parameters IA, JA and DESCA, the routine re-
3356* turns an error code in INFO.
3357*
3358* Arguments
3359* =========
3360*
3361* ICTXT (local input) INTEGER
3362* On entry, ICTXT specifies the BLACS context handle, indica-
3363* ting the global context of the operation. The context itself
3364* is global, but the value of ICTXT is local.
3365*
3366* M (global input) INTEGER
3367* On entry, M specifies the number of rows the submatrix
3368* sub( A ).
3369*
3370* MPOS0 (global input) INTEGER
3371* On entry, MPOS0 specifies the position in the calling rou-
3372* tine's parameter list where the formal parameter M appears.
3373*
3374* N (global input) INTEGER
3375* On entry, N specifies the number of columns the submatrix
3376* sub( A ).
3377*
3378* NPOS0 (global input) INTEGER
3379* On entry, NPOS0 specifies the position in the calling rou-
3380* tine's parameter list where the formal parameter N appears.
3381*
3382* IA (global input) INTEGER
3383* On entry, IA specifies A's global row index, which points to
3384* the beginning of the submatrix sub( A ).
3385*
3386* JA (global input) INTEGER
3387* On entry, JA specifies A's global column index, which points
3388* to the beginning of the submatrix sub( A ).
3389*
3390* DESCA (global and local input) INTEGER array
3391* On entry, DESCA is an integer array of dimension DLEN_. This
3392* is the array descriptor for the matrix A.
3393*
3394* DPOS0 (global input) INTEGER
3395* On entry, DPOS0 specifies the position in the calling rou-
3396* tine's parameter list where the formal parameter DESCA ap-
3397* pears. Note that it is assumed that IA and JA are respecti-
3398* vely 2 and 1 entries behind DESCA.
3399*
3400* INFO (local input/local output) INTEGER
3401* = 0: successful exit
3402* < 0: If the i-th argument is an array and the j-entry had an
3403* illegal value, then INFO = -(i*100+j), if the i-th
3404* argument is a scalar and had an illegal value, then
3405* INFO = -i.
3406*
3407* -- Written on April 1, 1998 by
3408* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3409*
3410* =====================================================================
3411*
3412* .. Parameters ..
3413 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3414 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3415 $ RSRC_
3416 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3417 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3418 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3419 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3420 INTEGER DESCMULT, BIGNUM
3421 PARAMETER ( DESCMULT = 100, bignum = descmult*descmult )
3422* ..
3423* .. Local Scalars ..
3424 INTEGER DPOS, IAPOS, JAPOS, MP, MPOS, MYCOL, MYROW,
3425 $ npcol, npos, nprow, nq
3426* ..
3427* .. Local Arrays ..
3428 INTEGER DESCA2( DLEN_ )
3429* ..
3430* .. External Subroutines ..
3431 EXTERNAL blacs_gridinfo, pb_desctrans
3432* ..
3433* .. External Functions ..
3434 INTEGER PB_NUMROC
3435 EXTERNAL PB_NUMROC
3436* ..
3437* .. Intrinsic Functions ..
3438 INTRINSIC min, max
3439* ..
3440* .. Executable Statements ..
3441*
3442* Convert descriptor
3443*
3444 CALL pb_desctrans( desca, desca2 )
3445*
3446* Want to find errors with MIN( ), so if no error, set it to a big
3447* number. If there already is an error, multiply by the the des-
3448* criptor multiplier
3449*
3450 IF( info.GE.0 ) THEN
3451 info = bignum
3452 ELSE IF( info.LT.-descmult ) THEN
3453 info = -info
3454 ELSE
3455 info = -info * descmult
3456 END IF
3457*
3458* Figure where in parameter list each parameter was, factoring in
3459* descriptor multiplier
3460*
3461 mpos = mpos0 * descmult
3462 npos = npos0 * descmult
3463 iapos = ( dpos0 - 2 ) * descmult
3464 japos = ( dpos0 - 1 ) * descmult
3465 dpos = dpos0 * descmult
3466*
3467* Get grid parameters
3468*
3469 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3470*
3471* Check that matrix values make sense from local viewpoint
3472*
3473 IF( m.LT.0 )
3474 $ info = min( info, mpos )
3475 IF( n.LT.0 )
3476 $ info = min( info, npos )
3477 IF( ia.LT.1 )
3478 $ info = min( info, iapos )
3479 IF( ja.LT.1 )
3480 $ info = min( info, japos )
3481 IF( desca2( dtype_ ).NE.block_cyclic_2d_inb )
3482 $ info = min( info, dpos + dtype_ )
3483 IF( desca2( imb_ ).LT.1 )
3484 $ info = min( info, dpos + imb_ )
3485 IF( desca2( inb_ ).LT.1 )
3486 $ info = min( info, dpos + inb_ )
3487 IF( desca2( mb_ ).LT.1 )
3488 $ info = min( info, dpos + mb_ )
3489 IF( desca2( nb_ ).LT.1 )
3490 $ info = min( info, dpos + nb_ )
3491 IF( desca2( rsrc_ ).LT.-1 .OR. desca2( rsrc_ ).GE.nprow )
3492 $ info = min( info, dpos + rsrc_ )
3493 IF( desca2( csrc_ ).LT.-1 .OR. desca2( csrc_ ).GE.npcol )
3494 $ info = min( info, dpos + csrc_ )
3495 IF( desca2( ctxt_ ).NE.ictxt )
3496 $ info = min( info, dpos + ctxt_ )
3497*
3498 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
3499*
3500* NULL matrix, relax some checks
3501*
3502 IF( desca2( m_ ).LT.0 )
3503 $ info = min( info, dpos + m_ )
3504 IF( desca2( n_ ).LT.0 )
3505 $ info = min( info, dpos + n_ )
3506 IF( desca2( lld_ ).LT.1 )
3507 $ info = min( info, dpos + lld_ )
3508*
3509 ELSE
3510*
3511* more rigorous checks for non-degenerate matrices
3512*
3513 mp = pb_numroc( desca2( m_ ), 1, desca2( imb_ ), desca2( mb_ ),
3514 $ myrow, desca2( rsrc_ ), nprow )
3515*
3516 IF( desca2( m_ ).LT.1 )
3517 $ info = min( info, dpos + m_ )
3518 IF( desca2( n_ ).LT.1 )
3519 $ info = min( info, dpos + n_ )
3520 IF( ia.GT.desca2( m_ ) )
3521 $ info = min( info, iapos )
3522 IF( ja.GT.desca2( n_ ) )
3523 $ info = min( info, japos )
3524 IF( ia+m-1.GT.desca2( m_ ) )
3525 $ info = min( info, mpos )
3526 IF( ja+n-1.GT.desca2( n_ ) )
3527 $ info = min( info, npos )
3528*
3529 IF( desca2( lld_ ).LT.max( 1, mp ) ) THEN
3530 nq = pb_numroc( desca2( n_ ), 1, desca2( inb_ ),
3531 $ desca2( nb_ ), mycol, desca2( csrc_ ),
3532 $ npcol )
3533 IF( desca2( lld_ ).LT.1 ) THEN
3534 info = min( info, dpos + lld_ )
3535 ELSE IF( nq.GT.0 ) THEN
3536 info = min( info, dpos + lld_ )
3537 END IF
3538 END IF
3539*
3540 END IF
3541*
3542* Prepare output: set info = 0 if no error, and divide by
3543* DESCMULT if error is not in a descriptor entry
3544*
3545 IF( info.EQ.bignum ) THEN
3546 info = 0
3547 ELSE IF( mod( info, descmult ).EQ.0 ) THEN
3548 info = -( info / descmult )
3549 ELSE
3550 info = -info
3551 END IF
3552*
3553 RETURN
3554*
3555* End of PB_CHKMAT
3556*
3557 END
3558 SUBROUTINE pb_desctrans( DESCIN, DESCOUT )
3559*
3560* -- PBLAS test routine (version 2.0) --
3561* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3562* and University of California, Berkeley.
3563* April 1, 1998
3564*
3565* .. Array Arguments ..
3566 INTEGER DESCIN( * ), DESCOUT( * )
3567* ..
3568*
3569* Purpose
3570* =======
3571*
3572* PB_DESCTRANS converts a descriptor DESCIN of type BLOCK_CYCLIC_2D
3573* or BLOCK_CYCLIC_INB_2D into a descriptor DESCOUT of type
3574* BLOCK_CYCLIC_INB_2D.
3575*
3576* Notes
3577* =====
3578*
3579* A description vector is associated with each 2D block-cyclicly dis-
3580* tributed matrix. This vector stores the information required to
3581* establish the mapping between a matrix entry and its corresponding
3582* process and memory location.
3583*
3584* In the following comments, the character _ should be read as
3585* "of the distributed matrix". Let A be a generic term for any 2D
3586* block cyclicly distributed matrix. Its description vector is DESCA:
3587*
3588* NOTATION STORED IN EXPLANATION
3589* ---------------- --------------- -----------------------------------
3590* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
3591* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
3592* the NPROW x NPCOL BLACS process
3593* grid A is distributed over. The
3594* context itself is global, but the
3595* handle (the integer value) may
3596* vary.
3597* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3598* buted matrix A, M_A >= 0.
3599* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3600* tributed matrix A, N_A >= 0.
3601* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3602* bute the rows of A, MB_A > 0.
3603* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3604* bute the columns of A, NB_A > 0.
3605* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3606* first row of the matrix A is dis-
3607* tributed, NPROW > RSRC_A >= 0.
3608* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3609* first column of A is distributed.
3610* NPCOL > CSRC_A >= 0.
3611* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3612* array storing the local blocks of
3613* the distributed matrix A,
3614* IF( Lc( 1, N_A ) > 0 )
3615* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3616* ELSE
3617* LLD_A >= 1.
3618*
3619* Let K be the number of rows of a matrix A starting at the global in-
3620* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3621* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3622* receive if these K rows were distributed over NPROW processes. If K
3623* is the number of columns of a matrix A starting at the global index
3624* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3625* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3626* these K columns were distributed over NPCOL processes.
3627*
3628* The values of Lr() and Lc() may be determined via a call to the func-
3629* tion PB_NUMROC:
3630* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3631* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3632*
3633* A description vector is associated with each 2D block-cyclicly dis-
3634* tributed matrix. This vector stores the information required to
3635* establish the mapping between a matrix entry and its corresponding
3636* process and memory location.
3637*
3638* In the following comments, the character _ should be read as
3639* "of the distributed matrix". Let A be a generic term for any 2D
3640* block cyclicly distributed matrix. Its description vector is DESCA:
3641*
3642* NOTATION STORED IN EXPLANATION
3643* ---------------- --------------- ------------------------------------
3644* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3645* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3646* the NPROW x NPCOL BLACS process grid
3647* A is distributed over. The context
3648* itself is global, but the handle
3649* (the integer value) may vary.
3650* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3651* ted matrix A, M_A >= 0.
3652* N_A (global) DESCA( N_ ) The number of columns in the distri-
3653* buted matrix A, N_A >= 0.
3654* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3655* block of the matrix A, IMB_A > 0.
3656* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3657* left block of the matrix A,
3658* INB_A > 0.
3659* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3660* bute the last M_A-IMB_A rows of A,
3661* MB_A > 0.
3662* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3663* bute the last N_A-INB_A columns of
3664* A, NB_A > 0.
3665* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3666* row of the matrix A is distributed,
3667* NPROW > RSRC_A >= 0.
3668* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3669* first column of A is distributed.
3670* NPCOL > CSRC_A >= 0.
3671* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3672* array storing the local blocks of
3673* the distributed matrix A,
3674* IF( Lc( 1, N_A ) > 0 )
3675* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3676* ELSE
3677* LLD_A >= 1.
3678*
3679* Let K be the number of rows of a matrix A starting at the global in-
3680* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3681* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3682* receive if these K rows were distributed over NPROW processes. If K
3683* is the number of columns of a matrix A starting at the global index
3684* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3685* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3686* these K columns were distributed over NPCOL processes.
3687*
3688* The values of Lr() and Lc() may be determined via a call to the func-
3689* tion PB_NUMROC:
3690* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3691* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3692*
3693* Arguments
3694* =========
3695*
3696* DESCIN (global and local input) INTEGER array
3697* On entry, DESCIN is an array of dimension DLEN1_ or DLEN_ as
3698* specified by its first entry DESCIN( DTYPE_ ). DESCIN is the
3699* source array descriptor of type BLOCK_CYCLIC_2D or of type
3700* BLOCK_CYCLIC_2D_INB.
3701*
3702* DESCOUT (global and local output) INTEGER array
3703* On entry, DESCOUT is an array of dimension DLEN_. DESCOUT is
3704* the target array descriptor of type BLOCK_CYCLIC_2D_INB.
3705*
3706* -- Written on April 1, 1998 by
3707* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
3708*
3709* =====================================================================
3710*
3711* .. Parameters ..
3712 INTEGER BLOCK_CYCLIC_2D, CSRC1_, CTXT1_, DLEN1_,
3713 $ DTYPE1_, LLD1_, M1_, MB1_, N1_, NB1_, RSRC1_
3714 PARAMETER ( BLOCK_CYCLIC_2D = 1, dlen1_ = 9, dtype1_ = 1,
3715 $ ctxt1_ = 2, m1_ = 3, n1_ = 4, mb1_ = 5,
3716 $ nb1_ = 6, rsrc1_ = 7, csrc1_ = 8, lld1_ = 9 )
3717 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3718 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3719 $ RSRC_
3720 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3721 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3722 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3723 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3724* ..
3725* .. Local Scalars ..
3726 INTEGER I
3727* ..
3728* .. Executable Statements ..
3729*
3730 IF( descin( dtype_ ).EQ.block_cyclic_2d ) THEN
3731 descout( dtype_ ) = block_cyclic_2d_inb
3732 descout( ctxt_ ) = descin( ctxt1_ )
3733 descout( m_ ) = descin( m1_ )
3734 descout( n_ ) = descin( n1_ )
3735 descout( imb_ ) = descin( mb1_ )
3736 descout( inb_ ) = descin( nb1_ )
3737 descout( mb_ ) = descin( mb1_ )
3738 descout( nb_ ) = descin( nb1_ )
3739 descout( rsrc_ ) = descin( rsrc1_ )
3740 descout( csrc_ ) = descin( csrc1_ )
3741 descout( lld_ ) = descin( lld1_ )
3742 ELSE IF( descin( dtype_ ).EQ.block_cyclic_2d_inb ) THEN
3743 DO 10 i = 1, dlen_
3744 descout( i ) = descin( i )
3745 10 CONTINUE
3746 ELSE
3747 descout( dtype_ ) = descin( 1 )
3748 descout( ctxt_ ) = descin( 2 )
3749 descout( m_ ) = 0
3750 descout( n_ ) = 0
3751 descout( imb_ ) = 1
3752 descout( inb_ ) = 1
3753 descout( mb_ ) = 1
3754 descout( nb_ ) = 1
3755 descout( rsrc_ ) = 0
3756 descout( csrc_ ) = 0
3757 descout( lld_ ) = 1
3758 END IF
3759*
3760 RETURN
3761*
3762* End of PB_DESCTRANS
3763*
3764 END
3765 SUBROUTINE pb_descset2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC,
3766 $ CTXT, LLD )
3767*
3768* -- PBLAS test routine (version 2.0) --
3769* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3770* and University of California, Berkeley.
3771* April 1, 1998
3772*
3773* .. Scalar Arguments ..
3774 INTEGER CSRC, CTXT, IMB, INB, LLD, M, MB, N, NB, RSRC
3775* ..
3776* .. Array Arguments ..
3777 INTEGER DESC( * )
3778* ..
3779*
3780* Purpose
3781* =======
3782*
3783* PB_DESCSET2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3784* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3785* BLOCK_CYCLIC_2D_INB.
3786*
3787* Notes
3788* =====
3789*
3790* A description vector is associated with each 2D block-cyclicly dis-
3791* tributed matrix. This vector stores the information required to
3792* establish the mapping between a matrix entry and its corresponding
3793* process and memory location.
3794*
3795* In the following comments, the character _ should be read as
3796* "of the distributed matrix". Let A be a generic term for any 2D
3797* block cyclicly distributed matrix. Its description vector is DESCA:
3798*
3799* NOTATION STORED IN EXPLANATION
3800* ---------------- --------------- -----------------------------------
3801* DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type.
3802* CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating
3803* the NPROW x NPCOL BLACS process
3804* grid A is distributed over. The
3805* context itself is global, but the
3806* handle (the integer value) may
3807* vary.
3808* M_A (global) DESCA( M1_ ) The number of rows in the distri-
3809* buted matrix A, M_A >= 0.
3810* N_A (global) DESCA( N1_ ) The number of columns in the dis-
3811* tributed matrix A, N_A >= 0.
3812* MB_A (global) DESCA( MB1_ ) The blocking factor used to distri-
3813* bute the rows of A, MB_A > 0.
3814* NB_A (global) DESCA( NB1_ ) The blocking factor used to distri-
3815* bute the columns of A, NB_A > 0.
3816* RSRC_A (global) DESCA( RSRC1_ ) The process row over which the
3817* first row of the matrix A is dis-
3818* tributed, NPROW > RSRC_A >= 0.
3819* CSRC_A (global) DESCA( CSRC1_ ) The process column over which the
3820* first column of A is distributed.
3821* NPCOL > CSRC_A >= 0.
3822* LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local
3823* array storing the local blocks of
3824* the distributed matrix A,
3825* IF( Lc( 1, N_A ) > 0 )
3826* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3827* ELSE
3828* LLD_A >= 1.
3829*
3830* Let K be the number of rows of a matrix A starting at the global in-
3831* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3832* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3833* receive if these K rows were distributed over NPROW processes. If K
3834* is the number of columns of a matrix A starting at the global index
3835* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3836* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3837* these K columns were distributed over NPCOL processes.
3838*
3839* The values of Lr() and Lc() may be determined via a call to the func-
3840* tion PB_NUMROC:
3841* Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW )
3842* Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3843*
3844* Arguments
3845* =========
3846*
3847* DESC (global and local output) INTEGER array
3848* On entry, DESC is an array of dimension DLEN_. DESC is the
3849* array descriptor to be set.
3850*
3851* M (global input) INTEGER
3852* On entry, M specifies the number of rows of the matrix.
3853* M must be at least zero.
3854*
3855* N (global input) INTEGER
3856* On entry, N specifies the number of columns of the matrix.
3857* N must be at least zero.
3858*
3859* IMB (global input) INTEGER
3860* On entry, IMB specifies the row size of the first block of
3861* the global matrix distribution. IMB must be at least one.
3862*
3863* INB (global input) INTEGER
3864* On entry, INB specifies the column size of the first block
3865* of the global matrix distribution. INB must be at least one.
3866*
3867* MB (global input) INTEGER
3868* On entry, MB specifies the row size of the blocks used to
3869* partition the matrix. MB must be at least one.
3870*
3871* NB (global input) INTEGER
3872* On entry, NB specifies the column size of the blocks used to
3873* partition the matrix. NB must be at least one.
3874*
3875* RSRC (global input) INTEGER
3876* On entry, RSRC specifies the row coordinate of the process
3877* that possesses the first row of the matrix. When RSRC = -1,
3878* the data is not distributed but replicated, otherwise RSRC
3879* must be at least zero and strictly less than NPROW.
3880*
3881* CSRC (global input) INTEGER
3882* On entry, CSRC specifies the column coordinate of the pro-
3883* cess that possesses the first column of the matrix. When
3884* CSRC = -1, the data is not distributed but replicated, other-
3885* wise CSRC must be at least zero and strictly less than NPCOL.
3886*
3887* CTXT (local input) INTEGER
3888* On entry, CTXT specifies the BLACS context handle, indicating
3889* the global communication context. The value of the context
3890* itself is local.
3891*
3892* LLD (local input) INTEGER
3893* On entry, LLD specifies the leading dimension of the local
3894* array storing the local entries of the matrix. LLD must be at
3895* least MAX( 1, Lr(1,M) ).
3896*
3897* -- Written on April 1, 1998 by
3898* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3899*
3900* =====================================================================
3901*
3902* .. Parameters ..
3903 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3904 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3905 $ RSRC_
3906 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3907 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3908 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3909 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3910* ..
3911* .. Executable Statements ..
3912*
3913 desc( dtype_ ) = block_cyclic_2d_inb
3914 desc( ctxt_ ) = ctxt
3915 desc( m_ ) = m
3916 desc( n_ ) = n
3917 desc( imb_ ) = imb
3918 desc( inb_ ) = inb
3919 desc( mb_ ) = mb
3920 desc( nb_ ) = nb
3921 desc( rsrc_ ) = rsrc
3922 desc( csrc_ ) = csrc
3923 desc( lld_ ) = lld
3924*
3925 RETURN
3926*
3927* End of PB_DESCSET2
3928*
3929 END
3930 SUBROUTINE pb_descinit2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC,
3931 $ CTXT, LLD, INFO )
3932*
3933* -- PBLAS test routine (version 2.0) --
3934* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3935* and University of California, Berkeley.
3936* April 1, 1998
3937*
3938* .. Scalar Arguments ..
3939 INTEGER CSRC, CTXT, IMB, INB, INFO, LLD, M, MB, N, NB,
3940 $ rsrc
3941* ..
3942* .. Array Arguments ..
3943 INTEGER DESC( * )
3944* ..
3945*
3946* Purpose
3947* =======
3948*
3949* PB_DESCINIT2 uses its 10 input arguments M, N, IMB, INB, MB, NB,
3950* RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type
3951* BLOCK_CYCLIC_2D_INB.
3952*
3953* Notes
3954* =====
3955*
3956* A description vector is associated with each 2D block-cyclicly dis-
3957* tributed matrix. This vector stores the information required to
3958* establish the mapping between a matrix entry and its corresponding
3959* process and memory location.
3960*
3961* In the following comments, the character _ should be read as
3962* "of the distributed matrix". Let A be a generic term for any 2D
3963* block cyclicly distributed matrix. Its description vector is DESCA:
3964*
3965* NOTATION STORED IN EXPLANATION
3966* ---------------- --------------- ------------------------------------
3967* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3968* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3969* the NPROW x NPCOL BLACS process grid
3970* A is distributed over. The context
3971* itself is global, but the handle
3972* (the integer value) may vary.
3973* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3974* ted matrix A, M_A >= 0.
3975* N_A (global) DESCA( N_ ) The number of columns in the distri-
3976* buted matrix A, N_A >= 0.
3977* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3978* block of the matrix A, IMB_A > 0.
3979* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3980* left block of the matrix A,
3981* INB_A > 0.
3982* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3983* bute the last M_A-IMB_A rows of A,
3984* MB_A > 0.
3985* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3986* bute the last N_A-INB_A columns of
3987* A, NB_A > 0.
3988* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3989* row of the matrix A is distributed,
3990* NPROW > RSRC_A >= 0.
3991* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3992* first column of A is distributed.
3993* NPCOL > CSRC_A >= 0.
3994* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3995* array storing the local blocks of
3996* the distributed matrix A,
3997* IF( Lc( 1, N_A ) > 0 )
3998* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3999* ELSE
4000* LLD_A >= 1.
4001*
4002* Let K be the number of rows of a matrix A starting at the global in-
4003* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4004* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4005* receive if these K rows were distributed over NPROW processes. If K
4006* is the number of columns of a matrix A starting at the global index
4007* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4008* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4009* these K columns were distributed over NPCOL processes.
4010*
4011* The values of Lr() and Lc() may be determined via a call to the func-
4012* tion PB_NUMROC:
4013* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4014* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4015*
4016* Arguments
4017* =========
4018*
4019* DESC (global and local output) INTEGER array
4020* On entry, DESC is an array of dimension DLEN_. DESC is the
4021* array descriptor to be set.
4022*
4023* M (global input) INTEGER
4024* On entry, M specifies the number of rows of the matrix.
4025* M must be at least zero.
4026*
4027* N (global input) INTEGER
4028* On entry, N specifies the number of columns of the matrix.
4029* N must be at least zero.
4030*
4031* IMB (global input) INTEGER
4032* On entry, IMB specifies the row size of the first block of
4033* the global matrix distribution. IMB must be at least one.
4034*
4035* INB (global input) INTEGER
4036* On entry, INB specifies the column size of the first block
4037* of the global matrix distribution. INB must be at least one.
4038*
4039* MB (global input) INTEGER
4040* On entry, MB specifies the row size of the blocks used to
4041* partition the matrix. MB must be at least one.
4042*
4043* NB (global input) INTEGER
4044* On entry, NB specifies the column size of the blocks used to
4045* partition the matrix. NB must be at least one.
4046*
4047* RSRC (global input) INTEGER
4048* On entry, RSRC specifies the row coordinate of the process
4049* that possesses the first row of the matrix. When RSRC = -1,
4050* the data is not distributed but replicated, otherwise RSRC
4051* must be at least zero and strictly less than NPROW.
4052*
4053* CSRC (global input) INTEGER
4054* On entry, CSRC specifies the column coordinate of the pro-
4055* cess that possesses the first column of the matrix. When
4056* CSRC = -1, the data is not distributed but replicated, other-
4057* wise CSRC must be at least zero and strictly less than NPCOL.
4058*
4059* CTXT (local input) INTEGER
4060* On entry, CTXT specifies the BLACS context handle, indicating
4061* the global communication context. The value of the context
4062* itself is local.
4063*
4064* LLD (local input) INTEGER
4065* On entry, LLD specifies the leading dimension of the local
4066* array storing the local entries of the matrix. LLD must be at
4067* least MAX( 1, Lr(1,M) ).
4068*
4069* INFO (local output) INTEGER
4070* = 0: successful exit
4071* < 0: if INFO = -i, the i-th argument had an illegal value.
4072*
4073* Notes
4074* =====
4075*
4076* If the routine can recover from an erroneous input argument, it will
4077* return an acceptable descriptor vector. For example, if LLD = 0 on
4078* input, DESC( LLD_ ) will contain the smallest leading dimension re-
4079* quired to store the specified m by n matrix, INFO will however be set
4080* to -11 on exit in that case.
4081*
4082* -- Written on April 1, 1998 by
4083* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4084*
4085* =====================================================================
4086*
4087* .. Parameters ..
4088 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4089 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4090 $ RSRC_
4091 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
4092 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4093 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4094 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4095* ..
4096* .. Local Scalars ..
4097 INTEGER LLDMIN, MP, MYCOL, MYROW, NPCOL, NPROW
4098* ..
4099* .. External Subroutines ..
4100 EXTERNAL blacs_gridinfo, pxerbla
4101* ..
4102* .. External Functions ..
4103 INTEGER PB_NUMROC
4104 EXTERNAL PB_NUMROC
4105* ..
4106* .. Intrinsic Functions ..
4107 INTRINSIC MAX, MIN
4108* ..
4109* .. Executable Statements ..
4110*
4111* Get grid parameters
4112*
4113 CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
4114*
4115 info = 0
4116 IF( m.LT.0 ) THEN
4117 info = -2
4118 ELSE IF( n.LT.0 ) THEN
4119 info = -3
4120 ELSE IF( imb.LT.1 ) THEN
4121 info = -4
4122 ELSE IF( inb.LT.1 ) THEN
4123 info = -5
4124 ELSE IF( mb.LT.1 ) THEN
4125 info = -6
4126 ELSE IF( nb.LT.1 ) THEN
4127 info = -7
4128 ELSE IF( rsrc.LT.-1 .OR. rsrc.GE.nprow ) THEN
4129 info = -8
4130 ELSE IF( csrc.LT.-1 .OR. csrc.GE.npcol ) THEN
4131 info = -9
4132 ELSE IF( nprow.EQ.-1 ) THEN
4133 info = -10
4134 END IF
4135*
4136* Compute minimum LLD if safe (to avoid division by 0)
4137*
4138 IF( info.EQ.0 ) THEN
4139 mp = pb_numroc( m, 1, imb, mb, myrow, rsrc, nprow )
4140 IF( pb_numroc( n, 1, inb, nb, mycol, csrc, npcol ).GT.0 ) THEN
4141 lldmin = max( 1, mp )
4142 ELSE
4143 lldmin = 1
4144 END IF
4145 IF( lld.LT.lldmin )
4146 $ info = -11
4147 END IF
4148*
4149 IF( info.NE.0 )
4150 $ CALL pxerbla( ctxt, 'PB_DESCINIT2', -info )
4151*
4152 desc( dtype_ ) = block_cyclic_2d_inb
4153 desc( ctxt_ ) = ctxt
4154 desc( m_ ) = max( 0, m )
4155 desc( n_ ) = max( 0, n )
4156 desc( imb_ ) = max( 1, imb )
4157 desc( inb_ ) = max( 1, inb )
4158 desc( mb_ ) = max( 1, mb )
4159 desc( nb_ ) = max( 1, nb )
4160 desc( rsrc_ ) = max( -1, min( rsrc, nprow-1 ) )
4161 desc( csrc_ ) = max( -1, min( csrc, npcol-1 ) )
4162 desc( lld_ ) = max( lld, lldmin )
4163*
4164 RETURN
4165*
4166* End of PB_DESCINIT2
4167*
4168 END
4169 SUBROUTINE pb_binfo( OFFD, M, N, IMB1, INB1, MB, NB, MRROW, MRCOL,
4170 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
4171 $ LNBLOC, ILOW, LOW, IUPP, UPP )
4172*
4173* -- PBLAS test routine (version 2.0) --
4174* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4175* and University of California, Berkeley.
4176* April 1, 1998
4177*
4178* .. Scalar Arguments ..
4179 INTEGER ILOW, IMB1, IMBLOC, INB1, INBLOC, IUPP, LCMT00,
4180 $ LMBLOC, LNBLOC, LOW, M, MB, MBLKS, MRCOL,
4181 $ mrrow, n, nb, nblks, offd, upp
4182* ..
4183*
4184* Purpose
4185* =======
4186*
4187* PB_BINFO initializes the local information of an m by n local array
4188* owned by the process of relative coordinates ( MRROW, MRCOL ). Note
4189* that if m or n is less or equal than zero, there is no data, in which
4190* case this process does not need the local information computed by
4191* this routine to proceed.
4192*
4193* Arguments
4194* =========
4195*
4196* OFFD (global input) INTEGER
4197* On entry, OFFD specifies the off-diagonal of the underlying
4198* matrix of interest as follows:
4199* OFFD = 0 specifies the main diagonal,
4200* OFFD > 0 specifies lower subdiagonals, and
4201* OFFD < 0 specifies upper superdiagonals.
4202*
4203* M (local input) INTEGER
4204* On entry, M specifies the local number of rows of the under-
4205* lying matrix owned by the process of relative coordinates
4206* ( MRROW, MRCOL ). M must be at least zero.
4207*
4208* N (local input) INTEGER
4209* On entry, N specifies the local number of columns of the un-
4210* derlying matrix owned by the process of relative coordinates
4211* ( MRROW, MRCOL ). N must be at least zero.
4212*
4213* IMB1 (global input) INTEGER
4214* On input, IMB1 specifies the global true size of the first
4215* block of rows of the underlying global submatrix. IMB1 must
4216* be at least MIN( 1, M ).
4217*
4218* INB1 (global input) INTEGER
4219* On input, INB1 specifies the global true size of the first
4220* block of columns of the underlying global submatrix. INB1
4221* must be at least MIN( 1, N ).
4222*
4223* MB (global input) INTEGER
4224* On entry, MB specifies the blocking factor used to partition
4225* the rows of the matrix. MB must be at least one.
4226*
4227* NB (global input) INTEGER
4228* On entry, NB specifies the blocking factor used to partition
4229* the the columns of the matrix. NB must be at least one.
4230*
4231* MRROW (local input) INTEGER
4232* On entry, MRROW specifies the relative row coordinate of the
4233* process that possesses these M rows. MRROW must be least zero
4234* and strictly less than NPROW.
4235*
4236* MRCOL (local input) INTEGER
4237* On entry, MRCOL specifies the relative column coordinate of
4238* the process that possesses these N columns. MRCOL must be
4239* least zero and strictly less than NPCOL.
4240*
4241* LCMT00 (local output) INTEGER
4242* On exit, LCMT00 is the LCM value of the left upper block of
4243* this m by n local block owned by the process of relative co-
4244* ordinates ( MRROW, MRCOL ).
4245*
4246* MBLKS (local output) INTEGER
4247* On exit, MBLKS specifies the local number of blocks of rows
4248* corresponding to M. MBLKS must be at least zero.
4249*
4250* NBLKS (local output) INTEGER
4251* On exit, NBLKS specifies the local number of blocks of co-
4252* lumns corresponding to N. NBLKS must be at least zero.
4253*
4254* IMBLOC (local output) INTEGER
4255* On exit, IMBLOC specifies the number of rows (size) of the
4256* uppest blocks of this m by n local array owned by the process
4257* of relative coordinates ( MRROW, MRCOL ). IMBLOC is at least
4258* MIN( 1, M ).
4259*
4260* INBLOC (local output) INTEGER
4261* On exit, INBLOC specifies the number of columns (size) of
4262* the leftmost blocks of this m by n local array owned by the
4263* process of relative coordinates ( MRROW, MRCOL ). INBLOC is
4264* at least MIN( 1, N ).
4265*
4266* LMBLOC (local output) INTEGER
4267* On exit, LMBLOC specifies the number of rows (size) of the
4268* lowest blocks of this m by n local array owned by the process
4269* of relative coordinates ( MRROW, MRCOL ). LMBLOC is at least
4270* MIN( 1, M ).
4271*
4272* LNBLOC (local output) INTEGER
4273* On exit, LNBLOC specifies the number of columns (size) of the
4274* rightmost blocks of this m by n local array owned by the
4275* process of relative coordinates ( MRROW, MRCOL ). LNBLOC is
4276* at least MIN( 1, N ).
4277*
4278* ILOW (local output) INTEGER
4279* On exit, ILOW is the lower bound characterizing the first co-
4280* lumn block owning offdiagonals of this m by n array. ILOW
4281* must be less or equal than zero.
4282*
4283* LOW (global output) INTEGER
4284* On exit, LOW is the lower bound characterizing the column
4285* blocks with te exception of the first one (see ILOW) owning
4286* offdiagonals of this m by n array. LOW must be less or equal
4287* than zero.
4288*
4289* IUPP (local output) INTEGER
4290* On exit, IUPP is the upper bound characterizing the first row
4291* block owning offdiagonals of this m by n array. IUPP must be
4292* greater or equal than zero.
4293*
4294* UPP (global output) INTEGER
4295* On exit, UPP is the upper bound characterizing the row
4296* blocks with te exception of the first one (see IUPP) owning
4297* offdiagonals of this m by n array. UPP must be greater or
4298* equal than zero.
4299*
4300* -- Written on April 1, 1998 by
4301* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4302*
4303* =====================================================================
4304*
4305* .. Local Scalars ..
4306 INTEGER TMP1
4307* ..
4308* .. Intrinsic Functions ..
4309 INTRINSIC MAX, MIN
4310* ..
4311* .. Executable Statements ..
4312*
4313* Initialize LOW, ILOW, UPP, IUPP, LMBLOC, LNBLOC, IMBLOC, INBLOC,
4314* MBLKS, NBLKS and LCMT00.
4315*
4316 LOW = 1 - nb
4317 upp = mb - 1
4318*
4319 lcmt00 = offd
4320*
4321 IF( m.LE.0 .OR. n.LE.0 ) THEN
4322*
4323 IF( mrrow.GT.0 ) THEN
4324 iupp = mb - 1
4325 ELSE
4326 iupp = max( 0, imb1 - 1 )
4327 END IF
4328 imbloc = 0
4329 mblks = 0
4330 lmbloc = 0
4331*
4332 IF( mrcol.GT.0 ) THEN
4333 ilow = 1 - nb
4334 ELSE
4335 ilow = min( 0, 1 - inb1 )
4336 END IF
4337 inbloc = 0
4338 nblks = 0
4339 lnbloc = 0
4340*
4341 lcmt00 = lcmt00 + ( low - ilow + mrcol * nb ) -
4342 $ ( iupp - upp + mrrow * mb )
4343*
4344 RETURN
4345*
4346 END IF
4347*
4348 IF( mrrow.GT.0 ) THEN
4349*
4350 imbloc = min( m, mb )
4351 iupp = mb - 1
4352 lcmt00 = lcmt00 - ( imb1 - mb + mrrow * mb )
4353 mblks = ( m - 1 ) / mb + 1
4354 lmbloc = m - ( m / mb ) * mb
4355 IF( lmbloc.EQ.0 )
4356 $ lmbloc = mb
4357*
4358 IF( mrcol.GT.0 ) THEN
4359*
4360 inbloc = min( n, nb )
4361 ilow = 1 - nb
4362 lcmt00 = lcmt00 + inb1 - nb + mrcol * nb
4363 nblks = ( n - 1 ) / nb + 1
4364 lnbloc = n - ( n / nb ) * nb
4365 IF( lnbloc.EQ.0 )
4366 $ lnbloc = nb
4367*
4368 ELSE
4369*
4370 inbloc = inb1
4371 ilow = 1 - inb1
4372 tmp1 = n - inb1
4373 IF( tmp1.GT.0 ) THEN
4374*
4375* more than one block
4376*
4377 nblks = ( tmp1 - 1 ) / nb + 2
4378 lnbloc = tmp1 - ( tmp1 / nb ) * nb
4379 IF( lnbloc.EQ.0 )
4380 $ lnbloc = nb
4381*
4382 ELSE
4383*
4384 nblks = 1
4385 lnbloc = inb1
4386*
4387 END IF
4388*
4389 END IF
4390*
4391 ELSE
4392*
4393 imbloc = imb1
4394 iupp = imb1 - 1
4395 tmp1 = m - imb1
4396 IF( tmp1.GT.0 ) THEN
4397*
4398* more than one block
4399*
4400 mblks = ( tmp1 - 1 ) / mb + 2
4401 lmbloc = tmp1 - ( tmp1 / mb ) * mb
4402 IF( lmbloc.EQ.0 )
4403 $ lmbloc = mb
4404*
4405 ELSE
4406*
4407 mblks = 1
4408 lmbloc = imb1
4409*
4410 END IF
4411*
4412 IF( mrcol.GT.0 ) THEN
4413*
4414 inbloc = min( n, nb )
4415 ilow = 1 - nb
4416 lcmt00 = lcmt00 + inb1 - nb + mrcol * nb
4417 nblks = ( n - 1 ) / nb + 1
4418 lnbloc = n - ( n / nb ) * nb
4419 IF( lnbloc.EQ.0 )
4420 $ lnbloc = nb
4421*
4422 ELSE
4423*
4424 inbloc = inb1
4425 ilow = 1 - inb1
4426 tmp1 = n - inb1
4427 IF( tmp1.GT.0 ) THEN
4428*
4429* more than one block
4430*
4431 nblks = ( tmp1 - 1 ) / nb + 2
4432 lnbloc = tmp1 - ( tmp1 / nb ) * nb
4433 IF( lnbloc.EQ.0 )
4434 $ lnbloc = nb
4435*
4436 ELSE
4437*
4438 nblks = 1
4439 lnbloc = inb1
4440*
4441 END IF
4442*
4443 END IF
4444*
4445 END IF
4446*
4447 RETURN
4448*
4449* End of PB_BINFO
4450*
4451 END
4452 INTEGER FUNCTION pilaenv( ICTXT, PREC )
4453*
4454* -- PBLAS test routine (version 2.0) --
4455* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4456* and University of California, Berkeley.
4457* April 1, 1998
4458*
4459* .. Scalar Arguments ..
4460 INTEGER ictxt
4461 CHARACTER*1 prec
4462* ..
4463*
4464* Purpose
4465* =======
4466*
4467* PILAENV returns the logical computational block size to be used by
4468* the PBLAS routines during testing and timing. This is a special ver-
4469* sion to be used only as part of the testing or timing PBLAS programs
4470* for testing different values of logical computational block sizes for
4471* the PBLAS routines. It is called by the PBLAS routines to retrieve a
4472* logical computational block size value.
4473*
4474* Arguments
4475* =========
4476*
4477* ICTXT (local input) INTEGER
4478* On entry, ICTXT specifies the BLACS context handle, indica-
4479* ting the global context of the operation. The context itself
4480* is global, but the value of ICTXT is local.
4481*
4482* PREC (dummy input) CHARACTER*1
4483* On entry, PREC is a dummy argument.
4484*
4485* -- Written on April 1, 1998 by
4486* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4487*
4488* =====================================================================
4489*
4490* .. Common Blocks ..
4491 INTEGER info, nblog
4492 common /infoc/info, nblog
4493* ..
4494* .. Executable Statements ..
4495*
4496 pilaenv = nblog
4497*
4498 RETURN
4499*
4500* End of PILAENV
4501*
4502 END
4503 SUBROUTINE pb_locinfo( I, INB, NB, MYROC, SRCPROC, NPROCS,
4504 $ ILOCBLK, ILOCOFF, MYDIST )
4505*
4506* -- PBLAS test routine (version 2.0) --
4507* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4508* and University of California, Berkeley.
4509* April 1, 1998
4510*
4511* .. Scalar Arguments ..
4512 INTEGER I, ILOCBLK, ILOCOFF, INB, MYDIST, MYROC, NB,
4513 $ NPROCS, SRCPROC
4514* ..
4515*
4516* Purpose
4517* =======
4518*
4519* PB_LOCINFO computes local information about the beginning of a sub-
4520* matrix starting at the global index I.
4521*
4522* Arguments
4523* =========
4524*
4525* I (global input) INTEGER
4526* On entry, I specifies the global starting index in the ma-
4527* trix. I must be at least one.
4528*
4529* INB (global input) INTEGER
4530* On entry, INB specifies the size of the first block of rows
4531* or columns of the matrix. INB must be at least one.
4532*
4533* NB (global input) INTEGER
4534* On entry, NB specifies the size of the blocks of rows or co-
4535* lumns of the matrix is partitioned into. NB must be at least
4536* one.
4537*
4538* MYROC (local input) INTEGER
4539* On entry, MYROC is the coordinate of the process whose local
4540* information is determined. MYROC is at least zero and
4541* strictly less than NPROCS.
4542*
4543* SRCPROC (global input) INTEGER
4544* On entry, SRCPROC specifies the coordinate of the process
4545* that possesses the first row or column of the matrix. When
4546* SRCPROC = -1, the data is not distributed but replicated,
4547* otherwise SRCPROC must be at least zero and strictly less
4548* than NPROCS.
4549*
4550* NPROCS (global input) INTEGER
4551* On entry, NPROCS specifies the total number of process rows
4552* or columns over which the submatrix is distributed. NPROCS
4553* must be at least one.
4554*
4555* ILOCBLK (local output) INTEGER
4556* On exit, ILOCBLK specifies the local row or column block
4557* coordinate corresponding to the row or column I of the ma-
4558* trix. ILOCBLK must be at least zero.
4559*
4560* ILOCOFF (local output) INTEGER
4561* On exit, ILOCOFF specifies the local row offset in the block
4562* of local coordinate ILOCBLK corresponding to the row or co-
4563* lumn I of the matrix. ILOCOFF must at least zero.
4564*
4565* MYDIST (local output) INTEGER
4566* On exit, MYDIST specifies the relative process coordinate of
4567* the process specified by MYROC to the process owning the row
4568* or column I. MYDIST is at least zero and strictly less than
4569* NPROCS.
4570*
4571* -- Written on April 1, 1998 by
4572* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4573*
4574* =====================================================================
4575*
4576* .. Local Scalars ..
4577 INTEGER ITMP, NBLOCKS, PROC
4578* ..
4579* .. Executable Statements ..
4580*
4581 ILOCOFF = 0
4582*
4583 if( srcproc.LT.0 ) THEN
4584*
4585 mydist = 0
4586*
4587 IF( i.LE.inb ) THEN
4588*
4589 ilocblk = 0
4590 ilocoff = i - 1
4591*
4592 ELSE
4593*
4594 itmp = i - inb
4595 nblocks = ( itmp - 1 ) / nb + 1
4596 ilocblk = nblocks
4597 ilocoff = itmp - 1 - ( nblocks - 1 ) * nb
4598*
4599 END IF
4600*
4601 ELSE
4602*
4603 proc = srcproc
4604 mydist = myroc - proc
4605 IF( mydist.LT.0 )
4606 $ mydist = mydist + nprocs
4607*
4608 IF( i.LE.inb ) THEN
4609*
4610 ilocblk = 0
4611 IF( myroc.EQ.proc )
4612 $ ilocoff = i - 1
4613*
4614 ELSE
4615*
4616 itmp = i - inb
4617 nblocks = ( itmp - 1 ) / nb + 1
4618 proc = proc + nblocks
4619 proc = proc - ( proc / nprocs ) * nprocs
4620 ilocblk = nblocks / nprocs
4621*
4622 IF( ( ilocblk*nprocs ).LT.( mydist-nblocks ) )
4623 $ ilocblk = ilocblk + 1
4624*
4625 IF( myroc.EQ.proc )
4626 $ ilocoff = itmp - 1 - ( nblocks - 1 ) * nb
4627*
4628 END IF
4629*
4630 END IF
4631*
4632 RETURN
4633*
4634* End of PB_LOCINFO
4635*
4636 END
4637 SUBROUTINE pb_initjmp( COLMAJ, NVIR, IMBVIR, INBVIR, IMBLOC,
4638 $ INBLOC, MB, NB, RSRC, CSRC, NPROW, NPCOL,
4639 $ STRIDE, JMP )
4640*
4641* -- PBLAS test routine (version 2.0) --
4642* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4643* and University of California, Berkeley.
4644* April 1, 1998
4645*
4646* .. Scalar Arguments ..
4647 LOGICAL COLMAJ
4648 INTEGER CSRC, IMBLOC, IMBVIR, INBLOC, INBVIR, MB, NB,
4649 $ NPCOL, NPROW, NVIR, RSRC, STRIDE
4650* ..
4651* .. Array Arguments ..
4652 INTEGER JMP( * )
4653* ..
4654*
4655* Purpose
4656* =======
4657*
4658* PB_INITJMP initializes the jump values JMP used by the random matrix
4659* generator.
4660*
4661* Arguments
4662* =========
4663*
4664* COLMAJ (global input) LOGICAL
4665* On entry, COLMAJ specifies the ordering of the random sequen-
4666* ce. When COLMAJ is .TRUE., the random sequence will be used
4667* for a column major ordering, and otherwise a row-major orde-
4668* ring. This impacts on the computation of the jump values.
4669*
4670* NVIR (global input) INTEGER
4671* On entry, NVIR specifies the size of the underlying virtual
4672* matrix. NVIR must be at least zero.
4673*
4674* IMBVIR (local input) INTEGER
4675* On entry, IMBVIR specifies the number of virtual rows of the
4676* upper left block of the underlying virtual submatrix. IMBVIR
4677* must be at least IMBLOC.
4678*
4679* INBVIR (local input) INTEGER
4680* On entry, INBVIR specifies the number of virtual columns of
4681* the upper left block of the underlying virtual submatrix.
4682* INBVIR must be at least INBLOC.
4683*
4684* IMBLOC (local input) INTEGER
4685* On entry, IMBLOC specifies the number of rows (size) of the
4686* local uppest blocks. IMBLOC is at least zero.
4687*
4688* INBLOC (local input) INTEGER
4689* On entry, INBLOC specifies the number of columns (size) of
4690* the local leftmost blocks. INBLOC is at least zero.
4691*
4692* MB (global input) INTEGER
4693* On entry, MB specifies the size of the blocks used to parti-
4694* tion the matrix rows. MB must be at least one.
4695*
4696* NB (global input) INTEGER
4697* On entry, NB specifies the size of the blocks used to parti-
4698* tion the matrix columns. NB must be at least one.
4699*
4700* RSRC (global input) INTEGER
4701* On entry, RSRC specifies the row coordinate of the process
4702* that possesses the first row of the matrix. When RSRC = -1,
4703* the rows are not distributed but replicated, otherwise RSRC
4704* must be at least zero and strictly less than NPROW.
4705*
4706* CSRC (global input) INTEGER
4707* On entry, CSRC specifies the column coordinate of the pro-
4708* cess that possesses the first column of the matrix. When CSRC
4709* is equal to -1, the columns are not distributed but replica-
4710* ted, otherwise CSRC must be at least zero and strictly less
4711* than NPCOL.
4712*
4713* NPROW (global input) INTEGER
4714* On entry, NPROW specifies the total number of process rows
4715* over which the matrix is distributed. NPROW must be at least
4716* one.
4717*
4718* NPCOL (global input) INTEGER
4719* On entry, NPCOL specifies the total number of process co-
4720* lumns over which the matrix is distributed. NPCOL must be at
4721* least one.
4722*
4723* STRIDE (global input) INTEGER
4724* On entry, STRIDE specifies the number of random numbers to be
4725* generated to compute one matrix entry. In the real case,
4726* STRIDE is usually 1, where as in the complex case STRIDE is
4727* usually 2 in order to generate the real and imaginary parts.
4728*
4729* JMP (local output) INTEGER array
4730* On entry, JMP is an array of dimension JMP_LEN. On exit, this
4731* array contains the different jump values used by the random
4732* matrix generator.
4733*
4734* -- Written on April 1, 1998 by
4735* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4736*
4737* =====================================================================
4738*
4739* .. Parameters ..
4740 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4741 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4742 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4743 PARAMETER ( JMP_1 = 1, jmp_row = 2, jmp_col = 3,
4744 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4745 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4746 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4747 $ jmp_len = 11 )
4748* ..
4749* .. Local Scalars ..
4750 INTEGER NPMB, NQNB
4751* ..
4752* .. Executable Statements ..
4753*
4754 IF( RSRC.LT.0 ) THEN
4755 NPMB = mb
4756 ELSE
4757 npmb = nprow * mb
4758 END IF
4759 IF( csrc.LT.0 ) THEN
4760 nqnb = nb
4761 ELSE
4762 nqnb = npcol * nb
4763 END IF
4764*
4765 jmp( jmp_1 ) = 1
4766*
4767 jmp( jmp_mb ) = mb
4768 jmp( jmp_imbv ) = imbvir
4769 jmp( jmp_npmb ) = npmb
4770 jmp( jmp_npimbloc ) = imbloc + npmb - mb
4771*
4772 jmp( jmp_nb ) = nb
4773 jmp( jmp_inbv ) = inbvir
4774 jmp( jmp_nqnb ) = nqnb
4775 jmp( jmp_nqinbloc ) = inbloc + nqnb - nb
4776*
4777 IF( colmaj ) THEN
4778 jmp( jmp_row ) = stride
4779 jmp( jmp_col ) = stride * nvir
4780 ELSE
4781 jmp( jmp_row ) = stride * nvir
4782 jmp( jmp_col ) = stride
4783 END IF
4784*
4785 RETURN
4786*
4787* End of PB_INITJMP
4788*
4789 END
4790 SUBROUTINE pb_initmuladd( MULADD0, JMP, IMULADD )
4791*
4792* -- PBLAS test routine (version 2.0) --
4793* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4794* and University of California, Berkeley.
4795* April 1, 1998
4796*
4797* .. Array Arguments ..
4798 INTEGER IMULADD( 4, * ), JMP( * ), MULADD0( * )
4799* ..
4800*
4801* Purpose
4802* =======
4803*
4804* PB_INITMULADD initializes the constants a's and c's corresponding to
4805* the jump values (JMP) used by the matrix generator.
4806*
4807* Arguments
4808* =========
4809*
4810* MULADD0 (local input) INTEGER array
4811* On entry, MULADD0 is an array of dimension 4 containing the
4812* encoded initial constants a and c to jump from X( n ) to
4813* X( n+1 ) = a*X( n ) + c in the random sequence. MULADD0(1:2)
4814* contains respectively the 16-lower and 16-higher bits of the
4815* constant a, and MULADD0(3:4) contains the 16-lower and
4816* 16-higher bits of the constant c.
4817*
4818* JMP (local input) INTEGER array
4819* On entry, JMP is an array of dimension JMP_LEN containing the
4820* different jump values used by the matrix generator.
4821*
4822* IMULADD (local output) INTEGER array
4823* On entry, IMULADD is an array of dimension ( 4, JMP_LEN ). On
4824* exit, the jth column of this array contains the encoded ini-
4825* tial constants a_j and c_j to jump from X( n ) to X(n+JMP(j))
4826* (= a_j*X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4827* contains respectively the 16-lower and 16-higher bits of the
4828* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4829* 16-higher bits of the constant c_j.
4830*
4831* -- Written on April 1, 1998 by
4832* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4833*
4834* =====================================================================
4835*
4836* .. Parameters ..
4837 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4838 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4839 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4840 PARAMETER ( JMP_1 = 1, jmp_row = 2, jmp_col = 3,
4841 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4842 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4843 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4844 $ jmp_len = 11 )
4845* ..
4846*
4847* .. Local Arrays ..
4848 INTEGER ITMP1( 2 ), ITMP2( 2 )
4849* ..
4850* .. External Subroutines ..
4851 EXTERNAL PB_JUMP
4852* ..
4853* .. Executable Statements ..
4854*
4855 itmp2( 1 ) = 100
4856 itmp2( 2 ) = 0
4857*
4858* Compute IMULADD for all JMP values
4859*
4860 CALL pb_jump( jmp( jmp_1 ), muladd0, itmp2, itmp1,
4861 $ imuladd( 1, jmp_1 ) )
4862*
4863 CALL pb_jump( jmp( jmp_row ), muladd0, itmp1, itmp2,
4864 $ imuladd( 1, jmp_row ) )
4865 CALL pb_jump( jmp( jmp_col ), muladd0, itmp1, itmp2,
4866 $ imuladd( 1, jmp_col ) )
4867*
4868* Compute constants a and c to jump JMP( * ) numbers in the
4869* sequence for column- or row-major ordering of the sequence.
4870*
4871 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp1,
4872 $ itmp2, imuladd( 1, jmp_imbv ) )
4873 CALL pb_jump( jmp( jmp_mb ), imuladd( 1, jmp_row ), itmp1,
4874 $ itmp2, imuladd( 1, jmp_mb ) )
4875 CALL pb_jump( jmp( jmp_npmb ), imuladd( 1, jmp_row ), itmp1,
4876 $ itmp2, imuladd( 1, jmp_npmb ) )
4877 CALL pb_jump( jmp( jmp_npimbloc ), imuladd( 1, jmp_row ), itmp1,
4878 $ itmp2, imuladd( 1, jmp_npimbloc ) )
4879*
4880 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp1,
4881 $ itmp2, imuladd( 1, jmp_inbv ) )
4882 CALL pb_jump( jmp( jmp_nb ), imuladd( 1, jmp_col ), itmp1,
4883 $ itmp2, imuladd( 1, jmp_nb ) )
4884 CALL pb_jump( jmp( jmp_nqnb ), imuladd( 1, jmp_col ), itmp1,
4885 $ itmp2, imuladd( 1, jmp_nqnb ) )
4886 CALL pb_jump( jmp( jmp_nqinbloc ), imuladd( 1, jmp_col ), itmp1,
4887 $ itmp2, imuladd( 1, jmp_nqinbloc ) )
4888*
4889 RETURN
4890*
4891* End of PB_INITMULADD
4892*
4893 END
4894 SUBROUTINE pb_setlocran( SEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
4895 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
4896 $ IMULADD, IRAN )
4897*
4898* -- PBLAS test routine (version 2.0) --
4899* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4900* and University of California, Berkeley.
4901* April 1, 1998
4902*
4903* .. Scalar Arguments ..
4904 INTEGER ILOCBLK, ILOCOFF, JLOCBLK, JLOCOFF, MYCDIST,
4905 $ MYRDIST, NPCOL, NPROW, SEED
4906* ..
4907* .. Array Arguments ..
4908 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
4909* ..
4910*
4911* Purpose
4912* =======
4913*
4914* PB_SETLOCRAN locally initializes the random number generator.
4915*
4916* Arguments
4917* =========
4918*
4919* SEED (global input) INTEGER
4920* On entry, SEED specifies a positive integer used to initiali-
4921* ze the first number in the random sequence used by the matrix
4922* generator. SEED must be at least zero.
4923*
4924* ILOCBLK (local input) INTEGER
4925* On entry, ILOCBLK specifies the local row block coordinate
4926* corresponding to the first row of the submatrix of interest.
4927* ILOCBLK must be at least zero.
4928*
4929* ILOCOFF (local input) INTEGER
4930* On entry, ILOCOFF specifies the local row offset in the block
4931* of local coordinate ILOCBLK corresponding to the first row of
4932* the submatrix of interest. ILOCOFF must at least zero.
4933*
4934* JLOCBLK (local input) INTEGER
4935* On entry, JLOCBLK specifies the local column block coordinate
4936* corresponding to the first column of the submatrix of inte-
4937* rest. JLOCBLK must be at least zero.
4938*
4939* JLOCOFF (local input) INTEGER
4940* On entry, JLOCOFF specifies the local column offset in the
4941* block of local coordinate JLOCBLK corresponding to the first
4942* column of the submatrix of interest. JLOCOFF must be at least
4943* zero.
4944*
4945* MYRDIST (local input) INTEGER
4946* On entry, MYRDIST specifies the relative row process coordi-
4947* nate to the process owning the first row of the submatrix of
4948* interest. MYRDIST must be at least zero and stricly less than
4949* NPROW (see the subroutine PB_LOCINFO).
4950*
4951* MYCDIST (local input) INTEGER
4952* On entry, MYCDIST specifies the relative column process coor-
4953* dinate to the process owning the first column of the subma-
4954* trix of interest. MYCDIST must be at least zero and stricly
4955* less than NPCOL (see the subroutine PB_LOCINFO).
4956*
4957* NPROW (global input) INTEGER
4958* On entry, NPROW specifies the total number of process rows
4959* over which the matrix is distributed. NPROW must be at least
4960* one.
4961*
4962* NPCOL (global input) INTEGER
4963* On entry, NPCOL specifies the total number of process co-
4964* lumns over which the matrix is distributed. NPCOL must be at
4965* least one.
4966*
4967* JMP (local input) INTEGER array
4968* On entry, JMP is an array of dimension JMP_LEN containing the
4969* different jump values used by the matrix generator.
4970*
4971* IMULADD (local input) INTEGER array
4972* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
4973* jth column of this array contains the encoded initial cons-
4974* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
4975* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
4976* contains respectively the 16-lower and 16-higher bits of the
4977* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
4978* 16-higher bits of the constant c_j.
4979*
4980* IRAN (local output) INTEGER array
4981* On entry, IRAN is an array of dimension 2. On exit, IRAN con-
4982* tains respectively the 16-lower and 32-higher bits of the en-
4983* coding of the entry of the random sequence corresponding lo-
4984* cally to the first local array entry to generate.
4985*
4986* -- Written on April 1, 1998 by
4987* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4988*
4989* =====================================================================
4990*
4991* .. Parameters ..
4992 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
4993 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
4994 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
4995 PARAMETER ( JMP_1 = 1, jmp_row = 2, jmp_col = 3,
4996 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
4997 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
4998 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
4999 $ jmp_len = 11 )
5000* ..
5001* .. Local Arrays ..
5002 INTEGER IMULADDTMP( 4 ), ITMP( 2 )
5003* ..
5004* .. External Subroutines ..
5005 EXTERNAL PB_JUMP, PB_SETRAN
5006* ..
5007* .. Executable Statements ..
5008*
5009* Compute and set the value of IRAN corresponding to A( IA, JA )
5010*
5011 itmp( 1 ) = seed
5012 itmp( 2 ) = 0
5013*
5014 CALL pb_jump( jmp( jmp_1 ), imuladd( 1, jmp_1 ), itmp, iran,
5015 $ imuladdtmp )
5016*
5017* Jump ILOCBLK blocks of rows + ILOCOFF rows
5018*
5019 CALL pb_jump( ilocoff, imuladd( 1, jmp_row ), iran, itmp,
5020 $ imuladdtmp )
5021 IF( myrdist.GT.0 ) THEN
5022 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp,
5023 $ iran, imuladdtmp )
5024 CALL pb_jump( myrdist - 1, imuladd( 1, jmp_mb ), iran,
5025 $ itmp, imuladdtmp )
5026 CALL pb_jump( ilocblk, imuladd( 1, jmp_npmb ), itmp,
5027 $ iran, imuladdtmp )
5028 ELSE
5029 IF( ilocblk.GT.0 ) THEN
5030 CALL pb_jump( jmp( jmp_imbv ), imuladd( 1, jmp_row ), itmp,
5031 $ iran, imuladdtmp )
5032 CALL pb_jump( nprow - 1, imuladd( 1, jmp_mb ), iran,
5033 $ itmp, imuladdtmp )
5034 CALL pb_jump( ilocblk - 1, imuladd( 1, jmp_npmb ), itmp,
5035 $ iran, imuladdtmp )
5036 ELSE
5037 CALL pb_jump( 0, imuladd( 1, jmp_1 ), itmp,
5038 $ iran, imuladdtmp )
5039 END IF
5040 END IF
5041*
5042* Jump JLOCBLK blocks of columns + JLOCOFF columns
5043*
5044 CALL pb_jump( jlocoff, imuladd( 1, jmp_col ), iran, itmp,
5045 $ imuladdtmp )
5046 IF( mycdist.GT.0 ) THEN
5047 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp,
5048 $ iran, imuladdtmp )
5049 CALL pb_jump( mycdist - 1, imuladd( 1, jmp_nb ), iran,
5050 $ itmp, imuladdtmp )
5051 CALL pb_jump( jlocblk, imuladd( 1, jmp_nqnb ), itmp,
5052 $ iran, imuladdtmp )
5053 ELSE
5054 IF( jlocblk.GT.0 ) THEN
5055 CALL pb_jump( jmp( jmp_inbv ), imuladd( 1, jmp_col ), itmp,
5056 $ iran, imuladdtmp )
5057 CALL pb_jump( npcol - 1, imuladd( 1, jmp_nb ), iran,
5058 $ itmp, imuladdtmp )
5059 CALL pb_jump( jlocblk - 1, imuladd( 1, jmp_nqnb ), itmp,
5060 $ iran, imuladdtmp )
5061 ELSE
5062 CALL pb_jump( 0, imuladd( 1, jmp_1 ), itmp,
5063 $ iran, imuladdtmp )
5064 END IF
5065 END IF
5066*
5067 CALL pb_setran( iran, imuladd( 1, jmp_1 ) )
5068*
5069 RETURN
5070*
5071* End of PB_SETLOCRAN
5072*
5073 END
5074 SUBROUTINE pb_ladd( J, K, I )
5075*
5076* -- PBLAS test routine (version 2.0) --
5077* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5078* and University of California, Berkeley.
5079* April 1, 1998
5080*
5081* .. Array Arguments ..
5082 INTEGER I( 2 ), J( 2 ), K( 2 )
5083* ..
5084*
5085* Purpose
5086* =======
5087*
5088* PB_LADD adds without carry two long positive integers K and J and put
5089* the result into I. The long integers I, J, K are encoded on 31 bits
5090* using an array of 2 integers. The 16-lower bits are stored in the
5091* first entry of each array, the 15-higher bits in the second entry.
5092* For efficiency purposes, the intrisic modulo function is inlined.
5093*
5094* Arguments
5095* =========
5096*
5097* J (local input) INTEGER array
5098* On entry, J is an array of dimension 2 containing the encoded
5099* long integer J.
5100*
5101* K (local input) INTEGER array
5102* On entry, K is an array of dimension 2 containing the encoded
5103* long integer K.
5104*
5105* I (local output) INTEGER array
5106* On entry, I is an array of dimension 2. On exit, this array
5107* contains the encoded long integer I.
5108*
5109* Further Details
5110* ===============
5111*
5112* K( 2 ) K( 1 )
5113* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
5114* + carry = ( K( 1 ) + J( 1 ) ) / 2**16
5115* J( 2 ) J( 1 )
5116* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
5117* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
5118* I( 2 ) I( 1 )
5119* 0XXXXXXX XXXXXXXX I
5120*
5121* -- Written on April 1, 1998 by
5122* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5123*
5124* =====================================================================
5125*
5126* .. Parameters ..
5127 INTEGER IPOW15, IPOW16
5128 PARAMETER ( IPOW15 = 2**15, ipow16 = 2**16 )
5129* ..
5130* .. Local Scalars ..
5131 INTEGER ITMP1, ITMP2
5132* ..
5133* .. Executable Statements ..
5134*
5135* I( 1 ) = MOD( K( 1 ) + J( 1 ), IPOW16 )
5136*
5137 ITMP1 = k( 1 ) + j( 1 )
5138 itmp2 = itmp1 / ipow16
5139 i( 1 ) = itmp1 - itmp2 * ipow16
5140*
5141* I( 2 ) = MOD( ( K( 1 ) + J( 1 ) ) / IPOW16 + K( 2 ) + J( 2 ),
5142* IPOW15 )
5143*
5144 itmp1 = itmp2 + k( 2 ) + j( 2 )
5145 itmp2 = itmp1 / ipow15
5146 i( 2 ) = itmp1 - itmp2 * ipow15
5147*
5148 RETURN
5149*
5150* End of PB_LADD
5151*
5152 END
5153 SUBROUTINE pb_lmul( K, J, I )
5154*
5155* -- PBLAS test routine (version 2.0) --
5156* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5157* and University of California, Berkeley.
5158* April 1, 1998
5159*
5160* .. Array Arguments ..
5161 INTEGER I( 2 ), J( 2 ), K( 2 )
5162* ..
5163*
5164* Purpose
5165* =======
5166*
5167* PB_LMUL multiplies without carry two long positive integers K and J
5168* and put the result into I. The long integers I, J, K are encoded on
5169* 31 bits using an array of 2 integers. The 16-lower bits are stored in
5170* the first entry of each array, the 15-higher bits in the second entry
5171* of each array. For efficiency purposes, the intrisic modulo function
5172* is inlined.
5173*
5174* Arguments
5175* =========
5176*
5177* K (local input) INTEGER array
5178* On entry, K is an array of dimension 2 containing the encoded
5179* long integer K.
5180*
5181* J (local input) INTEGER array
5182* On entry, J is an array of dimension 2 containing the encoded
5183* long integer J.
5184*
5185* I (local output) INTEGER array
5186* On entry, I is an array of dimension 2. On exit, this array
5187* contains the encoded long integer I.
5188*
5189* Further Details
5190* ===============
5191*
5192* K( 2 ) K( 1 )
5193* 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 )
5194* * carry = ( K( 1 ) + J( 1 ) ) / 2**16
5195* J( 2 ) J( 1 )
5196* 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry
5197* ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 )
5198* I( 2 ) I( 1 )
5199* 0XXXXXXX XXXXXXXX I
5200*
5201* -- Written on April 1, 1998 by
5202* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5203*
5204* =====================================================================
5205*
5206* .. Parameters ..
5207 INTEGER IPOW15, IPOW16, IPOW30
5208 PARAMETER ( IPOW15 = 2**15, ipow16 = 2**16,
5209 $ ipow30 = 2**30 )
5210* ..
5211* .. Local Scalars ..
5212 INTEGER ITMP1, ITMP2
5213* ..
5214* .. Executable Statements ..
5215*
5216 ITMP1 = k( 1 ) * j( 1 )
5217 IF( itmp1.LT.0 )
5218 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5219*
5220* I( 1 ) = MOD( ITMP1, IPOW16 )
5221*
5222 itmp2 = itmp1 / ipow16
5223 i( 1 ) = itmp1 - itmp2 * ipow16
5224*
5225 itmp1 = k( 1 ) * j( 2 ) + k( 2 ) * j( 1 )
5226 IF( itmp1.LT.0 )
5227 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5228*
5229 itmp1 = itmp2 + itmp1
5230 IF( itmp1.LT.0 )
5231 $ itmp1 = ( itmp1 + ipow30 ) + ipow30
5232*
5233* I( 2 ) = MOD( ITMP1, IPOW15 )
5234*
5235 i( 2 ) = itmp1 - ( itmp1 / ipow15 ) * ipow15
5236*
5237 RETURN
5238*
5239* End of PB_LMUL
5240*
5241 END
5242 SUBROUTINE pb_jump( K, MULADD, IRANN, IRANM, IMA )
5243*
5244* -- PBLAS test routine (version 2.0) --
5245* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5246* and University of California, Berkeley.
5247* April 1, 1998
5248*
5249* .. Scalar Arguments ..
5250 INTEGER K
5251* ..
5252* .. Array Arguments ..
5253 INTEGER IMA( 4 ), IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
5254* ..
5255*
5256* Purpose
5257* =======
5258*
5259* PB_JUMP computes the constants A and C to jump K numbers in the ran-
5260* dom sequence:
5261*
5262* X( n+K ) = A * X( n ) + C.
5263*
5264* The constants encoded in MULADD specify how to jump from entry in the
5265* sequence to the next.
5266*
5267* Arguments
5268* =========
5269*
5270* K (local input) INTEGER
5271* On entry, K specifies the number of entries of the sequence
5272* to jump over. When K is less or equal than zero, A and C are
5273* not computed, and IRANM is set to IRANN corresponding to a
5274* jump of size zero.
5275*
5276* MULADD (local input) INTEGER array
5277* On entry, MULADD is an array of dimension 4 containing the
5278* encoded constants a and c to jump from X( n ) to X( n+1 )
5279* ( = a*X( n )+c) in the random sequence. MULADD(1:2) contains
5280* respectively the 16-lower and 16-higher bits of the constant
5281* a, and MULADD(3:4) contains the 16-lower and 16-higher bits
5282* of the constant c.
5283*
5284* IRANN (local input) INTEGER array
5285* On entry, IRANN is an array of dimension 2. This array con-
5286* tains respectively the 16-lower and 16-higher bits of the en-
5287* coding of X( n ).
5288*
5289* IRANM (local output) INTEGER array
5290* On entry, IRANM is an array of dimension 2. On exit, this
5291* array contains respectively the 16-lower and 16-higher bits
5292* of the encoding of X( n+K ).
5293*
5294* IMA (local output) INTEGER array
5295* On entry, IMA is an array of dimension 4. On exit, when K is
5296* greater than zero, this array contains the encoded constants
5297* A and C to jump from X( n ) to X( n+K ) in the random se-
5298* quence. IMA(1:2) contains respectively the 16-lower and
5299* 16-higher bits of the constant A, and IMA(3:4) contains the
5300* 16-lower and 16-higher bits of the constant C. When K is
5301* less or equal than zero, this array is not referenced.
5302*
5303* -- Written on April 1, 1998 by
5304* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5305*
5306* =====================================================================
5307*
5308* .. Local Scalars ..
5309 INTEGER I
5310* ..
5311* .. Local Arrays ..
5312 INTEGER J( 2 )
5313* ..
5314* .. External Subroutines ..
5315 EXTERNAL PB_LADD, PB_LMUL
5316* ..
5317* .. Executable Statements ..
5318*
5319 IF( K.GT.0 ) THEN
5320*
5321 IMA( 1 ) = muladd( 1 )
5322 ima( 2 ) = muladd( 2 )
5323 ima( 3 ) = muladd( 3 )
5324 ima( 4 ) = muladd( 4 )
5325*
5326 DO 10 i = 1, k - 1
5327*
5328 CALL pb_lmul( ima, muladd, j )
5329*
5330 ima( 1 ) = j( 1 )
5331 ima( 2 ) = j( 2 )
5332*
5333 CALL pb_lmul( ima( 3 ), muladd, j )
5334 CALL pb_ladd( muladd( 3 ), j, ima( 3 ) )
5335*
5336 10 CONTINUE
5337*
5338 CALL pb_lmul( irann, ima, j )
5339 CALL pb_ladd( j, ima( 3 ), iranm )
5340*
5341 ELSE
5342*
5343 iranm( 1 ) = irann( 1 )
5344 iranm( 2 ) = irann( 2 )
5345*
5346 END IF
5347*
5348 RETURN
5349*
5350* End of PB_JUMP
5351*
5352 END
5353 SUBROUTINE pb_setran( IRAN, IAC )
5354*
5355* -- PBLAS test routine (version 2.0) --
5356* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5357* and University of California, Berkeley.
5358* April 1, 1998
5359*
5360* .. Array Arguments ..
5361 INTEGER IAC( 4 ), IRAN( 2 )
5362* ..
5363*
5364* Purpose
5365* =======
5366*
5367* PB_SETRAN initializes the random generator with the encoding of the
5368* first number X( 1 ) in the sequence, and the constants a and c used
5369* to compute the next element in the sequence:
5370*
5371* X( n+1 ) = a * X( n ) + c.
5372*
5373* X( 1 ), a and c are stored in the common block RANCOM for later use
5374* (see the routines PB_SRAN or PB_DRAN).
5375*
5376* Arguments
5377* =========
5378*
5379* IRAN (local input) INTEGER array
5380* On entry, IRAN is an array of dimension 2. This array con-
5381* tains respectively the 16-lower and 16-higher bits of the en-
5382* coding of X( 1 ).
5383*
5384* IAC (local input) INTEGER array
5385* On entry, IAC is an array of dimension 4. IAC(1:2) contain
5386* respectively the 16-lower and 16-higher bits of the constant
5387* a, and IAC(3:4) contain the 16-lower and 16-higher bits of
5388* the constant c.
5389*
5390* -- Written on April 1, 1998 by
5391* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5392*
5393* =====================================================================
5394*
5395* .. Common Blocks ..
5396 INTEGER IACS( 4 ), IRAND( 2 )
5397 COMMON /RANCOM/ IRAND, IACS
5398* ..
5399* .. Save Statements ..
5400 SAVE /RANCOM/
5401* ..
5402* .. Executable Statements ..
5403*
5404 IRAND( 1 ) = iran( 1 )
5405 irand( 2 ) = iran( 2 )
5406 iacs( 1 ) = iac( 1 )
5407 iacs( 2 ) = iac( 2 )
5408 iacs( 3 ) = iac( 3 )
5409 iacs( 4 ) = iac( 4 )
5410*
5411 RETURN
5412*
5413* End of PB_SETRAN
5414*
5415 END
5416 SUBROUTINE pb_jumpit( MULADD, IRANN, IRANM )
5417*
5418* -- PBLAS test routine (version 2.0) --
5419* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5420* and University of California, Berkeley.
5421* April 1, 1998
5422*
5423* .. Array Arguments ..
5424 INTEGER IRANM( 2 ), IRANN( 2 ), MULADD( 4 )
5425* ..
5426*
5427* Purpose
5428* =======
5429*
5430* PB_JUMPIT jumps in the random sequence from the number X( n ) enco-
5431* ded in IRANN to the number X( m ) encoded in IRANM using the cons-
5432* tants A and C encoded in MULADD:
5433*
5434* X( m ) = A * X( n ) + C.
5435*
5436* The constants A and C obviously depend on m and n, see the subroutine
5437* PB_JUMP in order to set them up.
5438*
5439* Arguments
5440* =========
5441*
5442* MULADD (local input) INTEGER array
5443* On netry, MULADD is an array of dimension 4. MULADD(1:2) con-
5444* tains respectively the 16-lower and 16-higher bits of the
5445* constant A, and MULADD(3:4) contains the 16-lower and
5446* 16-higher bits of the constant C.
5447*
5448* IRANN (local input) INTEGER array
5449* On entry, IRANN is an array of dimension 2. This array con-
5450* tains respectively the 16-lower and 16-higher bits of the en-
5451* coding of X( n ).
5452*
5453* IRANM (local output) INTEGER array
5454* On entry, IRANM is an array of dimension 2. On exit, this
5455* array contains respectively the 16-lower and 16-higher bits
5456* of the encoding of X( m ).
5457*
5458* -- Written on April 1, 1998 by
5459* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5460*
5461* =====================================================================
5462*
5463* .. Local Arrays ..
5464 INTEGER J( 2 )
5465* ..
5466* .. External Subroutines ..
5467 EXTERNAL PB_LADD, PB_LMUL
5468* ..
5469* .. Common Blocks ..
5470 INTEGER IACS( 4 ), IRAND( 2 )
5471 COMMON /RANCOM/ IRAND, IACS
5472* ..
5473* .. Save Statements ..
5474 SAVE /RANCOM/
5475* ..
5476* .. Executable Statements ..
5477*
5478 CALL PB_LMUL( IRANN, MULADD, J )
5479 CALL PB_LADD( J, MULADD( 3 ), IRANM )
5480*
5481 IRAND( 1 ) = iranm( 1 )
5482 irand( 2 ) = iranm( 2 )
5483*
5484 RETURN
5485*
5486* End of PB_JUMPIT
5487*
5488 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
pmdimchk
subroutine pmdimchk(ictxt, nout, m, n, matrix, ia, ja, desca, info)
Definition pblastim.f:202
pvdimchk
subroutine pvdimchk(ictxt, nout, n, matrix, ix, jx, descx, incx, info)
Definition pblastim.f:3
pb_descset2
subroutine pb_descset2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
Definition pblastim.f:3767
pmdescchk
subroutine pmdescchk(ictxt, nout, matrix, desca, dta, ma, na, imba, inba, mba, nba, rsrca, csrca, mpa, nqa, iprea, imida, iposta, igap, gapmul, info)
Definition pblastim.f:746
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastim.f:5075
lsame
logical function lsame(ca, cb)
Definition pblastim.f:1601
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 pblastim.f:4172
pilaenv
integer function pilaenv(ictxt, prec)
Definition pblastim.f:4453
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastim.f:5354
pxerbla
subroutine pxerbla(ictxt, srname, info)
Definition pblastim.f:1538
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastim.f:4505
pb_descinit2
subroutine pb_descinit2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld, info)
Definition pblastim.f:3932
pvdescchk
subroutine pvdescchk(ictxt, nout, matrix, descx, dtx, mx, nx, imbx, inbx, mbx, nbx, rsrcx, csrcx, incx, mpx, nqx, iprex, imidx, ipostx, igap, gapmul, info)
Definition pblastim.f:388
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastim.f:3337
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastim.f:5154
pdopbl2
double precision function pdopbl2(subnam, m, n, kkl, kku)
Definition pblastim.f:1084
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastim.f:5243
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastim.f:4897
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastim.f:4791
lsamen
logical function lsamen(n, ca, cb)
Definition pblastim.f:1688
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastim.f:3559
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastim.f:4640
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastim.f:5417