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