ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
psblastim.f
Go to the documentation of this file.
1  SUBROUTINE pslascal( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
2 *
3 * -- PBLAS test routine (version 2.0) --
4 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5 * and University of California, Berkeley.
6 * April 1, 1998
7 *
8 * .. Scalar Arguments ..
9  CHARACTER*1 TYPE
10  INTEGER IA, JA, M, N
11  REAL ALPHA
12 * ..
13 * .. Array Arguments ..
14  INTEGER DESCA( * )
15  REAL A( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PSLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
22 * by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full,
23 * upper triangular, lower triangular or upper Hessenberg.
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 * TYPE (global input) CHARACTER*1
92 * On entry, TYPE specifies the type of the input submatrix as
93 * follows:
94 * = 'L' or 'l': sub( A ) is a lower triangular matrix,
95 * = 'U' or 'u': sub( A ) is an upper triangular matrix,
96 * = 'H' or 'h': sub( A ) is an upper Hessenberg matrix,
97 * otherwise sub( A ) is a full matrix.
98 *
99 * M (global input) INTEGER
100 * On entry, M specifies the number of rows of the submatrix
101 * sub( A ). M must be at least zero.
102 *
103 * N (global input) INTEGER
104 * On entry, N specifies the number of columns of the submatrix
105 * sub( A ). N must be at least zero.
106 *
107 * ALPHA (global input) REAL
108 * On entry, ALPHA specifies the scalar alpha.
109 *
110 * A (local input/local output) REAL array
111 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is
112 * at least Lc( 1, JA+N-1 ). Before entry, this array contains
113 * the local entries of the matrix A.
114 * On exit, the local entries of this array corresponding to the
115 * to the entries of the submatrix sub( A ) are overwritten by
116 * the local entries of the m by n scaled submatrix.
117 *
118 * IA (global input) INTEGER
119 * On entry, IA specifies A's global row index, which points to
120 * the beginning of the submatrix sub( A ).
121 *
122 * JA (global input) INTEGER
123 * On entry, JA specifies A's global column index, which points
124 * to the beginning of the submatrix sub( A ).
125 *
126 * DESCA (global and local input) INTEGER array
127 * On entry, DESCA is an integer array of dimension DLEN_. This
128 * is the array descriptor for the matrix A.
129 *
130 * -- Written on April 1, 1998 by
131 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
132 *
133 * =====================================================================
134 *
135 * .. Parameters ..
136  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
137  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
138  $ RSRC_
139  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
140  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
141  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
142  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
143 * ..
144 * .. Local Scalars ..
145  CHARACTER*1 UPLO
146  LOGICAL GODOWN, GOLEFT, LOWER, UPPER
147  INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
148  $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
149  $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
150  $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
151  $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
152  $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
153  $ QNB, TMP1, UPP
154 * ..
155 * .. Local Arrays ..
156  INTEGER DESCA2( DLEN_ )
157 * ..
158 * .. External Subroutines ..
159  EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
160  $ pb_desctrans, pb_infog2l, pb_slascal
161 * ..
162 * .. External Functions ..
163  LOGICAL LSAME
164  INTEGER PB_NUMROC
165  EXTERNAL lsame, pb_numroc
166 * ..
167 * .. Intrinsic Functions ..
168  INTRINSIC min
169 * ..
170 * .. Executable Statements ..
171 *
172 * Convert descriptor
173 *
174  CALL pb_desctrans( desca, desca2 )
175 *
176 * Get grid parameters
177 *
178  ictxt = desca2( ctxt_ )
179  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
180 *
181 * Quick return if possible
182 *
183  IF( m.EQ.0 .OR. n.EQ.0 )
184  $ RETURN
185 *
186  IF( lsame( TYPE, 'L' ) ) then
187  itype = 1
188  uplo = TYPE
189  upper = .false.
190  lower = .true.
191  ioffd = 0
192  ELSE IF( lsame( TYPE, 'U' ) ) then
193  itype = 2
194  uplo = TYPE
195  upper = .true.
196  lower = .false.
197  ioffd = 0
198  ELSE IF( lsame( TYPE, 'H' ) ) then
199  itype = 3
200  uplo = 'U'
201  upper = .true.
202  lower = .false.
203  ioffd = 1
204  ELSE
205  itype = 0
206  uplo = 'A'
207  upper = .true.
208  lower = .true.
209  ioffd = 0
210  END IF
211 *
212 * Compute local indexes
213 *
214  IF( itype.EQ.0 ) THEN
215 *
216 * Full matrix
217 *
218  CALL pb_infog2l( ia, ja, desca2, nprow, npcol, myrow, mycol,
219  $ iia, jja, iarow, iacol )
220  mp = pb_numroc( m, ia, desca2( imb_ ), desca2( mb_ ), myrow,
221  $ desca2( rsrc_ ), nprow )
222  nq = pb_numroc( n, ja, desca2( inb_ ), desca2( nb_ ), mycol,
223  $ desca2( csrc_ ), npcol )
224 *
225  IF( mp.LE.0 .OR. nq.LE.0 )
226  $ RETURN
227 *
228  lda = desca2( lld_ )
229  ioffa = iia + ( jja - 1 ) * lda
230 *
231  CALL pb_slascal( 'All', mp, nq, 0, alpha, a( ioffa ), lda )
232 *
233  ELSE
234 *
235 * Trapezoidal matrix
236 *
237  CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
238  $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
239  $ iacol, mrrow, mrcol )
240 *
241  IF( mp.LE.0 .OR. nq.LE.0 )
242  $ RETURN
243 *
244 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
245 * LNBLOC, ILOW, LOW, IUPP, and UPP.
246 *
247  mb = desca2( mb_ )
248  nb = desca2( nb_ )
249  lda = desca2( lld_ )
250 *
251  CALL pb_binfo( ioffd, mp, nq, imb1, inb1, mb, nb, mrrow,
252  $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
253  $ lmbloc, lnbloc, ilow, low, iupp, upp )
254 *
255  m1 = mp
256  n1 = nq
257  ioffa = iia - 1
258  joffa = jja - 1
259  iimax = ioffa + mp
260  jjmax = joffa + nq
261 *
262  IF( desca2( rsrc_ ).LT.0 ) THEN
263  pmb = mb
264  ELSE
265  pmb = nprow * mb
266  END IF
267  IF( desca2( csrc_ ).LT.0 ) THEN
268  qnb = nb
269  ELSE
270  qnb = npcol * nb
271  END IF
272 *
273 * Handle the first block of rows or columns separately, and
274 * update LCMT00, MBLKS and NBLKS.
275 *
276  godown = ( lcmt00.GT.iupp )
277  goleft = ( lcmt00.LT.ilow )
278 *
279  IF( .NOT.godown .AND. .NOT.goleft ) THEN
280 *
281 * LCMT00 >= ILOW && LCMT00 <= IUPP
282 *
283  goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
284  godown = .NOT.goleft
285 *
286  CALL pb_slascal( uplo, imbloc, inbloc, lcmt00, alpha,
287  $ a( iia+joffa*lda ), lda )
288  IF( godown ) THEN
289  IF( upper .AND. nq.GT.inbloc )
290  $ CALL pb_slascal( 'All', imbloc, nq-inbloc, 0, alpha,
291  $ a( iia+(joffa+inbloc)*lda ), lda )
292  iia = iia + imbloc
293  m1 = m1 - imbloc
294  ELSE
295  IF( lower .AND. mp.GT.imbloc )
296  $ CALL pb_slascal( 'All', mp-imbloc, inbloc, 0, alpha,
297  $ a( iia+imbloc+joffa*lda ), lda )
298  jja = jja + inbloc
299  n1 = n1 - inbloc
300  END IF
301 *
302  END IF
303 *
304  IF( godown ) THEN
305 *
306  lcmt00 = lcmt00 - ( iupp - upp + pmb )
307  mblks = mblks - 1
308  ioffa = ioffa + imbloc
309 *
310  10 CONTINUE
311  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
312  lcmt00 = lcmt00 - pmb
313  mblks = mblks - 1
314  ioffa = ioffa + mb
315  GO TO 10
316  END IF
317 *
318  tmp1 = min( ioffa, iimax ) - iia + 1
319  IF( upper .AND. tmp1.GT.0 ) THEN
320  CALL pb_slascal( 'All', tmp1, n1, 0, alpha,
321  $ a( iia+joffa*lda ), lda )
322  iia = iia + tmp1
323  m1 = m1 - tmp1
324  END IF
325 *
326  IF( mblks.LE.0 )
327  $ RETURN
328 *
329  lcmt = lcmt00
330  mblkd = mblks
331  ioffd = ioffa
332 *
333  mbloc = mb
334  20 CONTINUE
335  IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
336  IF( mblkd.EQ.1 )
337  $ mbloc = lmbloc
338  CALL pb_slascal( uplo, mbloc, inbloc, lcmt, alpha,
339  $ a( ioffd+1+joffa*lda ), lda )
340  lcmt00 = lcmt
341  lcmt = lcmt - pmb
342  mblks = mblkd
343  mblkd = mblkd - 1
344  ioffa = ioffd
345  ioffd = ioffd + mbloc
346  GO TO 20
347  END IF
348 *
349  tmp1 = m1 - ioffd + iia - 1
350  IF( lower .AND. tmp1.GT.0 )
351  $ CALL pb_slascal( 'All', tmp1, inbloc, 0, alpha,
352  $ a( ioffd+1+joffa*lda ), lda )
353 *
354  tmp1 = ioffa - iia + 1
355  m1 = m1 - tmp1
356  n1 = n1 - inbloc
357  lcmt00 = lcmt00 + low - ilow + qnb
358  nblks = nblks - 1
359  joffa = joffa + inbloc
360 *
361  IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
362  $ CALL pb_slascal( 'All', tmp1, n1, 0, alpha,
363  $ a( iia+joffa*lda ), lda )
364 *
365  iia = ioffa + 1
366  jja = joffa + 1
367 *
368  ELSE IF( goleft ) THEN
369 *
370  lcmt00 = lcmt00 + low - ilow + qnb
371  nblks = nblks - 1
372  joffa = joffa + inbloc
373 *
374  30 CONTINUE
375  IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
376  lcmt00 = lcmt00 + qnb
377  nblks = nblks - 1
378  joffa = joffa + nb
379  GO TO 30
380  END IF
381 *
382  tmp1 = min( joffa, jjmax ) - jja + 1
383  IF( lower .AND. tmp1.GT.0 ) THEN
384  CALL pb_slascal( 'All', m1, tmp1, 0, alpha,
385  $ a( iia+(jja-1)*lda ), lda )
386  jja = jja + tmp1
387  n1 = n1 - tmp1
388  END IF
389 *
390  IF( nblks.LE.0 )
391  $ RETURN
392 *
393  lcmt = lcmt00
394  nblkd = nblks
395  joffd = joffa
396 *
397  nbloc = nb
398  40 CONTINUE
399  IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
400  IF( nblkd.EQ.1 )
401  $ nbloc = lnbloc
402  CALL pb_slascal( uplo, imbloc, nbloc, lcmt, alpha,
403  $ a( iia+joffd*lda ), lda )
404  lcmt00 = lcmt
405  lcmt = lcmt + qnb
406  nblks = nblkd
407  nblkd = nblkd - 1
408  joffa = joffd
409  joffd = joffd + nbloc
410  GO TO 40
411  END IF
412 *
413  tmp1 = n1 - joffd + jja - 1
414  IF( upper .AND. tmp1.GT.0 )
415  $ CALL pb_slascal( 'All', imbloc, tmp1, 0, alpha,
416  $ a( iia+joffd*lda ), lda )
417 *
418  tmp1 = joffa - jja + 1
419  m1 = m1 - imbloc
420  n1 = n1 - tmp1
421  lcmt00 = lcmt00 - ( iupp - upp + pmb )
422  mblks = mblks - 1
423  ioffa = ioffa + imbloc
424 *
425  IF( lower .AND. m1.GT.0 .AND. tmp1.GT.0 )
426  $ CALL pb_slascal( 'All', m1, tmp1, 0, alpha,
427  $ a( ioffa+1+(jja-1)*lda ), lda )
428 *
429  iia = ioffa + 1
430  jja = joffa + 1
431 *
432  END IF
433 *
434  nbloc = nb
435  50 CONTINUE
436  IF( nblks.GT.0 ) THEN
437  IF( nblks.EQ.1 )
438  $ nbloc = lnbloc
439  60 CONTINUE
440  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
441  lcmt00 = lcmt00 - pmb
442  mblks = mblks - 1
443  ioffa = ioffa + mb
444  GO TO 60
445  END IF
446 *
447  tmp1 = min( ioffa, iimax ) - iia + 1
448  IF( upper .AND. tmp1.GT.0 ) THEN
449  CALL pb_slascal( 'All', tmp1, n1, 0, alpha,
450  $ a( iia+joffa*lda ), lda )
451  iia = iia + tmp1
452  m1 = m1 - tmp1
453  END IF
454 *
455  IF( mblks.LE.0 )
456  $ RETURN
457 *
458  lcmt = lcmt00
459  mblkd = mblks
460  ioffd = ioffa
461 *
462  mbloc = mb
463  70 CONTINUE
464  IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
465  IF( mblkd.EQ.1 )
466  $ mbloc = lmbloc
467  CALL pb_slascal( uplo, mbloc, nbloc, lcmt, alpha,
468  $ a( ioffd+1+joffa*lda ), lda )
469  lcmt00 = lcmt
470  lcmt = lcmt - pmb
471  mblks = mblkd
472  mblkd = mblkd - 1
473  ioffa = ioffd
474  ioffd = ioffd + mbloc
475  GO TO 70
476  END IF
477 *
478  tmp1 = m1 - ioffd + iia - 1
479  IF( lower .AND. tmp1.GT.0 )
480  $ CALL pb_slascal( 'All', tmp1, nbloc, 0, alpha,
481  $ a( ioffd+1+joffa*lda ), lda )
482 *
483  tmp1 = min( ioffa, iimax ) - iia + 1
484  m1 = m1 - tmp1
485  n1 = n1 - nbloc
486  lcmt00 = lcmt00 + qnb
487  nblks = nblks - 1
488  joffa = joffa + nbloc
489 *
490  IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
491  $ CALL pb_slascal( 'All', tmp1, n1, 0, alpha,
492  $ a( iia+joffa*lda ), lda )
493 *
494  iia = ioffa + 1
495  jja = joffa + 1
496 *
497  GO TO 50
498 *
499  END IF
500 *
501  END IF
502 *
503  RETURN
504 *
505 * End of PSLASCAL
506 *
507  END
508  SUBROUTINE pslagen( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
509  $ DESCA, IASEED, A, LDA )
510 *
511 * -- PBLAS test routine (version 2.0) --
512 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
513 * and University of California, Berkeley.
514 * April 1, 1998
515 *
516 * .. Scalar Arguments ..
517  LOGICAL inplace
518  CHARACTER*1 aform, diag
519  INTEGER ia, iaseed, ja, lda, m, n, offa
520 * ..
521 * .. Array Arguments ..
522  INTEGER desca( * )
523  REAL A( LDA, * )
524 * ..
525 *
526 * Purpose
527 * =======
528 *
529 * PSLAGEN generates (or regenerates) a submatrix sub( A ) denoting
530 * A(IA:IA+M-1,JA:JA+N-1).
531 *
532 * Notes
533 * =====
534 *
535 * A description vector is associated with each 2D block-cyclicly dis-
536 * tributed matrix. This vector stores the information required to
537 * establish the mapping between a matrix entry and its corresponding
538 * process and memory location.
539 *
540 * In the following comments, the character _ should be read as
541 * "of the distributed matrix". Let A be a generic term for any 2D
542 * block cyclicly distributed matrix. Its description vector is DESCA:
543 *
544 * NOTATION STORED IN EXPLANATION
545 * ---------------- --------------- ------------------------------------
546 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
547 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
548 * the NPROW x NPCOL BLACS process grid
549 * A is distributed over. The context
550 * itself is global, but the handle
551 * (the integer value) may vary.
552 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
553 * ted matrix A, M_A >= 0.
554 * N_A (global) DESCA( N_ ) The number of columns in the distri-
555 * buted matrix A, N_A >= 0.
556 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
557 * block of the matrix A, IMB_A > 0.
558 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
559 * left block of the matrix A,
560 * INB_A > 0.
561 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
562 * bute the last M_A-IMB_A rows of A,
563 * MB_A > 0.
564 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
565 * bute the last N_A-INB_A columns of
566 * A, NB_A > 0.
567 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
568 * row of the matrix A is distributed,
569 * NPROW > RSRC_A >= 0.
570 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
571 * first column of A is distributed.
572 * NPCOL > CSRC_A >= 0.
573 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
574 * array storing the local blocks of
575 * the distributed matrix A,
576 * IF( Lc( 1, N_A ) > 0 )
577 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
578 * ELSE
579 * LLD_A >= 1.
580 *
581 * Let K be the number of rows of a matrix A starting at the global in-
582 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
583 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
584 * receive if these K rows were distributed over NPROW processes. If K
585 * is the number of columns of a matrix A starting at the global index
586 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
587 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
588 * these K columns were distributed over NPCOL processes.
589 *
590 * The values of Lr() and Lc() may be determined via a call to the func-
591 * tion PB_NUMROC:
592 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
593 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
594 *
595 * Arguments
596 * =========
597 *
598 * INPLACE (global input) LOGICAL
599 * On entry, INPLACE specifies if the matrix should be generated
600 * in place or not. If INPLACE is .TRUE., the local random array
601 * to be generated will start in memory at the local memory lo-
602 * cation A( 1, 1 ), otherwise it will start at the local posi-
603 * tion induced by IA and JA.
604 *
605 * AFORM (global input) CHARACTER*1
606 * On entry, AFORM specifies the type of submatrix to be genera-
607 * ted as follows:
608 * AFORM = 'S', sub( A ) is a symmetric matrix,
609 * AFORM = 'H', sub( A ) is a Hermitian matrix,
610 * AFORM = 'T', sub( A ) is overrwritten with the transpose
611 * of what would normally be generated,
612 * AFORM = 'C', sub( A ) is overwritten with the conjugate
613 * transpose of what would normally be genera-
614 * ted.
615 * AFORM = 'N', a random submatrix is generated.
616 *
617 * DIAG (global input) CHARACTER*1
618 * On entry, DIAG specifies if the generated submatrix is diago-
619 * nally dominant or not as follows:
620 * DIAG = 'D' : sub( A ) is diagonally dominant,
621 * DIAG = 'N' : sub( A ) is not diagonally dominant.
622 *
623 * OFFA (global input) INTEGER
624 * On entry, OFFA specifies the offdiagonal of the underlying
625 * matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
626 * trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
627 * specifies the main diagonal, OFFA > 0 specifies a subdiago-
628 * nal, and OFFA < 0 specifies a superdiagonal (see further de-
629 * tails).
630 *
631 * M (global input) INTEGER
632 * On entry, M specifies the global number of matrix rows of the
633 * submatrix sub( A ) to be generated. M must be at least zero.
634 *
635 * N (global input) INTEGER
636 * On entry, N specifies the global number of matrix columns of
637 * the submatrix sub( A ) to be generated. N must be at least
638 * zero.
639 *
640 * IA (global input) INTEGER
641 * On entry, IA specifies A's global row index, which points to
642 * the beginning of the submatrix sub( A ).
643 *
644 * JA (global input) INTEGER
645 * On entry, JA specifies A's global column index, which points
646 * to the beginning of the submatrix sub( A ).
647 *
648 * DESCA (global and local input) INTEGER array
649 * On entry, DESCA is an integer array of dimension DLEN_. This
650 * is the array descriptor for the matrix A.
651 *
652 * IASEED (global input) INTEGER
653 * On entry, IASEED specifies the seed number to generate the
654 * matrix A. IASEED must be at least zero.
655 *
656 * A (local output) REAL array
657 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is
658 * at least Lc( 1, JA+N-1 ). On exit, this array contains the
659 * local entries of the randomly generated submatrix sub( A ).
660 *
661 * LDA (local input) INTEGER
662 * On entry, LDA specifies the local leading dimension of the
663 * array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
664 * This restriction is however not enforced, and this subroutine
665 * requires only that LDA >= MAX( 1, Mp ) where
666 *
667 * Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
668 *
669 * PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW
670 * and NPCOL can be determined by calling the BLACS subroutine
671 * BLACS_GRIDINFO.
672 *
673 * Further Details
674 * ===============
675 *
676 * OFFD is tied to the matrix described by DESCA, as opposed to the
677 * piece that is currently (re)generated. This is a global information
678 * independent from the distribution parameters. Below are examples of
679 * the meaning of OFFD for a global 7 by 5 matrix:
680 *
681 * ---------------------------------------------------------------------
682 * OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4
683 * -------|-------------------------------------------------------------
684 * | | OFFD=-1 | OFFD=0 OFFD=2
685 * | V V
686 * 0 | . d . . . -> d . . . . . . . . .
687 * 1 | . . d . . . d . . . . . . . .
688 * 2 | . . . d . . . d . . -> d . . . .
689 * 3 | . . . . d . . . d . . d . . .
690 * 4 | . . . . . . . . . d . . d . .
691 * 5 | . . . . . . . . . . . . . d .
692 * 6 | . . . . . . . . . . . . . . d
693 * ---------------------------------------------------------------------
694 *
695 * -- Written on April 1, 1998 by
696 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
697 *
698 * =====================================================================
699 *
700 * .. Parameters ..
701  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
702  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
703  $ rsrc_
704  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
705  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
706  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
707  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
708  INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
709  $ jmp_mb, jmp_nb, jmp_npimbloc, jmp_npmb,
710  $ jmp_nqinbloc, jmp_nqnb, jmp_row
711  parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
712  $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
713  $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
714  $ jmp_nqnb = 10, jmp_nqinbloc = 11,
715  $ jmp_len = 11 )
716 * ..
717 * .. Local Scalars ..
718  LOGICAL DIAGDO, SYMM, HERM, NOTRAN
719  INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
720  $ ilocoff, ilow, imb, imb1, imbloc, imbvir, inb,
721  $ inb1, inbloc, inbvir, info, ioffda, itmp, iupp,
722  $ ivir, jja, jlocblk, jlocoff, jvir, lcmt00,
723  $ lmbloc, lnbloc, low, maxmn, mb, mblks, mp,
724  $ mrcol, mrrow, mycdist, mycol, myrdist, myrow,
725  $ nb, nblks, npcol, nprow, nq, nvir, rsrc, upp
726  REAL ALPHA
727 * ..
728 * .. Local Arrays ..
729  INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
730  $ iran( 2 ), jmp( jmp_len ), muladd0( 4 )
731 * ..
732 * .. External Subroutines ..
733  EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
734  $ pb_chkmat, pb_desctrans, pb_initjmp,
735  $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
736  $ pb_setlocran, pb_setran, pb_slagen, psladom,
737  $ pxerbla
738 * ..
739 * .. External Functions ..
740  LOGICAL LSAME
741  EXTERNAL lsame
742 * ..
743 * .. Intrinsic Functions ..
744  INTRINSIC max, min, real
745 * ..
746 * .. Data Statements ..
747  DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
748  $ 12345, 0 /
749 * ..
750 * .. Executable Statements ..
751 *
752 * Convert descriptor
753 *
754  CALL pb_desctrans( desca, desca2 )
755 *
756 * Test the input arguments
757 *
758  ictxt = desca2( ctxt_ )
759  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
760 *
761 * Test the input parameters
762 *
763  info = 0
764  IF( nprow.EQ.-1 ) THEN
765  info = -( 1000 + ctxt_ )
766  ELSE
767  symm = lsame( aform, 'S' )
768  herm = lsame( aform, 'H' )
769  notran = lsame( aform, 'N' )
770  diagdo = lsame( diag, 'D' )
771  IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
772  $ .NOT.( lsame( aform, 'T' ) ) .AND.
773  $ .NOT.( lsame( aform, 'C' ) ) ) THEN
774  info = -2
775  ELSE IF( ( .NOT.diagdo ) .AND.
776  $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
777  info = -3
778  END IF
779  CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
780  END IF
781 *
782  IF( info.NE.0 ) THEN
783  CALL pxerbla( ictxt, 'PSLAGEN', -info )
784  RETURN
785  END IF
786 *
787 * Quick return if possible
788 *
789  IF( ( m.LE.0 ).OR.( n.LE.0 ) )
790  $ RETURN
791 *
792 * Start the operations
793 *
794  mb = desca2( mb_ )
795  nb = desca2( nb_ )
796  imb = desca2( imb_ )
797  inb = desca2( inb_ )
798  rsrc = desca2( rsrc_ )
799  csrc = desca2( csrc_ )
800 *
801 * Figure out local information about the distributed matrix operand
802 *
803  CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
804  $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
805  $ iacol, mrrow, mrcol )
806 *
807 * Decide where the entries shall be stored in memory
808 *
809  IF( inplace ) THEN
810  iia = 1
811  jja = 1
812  END IF
813 *
814 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
815 * ILOW, LOW, IUPP, and UPP.
816 *
817  ioffda = ja + offa - ia
818  CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
819  $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
820  $ lmbloc, lnbloc, ilow, low, iupp, upp )
821 *
822 * Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
823 * This values correspond to the square virtual underlying matrix
824 * of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
825 * to set up the random sequence. For practical purposes, the size
826 * of this virtual matrix is upper bounded by M_ + N_ - 1.
827 *
828  itmp = max( 0, -offa )
829  ivir = ia + itmp
830  imbvir = imb + itmp
831  nvir = desca2( m_ ) + itmp
832 *
833  CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
834  $ ilocoff, myrdist )
835 *
836  itmp = max( 0, offa )
837  jvir = ja + itmp
838  inbvir = inb + itmp
839  nvir = max( max( nvir, desca2( n_ ) + itmp ),
840  $ desca2( m_ ) + desca2( n_ ) - 1 )
841 *
842  CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
843  $ jlocoff, mycdist )
844 *
845  IF( symm .OR. herm .OR. notran ) THEN
846 *
847  CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
848  $ mb, nb, rsrc, csrc, nprow, npcol, 1, jmp )
849 *
850 * Compute constants to jump JMP( * ) numbers in the sequence
851 *
852  CALL pb_initmuladd( muladd0, jmp, imuladd )
853 *
854 * Compute and set the random value corresponding to A( IA, JA )
855 *
856  CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
857  $ myrdist, mycdist, nprow, npcol, jmp,
858  $ imuladd, iran )
859 *
860  CALL pb_slagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
861  $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
862  $ nb, lnbloc, jmp, imuladd )
863 *
864  END IF
865 *
866  IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
867 *
868  CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
869  $ mb, nb, rsrc, csrc, nprow, npcol, 1, jmp )
870 *
871 * Compute constants to jump JMP( * ) numbers in the sequence
872 *
873  CALL pb_initmuladd( muladd0, jmp, imuladd )
874 *
875 * Compute and set the random value corresponding to A( IA, JA )
876 *
877  CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
878  $ myrdist, mycdist, nprow, npcol, jmp,
879  $ imuladd, iran )
880 *
881  CALL pb_slagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
882  $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
883  $ nb, lnbloc, jmp, imuladd )
884 *
885  END IF
886 *
887  IF( diagdo ) THEN
888 *
889  maxmn = max( desca2( m_ ), desca2( n_ ) )
890  alpha = real( maxmn )
891 *
892  IF( ioffda.GE.0 ) THEN
893  CALL psladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
894  $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
895  ELSE
896  CALL psladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
897  $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
898  END IF
899 *
900  END IF
901 *
902  RETURN
903 *
904 * End of PSLAGEN
905 *
906  END
907  SUBROUTINE psladom( INPLACE, N, ALPHA, A, IA, JA, DESCA )
908 *
909 * -- PBLAS test routine (version 2.0) --
910 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
911 * and University of California, Berkeley.
912 * April 1, 1998
913 *
914 * .. Scalar Arguments ..
915  LOGICAL INPLACE
916  INTEGER IA, JA, N
917  REAL ALPHA
918 * ..
919 * .. Array Arguments ..
920  INTEGER DESCA( * )
921  REAL A( * )
922 * ..
923 *
924 * Purpose
925 * =======
926 *
927 * PSLADOM adds alpha to the diagonal entries of an n by n submatrix
928 * sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
929 *
930 * Notes
931 * =====
932 *
933 * A description vector is associated with each 2D block-cyclicly dis-
934 * tributed matrix. This vector stores the information required to
935 * establish the mapping between a matrix entry and its corresponding
936 * process and memory location.
937 *
938 * In the following comments, the character _ should be read as
939 * "of the distributed matrix". Let A be a generic term for any 2D
940 * block cyclicly distributed matrix. Its description vector is DESCA:
941 *
942 * NOTATION STORED IN EXPLANATION
943 * ---------------- --------------- ------------------------------------
944 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
945 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
946 * the NPROW x NPCOL BLACS process grid
947 * A is distributed over. The context
948 * itself is global, but the handle
949 * (the integer value) may vary.
950 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
951 * ted matrix A, M_A >= 0.
952 * N_A (global) DESCA( N_ ) The number of columns in the distri-
953 * buted matrix A, N_A >= 0.
954 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
955 * block of the matrix A, IMB_A > 0.
956 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
957 * left block of the matrix A,
958 * INB_A > 0.
959 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
960 * bute the last M_A-IMB_A rows of A,
961 * MB_A > 0.
962 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
963 * bute the last N_A-INB_A columns of
964 * A, NB_A > 0.
965 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
966 * row of the matrix A is distributed,
967 * NPROW > RSRC_A >= 0.
968 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
969 * first column of A is distributed.
970 * NPCOL > CSRC_A >= 0.
971 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
972 * array storing the local blocks of
973 * the distributed matrix A,
974 * IF( Lc( 1, N_A ) > 0 )
975 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
976 * ELSE
977 * LLD_A >= 1.
978 *
979 * Let K be the number of rows of a matrix A starting at the global in-
980 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
981 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
982 * receive if these K rows were distributed over NPROW processes. If K
983 * is the number of columns of a matrix A starting at the global index
984 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
985 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
986 * these K columns were distributed over NPCOL processes.
987 *
988 * The values of Lr() and Lc() may be determined via a call to the func-
989 * tion PB_NUMROC:
990 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
991 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
992 *
993 * Arguments
994 * =========
995 *
996 * INPLACE (global input) LOGICAL
997 * On entry, INPLACE specifies if the matrix should be generated
998 * in place or not. If INPLACE is .TRUE., the local random array
999 * to be generated will start in memory at the local memory lo-
1000 * cation A( 1, 1 ), otherwise it will start at the local posi-
1001 * tion induced by IA and JA.
1002 *
1003 * N (global input) INTEGER
1004 * On entry, N specifies the global order of the submatrix
1005 * sub( A ) to be modified. N must be at least zero.
1006 *
1007 * ALPHA (global input) REAL
1008 * On entry, ALPHA specifies the scalar alpha.
1009 *
1010 * A (local input/local output) REAL array
1011 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is
1012 * at least Lc( 1, JA+N-1 ). Before entry, this array contains
1013 * the local entries of the matrix A. On exit, the local entries
1014 * of this array corresponding to the main diagonal of sub( A )
1015 * have been updated.
1016 *
1017 * IA (global input) INTEGER
1018 * On entry, IA specifies A's global row index, which points to
1019 * the beginning of the submatrix sub( A ).
1020 *
1021 * JA (global input) INTEGER
1022 * On entry, JA specifies A's global column index, which points
1023 * to the beginning of the submatrix sub( A ).
1024 *
1025 * DESCA (global and local input) INTEGER array
1026 * On entry, DESCA is an integer array of dimension DLEN_. This
1027 * is the array descriptor for the matrix A.
1028 *
1029 * -- Written on April 1, 1998 by
1030 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1031 *
1032 * =====================================================================
1033 *
1034 * .. Parameters ..
1035  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1036  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
1037  $ rsrc_
1038  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1039  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1040  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1041  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1042 * ..
1043 * .. Local Scalars ..
1044  LOGICAL GODOWN, GOLEFT
1045  INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
1046  $ imb1, imbloc, inb1, inbloc, ioffa, ioffd, iupp,
1047  $ jja, joffa, joffd, lcmt, lcmt00, lda, ldap1,
1048  $ lmbloc, lnbloc, low, mb, mblkd, mblks, mbloc,
1049  $ mrcol, mrrow, mycol, myrow, nb, nblkd, nblks,
1050  $ nbloc, np, npcol, nprow, nq, pmb, qnb, upp
1051  REAL ATMP
1052 * ..
1053 * .. Local Scalars ..
1054  INTEGER DESCA2( DLEN_ )
1055 * ..
1056 * .. External Subroutines ..
1057  EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
1058  $ pb_desctrans
1059 * ..
1060 * .. Intrinsic Functions ..
1061  INTRINSIC abs, max, min
1062 * ..
1063 * .. Executable Statements ..
1064 *
1065 * Convert descriptor
1066 *
1067  CALL pb_desctrans( desca, desca2 )
1068 *
1069 * Get grid parameters
1070 *
1071  ictxt = desca2( ctxt_ )
1072  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1073 *
1074  IF( n.EQ.0 )
1075  $ RETURN
1076 *
1077  CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
1078  $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
1079  $ iacol, mrrow, mrcol )
1080 *
1081 * Decide where the entries shall be stored in memory
1082 *
1083  IF( inplace ) THEN
1084  iia = 1
1085  jja = 1
1086  END IF
1087 *
1088 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
1089 * ILOW, LOW, IUPP, and UPP.
1090 *
1091  mb = desca2( mb_ )
1092  nb = desca2( nb_ )
1093 *
1094  CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
1095  $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
1096  $ lnbloc, ilow, low, iupp, upp )
1097 *
1098  ioffa = iia - 1
1099  joffa = jja - 1
1100  lda = desca2( lld_ )
1101  ldap1 = lda + 1
1102 *
1103  IF( desca2( rsrc_ ).LT.0 ) THEN
1104  pmb = mb
1105  ELSE
1106  pmb = nprow * mb
1107  END IF
1108  IF( desca2( csrc_ ).LT.0 ) THEN
1109  qnb = nb
1110  ELSE
1111  qnb = npcol * nb
1112  END IF
1113 *
1114 * Handle the first block of rows or columns separately, and update
1115 * LCMT00, MBLKS and NBLKS.
1116 *
1117  godown = ( lcmt00.GT.iupp )
1118  goleft = ( lcmt00.LT.ilow )
1119 *
1120  IF( .NOT.godown .AND. .NOT.goleft ) THEN
1121 *
1122 * LCMT00 >= ILOW && LCMT00 <= IUPP
1123 *
1124  IF( lcmt00.GE.0 ) THEN
1125  ijoffa = ioffa+lcmt00 + ( joffa - 1 ) * lda
1126  DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
1127  atmp = a( ijoffa + i*ldap1 )
1128  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1129  10 CONTINUE
1130  ELSE
1131  ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
1132  DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
1133  atmp = a( ijoffa + i*ldap1 )
1134  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1135  20 CONTINUE
1136  END IF
1137  goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
1138  godown = .NOT.goleft
1139 *
1140  END IF
1141 *
1142  IF( godown ) THEN
1143 *
1144  lcmt00 = lcmt00 - ( iupp - upp + pmb )
1145  mblks = mblks - 1
1146  ioffa = ioffa + imbloc
1147 *
1148  30 CONTINUE
1149  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1150  lcmt00 = lcmt00 - pmb
1151  mblks = mblks - 1
1152  ioffa = ioffa + mb
1153  GO TO 30
1154  END IF
1155 *
1156  lcmt = lcmt00
1157  mblkd = mblks
1158  ioffd = ioffa
1159 *
1160  mbloc = mb
1161  40 CONTINUE
1162  IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
1163  IF( mblkd.EQ.1 )
1164  $ mbloc = lmbloc
1165  IF( lcmt.GE.0 ) THEN
1166  ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1167  DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
1168  atmp = a( ijoffa + i*ldap1 )
1169  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1170  50 CONTINUE
1171  ELSE
1172  ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1173  DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
1174  atmp = a( ijoffa + i*ldap1 )
1175  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1176  60 CONTINUE
1177  END IF
1178  lcmt00 = lcmt
1179  lcmt = lcmt - pmb
1180  mblks = mblkd
1181  mblkd = mblkd - 1
1182  ioffa = ioffd
1183  ioffd = ioffd + mbloc
1184  GO TO 40
1185  END IF
1186 *
1187  lcmt00 = lcmt00 + low - ilow + qnb
1188  nblks = nblks - 1
1189  joffa = joffa + inbloc
1190 *
1191  ELSE IF( goleft ) THEN
1192 *
1193  lcmt00 = lcmt00 + low - ilow + qnb
1194  nblks = nblks - 1
1195  joffa = joffa + inbloc
1196 *
1197  70 CONTINUE
1198  IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
1199  lcmt00 = lcmt00 + qnb
1200  nblks = nblks - 1
1201  joffa = joffa + nb
1202  GO TO 70
1203  END IF
1204 *
1205  lcmt = lcmt00
1206  nblkd = nblks
1207  joffd = joffa
1208 *
1209  nbloc = nb
1210  80 CONTINUE
1211  IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
1212  IF( nblkd.EQ.1 )
1213  $ nbloc = lnbloc
1214  IF( lcmt.GE.0 ) THEN
1215  ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
1216  DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
1217  atmp = a( ijoffa + i*ldap1 )
1218  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1219  90 CONTINUE
1220  ELSE
1221  ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
1222  DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
1223  atmp = a( ijoffa + i*ldap1 )
1224  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1225  100 CONTINUE
1226  END IF
1227  lcmt00 = lcmt
1228  lcmt = lcmt + qnb
1229  nblks = nblkd
1230  nblkd = nblkd - 1
1231  joffa = joffd
1232  joffd = joffd + nbloc
1233  GO TO 80
1234  END IF
1235 *
1236  lcmt00 = lcmt00 - ( iupp - upp + pmb )
1237  mblks = mblks - 1
1238  ioffa = ioffa + imbloc
1239 *
1240  END IF
1241 *
1242  nbloc = nb
1243  110 CONTINUE
1244  IF( nblks.GT.0 ) THEN
1245  IF( nblks.EQ.1 )
1246  $ nbloc = lnbloc
1247  120 CONTINUE
1248  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1249  lcmt00 = lcmt00 - pmb
1250  mblks = mblks - 1
1251  ioffa = ioffa + mb
1252  GO TO 120
1253  END IF
1254 *
1255  lcmt = lcmt00
1256  mblkd = mblks
1257  ioffd = ioffa
1258 *
1259  mbloc = mb
1260  130 CONTINUE
1261  IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
1262  IF( mblkd.EQ.1 )
1263  $ mbloc = lmbloc
1264  IF( lcmt.GE.0 ) THEN
1265  ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1266  DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
1267  atmp = a( ijoffa + i*ldap1 )
1268  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1269  140 CONTINUE
1270  ELSE
1271  ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1272  DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
1273  atmp = a( ijoffa + i*ldap1 )
1274  a( ijoffa + i*ldap1 ) = abs( atmp ) + alpha
1275  150 CONTINUE
1276  END IF
1277  lcmt00 = lcmt
1278  lcmt = lcmt - pmb
1279  mblks = mblkd
1280  mblkd = mblkd - 1
1281  ioffa = ioffd
1282  ioffd = ioffd + mbloc
1283  GO TO 130
1284  END IF
1285 *
1286  lcmt00 = lcmt00 + qnb
1287  nblks = nblks - 1
1288  joffa = joffa + nbloc
1289  GO TO 110
1290 *
1291  END IF
1292 *
1293  RETURN
1294 *
1295 * End of PSLADOM
1296 *
1297  END
1298  SUBROUTINE pb_slascal( UPLO, M, N, IOFFD, ALPHA, A, LDA )
1299 *
1300 * -- PBLAS test routine (version 2.0) --
1301 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1302 * and University of California, Berkeley.
1303 * April 1, 1998
1304 *
1305 * .. Scalar Arguments ..
1306  CHARACTER*1 UPLO
1307  INTEGER IOFFD, LDA, M, N
1308  REAL ALPHA
1309 * ..
1310 * .. Array Arguments ..
1311  REAL A( LDA, * )
1312 * ..
1313 *
1314 * Purpose
1315 * =======
1316 *
1317 * PB_SLASCAL scales a two-dimensional array A by the scalar alpha.
1318 *
1319 * Arguments
1320 * =========
1321 *
1322 * UPLO (input) CHARACTER*1
1323 * On entry, UPLO specifies which trapezoidal part of the ar-
1324 * ray A is to be scaled as follows:
1325 * = 'L' or 'l': the lower trapezoid of A is scaled,
1326 * = 'U' or 'u': the upper trapezoid of A is scaled,
1327 * = 'D' or 'd': diagonal specified by IOFFD is scaled,
1328 * Otherwise: all of the array A is scaled.
1329 *
1330 * M (input) INTEGER
1331 * On entry, M specifies the number of rows of the array A. M
1332 * must be at least zero.
1333 *
1334 * N (input) INTEGER
1335 * On entry, N specifies the number of columns of the array A.
1336 * N must be at least zero.
1337 *
1338 * IOFFD (input) INTEGER
1339 * On entry, IOFFD specifies the position of the offdiagonal de-
1340 * limiting the upper and lower trapezoidal part of A as follows
1341 * (see the notes below):
1342 *
1343 * IOFFD = 0 specifies the main diagonal A( i, i ),
1344 * with i = 1 ... MIN( M, N ),
1345 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
1346 * with i = 1 ... MIN( M-IOFFD, N ),
1347 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
1348 * with i = 1 ... MIN( M, N+IOFFD ).
1349 *
1350 * ALPHA (input) REAL
1351 * On entry, ALPHA specifies the scalar alpha.
1352 *
1353 * A (input/output) REAL array
1354 * On entry, A is an array of dimension (LDA,N). Before entry
1355 * with UPLO = 'U' or 'u', the leading m by n part of the array
1356 * A must contain the upper trapezoidal part of the matrix as
1357 * specified by IOFFD to be scaled, and the strictly lower tra-
1358 * pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
1359 * the leading m by n part of the array A must contain the lower
1360 * trapezoidal part of the matrix as specified by IOFFD to be
1361 * scaled, and the strictly upper trapezoidal part of A is not
1362 * referenced. On exit, the entries of the trapezoid part of A
1363 * determined by UPLO and IOFFD are scaled.
1364 *
1365 * LDA (input) INTEGER
1366 * On entry, LDA specifies the leading dimension of the array A.
1367 * LDA must be at least max( 1, M ).
1368 *
1369 * Notes
1370 * =====
1371 * N N
1372 * ---------------------------- -----------
1373 * | d | | |
1374 * M | d 'U' | | 'U' |
1375 * | 'L' 'D' | |d |
1376 * | d | M | d |
1377 * ---------------------------- | 'D' |
1378 * | d |
1379 * IOFFD < 0 | 'L' d |
1380 * | d|
1381 * N | |
1382 * ----------- -----------
1383 * | d 'U'|
1384 * | d | IOFFD > 0
1385 * M | 'D' |
1386 * | d| N
1387 * | 'L' | ----------------------------
1388 * | | | 'U' |
1389 * | | |d |
1390 * | | | 'D' |
1391 * | | | d |
1392 * | | |'L' d |
1393 * ----------- ----------------------------
1394 *
1395 * -- Written on April 1, 1998 by
1396 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1397 *
1398 * =====================================================================
1399 *
1400 * .. Local Scalars ..
1401  INTEGER I, J, JTMP, MN
1402 * ..
1403 * .. External Functions ..
1404  LOGICAL LSAME
1405  EXTERNAL lsame
1406 * ..
1407 * .. Intrinsic Functions ..
1408  INTRINSIC max, min
1409 * ..
1410 * .. Executable Statements ..
1411 *
1412 * Quick return if possible
1413 *
1414  IF( m.LE.0 .OR. n.LE.0 )
1415  $ RETURN
1416 *
1417 * Start the operations
1418 *
1419  IF( lsame( uplo, 'L' ) ) THEN
1420 *
1421 * Scales the lower triangular part of the array by ALPHA.
1422 *
1423  mn = max( 0, -ioffd )
1424  DO 20 j = 1, min( mn, n )
1425  DO 10 i = 1, m
1426  a( i, j ) = alpha * a( i, j )
1427  10 CONTINUE
1428  20 CONTINUE
1429  DO 40 j = mn + 1, min( m - ioffd, n )
1430  DO 30 i = j + ioffd, m
1431  a( i, j ) = alpha * a( i, j )
1432  30 CONTINUE
1433  40 CONTINUE
1434 *
1435  ELSE IF( lsame( uplo, 'U' ) ) THEN
1436 *
1437 * Scales the upper triangular part of the array by ALPHA.
1438 *
1439  mn = min( m - ioffd, n )
1440  DO 60 j = max( 0, -ioffd ) + 1, mn
1441  DO 50 i = 1, j + ioffd
1442  a( i, j ) = alpha * a( i, j )
1443  50 CONTINUE
1444  60 CONTINUE
1445  DO 80 j = max( 0, mn ) + 1, n
1446  DO 70 i = 1, m
1447  a( i, j ) = alpha * a( i, j )
1448  70 CONTINUE
1449  80 CONTINUE
1450 *
1451  ELSE IF( lsame( uplo, 'D' ) ) THEN
1452 *
1453 * Scales the diagonal entries by ALPHA.
1454 *
1455  DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
1456  jtmp = j + ioffd
1457  a( jtmp, j ) = alpha * a( jtmp, j )
1458  90 CONTINUE
1459 *
1460  ELSE
1461 *
1462 * Scales the entire array by ALPHA.
1463 *
1464  DO 110 j = 1, n
1465  DO 100 i = 1, m
1466  a( i, j ) = alpha * a( i, j )
1467  100 CONTINUE
1468  110 CONTINUE
1469 *
1470  END IF
1471 *
1472  RETURN
1473 *
1474 * End of PB_SLASCAL
1475 *
1476  END
1477  SUBROUTINE pb_slagen( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
1478  $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
1479  $ LNBLOC, JMP, IMULADD )
1480 *
1481 * -- PBLAS test routine (version 2.0) --
1482 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1483 * and University of California, Berkeley.
1484 * April 1, 1998
1485 *
1486 * .. Scalar Arguments ..
1487  CHARACTER*1 UPLO, AFORM
1488  INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
1489  $ MB, MBLKS, NB, NBLKS
1490 * ..
1491 * .. Array Arguments ..
1492  INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
1493  REAL A( LDA, * )
1494 * ..
1495 *
1496 * Purpose
1497 * =======
1498 *
1499 * PB_SLAGEN locally initializes an array A.
1500 *
1501 * Arguments
1502 * =========
1503 *
1504 * UPLO (global input) CHARACTER*1
1505 * On entry, UPLO specifies whether the lower (UPLO='L') trape-
1506 * zoidal part or the upper (UPLO='U') trapezoidal part is to be
1507 * generated when the matrix to be generated is symmetric or
1508 * Hermitian. For all the other values of AFORM, the value of
1509 * this input argument is ignored.
1510 *
1511 * AFORM (global input) CHARACTER*1
1512 * On entry, AFORM specifies the type of submatrix to be genera-
1513 * ted as follows:
1514 * AFORM = 'S', sub( A ) is a symmetric matrix,
1515 * AFORM = 'H', sub( A ) is a Hermitian matrix,
1516 * AFORM = 'T', sub( A ) is overrwritten with the transpose
1517 * of what would normally be generated,
1518 * AFORM = 'C', sub( A ) is overwritten with the conjugate
1519 * transpose of what would normally be genera-
1520 * ted.
1521 * AFORM = 'N', a random submatrix is generated.
1522 *
1523 * A (local output) REAL array
1524 * On entry, A is an array of dimension (LLD_A, *). On exit,
1525 * this array contains the local entries of the randomly genera-
1526 * ted submatrix sub( A ).
1527 *
1528 * LDA (local input) INTEGER
1529 * On entry, LDA specifies the local leading dimension of the
1530 * array A. LDA must be at least one.
1531 *
1532 * LCMT00 (global input) INTEGER
1533 * On entry, LCMT00 is the LCM value specifying the off-diagonal
1534 * of the underlying matrix of interest. LCMT00=0 specifies the
1535 * main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
1536 * specifies superdiagonals.
1537 *
1538 * IRAN (local input) INTEGER array
1539 * On entry, IRAN is an array of dimension 2 containing respec-
1540 * tively the 16-lower and 16-higher bits of the encoding of the
1541 * entry of the random sequence corresponding locally to the
1542 * first local array entry to generate. Usually, this array is
1543 * computed by PB_SETLOCRAN.
1544 *
1545 * MBLKS (local input) INTEGER
1546 * On entry, MBLKS specifies the local number of blocks of rows.
1547 * MBLKS is at least zero.
1548 *
1549 * IMBLOC (local input) INTEGER
1550 * On entry, IMBLOC specifies the number of rows (size) of the
1551 * local uppest blocks. IMBLOC is at least zero.
1552 *
1553 * MB (global input) INTEGER
1554 * On entry, MB specifies the blocking factor used to partition
1555 * the rows of the matrix. MB must be at least one.
1556 *
1557 * LMBLOC (local input) INTEGER
1558 * On entry, LMBLOC specifies the number of rows (size) of the
1559 * local lowest blocks. LMBLOC is at least zero.
1560 *
1561 * NBLKS (local input) INTEGER
1562 * On entry, NBLKS specifies the local number of blocks of co-
1563 * lumns. NBLKS is at least zero.
1564 *
1565 * INBLOC (local input) INTEGER
1566 * On entry, INBLOC specifies the number of columns (size) of
1567 * the local leftmost blocks. INBLOC is at least zero.
1568 *
1569 * NB (global input) INTEGER
1570 * On entry, NB specifies the blocking factor used to partition
1571 * the the columns of the matrix. NB must be at least one.
1572 *
1573 * LNBLOC (local input) INTEGER
1574 * On entry, LNBLOC specifies the number of columns (size) of
1575 * the local rightmost blocks. LNBLOC is at least zero.
1576 *
1577 * JMP (local input) INTEGER array
1578 * On entry, JMP is an array of dimension JMP_LEN containing the
1579 * different jump values used by the random matrix generator.
1580 *
1581 * IMULADD (local input) INTEGER array
1582 * On entry, IMULADD is an array of dimension (4, JMP_LEN). The
1583 * jth column of this array contains the encoded initial cons-
1584 * tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
1585 * (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
1586 * contains respectively the 16-lower and 16-higher bits of the
1587 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and
1588 * 16-higher bits of the constant c_j.
1589 *
1590 * -- Written on April 1, 1998 by
1591 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1592 *
1593 * =====================================================================
1594 *
1595 * .. Parameters ..
1596  INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
1597  $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
1598  $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
1599  parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
1600  $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
1601  $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
1602  $ jmp_nqnb = 10, jmp_nqinbloc = 11,
1603  $ jmp_len = 11 )
1604 * ..
1605 * .. Local Scalars ..
1606  INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
1607  $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
1608  REAL DUMMY
1609 * ..
1610 * .. Local Arrays ..
1611  INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
1612 * ..
1613 * .. External Subroutines ..
1614  EXTERNAL pb_jumpit
1615 * ..
1616 * .. External Functions ..
1617  LOGICAL LSAME
1618  REAL PB_SRAND
1619  EXTERNAL LSAME, PB_SRAND
1620 * ..
1621 * .. Intrinsic Functions ..
1622  INTRINSIC max, min
1623 * ..
1624 * .. Executable Statements ..
1625 *
1626  DO 10 i = 1, 2
1627  ib1( i ) = iran( i )
1628  ib2( i ) = iran( i )
1629  ib3( i ) = iran( i )
1630  10 CONTINUE
1631 *
1632  IF( lsame( aform, 'N' ) ) THEN
1633 *
1634 * Generate random matrix
1635 *
1636  jj = 1
1637 *
1638  DO 50 jblk = 1, nblks
1639 *
1640  IF( jblk.EQ.1 ) THEN
1641  jb = inbloc
1642  ELSE IF( jblk.EQ.nblks ) THEN
1643  jb = lnbloc
1644  ELSE
1645  jb = nb
1646  END IF
1647 *
1648  DO 40 jk = jj, jj + jb - 1
1649 *
1650  ii = 1
1651 *
1652  DO 30 iblk = 1, mblks
1653 *
1654  IF( iblk.EQ.1 ) THEN
1655  ib = imbloc
1656  ELSE IF( iblk.EQ.mblks ) THEN
1657  ib = lmbloc
1658  ELSE
1659  ib = mb
1660  END IF
1661 *
1662 * Blocks are IB by JB
1663 *
1664  DO 20 ik = ii, ii + ib - 1
1665  a( ik, jk ) = pb_srand( 0 )
1666  20 CONTINUE
1667 *
1668  ii = ii + ib
1669 *
1670  IF( iblk.EQ.1 ) THEN
1671 *
1672 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1673 *
1674  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1675  $ ib0 )
1676 *
1677  ELSE
1678 *
1679 * Jump NPROW * MB rows
1680 *
1681  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
1682 *
1683  END IF
1684 *
1685  ib1( 1 ) = ib0( 1 )
1686  ib1( 2 ) = ib0( 2 )
1687 *
1688  30 CONTINUE
1689 *
1690 * Jump one column
1691 *
1692  CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1693 *
1694  ib1( 1 ) = ib0( 1 )
1695  ib1( 2 ) = ib0( 2 )
1696  ib2( 1 ) = ib0( 1 )
1697  ib2( 2 ) = ib0( 2 )
1698 *
1699  40 CONTINUE
1700 *
1701  jj = jj + jb
1702 *
1703  IF( jblk.EQ.1 ) THEN
1704 *
1705 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1706 *
1707  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1708 *
1709  ELSE
1710 *
1711 * Jump NPCOL * NB columns
1712 *
1713  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1714 *
1715  END IF
1716 *
1717  ib1( 1 ) = ib0( 1 )
1718  ib1( 2 ) = ib0( 2 )
1719  ib2( 1 ) = ib0( 1 )
1720  ib2( 2 ) = ib0( 2 )
1721  ib3( 1 ) = ib0( 1 )
1722  ib3( 2 ) = ib0( 2 )
1723 *
1724  50 CONTINUE
1725 *
1726  ELSE IF( lsame( aform, 'T' ) .OR. lsame( aform, 'C' ) ) THEN
1727 *
1728 * Generate the transpose of the matrix that would be normally
1729 * generated.
1730 *
1731  ii = 1
1732 *
1733  DO 90 iblk = 1, mblks
1734 *
1735  IF( iblk.EQ.1 ) THEN
1736  ib = imbloc
1737  ELSE IF( iblk.EQ.mblks ) THEN
1738  ib = lmbloc
1739  ELSE
1740  ib = mb
1741  END IF
1742 *
1743  DO 80 ik = ii, ii + ib - 1
1744 *
1745  jj = 1
1746 *
1747  DO 70 jblk = 1, nblks
1748 *
1749  IF( jblk.EQ.1 ) THEN
1750  jb = inbloc
1751  ELSE IF( jblk.EQ.nblks ) THEN
1752  jb = lnbloc
1753  ELSE
1754  jb = nb
1755  END IF
1756 *
1757 * Blocks are IB by JB
1758 *
1759  DO 60 jk = jj, jj + jb - 1
1760  a( ik, jk ) = pb_srand( 0 )
1761  60 CONTINUE
1762 *
1763  jj = jj + jb
1764 *
1765  IF( jblk.EQ.1 ) THEN
1766 *
1767 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1768 *
1769  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
1770  $ ib0 )
1771 *
1772  ELSE
1773 *
1774 * Jump NPCOL * NB columns
1775 *
1776  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
1777 *
1778  END IF
1779 *
1780  ib1( 1 ) = ib0( 1 )
1781  ib1( 2 ) = ib0( 2 )
1782 *
1783  70 CONTINUE
1784 *
1785 * Jump one row
1786 *
1787  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
1788 *
1789  ib1( 1 ) = ib0( 1 )
1790  ib1( 2 ) = ib0( 2 )
1791  ib2( 1 ) = ib0( 1 )
1792  ib2( 2 ) = ib0( 2 )
1793 *
1794  80 CONTINUE
1795 *
1796  ii = ii + ib
1797 *
1798  IF( iblk.EQ.1 ) THEN
1799 *
1800 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1801 *
1802  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
1803 *
1804  ELSE
1805 *
1806 * Jump NPROW * MB rows
1807 *
1808  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
1809 *
1810  END IF
1811 *
1812  ib1( 1 ) = ib0( 1 )
1813  ib1( 2 ) = ib0( 2 )
1814  ib2( 1 ) = ib0( 1 )
1815  ib2( 2 ) = ib0( 2 )
1816  ib3( 1 ) = ib0( 1 )
1817  ib3( 2 ) = ib0( 2 )
1818 *
1819  90 CONTINUE
1820 *
1821  ELSE IF( ( lsame( aform, 'S' ) ).OR.( lsame( aform, 'H' ) ) ) THEN
1822 *
1823 * Generate a symmetric matrix
1824 *
1825  IF( lsame( uplo, 'L' ) ) THEN
1826 *
1827 * generate lower trapezoidal part
1828 *
1829  jj = 1
1830  lcmtc = lcmt00
1831 *
1832  DO 170 jblk = 1, nblks
1833 *
1834  IF( jblk.EQ.1 ) THEN
1835  jb = inbloc
1836  low = 1 - inbloc
1837  ELSE IF( jblk.EQ.nblks ) THEN
1838  jb = lnbloc
1839  low = 1 - nb
1840  ELSE
1841  jb = nb
1842  low = 1 - nb
1843  END IF
1844 *
1845  DO 160 jk = jj, jj + jb - 1
1846 *
1847  ii = 1
1848  lcmtr = lcmtc
1849 *
1850  DO 150 iblk = 1, mblks
1851 *
1852  IF( iblk.EQ.1 ) THEN
1853  ib = imbloc
1854  upp = imbloc - 1
1855  ELSE IF( iblk.EQ.mblks ) THEN
1856  ib = lmbloc
1857  upp = mb - 1
1858  ELSE
1859  ib = mb
1860  upp = mb - 1
1861  END IF
1862 *
1863 * Blocks are IB by JB
1864 *
1865  IF( lcmtr.GT.upp ) THEN
1866 *
1867  DO 100 ik = ii, ii + ib - 1
1868  dummy = pb_srand( 0 )
1869  100 CONTINUE
1870 *
1871  ELSE IF( lcmtr.GE.low ) THEN
1872 *
1873  jtmp = jk - jj + 1
1874  mnb = max( 0, -lcmtr )
1875 *
1876  IF( jtmp.LE.min( mnb, jb ) ) THEN
1877 *
1878  DO 110 ik = ii, ii + ib - 1
1879  a( ik, jk ) = pb_srand( 0 )
1880  110 CONTINUE
1881 *
1882  ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
1883  $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
1884 *
1885  itmp = ii + jtmp + lcmtr - 1
1886 *
1887  DO 120 ik = ii, itmp - 1
1888  dummy = pb_srand( 0 )
1889  120 CONTINUE
1890 *
1891  DO 130 ik = itmp, ii + ib - 1
1892  a( ik, jk ) = pb_srand( 0 )
1893  130 CONTINUE
1894 *
1895  END IF
1896 *
1897  ELSE
1898 *
1899  DO 140 ik = ii, ii + ib - 1
1900  a( ik, jk ) = pb_srand( 0 )
1901  140 CONTINUE
1902 *
1903  END IF
1904 *
1905  ii = ii + ib
1906 *
1907  IF( iblk.EQ.1 ) THEN
1908 *
1909 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1910 *
1911  lcmtr = lcmtr - jmp( jmp_npimbloc )
1912  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1913  $ ib0 )
1914 *
1915  ELSE
1916 *
1917 * Jump NPROW * MB rows
1918 *
1919  lcmtr = lcmtr - jmp( jmp_npmb )
1920  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
1921  $ ib0 )
1922 *
1923  END IF
1924 *
1925  ib1( 1 ) = ib0( 1 )
1926  ib1( 2 ) = ib0( 2 )
1927 *
1928  150 CONTINUE
1929 *
1930 * Jump one column
1931 *
1932  CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1933 *
1934  ib1( 1 ) = ib0( 1 )
1935  ib1( 2 ) = ib0( 2 )
1936  ib2( 1 ) = ib0( 1 )
1937  ib2( 2 ) = ib0( 2 )
1938 *
1939  160 CONTINUE
1940 *
1941  jj = jj + jb
1942 *
1943  IF( jblk.EQ.1 ) THEN
1944 *
1945 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1946 *
1947  lcmtc = lcmtc + jmp( jmp_nqinbloc )
1948  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1949 *
1950  ELSE
1951 *
1952 * Jump NPCOL * NB columns
1953 *
1954  lcmtc = lcmtc + jmp( jmp_nqnb )
1955  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1956 *
1957  END IF
1958 *
1959  ib1( 1 ) = ib0( 1 )
1960  ib1( 2 ) = ib0( 2 )
1961  ib2( 1 ) = ib0( 1 )
1962  ib2( 2 ) = ib0( 2 )
1963  ib3( 1 ) = ib0( 1 )
1964  ib3( 2 ) = ib0( 2 )
1965 *
1966  170 CONTINUE
1967 *
1968  ELSE
1969 *
1970 * generate upper trapezoidal part
1971 *
1972  ii = 1
1973  lcmtr = lcmt00
1974 *
1975  DO 250 iblk = 1, mblks
1976 *
1977  IF( iblk.EQ.1 ) THEN
1978  ib = imbloc
1979  upp = imbloc - 1
1980  ELSE IF( iblk.EQ.mblks ) THEN
1981  ib = lmbloc
1982  upp = mb - 1
1983  ELSE
1984  ib = mb
1985  upp = mb - 1
1986  END IF
1987 *
1988  DO 240 ik = ii, ii + ib - 1
1989 *
1990  jj = 1
1991  lcmtc = lcmtr
1992 *
1993  DO 230 jblk = 1, nblks
1994 *
1995  IF( jblk.EQ.1 ) THEN
1996  jb = inbloc
1997  low = 1 - inbloc
1998  ELSE IF( jblk.EQ.nblks ) THEN
1999  jb = lnbloc
2000  low = 1 - nb
2001  ELSE
2002  jb = nb
2003  low = 1 - nb
2004  END IF
2005 *
2006 * Blocks are IB by JB
2007 *
2008  IF( lcmtc.LT.low ) THEN
2009 *
2010  DO 180 jk = jj, jj + jb - 1
2011  dummy = pb_srand( 0 )
2012  180 CONTINUE
2013 *
2014  ELSE IF( lcmtc.LE.upp ) THEN
2015 *
2016  itmp = ik - ii + 1
2017  mnb = max( 0, lcmtc )
2018 *
2019  IF( itmp.LE.min( mnb, ib ) ) THEN
2020 *
2021  DO 190 jk = jj, jj + jb - 1
2022  a( ik, jk ) = pb_srand( 0 )
2023  190 CONTINUE
2024 *
2025  ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2026  $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2027 *
2028  jtmp = jj + itmp - lcmtc - 1
2029 *
2030  DO 200 jk = jj, jtmp - 1
2031  dummy = pb_srand( 0 )
2032  200 CONTINUE
2033 *
2034  DO 210 jk = jtmp, jj + jb - 1
2035  a( ik, jk ) = pb_srand( 0 )
2036  210 CONTINUE
2037 *
2038  END IF
2039 *
2040  ELSE
2041 *
2042  DO 220 jk = jj, jj + jb - 1
2043  a( ik, jk ) = pb_srand( 0 )
2044  220 CONTINUE
2045 *
2046  END IF
2047 *
2048  jj = jj + jb
2049 *
2050  IF( jblk.EQ.1 ) THEN
2051 *
2052 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
2053 *
2054  lcmtc = lcmtc + jmp( jmp_nqinbloc )
2055  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2056  $ ib0 )
2057 *
2058  ELSE
2059 *
2060 * Jump NPCOL * NB columns
2061 *
2062  lcmtc = lcmtc + jmp( jmp_nqnb )
2063  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2064  $ ib0 )
2065 *
2066  END IF
2067 *
2068  ib1( 1 ) = ib0( 1 )
2069  ib1( 2 ) = ib0( 2 )
2070 *
2071  230 CONTINUE
2072 *
2073 * Jump one row
2074 *
2075  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2076 *
2077  ib1( 1 ) = ib0( 1 )
2078  ib1( 2 ) = ib0( 2 )
2079  ib2( 1 ) = ib0( 1 )
2080  ib2( 2 ) = ib0( 2 )
2081 *
2082  240 CONTINUE
2083 *
2084  ii = ii + ib
2085 *
2086  IF( iblk.EQ.1 ) THEN
2087 *
2088 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
2089 *
2090  lcmtr = lcmtr - jmp( jmp_npimbloc )
2091  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2092 *
2093  ELSE
2094 *
2095 * Jump NPROW * MB rows
2096 *
2097  lcmtr = lcmtr - jmp( jmp_npmb )
2098  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2099 *
2100  END IF
2101 *
2102  ib1( 1 ) = ib0( 1 )
2103  ib1( 2 ) = ib0( 2 )
2104  ib2( 1 ) = ib0( 1 )
2105  ib2( 2 ) = ib0( 2 )
2106  ib3( 1 ) = ib0( 1 )
2107  ib3( 2 ) = ib0( 2 )
2108 *
2109  250 CONTINUE
2110 *
2111  END IF
2112 *
2113  END IF
2114 *
2115  RETURN
2116 *
2117 * End of PB_SLAGEN
2118 *
2119  END
2120  REAL FUNCTION PB_SRAND( IDUMM )
2121 *
2122 * -- PBLAS test routine (version 2.0) --
2123 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2124 * and University of California, Berkeley.
2125 * April 1, 1998
2126 *
2127 * .. Scalar Arguments ..
2128  INTEGER idumm
2129 * ..
2130 *
2131 * Purpose
2132 * =======
2133 *
2134 * PB_SRAND generates the next number in the random sequence. This func-
2135 * tion ensures that this number will be in the interval ( -1.0, 1.0 ).
2136 *
2137 * Arguments
2138 * =========
2139 *
2140 * IDUMM (local input) INTEGER
2141 * This argument is ignored, but necessary to a FORTRAN 77 func-
2142 * tion.
2143 *
2144 * Further Details
2145 * ===============
2146 *
2147 * On entry, the array IRAND stored in the common block RANCOM contains
2148 * the information (2 integers) required to generate the next number in
2149 * the sequence X( n ). This number is computed as
2150 *
2151 * X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2152 *
2153 * where the constant d is the largest 32 bit positive integer. The
2154 * array IRAND is then updated for the generation of the next number
2155 * X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2156 * The constants a and c should have been preliminarily stored in the
2157 * array IACS as 2 pairs of integers. The initial set up of IRAND and
2158 * IACS is performed by the routine PB_SETRAN.
2159 *
2160 * -- Written on April 1, 1998 by
2161 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2162 *
2163 * =====================================================================
2164 *
2165 * .. Parameters ..
2166  REAL one, two
2167  PARAMETER ( one = 1.0e+0, two = 2.0e+0 )
2168 * ..
2169 * .. External Functions ..
2170  REAL pb_sran
2171  EXTERNAL pb_sran
2172 * ..
2173 * .. Executable Statements ..
2174 *
2175  pb_srand = one - two * pb_sran( idumm )
2176 *
2177  RETURN
2178 *
2179 * End of PB_SRAND
2180 *
2181  END
2182  REAL function pb_sran( idumm )
2183 *
2184 * -- PBLAS test routine (version 2.0) --
2185 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2186 * and University of California, Berkeley.
2187 * April 1, 1998
2188 *
2189 * .. Scalar Arguments ..
2190  INTEGER idumm
2191 * ..
2192 *
2193 * Purpose
2194 * =======
2195 *
2196 * PB_SRAN generates the next number in the random sequence.
2197 *
2198 * Arguments
2199 * =========
2200 *
2201 * IDUMM (local input) INTEGER
2202 * This argument is ignored, but necessary to a FORTRAN 77 func-
2203 * tion.
2204 *
2205 * Further Details
2206 * ===============
2207 *
2208 * On entry, the array IRAND stored in the common block RANCOM contains
2209 * the information (2 integers) required to generate the next number in
2210 * the sequence X( n ). This number is computed as
2211 *
2212 * X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2213 *
2214 * where the constant d is the largest 32 bit positive integer. The
2215 * array IRAND is then updated for the generation of the next number
2216 * X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2217 * The constants a and c should have been preliminarily stored in the
2218 * array IACS as 2 pairs of integers. The initial set up of IRAND and
2219 * IACS is performed by the routine PB_SETRAN.
2220 *
2221 * -- Written on April 1, 1998 by
2222 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2223 *
2224 * =====================================================================
2225 *
2226 * .. Parameters ..
2227  REAL divfac, pow16
2228  PARAMETER ( divfac = 2.147483648e+9,
2229  $ pow16 = 6.5536e+4 )
2230 * ..
2231 * .. Local Arrays ..
2232  INTEGER j( 2 )
2233 * ..
2234 * .. External Subroutines ..
2235  EXTERNAL pb_ladd, pb_lmul
2236 * ..
2237 * .. Intrinsic Functions ..
2238  INTRINSIC real
2239 * ..
2240 * .. Common Blocks ..
2241  INTEGER iacs( 4 ), irand( 2 )
2242  common /rancom/ irand, iacs
2243 * ..
2244 * .. Save Statements ..
2245  SAVE /rancom/
2246 * ..
2247 * .. Executable Statements ..
2248 *
2249  pb_sran = ( real( irand( 1 ) ) + pow16 * real( irand( 2 ) ) ) /
2250  $ divfac
2251 *
2252  CALL pb_lmul( irand, iacs, j )
2253  CALL pb_ladd( j, iacs( 3 ), irand )
2254 *
2255  RETURN
2256 *
2257 * End of PB_SRAN
2258 *
2259  END
pb_ladd
subroutine pb_ladd(J, K, I)
Definition: pblastst.f:4480
max
#define max(A, B)
Definition: pcgemr.c:180
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_lmul
subroutine pb_lmul(K, J, I)
Definition: pblastst.f:4559
psladom
subroutine psladom(INPLACE, N, ALPHA, A, IA, JA, DESCA)
Definition: psblastst.f:8244
pslagen
subroutine pslagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: psblastst.f:7846
pb_desctrans
subroutine pb_desctrans(DESCIN, DESCOUT)
Definition: pblastst.f:2964
pb_slagen
subroutine pb_slagen(UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB, LNBLOC, JMP, IMULADD)
Definition: psblastst.f:9739
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_sran
real function pb_sran(IDUMM)
Definition: pcblastst.f:11552
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
pslascal
subroutine pslascal(TYPE, M, N, ALPHA, A, IA, JA, DESCA)
Definition: psblastst.f:7338
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_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
pb_slascal
subroutine pb_slascal(UPLO, M, N, IOFFD, ALPHA, A, LDA)
Definition: psblastst.f:9558
pb_locinfo
subroutine pb_locinfo(I, INB, NB, MYROC, SRCPROC, NPROCS, ILOCBLK, ILOCOFF, MYDIST)
Definition: pblastst.f:3910
min
#define min(A, B)
Definition: pcgemr.c:181