ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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  IF( info.NE.0 ) THEN
1049  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) 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  IF( m.LE.0 .OR. .NOT.( 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  IF( k.LE.0 ) 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  IF( k.LE.0 ) THEN
1493  IF( m.LE.n ) 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  IF( m.GE.n ) 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  lsame = ca.EQ.cb
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  IF( zcode.EQ.90 .OR. zcode.EQ.122 ) THEN
1653 *
1654 * ASCII is assumed - ZCODE is the ASCII code of either lower or
1655 * upper case 'Z'.
1656 *
1657  IF( inta.GE.97 .AND. inta.LE.122 ) inta = inta - 32
1658  IF( intb.GE.97 .AND. intb.LE.122 ) intb = intb - 32
1659 *
1660  ELSE IF( zcode.EQ.233 .OR. zcode.EQ.169 ) THEN
1661 *
1662 * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
1663 * upper case 'Z'.
1664 *
1665  IF( inta.GE.129 .AND. inta.LE.137 .OR.
1666  $ inta.GE.145 .AND. inta.LE.153 .OR.
1667  $ inta.GE.162 .AND. inta.LE.169 ) inta = inta + 64
1668  IF( intb.GE.129 .AND. intb.LE.137 .OR.
1669  $ intb.GE.145 .AND. intb.LE.153 .OR.
1670  $ intb.GE.162 .AND. intb.LE.169 ) intb = intb + 64
1671 *
1672  ELSE IF( zcode.EQ.218 .OR. zcode.EQ.250 ) 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  IF( inta.GE.225 .AND. inta.LE.250 ) inta = inta - 32
1678  IF( intb.GE.225 .AND. intb.LE.250 ) intb = intb - 32
1679  END IF
1680  lsame = inta.EQ.intb
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  IF( len( ca ).LT.n .OR. len( cb ).LT.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  IF( .NOT.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  IF( N.LE.0 )
1804  $ RETURN
1805  IF( incx.EQ.1 .AND. incy.EQ.1 )
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  IF( incx.LT.0 )
1813  $ ix = ( -n+1 )*incx + 1
1814  IF( incy.LT.0 )
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  IF( m.EQ.0 )
1830  $ GO TO 40
1831  DO 30 i = 1, m
1832  sy( i ) = sx( i )
1833  30 CONTINUE
1834  IF( n.LT.7 )
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  IF( ( prow.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
2080 *
2081  ii = i
2082 *
2083  ELSE IF( i.LE.imb ) THEN
2084 *
2085 * I is in range of first block
2086 *
2087  IF( myrow.EQ.prow ) 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  IF( myrow.EQ.rsrc ) 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  IF( ilocblk.GT.0 ) THEN
2109  IF( ( ilocblk*nprow ).GE.nblocks ) THEN
2110  IF( myrow.EQ.prow ) 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  IF( mydist.LT.0 )
2131  $ mydist = mydist + nprow
2132 *
2133  ilocblk = nblocks / nprow
2134 *
2135  IF( ilocblk.GT.0 ) THEN
2136  mydist = mydist - nblocks + ilocblk * nprow
2137  IF( mydist.LT.0 ) THEN
2138  ii = mb + ilocblk * mb + 1
2139  ELSE
2140  IF( myrow.EQ.prow ) 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  IF( mydist.LT.0 ) THEN
2149  ii = mb + 1
2150  ELSE IF( myrow.EQ.prow ) 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  IF( ( pcol.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
2166 *
2167  jj = j
2168 *
2169  ELSE IF( j.LE.inb ) THEN
2170 *
2171 * J is in range of first block
2172 *
2173  IF( mycol.EQ.pcol ) 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  IF( mycol.EQ.csrc ) 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  IF( ilocblk.GT.0 ) THEN
2195  IF( ( ilocblk*npcol ).GE.nblocks ) THEN
2196  IF( mycol.EQ.pcol ) 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  IF( mydist.LT.0 )
2217  $ mydist = mydist + npcol
2218 *
2219  ilocblk = nblocks / npcol
2220 *
2221  IF( ilocblk.GT.0 ) THEN
2222  mydist = mydist - nblocks + ilocblk * npcol
2223  IF( mydist.LT.0 ) THEN
2224  jj = nb + ilocblk * nb + 1
2225  ELSE
2226  IF( mycol.EQ.pcol ) 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  IF( mydist.LT.0 ) THEN
2235  jj = nb + 1
2236  ELSE IF( mycol.EQ.pcol ) 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  IF( ( rsrc.EQ.-1 ).OR.( nprow.EQ.1 ) ) THEN
2478 *
2479  ii = i
2480  imb1 = imb1 - i + 1
2481  IF( imb1.LE.0 )
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  IF( i.LE.imb1 ) THEN
2493 *
2494  prow = rsrc
2495 *
2496  IF( myrow.EQ.prow ) 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  IF( myrow.EQ.rsrc ) THEN
2512 *
2513  ilocblk = nblocks / nprow
2514 *
2515  IF( ilocblk.GT.0 ) THEN
2516  IF( ( ilocblk*nprow ).GE.nblocks ) THEN
2517  IF( myrow.EQ.prow ) 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  IF( mydist.LT.0 )
2533  $ mydist = mydist + nprow
2534 *
2535  ilocblk = nblocks / nprow
2536 *
2537  IF( ilocblk.GT.0 ) THEN
2538  mydist = mydist - nblocks + ilocblk * nprow
2539  IF( mydist.LT.0 ) THEN
2540  ii = ( ilocblk + 1 ) * mb + 1
2541  ELSE IF( myrow.EQ.prow ) 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  IF( mydist.LT.0 ) THEN
2549  ii = mb + 1
2550  ELSE IF( myrow.EQ.prow ) 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  IF( m.LE.imb1 ) THEN
2565 *
2566  IF( myrow.EQ.prow ) 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  IF( myrow.EQ.prow ) THEN
2578  ilocblk = nblocks / nprow
2579  IF( ilocblk.GT.0 ) THEN
2580  IF( ( nblocks - ilocblk * nprow ).GT.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  IF( mydist.LT.0 )
2591  $ mydist = mydist + nprow
2592  ilocblk = nblocks / nprow
2593  IF( ilocblk.GT.0 ) THEN
2594  mydist = mydist - nblocks + ilocblk * nprow
2595  IF( mydist.LT.0 ) THEN
2596  mp = ( ilocblk + 1 ) * mb
2597  ELSE IF( mydist.GT.0 ) THEN
2598  mp = ilocblk * mb
2599  ELSE
2600  mp = m1 + mb * ( ilocblk - nblocks + 1 )
2601  END IF
2602  ELSE
2603  mydist = mydist - nblocks
2604  IF( mydist.LT.0 ) THEN
2605  mp = mb
2606  ELSE IF( mydist.GT.0 ) 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  IF( rprow.LT.0 )
2619  $ rprow = rprow + nprow
2620 *
2621  END IF
2622 *
2623  nb = desc2( nb_ )
2624  inb1 = desc2( inb_ )
2625  csrc = desc2( csrc_ )
2626 *
2627  IF( ( csrc.EQ.-1 ).OR.( npcol.EQ.1 ) ) THEN
2628 *
2629  jj = j
2630  inb1 = inb1 - i + 1
2631  IF( inb1.LE.0 )
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  IF( j.LE.inb1 ) THEN
2643 *
2644  pcol = csrc
2645 *
2646  IF( mycol.EQ.pcol ) 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  IF( mycol.EQ.csrc ) THEN
2662 *
2663  ilocblk = nblocks / npcol
2664 *
2665  IF( ilocblk.GT.0 ) THEN
2666  IF( ( ilocblk*npcol ).GE.nblocks ) THEN
2667  IF( mycol.EQ.pcol ) 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  IF( mydist.LT.0 )
2683  $ mydist = mydist + npcol
2684 *
2685  ilocblk = nblocks / npcol
2686 *
2687  IF( ilocblk.GT.0 ) THEN
2688  mydist = mydist - nblocks + ilocblk * npcol
2689  IF( mydist.LT.0 ) THEN
2690  jj = ( ilocblk + 1 ) * nb + 1
2691  ELSE IF( mycol.EQ.pcol ) 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  IF( mydist.LT.0 ) THEN
2699  jj = nb + 1
2700  ELSE IF( mycol.EQ.pcol ) 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  IF( n.LE.inb1 ) THEN
2715 *
2716  IF( mycol.EQ.pcol ) 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  IF( mycol.EQ.pcol ) THEN
2728  ilocblk = nblocks / npcol
2729  IF( ilocblk.GT.0 ) THEN
2730  IF( ( nblocks - ilocblk * npcol ).GT.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  IF( mydist.LT.0 )
2741  $ mydist = mydist + npcol
2742  ilocblk = nblocks / npcol
2743  IF( ilocblk.GT.0 ) THEN
2744  mydist = mydist - nblocks + ilocblk * npcol
2745  IF( mydist.LT.0 ) THEN
2746  nq = ( ilocblk + 1 ) * nb
2747  ELSE IF( mydist.GT.0 ) THEN
2748  nq = ilocblk * nb
2749  ELSE
2750  nq = n1 + nb * ( ilocblk - nblocks + 1 )
2751  END IF
2752  ELSE
2753  mydist = mydist - nblocks
2754  IF( mydist.LT.0 ) THEN
2755  nq = nb
2756  ELSE IF( mydist.GT.0 ) 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  IF( rpcol.LT.0 )
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  if( ( srcproc.EQ.-1 ).OR.( nprocs.EQ.1 ) ) then
2844  pb_numroc = n
2845  RETURN
2846  END IF
2847 *
2848 * Compute coordinate of process owning I and corresponding INB
2849 *
2850  IF( i.LE.inb ) 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  IF( n.LE.inb1 ) THEN
2873  IF( proc.EQ.srcproc1 ) 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  IF( proc.EQ.srcproc1 ) THEN
2885  ilocblk = nblocks / nprocs
2886  IF( ilocblk.GT.0 ) THEN
2887  IF( ( nblocks - ilocblk * nprocs ).GT.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  IF( mydist.LT.0 )
2898  $ mydist = mydist + nprocs
2899  ilocblk = nblocks / nprocs
2900  IF( ilocblk.GT.0 ) THEN
2901  mydist = mydist - nblocks + ilocblk * nprocs
2902  IF( mydist.LT.0 ) THEN
2903  pb_numroc = ( ilocblk + 1 ) * nb
2904  ELSE IF( mydist.GT.0 ) 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  IF( mydist.LT.0 ) THEN
2912  pb_numroc = nb
2913  ELSE IF( mydist.GT.0 ) 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  IF( wallstart( i ).EQ.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  IF( dwalltime00().EQ.errflag ) THEN
3189  time = errflag
3190  ELSE
3191  time = wallsec( i )
3192  END IF
3193  ELSE
3194  IF( dcputime00().EQ.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  IF( dwalltime00().EQ.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  IF( dcputime00().EQ.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  IF( op.EQ.'>' ) 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  ELSE IF( op.EQ.'<' ) 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  ELSE IF( op.EQ.'+' ) 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
pb_ladd
subroutine pb_ladd(J, K, I)
Definition: pblastst.f:4480
max
#define max(A, B)
Definition: pcgemr.c:180
pb_noabort
integer function pb_noabort(CINFO)
Definition: pblastst.f:1622
pb_setlocran
subroutine pb_setlocran(SEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, MYRDIST, MYCDIST, NPROW, NPCOL, JMP, IMULADD, IRAN)
Definition: pblastst.f:4302
pb_setran
subroutine pb_setran(IRAN, IAC)
Definition: pblastst.f:4759
pb_descset2
subroutine pb_descset2(DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, CTXT, LLD)
Definition: pblastst.f:3172
pilaenv
integer function pilaenv(ICTXT, PREC)
Definition: pilaenv.f:2
pb_lmul
subroutine pb_lmul(K, J, I)
Definition: pblastst.f:4559
pb_enable
subroutine pb_enable()
Definition: pblastim.f:3054
pb_timer
subroutine pb_timer(I)
Definition: pblastim.f:2976
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
pb_inquire
double precision function pb_inquire(TMTYPE, I)
Definition: pblastim.f:3129
pb_desctrans
subroutine pb_desctrans(DESCIN, DESCOUT)
Definition: pblastst.f:2964
pb_boot
subroutine pb_boot()
Definition: pblastim.f:2927
pb_combine
subroutine pb_combine(ICTXT, SCOPE, OP, TMTYPE, N, IBEG, TIMES)
Definition: pblastim.f:3211
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: pblastst.f:746
pb_jumpit
subroutine pb_jumpit(MULADD, IRANN, IRANM)
Definition: pblastst.f:4822
pb_infog2l
subroutine pb_infog2l(I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II, JJ, PROW, PCOL)
Definition: pblastst.f:1673
pb_numroc
integer function pb_numroc(N, I, INB, NB, PROC, SRCPROC, NPROCS)
Definition: pblastst.f:2548
pb_initmuladd
subroutine pb_initmuladd(MULADD0, JMP, IMULADD)
Definition: pblastst.f:4196
pb_ainfog2l
subroutine pb_ainfog2l(M, N, I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, IMB1, INB1, MP, NQ, II, JJ, PROW, PCOL, RPROW, RPCOL)
Definition: pblastst.f:2023
pb_initjmp
subroutine pb_initjmp(COLMAJ, NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC, MB, NB, RSRC, CSRC, NPROW, NPCOL, STRIDE, JMP)
Definition: pblastst.f:4045
lsamen
logical function lsamen(N, CA, CB)
Definition: pblastst.f:1457
pdopbl2
double precision function pdopbl2(SUBNAM, M, N, KKL, KKU)
Definition: pblastim.f:1084
pb_disable
subroutine pb_disable()
Definition: pblastim.f:3092
pdopbl3
double precision function pdopbl3(SUBNAM, M, N, K)
Definition: pblastim.f:1313
pb_jump
subroutine pb_jump(K, MULADD, IRANN, IRANM, IMA)
Definition: pblastst.f:4648
pxerbla
subroutine pxerbla(ICTXT, SRNAME, INFO)
Definition: pxerbla.f:2
pb_descinit2
subroutine pb_descinit2(DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, CTXT, LLD, INFO)
Definition: pblastst.f:3337
pb_binfo
subroutine pb_binfo(OFFD, M, N, IMB1, INB1, MB, NB, MRROW, MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP)
Definition: pblastst.f:3577
pb_chkmat
subroutine pb_chkmat(ICTXT, M, MPOS0, N, NPOS0, IA, JA, DESCA, DPOS0, INFO)
Definition: pblastst.f:2742
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
pb_locinfo
subroutine pb_locinfo(I, INB, NB, MYROC, SRCPROC, NPROCS, ILOCBLK, ILOCOFF, MYDIST)
Definition: pblastst.f:3910
pmdimchk
subroutine pmdimchk(ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA, INFO)
Definition: pblastst.f:202
pvdescchk
subroutine pvdescchk(ICTXT, NOUT, MATRIX, DESCX, DTX, MX, NX, IMBX, INBX, MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX, IPREX, IMIDX, IPOSTX, IGAP, GAPMUL, INFO)
Definition: pblastst.f:388
pvdimchk
subroutine pvdimchk(ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX, INFO)
Definition: pblastst.f:3
min
#define min(A, B)
Definition: pcgemr.c:181