ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pcblastim.f
Go to the documentation of this file.
1  SUBROUTINE pclascal( 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  COMPLEX ALPHA
12 * ..
13 * .. Array Arguments ..
14  INTEGER DESCA( * )
15  COMPLEX A( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PCLASCAL 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) COMPLEX
108 * On entry, ALPHA specifies the scalar alpha.
109 *
110 * A (local input/local output) COMPLEX 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_clascal, pb_desctrans, pb_infog2l
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_clascal( '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_clascal( 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_clascal( '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_clascal( '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_clascal( '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_clascal( 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_clascal( '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_clascal( '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_clascal( '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_clascal( 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_clascal( '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_clascal( '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_clascal( '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_clascal( 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_clascal( '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_clascal( '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 PCLASCAL
506 *
507  END
508  SUBROUTINE pclagen( 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  COMPLEX A( LDA, * )
524 * ..
525 *
526 * Purpose
527 * =======
528 *
529 * PCLAGEN 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) COMPLEX 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  REAL ZERO
717  parameter( zero = 0.0e+0 )
718 * ..
719 * .. Local Scalars ..
720  LOGICAL DIAGDO, SYMM, HERM, NOTRAN
721  INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
722  $ ilocoff, ilow, imb, imb1, imbloc, imbvir, inb,
723  $ inb1, inbloc, inbvir, info, ioffda, itmp, iupp,
724  $ ivir, jja, jlocblk, jlocoff, jvir, lcmt00,
725  $ lmbloc, lnbloc, low, maxmn, mb, mblks, mp,
726  $ mrcol, mrrow, mycdist, mycol, myrdist, myrow,
727  $ nb, nblks, npcol, nprow, nq, nvir, rsrc, upp
728  COMPLEX ALPHA
729 * ..
730 * .. Local Arrays ..
731  INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
732  $ iran( 2 ), jmp( jmp_len ), muladd0( 4 )
733 * ..
734 * .. External Subroutines ..
735  EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
736  $ pb_chkmat, pb_clagen, pb_desctrans, pb_initjmp,
737  $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
738  $ pb_setlocran, pb_setran, pcladom, pxerbla
739 * ..
740 * .. External Functions ..
741  LOGICAL LSAME
742  EXTERNAL lsame
743 * ..
744 * .. Intrinsic Functions ..
745  INTRINSIC cmplx, max, min, real
746 * ..
747 * .. Data Statements ..
748  DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
749  $ 12345, 0 /
750 * ..
751 * .. Executable Statements ..
752 *
753 * Convert descriptor
754 *
755  CALL pb_desctrans( desca, desca2 )
756 *
757 * Test the input arguments
758 *
759  ictxt = desca2( ctxt_ )
760  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
761 *
762 * Test the input parameters
763 *
764  info = 0
765  IF( nprow.EQ.-1 ) THEN
766  info = -( 1000 + ctxt_ )
767  ELSE
768  symm = lsame( aform, 'S' )
769  herm = lsame( aform, 'H' )
770  notran = lsame( aform, 'N' )
771  diagdo = lsame( diag, 'D' )
772  IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
773  $ .NOT.( lsame( aform, 'T' ) ) .AND.
774  $ .NOT.( lsame( aform, 'C' ) ) ) THEN
775  info = -2
776  ELSE IF( ( .NOT.diagdo ) .AND.
777  $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
778  info = -3
779  END IF
780  CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
781  END IF
782 *
783  IF( info.NE.0 ) THEN
784  CALL pxerbla( ictxt, 'PCLAGEN', -info )
785  RETURN
786  END IF
787 *
788 * Quick return if possible
789 *
790  IF( ( m.LE.0 ).OR.( n.LE.0 ) )
791  $ RETURN
792 *
793 * Start the operations
794 *
795  mb = desca2( mb_ )
796  nb = desca2( nb_ )
797  imb = desca2( imb_ )
798  inb = desca2( inb_ )
799  rsrc = desca2( rsrc_ )
800  csrc = desca2( csrc_ )
801 *
802 * Figure out local information about the distributed matrix operand
803 *
804  CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
805  $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
806  $ iacol, mrrow, mrcol )
807 *
808 * Decide where the entries shall be stored in memory
809 *
810  IF( inplace ) THEN
811  iia = 1
812  jja = 1
813  END IF
814 *
815 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
816 * ILOW, LOW, IUPP, and UPP.
817 *
818  ioffda = ja + offa - ia
819  CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
820  $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
821  $ lmbloc, lnbloc, ilow, low, iupp, upp )
822 *
823 * Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
824 * This values correspond to the square virtual underlying matrix
825 * of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
826 * to set up the random sequence. For practical purposes, the size
827 * of this virtual matrix is upper bounded by M_ + N_ - 1.
828 *
829  itmp = max( 0, -offa )
830  ivir = ia + itmp
831  imbvir = imb + itmp
832  nvir = desca2( m_ ) + itmp
833 *
834  CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
835  $ ilocoff, myrdist )
836 *
837  itmp = max( 0, offa )
838  jvir = ja + itmp
839  inbvir = inb + itmp
840  nvir = max( max( nvir, desca2( n_ ) + itmp ),
841  $ desca2( m_ ) + desca2( n_ ) - 1 )
842 *
843  CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
844  $ jlocoff, mycdist )
845 *
846  IF( symm .OR. herm .OR. notran ) THEN
847 *
848  CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
849  $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
850 *
851 * Compute constants to jump JMP( * ) numbers in the sequence
852 *
853  CALL pb_initmuladd( muladd0, jmp, imuladd )
854 *
855 * Compute and set the random value corresponding to A( IA, JA )
856 *
857  CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
858  $ myrdist, mycdist, nprow, npcol, jmp,
859  $ imuladd, iran )
860 *
861  CALL pb_clagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
862  $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
863  $ nb, lnbloc, jmp, imuladd )
864 *
865  END IF
866 *
867  IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
868 *
869  CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
870  $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
871 *
872 * Compute constants to jump JMP( * ) numbers in the sequence
873 *
874  CALL pb_initmuladd( muladd0, jmp, imuladd )
875 *
876 * Compute and set the random value corresponding to A( IA, JA )
877 *
878  CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
879  $ myrdist, mycdist, nprow, npcol, jmp,
880  $ imuladd, iran )
881 *
882  CALL pb_clagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
883  $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
884  $ nb, lnbloc, jmp, imuladd )
885 *
886  END IF
887 *
888  IF( diagdo ) THEN
889 *
890  maxmn = max( desca2( m_ ), desca2( n_ ) )
891  IF( herm ) THEN
892  alpha = cmplx( real( 2 * maxmn ), zero )
893  ELSE
894  alpha = cmplx( real( maxmn ), real( maxmn ) )
895  END IF
896 *
897  IF( ioffda.GE.0 ) THEN
898  CALL pcladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
899  $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
900  ELSE
901  CALL pcladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
902  $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
903  END IF
904 *
905  END IF
906 *
907  RETURN
908 *
909 * End of PCLAGEN
910 *
911  END
912  SUBROUTINE pcladom( INPLACE, N, ALPHA, A, IA, JA, DESCA )
913 *
914 * -- PBLAS test routine (version 2.0) --
915 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
916 * and University of California, Berkeley.
917 * April 1, 1998
918 *
919 * .. Scalar Arguments ..
920  LOGICAL INPLACE
921  INTEGER IA, JA, N
922  COMPLEX ALPHA
923 * ..
924 * .. Array Arguments ..
925  INTEGER DESCA( * )
926  COMPLEX A( * )
927 * ..
928 *
929 * Purpose
930 * =======
931 *
932 * PCLADOM adds alpha to the diagonal entries of an n by n submatrix
933 * sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
934 *
935 * Notes
936 * =====
937 *
938 * A description vector is associated with each 2D block-cyclicly dis-
939 * tributed matrix. This vector stores the information required to
940 * establish the mapping between a matrix entry and its corresponding
941 * process and memory location.
942 *
943 * In the following comments, the character _ should be read as
944 * "of the distributed matrix". Let A be a generic term for any 2D
945 * block cyclicly distributed matrix. Its description vector is DESCA:
946 *
947 * NOTATION STORED IN EXPLANATION
948 * ---------------- --------------- ------------------------------------
949 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
950 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
951 * the NPROW x NPCOL BLACS process grid
952 * A is distributed over. The context
953 * itself is global, but the handle
954 * (the integer value) may vary.
955 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
956 * ted matrix A, M_A >= 0.
957 * N_A (global) DESCA( N_ ) The number of columns in the distri-
958 * buted matrix A, N_A >= 0.
959 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
960 * block of the matrix A, IMB_A > 0.
961 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
962 * left block of the matrix A,
963 * INB_A > 0.
964 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
965 * bute the last M_A-IMB_A rows of A,
966 * MB_A > 0.
967 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
968 * bute the last N_A-INB_A columns of
969 * A, NB_A > 0.
970 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
971 * row of the matrix A is distributed,
972 * NPROW > RSRC_A >= 0.
973 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
974 * first column of A is distributed.
975 * NPCOL > CSRC_A >= 0.
976 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
977 * array storing the local blocks of
978 * the distributed matrix A,
979 * IF( Lc( 1, N_A ) > 0 )
980 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
981 * ELSE
982 * LLD_A >= 1.
983 *
984 * Let K be the number of rows of a matrix A starting at the global in-
985 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
986 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
987 * receive if these K rows were distributed over NPROW processes. If K
988 * is the number of columns of a matrix A starting at the global index
989 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
990 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
991 * these K columns were distributed over NPCOL processes.
992 *
993 * The values of Lr() and Lc() may be determined via a call to the func-
994 * tion PB_NUMROC:
995 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
996 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
997 *
998 * Arguments
999 * =========
1000 *
1001 * INPLACE (global input) LOGICAL
1002 * On entry, INPLACE specifies if the matrix should be generated
1003 * in place or not. If INPLACE is .TRUE., the local random array
1004 * to be generated will start in memory at the local memory lo-
1005 * cation A( 1, 1 ), otherwise it will start at the local posi-
1006 * tion induced by IA and JA.
1007 *
1008 * N (global input) INTEGER
1009 * On entry, N specifies the global order of the submatrix
1010 * sub( A ) to be modified. N must be at least zero.
1011 *
1012 * ALPHA (global input) COMPLEX
1013 * On entry, ALPHA specifies the scalar alpha.
1014 *
1015 * A (local input/local output) COMPLEX array
1016 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is
1017 * at least Lc( 1, JA+N-1 ). Before entry, this array contains
1018 * the local entries of the matrix A. On exit, the local entries
1019 * of this array corresponding to the main diagonal of sub( A )
1020 * have been updated.
1021 *
1022 * IA (global input) INTEGER
1023 * On entry, IA specifies A's global row index, which points to
1024 * the beginning of the submatrix sub( A ).
1025 *
1026 * JA (global input) INTEGER
1027 * On entry, JA specifies A's global column index, which points
1028 * to the beginning of the submatrix sub( A ).
1029 *
1030 * DESCA (global and local input) INTEGER array
1031 * On entry, DESCA is an integer array of dimension DLEN_. This
1032 * is the array descriptor for the matrix A.
1033 *
1034 * -- Written on April 1, 1998 by
1035 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1036 *
1037 * =====================================================================
1038 *
1039 * .. Parameters ..
1040  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1041  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
1042  $ rsrc_
1043  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1044  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1045  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1046  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1047 * ..
1048 * .. Local Scalars ..
1049  LOGICAL GODOWN, GOLEFT
1050  INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
1051  $ imb1, imbloc, inb1, inbloc, ioffa, ioffd, iupp,
1052  $ jja, joffa, joffd, lcmt, lcmt00, lda, ldap1,
1053  $ lmbloc, lnbloc, low, mb, mblkd, mblks, mbloc,
1054  $ mrcol, mrrow, mycol, myrow, nb, nblkd, nblks,
1055  $ nbloc, np, npcol, nprow, nq, pmb, qnb, upp
1056  COMPLEX ATMP
1057 * ..
1058 * .. Local Scalars ..
1059  INTEGER DESCA2( DLEN_ )
1060 * ..
1061 * .. External Subroutines ..
1062  EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
1063  $ pb_desctrans
1064 * ..
1065 * .. Intrinsic Functions ..
1066  INTRINSIC abs, aimag, cmplx, max, min, real
1067 * ..
1068 * .. Executable Statements ..
1069 *
1070 * Convert descriptor
1071 *
1072  CALL pb_desctrans( desca, desca2 )
1073 *
1074 * Get grid parameters
1075 *
1076  ictxt = desca2( ctxt_ )
1077  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1078 *
1079  IF( n.EQ.0 )
1080  $ RETURN
1081 *
1082  CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
1083  $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
1084  $ iacol, mrrow, mrcol )
1085 *
1086 * Decide where the entries shall be stored in memory
1087 *
1088  IF( inplace ) THEN
1089  iia = 1
1090  jja = 1
1091  END IF
1092 *
1093 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
1094 * ILOW, LOW, IUPP, and UPP.
1095 *
1096  mb = desca2( mb_ )
1097  nb = desca2( nb_ )
1098 *
1099  CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
1100  $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
1101  $ lnbloc, ilow, low, iupp, upp )
1102 *
1103  ioffa = iia - 1
1104  joffa = jja - 1
1105  lda = desca2( lld_ )
1106  ldap1 = lda + 1
1107 *
1108  IF( desca2( rsrc_ ).LT.0 ) THEN
1109  pmb = mb
1110  ELSE
1111  pmb = nprow * mb
1112  END IF
1113  IF( desca2( csrc_ ).LT.0 ) THEN
1114  qnb = nb
1115  ELSE
1116  qnb = npcol * nb
1117  END IF
1118 *
1119 * Handle the first block of rows or columns separately, and update
1120 * LCMT00, MBLKS and NBLKS.
1121 *
1122  godown = ( lcmt00.GT.iupp )
1123  goleft = ( lcmt00.LT.ilow )
1124 *
1125  IF( .NOT.godown .AND. .NOT.goleft ) THEN
1126 *
1127 * LCMT00 >= ILOW && LCMT00 <= IUPP
1128 *
1129  IF( lcmt00.GE.0 ) THEN
1130  ijoffa = ioffa+lcmt00 + ( joffa - 1 ) * lda
1131  DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
1132  atmp = a( ijoffa + i*ldap1 )
1133  a( ijoffa + i*ldap1 ) = alpha +
1134  $ cmplx( abs( real( atmp ) ),
1135  $ abs( aimag( atmp ) ) )
1136  10 CONTINUE
1137  ELSE
1138  ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
1139  DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
1140  atmp = a( ijoffa + i*ldap1 )
1141  a( ijoffa + i*ldap1 ) = alpha +
1142  $ cmplx( abs( real( atmp ) ),
1143  $ abs( aimag( atmp ) ) )
1144  20 CONTINUE
1145  END IF
1146  goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
1147  godown = .NOT.goleft
1148 *
1149  END IF
1150 *
1151  IF( godown ) THEN
1152 *
1153  lcmt00 = lcmt00 - ( iupp - upp + pmb )
1154  mblks = mblks - 1
1155  ioffa = ioffa + imbloc
1156 *
1157  30 CONTINUE
1158  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1159  lcmt00 = lcmt00 - pmb
1160  mblks = mblks - 1
1161  ioffa = ioffa + mb
1162  GO TO 30
1163  END IF
1164 *
1165  lcmt = lcmt00
1166  mblkd = mblks
1167  ioffd = ioffa
1168 *
1169  mbloc = mb
1170  40 CONTINUE
1171  IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
1172  IF( mblkd.EQ.1 )
1173  $ mbloc = lmbloc
1174  IF( lcmt.GE.0 ) THEN
1175  ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1176  DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
1177  atmp = a( ijoffa + i*ldap1 )
1178  a( ijoffa + i*ldap1 ) = alpha +
1179  $ cmplx( abs( real( atmp ) ),
1180  $ abs( aimag( atmp ) ) )
1181  50 CONTINUE
1182  ELSE
1183  ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1184  DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
1185  atmp = a( ijoffa + i*ldap1 )
1186  a( ijoffa + i*ldap1 ) = alpha +
1187  $ cmplx( abs( real( atmp ) ),
1188  $ abs( aimag( atmp ) ) )
1189  60 CONTINUE
1190  END IF
1191  lcmt00 = lcmt
1192  lcmt = lcmt - pmb
1193  mblks = mblkd
1194  mblkd = mblkd - 1
1195  ioffa = ioffd
1196  ioffd = ioffd + mbloc
1197  GO TO 40
1198  END IF
1199 *
1200  lcmt00 = lcmt00 + low - ilow + qnb
1201  nblks = nblks - 1
1202  joffa = joffa + inbloc
1203 *
1204  ELSE IF( goleft ) THEN
1205 *
1206  lcmt00 = lcmt00 + low - ilow + qnb
1207  nblks = nblks - 1
1208  joffa = joffa + inbloc
1209 *
1210  70 CONTINUE
1211  IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
1212  lcmt00 = lcmt00 + qnb
1213  nblks = nblks - 1
1214  joffa = joffa + nb
1215  GO TO 70
1216  END IF
1217 *
1218  lcmt = lcmt00
1219  nblkd = nblks
1220  joffd = joffa
1221 *
1222  nbloc = nb
1223  80 CONTINUE
1224  IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
1225  IF( nblkd.EQ.1 )
1226  $ nbloc = lnbloc
1227  IF( lcmt.GE.0 ) THEN
1228  ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
1229  DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
1230  atmp = a( ijoffa + i*ldap1 )
1231  a( ijoffa + i*ldap1 ) = alpha +
1232  $ cmplx( abs( real( atmp ) ),
1233  $ abs( aimag( atmp ) ) )
1234  90 CONTINUE
1235  ELSE
1236  ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
1237  DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
1238  atmp = a( ijoffa + i*ldap1 )
1239  a( ijoffa + i*ldap1 ) = alpha +
1240  $ cmplx( abs( real( atmp ) ),
1241  $ abs( aimag( atmp ) ) )
1242  100 CONTINUE
1243  END IF
1244  lcmt00 = lcmt
1245  lcmt = lcmt + qnb
1246  nblks = nblkd
1247  nblkd = nblkd - 1
1248  joffa = joffd
1249  joffd = joffd + nbloc
1250  GO TO 80
1251  END IF
1252 *
1253  lcmt00 = lcmt00 - ( iupp - upp + pmb )
1254  mblks = mblks - 1
1255  ioffa = ioffa + imbloc
1256 *
1257  END IF
1258 *
1259  nbloc = nb
1260  110 CONTINUE
1261  IF( nblks.GT.0 ) THEN
1262  IF( nblks.EQ.1 )
1263  $ nbloc = lnbloc
1264  120 CONTINUE
1265  IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1266  lcmt00 = lcmt00 - pmb
1267  mblks = mblks - 1
1268  ioffa = ioffa + mb
1269  GO TO 120
1270  END IF
1271 *
1272  lcmt = lcmt00
1273  mblkd = mblks
1274  ioffd = ioffa
1275 *
1276  mbloc = mb
1277  130 CONTINUE
1278  IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
1279  IF( mblkd.EQ.1 )
1280  $ mbloc = lmbloc
1281  IF( lcmt.GE.0 ) THEN
1282  ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1283  DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
1284  atmp = a( ijoffa + i*ldap1 )
1285  a( ijoffa + i*ldap1 ) = alpha +
1286  $ cmplx( abs( real( atmp ) ),
1287  $ abs( aimag( atmp ) ) )
1288  140 CONTINUE
1289  ELSE
1290  ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1291  DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
1292  atmp = a( ijoffa + i*ldap1 )
1293  a( ijoffa + i*ldap1 ) = alpha +
1294  $ cmplx( abs( real( atmp ) ),
1295  $ abs( aimag( atmp ) ) )
1296  150 CONTINUE
1297  END IF
1298  lcmt00 = lcmt
1299  lcmt = lcmt - pmb
1300  mblks = mblkd
1301  mblkd = mblkd - 1
1302  ioffa = ioffd
1303  ioffd = ioffd + mbloc
1304  GO TO 130
1305  END IF
1306 *
1307  lcmt00 = lcmt00 + qnb
1308  nblks = nblks - 1
1309  joffa = joffa + nbloc
1310  GO TO 110
1311 *
1312  END IF
1313 *
1314  RETURN
1315 *
1316 * End of PCLADOM
1317 *
1318  END
1319  SUBROUTINE pb_clascal( UPLO, M, N, IOFFD, ALPHA, A, LDA )
1320 *
1321 * -- PBLAS test routine (version 2.0) --
1322 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1323 * and University of California, Berkeley.
1324 * April 1, 1998
1325 *
1326 * .. Scalar Arguments ..
1327  CHARACTER*1 UPLO
1328  INTEGER IOFFD, LDA, M, N
1329  COMPLEX ALPHA
1330 * ..
1331 * .. Array Arguments ..
1332  COMPLEX A( LDA, * )
1333 * ..
1334 *
1335 * Purpose
1336 * =======
1337 *
1338 * PB_CLASCAL scales a two-dimensional array A by the scalar alpha.
1339 *
1340 * Arguments
1341 * =========
1342 *
1343 * UPLO (input) CHARACTER*1
1344 * On entry, UPLO specifies which trapezoidal part of the ar-
1345 * ray A is to be scaled as follows:
1346 * = 'L' or 'l': the lower trapezoid of A is scaled,
1347 * = 'U' or 'u': the upper trapezoid of A is scaled,
1348 * = 'D' or 'd': diagonal specified by IOFFD is scaled,
1349 * Otherwise: all of the array A is scaled.
1350 *
1351 * M (input) INTEGER
1352 * On entry, M specifies the number of rows of the array A. M
1353 * must be at least zero.
1354 *
1355 * N (input) INTEGER
1356 * On entry, N specifies the number of columns of the array A.
1357 * N must be at least zero.
1358 *
1359 * IOFFD (input) INTEGER
1360 * On entry, IOFFD specifies the position of the offdiagonal de-
1361 * limiting the upper and lower trapezoidal part of A as follows
1362 * (see the notes below):
1363 *
1364 * IOFFD = 0 specifies the main diagonal A( i, i ),
1365 * with i = 1 ... MIN( M, N ),
1366 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
1367 * with i = 1 ... MIN( M-IOFFD, N ),
1368 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
1369 * with i = 1 ... MIN( M, N+IOFFD ).
1370 *
1371 * ALPHA (input) COMPLEX
1372 * On entry, ALPHA specifies the scalar alpha.
1373 *
1374 * A (input/output) COMPLEX array
1375 * On entry, A is an array of dimension (LDA,N). Before entry
1376 * with UPLO = 'U' or 'u', the leading m by n part of the array
1377 * A must contain the upper trapezoidal part of the matrix as
1378 * specified by IOFFD to be scaled, and the strictly lower tra-
1379 * pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
1380 * the leading m by n part of the array A must contain the lower
1381 * trapezoidal part of the matrix as specified by IOFFD to be
1382 * scaled, and the strictly upper trapezoidal part of A is not
1383 * referenced. On exit, the entries of the trapezoid part of A
1384 * determined by UPLO and IOFFD are scaled.
1385 *
1386 * LDA (input) INTEGER
1387 * On entry, LDA specifies the leading dimension of the array A.
1388 * LDA must be at least max( 1, M ).
1389 *
1390 * Notes
1391 * =====
1392 * N N
1393 * ---------------------------- -----------
1394 * | d | | |
1395 * M | d 'U' | | 'U' |
1396 * | 'L' 'D' | |d |
1397 * | d | M | d |
1398 * ---------------------------- | 'D' |
1399 * | d |
1400 * IOFFD < 0 | 'L' d |
1401 * | d|
1402 * N | |
1403 * ----------- -----------
1404 * | d 'U'|
1405 * | d | IOFFD > 0
1406 * M | 'D' |
1407 * | d| N
1408 * | 'L' | ----------------------------
1409 * | | | 'U' |
1410 * | | |d |
1411 * | | | 'D' |
1412 * | | | d |
1413 * | | |'L' d |
1414 * ----------- ----------------------------
1415 *
1416 * -- Written on April 1, 1998 by
1417 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1418 *
1419 * =====================================================================
1420 *
1421 * .. Local Scalars ..
1422  INTEGER I, J, JTMP, MN
1423 * ..
1424 * .. External Functions ..
1425  LOGICAL LSAME
1426  EXTERNAL lsame
1427 * ..
1428 * .. Intrinsic Functions ..
1429  INTRINSIC max, min
1430 * ..
1431 * .. Executable Statements ..
1432 *
1433 * Quick return if possible
1434 *
1435  IF( m.LE.0 .OR. n.LE.0 )
1436  $ RETURN
1437 *
1438 * Start the operations
1439 *
1440  IF( lsame( uplo, 'L' ) ) THEN
1441 *
1442 * Scales the lower triangular part of the array by ALPHA.
1443 *
1444  mn = max( 0, -ioffd )
1445  DO 20 j = 1, min( mn, n )
1446  DO 10 i = 1, m
1447  a( i, j ) = alpha * a( i, j )
1448  10 CONTINUE
1449  20 CONTINUE
1450  DO 40 j = mn + 1, min( m - ioffd, n )
1451  DO 30 i = j + ioffd, m
1452  a( i, j ) = alpha * a( i, j )
1453  30 CONTINUE
1454  40 CONTINUE
1455 *
1456  ELSE IF( lsame( uplo, 'U' ) ) THEN
1457 *
1458 * Scales the upper triangular part of the array by ALPHA.
1459 *
1460  mn = min( m - ioffd, n )
1461  DO 60 j = max( 0, -ioffd ) + 1, mn
1462  DO 50 i = 1, j + ioffd
1463  a( i, j ) = alpha * a( i, j )
1464  50 CONTINUE
1465  60 CONTINUE
1466  DO 80 j = max( 0, mn ) + 1, n
1467  DO 70 i = 1, m
1468  a( i, j ) = alpha * a( i, j )
1469  70 CONTINUE
1470  80 CONTINUE
1471 *
1472  ELSE IF( lsame( uplo, 'D' ) ) THEN
1473 *
1474 * Scales the diagonal entries by ALPHA.
1475 *
1476  DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
1477  jtmp = j + ioffd
1478  a( jtmp, j ) = alpha * a( jtmp, j )
1479  90 CONTINUE
1480 *
1481  ELSE
1482 *
1483 * Scales the entire array by ALPHA.
1484 *
1485  DO 110 j = 1, n
1486  DO 100 i = 1, m
1487  a( i, j ) = alpha * a( i, j )
1488  100 CONTINUE
1489  110 CONTINUE
1490 *
1491  END IF
1492 *
1493  RETURN
1494 *
1495 * End of PB_CLASCAL
1496 *
1497  END
1498  SUBROUTINE pb_clagen( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
1499  $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
1500  $ LNBLOC, JMP, IMULADD )
1501 *
1502 * -- PBLAS test routine (version 2.0) --
1503 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1504 * and University of California, Berkeley.
1505 * April 1, 1998
1506 *
1507 * .. Scalar Arguments ..
1508  CHARACTER*1 UPLO, AFORM
1509  INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
1510  $ MB, MBLKS, NB, NBLKS
1511 * ..
1512 * .. Array Arguments ..
1513  INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
1514  COMPLEX A( LDA, * )
1515 * ..
1516 *
1517 * Purpose
1518 * =======
1519 *
1520 * PB_CLAGEN locally initializes an array A.
1521 *
1522 * Arguments
1523 * =========
1524 *
1525 * UPLO (global input) CHARACTER*1
1526 * On entry, UPLO specifies whether the lower (UPLO='L') trape-
1527 * zoidal part or the upper (UPLO='U') trapezoidal part is to be
1528 * generated when the matrix to be generated is symmetric or
1529 * Hermitian. For all the other values of AFORM, the value of
1530 * this input argument is ignored.
1531 *
1532 * AFORM (global input) CHARACTER*1
1533 * On entry, AFORM specifies the type of submatrix to be genera-
1534 * ted as follows:
1535 * AFORM = 'S', sub( A ) is a symmetric matrix,
1536 * AFORM = 'H', sub( A ) is a Hermitian matrix,
1537 * AFORM = 'T', sub( A ) is overrwritten with the transpose
1538 * of what would normally be generated,
1539 * AFORM = 'C', sub( A ) is overwritten with the conjugate
1540 * transpose of what would normally be genera-
1541 * ted.
1542 * AFORM = 'N', a random submatrix is generated.
1543 *
1544 * A (local output) COMPLEX array
1545 * On entry, A is an array of dimension (LLD_A, *). On exit,
1546 * this array contains the local entries of the randomly genera-
1547 * ted submatrix sub( A ).
1548 *
1549 * LDA (local input) INTEGER
1550 * On entry, LDA specifies the local leading dimension of the
1551 * array A. LDA must be at least one.
1552 *
1553 * LCMT00 (global input) INTEGER
1554 * On entry, LCMT00 is the LCM value specifying the off-diagonal
1555 * of the underlying matrix of interest. LCMT00=0 specifies the
1556 * main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
1557 * specifies superdiagonals.
1558 *
1559 * IRAN (local input) INTEGER array
1560 * On entry, IRAN is an array of dimension 2 containing respec-
1561 * tively the 16-lower and 16-higher bits of the encoding of the
1562 * entry of the random sequence corresponding locally to the
1563 * first local array entry to generate. Usually, this array is
1564 * computed by PB_SETLOCRAN.
1565 *
1566 * MBLKS (local input) INTEGER
1567 * On entry, MBLKS specifies the local number of blocks of rows.
1568 * MBLKS is at least zero.
1569 *
1570 * IMBLOC (local input) INTEGER
1571 * On entry, IMBLOC specifies the number of rows (size) of the
1572 * local uppest blocks. IMBLOC is at least zero.
1573 *
1574 * MB (global input) INTEGER
1575 * On entry, MB specifies the blocking factor used to partition
1576 * the rows of the matrix. MB must be at least one.
1577 *
1578 * LMBLOC (local input) INTEGER
1579 * On entry, LMBLOC specifies the number of rows (size) of the
1580 * local lowest blocks. LMBLOC is at least zero.
1581 *
1582 * NBLKS (local input) INTEGER
1583 * On entry, NBLKS specifies the local number of blocks of co-
1584 * lumns. NBLKS is at least zero.
1585 *
1586 * INBLOC (local input) INTEGER
1587 * On entry, INBLOC specifies the number of columns (size) of
1588 * the local leftmost blocks. INBLOC is at least zero.
1589 *
1590 * NB (global input) INTEGER
1591 * On entry, NB specifies the blocking factor used to partition
1592 * the the columns of the matrix. NB must be at least one.
1593 *
1594 * LNBLOC (local input) INTEGER
1595 * On entry, LNBLOC specifies the number of columns (size) of
1596 * the local rightmost blocks. LNBLOC is at least zero.
1597 *
1598 * JMP (local input) INTEGER array
1599 * On entry, JMP is an array of dimension JMP_LEN containing the
1600 * different jump values used by the random matrix generator.
1601 *
1602 * IMULADD (local input) INTEGER array
1603 * On entry, IMULADD is an array of dimension (4, JMP_LEN). The
1604 * jth column of this array contains the encoded initial cons-
1605 * tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
1606 * (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
1607 * contains respectively the 16-lower and 16-higher bits of the
1608 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and
1609 * 16-higher bits of the constant c_j.
1610 *
1611 * -- Written on April 1, 1998 by
1612 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1613 *
1614 * =====================================================================
1615 *
1616 * .. Parameters ..
1617  INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
1618  $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
1619  $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
1620  parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
1621  $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
1622  $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
1623  $ jmp_nqnb = 10, jmp_nqinbloc = 11,
1624  $ jmp_len = 11 )
1625  REAL ZERO
1626  PARAMETER ( ZERO = 0.0e+0 )
1627 * ..
1628 * .. Local Scalars ..
1629  INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
1630  $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
1631  COMPLEX DUMMY
1632 * ..
1633 * .. Local Arrays ..
1634  INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
1635 * ..
1636 * .. External Subroutines ..
1637  EXTERNAL pb_jumpit
1638 * ..
1639 * .. External Functions ..
1640  LOGICAL LSAME
1641  REAL PB_SRAND
1642  EXTERNAL LSAME, PB_SRAND
1643 * ..
1644 * .. Intrinsic Functions ..
1645  INTRINSIC cmplx, max, min, real
1646 * ..
1647 * .. Executable Statements ..
1648 *
1649  DO 10 i = 1, 2
1650  ib1( i ) = iran( i )
1651  ib2( i ) = iran( i )
1652  ib3( i ) = iran( i )
1653  10 CONTINUE
1654 *
1655  IF( lsame( aform, 'N' ) ) THEN
1656 *
1657 * Generate random matrix
1658 *
1659  jj = 1
1660 *
1661  DO 50 jblk = 1, nblks
1662 *
1663  IF( jblk.EQ.1 ) THEN
1664  jb = inbloc
1665  ELSE IF( jblk.EQ.nblks ) THEN
1666  jb = lnbloc
1667  ELSE
1668  jb = nb
1669  END IF
1670 *
1671  DO 40 jk = jj, jj + jb - 1
1672 *
1673  ii = 1
1674 *
1675  DO 30 iblk = 1, mblks
1676 *
1677  IF( iblk.EQ.1 ) THEN
1678  ib = imbloc
1679  ELSE IF( iblk.EQ.mblks ) THEN
1680  ib = lmbloc
1681  ELSE
1682  ib = mb
1683  END IF
1684 *
1685 * Blocks are IB by JB
1686 *
1687  DO 20 ik = ii, ii + ib - 1
1688  a( ik, jk ) = cmplx( pb_srand( 0 ), pb_srand( 0 ) )
1689  20 CONTINUE
1690 *
1691  ii = ii + ib
1692 *
1693  IF( iblk.EQ.1 ) THEN
1694 *
1695 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1696 *
1697  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1698  $ ib0 )
1699 *
1700  ELSE
1701 *
1702 * Jump NPROW * MB rows
1703 *
1704  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
1705 *
1706  END IF
1707 *
1708  ib1( 1 ) = ib0( 1 )
1709  ib1( 2 ) = ib0( 2 )
1710 *
1711  30 CONTINUE
1712 *
1713 * Jump one column
1714 *
1715  CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1716 *
1717  ib1( 1 ) = ib0( 1 )
1718  ib1( 2 ) = ib0( 2 )
1719  ib2( 1 ) = ib0( 1 )
1720  ib2( 2 ) = ib0( 2 )
1721 *
1722  40 CONTINUE
1723 *
1724  jj = jj + jb
1725 *
1726  IF( jblk.EQ.1 ) THEN
1727 *
1728 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1729 *
1730  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1731 *
1732  ELSE
1733 *
1734 * Jump NPCOL * NB columns
1735 *
1736  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1737 *
1738  END IF
1739 *
1740  ib1( 1 ) = ib0( 1 )
1741  ib1( 2 ) = ib0( 2 )
1742  ib2( 1 ) = ib0( 1 )
1743  ib2( 2 ) = ib0( 2 )
1744  ib3( 1 ) = ib0( 1 )
1745  ib3( 2 ) = ib0( 2 )
1746 *
1747  50 CONTINUE
1748 *
1749  ELSE IF( lsame( aform, 'T' ) ) THEN
1750 *
1751 * Generate the transpose of the matrix that would be normally
1752 * generated.
1753 *
1754  ii = 1
1755 *
1756  DO 90 iblk = 1, mblks
1757 *
1758  IF( iblk.EQ.1 ) THEN
1759  ib = imbloc
1760  ELSE IF( iblk.EQ.mblks ) THEN
1761  ib = lmbloc
1762  ELSE
1763  ib = mb
1764  END IF
1765 *
1766  DO 80 ik = ii, ii + ib - 1
1767 *
1768  jj = 1
1769 *
1770  DO 70 jblk = 1, nblks
1771 *
1772  IF( jblk.EQ.1 ) THEN
1773  jb = inbloc
1774  ELSE IF( jblk.EQ.nblks ) THEN
1775  jb = lnbloc
1776  ELSE
1777  jb = nb
1778  END IF
1779 *
1780 * Blocks are IB by JB
1781 *
1782  DO 60 jk = jj, jj + jb - 1
1783  a( ik, jk ) = cmplx( pb_srand( 0 ), pb_srand( 0 ) )
1784  60 CONTINUE
1785 *
1786  jj = jj + jb
1787 *
1788  IF( jblk.EQ.1 ) THEN
1789 *
1790 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1791 *
1792  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
1793  $ ib0 )
1794 *
1795  ELSE
1796 *
1797 * Jump NPCOL * NB columns
1798 *
1799  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
1800 *
1801  END IF
1802 *
1803  ib1( 1 ) = ib0( 1 )
1804  ib1( 2 ) = ib0( 2 )
1805 *
1806  70 CONTINUE
1807 *
1808 * Jump one row
1809 *
1810  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
1811 *
1812  ib1( 1 ) = ib0( 1 )
1813  ib1( 2 ) = ib0( 2 )
1814  ib2( 1 ) = ib0( 1 )
1815  ib2( 2 ) = ib0( 2 )
1816 *
1817  80 CONTINUE
1818 *
1819  ii = ii + ib
1820 *
1821  IF( iblk.EQ.1 ) THEN
1822 *
1823 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1824 *
1825  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
1826 *
1827  ELSE
1828 *
1829 * Jump NPROW * MB rows
1830 *
1831  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
1832 *
1833  END IF
1834 *
1835  ib1( 1 ) = ib0( 1 )
1836  ib1( 2 ) = ib0( 2 )
1837  ib2( 1 ) = ib0( 1 )
1838  ib2( 2 ) = ib0( 2 )
1839  ib3( 1 ) = ib0( 1 )
1840  ib3( 2 ) = ib0( 2 )
1841 *
1842  90 CONTINUE
1843 *
1844  ELSE IF( lsame( aform, 'S' ) ) THEN
1845 *
1846 * Generate a symmetric matrix
1847 *
1848  IF( lsame( uplo, 'L' ) ) THEN
1849 *
1850 * generate lower trapezoidal part
1851 *
1852  jj = 1
1853  lcmtc = lcmt00
1854 *
1855  DO 170 jblk = 1, nblks
1856 *
1857  IF( jblk.EQ.1 ) THEN
1858  jb = inbloc
1859  low = 1 - inbloc
1860  ELSE IF( jblk.EQ.nblks ) THEN
1861  jb = lnbloc
1862  low = 1 - nb
1863  ELSE
1864  jb = nb
1865  low = 1 - nb
1866  END IF
1867 *
1868  DO 160 jk = jj, jj + jb - 1
1869 *
1870  ii = 1
1871  lcmtr = lcmtc
1872 *
1873  DO 150 iblk = 1, mblks
1874 *
1875  IF( iblk.EQ.1 ) THEN
1876  ib = imbloc
1877  upp = imbloc - 1
1878  ELSE IF( iblk.EQ.mblks ) THEN
1879  ib = lmbloc
1880  upp = mb - 1
1881  ELSE
1882  ib = mb
1883  upp = mb - 1
1884  END IF
1885 *
1886 * Blocks are IB by JB
1887 *
1888  IF( lcmtr.GT.upp ) THEN
1889 *
1890  DO 100 ik = ii, ii + ib - 1
1891  dummy = cmplx( pb_srand( 0 ),
1892  $ pb_srand( 0 ) )
1893  100 CONTINUE
1894 *
1895  ELSE IF( lcmtr.GE.low ) THEN
1896 *
1897  jtmp = jk - jj + 1
1898  mnb = max( 0, -lcmtr )
1899 *
1900  IF( jtmp.LE.min( mnb, jb ) ) THEN
1901 *
1902  DO 110 ik = ii, ii + ib - 1
1903  a( ik, jk ) = cmplx( pb_srand( 0 ),
1904  $ pb_srand( 0 ) )
1905  110 CONTINUE
1906 *
1907  ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
1908  $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
1909 *
1910  itmp = ii + jtmp + lcmtr - 1
1911 *
1912  DO 120 ik = ii, itmp - 1
1913  dummy = cmplx( pb_srand( 0 ),
1914  $ pb_srand( 0 ) )
1915  120 CONTINUE
1916 *
1917  DO 130 ik = itmp, ii + ib - 1
1918  a( ik, jk ) = cmplx( pb_srand( 0 ),
1919  $ pb_srand( 0 ) )
1920  130 CONTINUE
1921 *
1922  END IF
1923 *
1924  ELSE
1925 *
1926  DO 140 ik = ii, ii + ib - 1
1927  a( ik, jk ) = cmplx( pb_srand( 0 ),
1928  $ pb_srand( 0 ) )
1929  140 CONTINUE
1930 *
1931  END IF
1932 *
1933  ii = ii + ib
1934 *
1935  IF( iblk.EQ.1 ) THEN
1936 *
1937 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
1938 *
1939  lcmtr = lcmtr - jmp( jmp_npimbloc )
1940  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1941  $ ib0 )
1942 *
1943  ELSE
1944 *
1945 * Jump NPROW * MB rows
1946 *
1947  lcmtr = lcmtr - jmp( jmp_npmb )
1948  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
1949  $ ib0 )
1950 *
1951  END IF
1952 *
1953  ib1( 1 ) = ib0( 1 )
1954  ib1( 2 ) = ib0( 2 )
1955 *
1956  150 CONTINUE
1957 *
1958 * Jump one column
1959 *
1960  CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1961 *
1962  ib1( 1 ) = ib0( 1 )
1963  ib1( 2 ) = ib0( 2 )
1964  ib2( 1 ) = ib0( 1 )
1965  ib2( 2 ) = ib0( 2 )
1966 *
1967  160 CONTINUE
1968 *
1969  jj = jj + jb
1970 *
1971  IF( jblk.EQ.1 ) THEN
1972 *
1973 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
1974 *
1975  lcmtc = lcmtc + jmp( jmp_nqinbloc )
1976  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1977 *
1978  ELSE
1979 *
1980 * Jump NPCOL * NB columns
1981 *
1982  lcmtc = lcmtc + jmp( jmp_nqnb )
1983  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1984 *
1985  END IF
1986 *
1987  ib1( 1 ) = ib0( 1 )
1988  ib1( 2 ) = ib0( 2 )
1989  ib2( 1 ) = ib0( 1 )
1990  ib2( 2 ) = ib0( 2 )
1991  ib3( 1 ) = ib0( 1 )
1992  ib3( 2 ) = ib0( 2 )
1993 *
1994  170 CONTINUE
1995 *
1996  ELSE
1997 *
1998 * generate upper trapezoidal part
1999 *
2000  ii = 1
2001  lcmtr = lcmt00
2002 *
2003  DO 250 iblk = 1, mblks
2004 *
2005  IF( iblk.EQ.1 ) THEN
2006  ib = imbloc
2007  upp = imbloc - 1
2008  ELSE IF( iblk.EQ.mblks ) THEN
2009  ib = lmbloc
2010  upp = mb - 1
2011  ELSE
2012  ib = mb
2013  upp = mb - 1
2014  END IF
2015 *
2016  DO 240 ik = ii, ii + ib - 1
2017 *
2018  jj = 1
2019  lcmtc = lcmtr
2020 *
2021  DO 230 jblk = 1, nblks
2022 *
2023  IF( jblk.EQ.1 ) THEN
2024  jb = inbloc
2025  low = 1 - inbloc
2026  ELSE IF( jblk.EQ.nblks ) THEN
2027  jb = lnbloc
2028  low = 1 - nb
2029  ELSE
2030  jb = nb
2031  low = 1 - nb
2032  END IF
2033 *
2034 * Blocks are IB by JB
2035 *
2036  IF( lcmtc.LT.low ) THEN
2037 *
2038  DO 180 jk = jj, jj + jb - 1
2039  dummy = cmplx( pb_srand( 0 ), pb_srand( 0 ) )
2040  180 CONTINUE
2041 *
2042  ELSE IF( lcmtc.LE.upp ) THEN
2043 *
2044  itmp = ik - ii + 1
2045  mnb = max( 0, lcmtc )
2046 *
2047  IF( itmp.LE.min( mnb, ib ) ) THEN
2048 *
2049  DO 190 jk = jj, jj + jb - 1
2050  a( ik, jk ) = cmplx( pb_srand( 0 ),
2051  $ pb_srand( 0 ) )
2052  190 CONTINUE
2053 *
2054  ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2055  $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2056 *
2057  jtmp = jj + itmp - lcmtc - 1
2058 *
2059  DO 200 jk = jj, jtmp - 1
2060  dummy = cmplx( pb_srand( 0 ),
2061  $ pb_srand( 0 ) )
2062  200 CONTINUE
2063 *
2064  DO 210 jk = jtmp, jj + jb - 1
2065  a( ik, jk ) = cmplx( pb_srand( 0 ),
2066  $ pb_srand( 0 ) )
2067  210 CONTINUE
2068 *
2069  END IF
2070 *
2071  ELSE
2072 *
2073  DO 220 jk = jj, jj + jb - 1
2074  a( ik, jk ) = cmplx( pb_srand( 0 ),
2075  $ pb_srand( 0 ) )
2076  220 CONTINUE
2077 *
2078  END IF
2079 *
2080  jj = jj + jb
2081 *
2082  IF( jblk.EQ.1 ) THEN
2083 *
2084 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
2085 *
2086  lcmtc = lcmtc + jmp( jmp_nqinbloc )
2087  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2088  $ ib0 )
2089 *
2090  ELSE
2091 *
2092 * Jump NPCOL * NB columns
2093 *
2094  lcmtc = lcmtc + jmp( jmp_nqnb )
2095  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2096  $ ib0 )
2097 *
2098  END IF
2099 *
2100  ib1( 1 ) = ib0( 1 )
2101  ib1( 2 ) = ib0( 2 )
2102 *
2103  230 CONTINUE
2104 *
2105 * Jump one row
2106 *
2107  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2108 *
2109  ib1( 1 ) = ib0( 1 )
2110  ib1( 2 ) = ib0( 2 )
2111  ib2( 1 ) = ib0( 1 )
2112  ib2( 2 ) = ib0( 2 )
2113 *
2114  240 CONTINUE
2115 *
2116  ii = ii + ib
2117 *
2118  IF( iblk.EQ.1 ) THEN
2119 *
2120 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
2121 *
2122  lcmtr = lcmtr - jmp( jmp_npimbloc )
2123  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2124 *
2125  ELSE
2126 *
2127 * Jump NPROW * MB rows
2128 *
2129  lcmtr = lcmtr - jmp( jmp_npmb )
2130  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2131 *
2132  END IF
2133 *
2134  ib1( 1 ) = ib0( 1 )
2135  ib1( 2 ) = ib0( 2 )
2136  ib2( 1 ) = ib0( 1 )
2137  ib2( 2 ) = ib0( 2 )
2138  ib3( 1 ) = ib0( 1 )
2139  ib3( 2 ) = ib0( 2 )
2140 *
2141  250 CONTINUE
2142 *
2143  END IF
2144 *
2145  ELSE IF( lsame( aform, 'C' ) ) THEN
2146 *
2147 * Generate the conjugate transpose of the matrix that would be
2148 * normally generated.
2149 *
2150  ii = 1
2151 *
2152  DO 290 iblk = 1, mblks
2153 *
2154  IF( iblk.EQ.1 ) THEN
2155  ib = imbloc
2156  ELSE IF( iblk.EQ.mblks ) THEN
2157  ib = lmbloc
2158  ELSE
2159  ib = mb
2160  END IF
2161 *
2162  DO 280 ik = ii, ii + ib - 1
2163 *
2164  jj = 1
2165 *
2166  DO 270 jblk = 1, nblks
2167 *
2168  IF( jblk.EQ.1 ) THEN
2169  jb = inbloc
2170  ELSE IF( jblk.EQ.nblks ) THEN
2171  jb = lnbloc
2172  ELSE
2173  jb = nb
2174  END IF
2175 *
2176 * Blocks are IB by JB
2177 *
2178  DO 260 jk = jj, jj + jb - 1
2179  a( ik, jk ) = cmplx( pb_srand( 0 ),
2180  $ -pb_srand( 0 ) )
2181  260 CONTINUE
2182 *
2183  jj = jj + jb
2184 *
2185  IF( jblk.EQ.1 ) THEN
2186 *
2187 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
2188 *
2189  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2190  $ ib0 )
2191 *
2192  ELSE
2193 *
2194 * Jump NPCOL * NB columns
2195 *
2196  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2197  $ ib0 )
2198 *
2199  END IF
2200 *
2201  ib1( 1 ) = ib0( 1 )
2202  ib1( 2 ) = ib0( 2 )
2203 *
2204  270 CONTINUE
2205 *
2206 * Jump one row
2207 *
2208  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2209 *
2210  ib1( 1 ) = ib0( 1 )
2211  ib1( 2 ) = ib0( 2 )
2212  ib2( 1 ) = ib0( 1 )
2213  ib2( 2 ) = ib0( 2 )
2214 *
2215  280 CONTINUE
2216 *
2217  ii = ii + ib
2218 *
2219  IF( iblk.EQ.1 ) THEN
2220 *
2221 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
2222 *
2223  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2224 *
2225  ELSE
2226 *
2227 * Jump NPROW * MB rows
2228 *
2229  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2230 *
2231  END IF
2232 *
2233  ib1( 1 ) = ib0( 1 )
2234  ib1( 2 ) = ib0( 2 )
2235  ib2( 1 ) = ib0( 1 )
2236  ib2( 2 ) = ib0( 2 )
2237  ib3( 1 ) = ib0( 1 )
2238  ib3( 2 ) = ib0( 2 )
2239 *
2240  290 CONTINUE
2241 *
2242  ELSE IF( lsame( aform, 'H' ) ) THEN
2243 *
2244 * Generate a Hermitian matrix
2245 *
2246  IF( lsame( uplo, 'L' ) ) THEN
2247 *
2248 * generate lower trapezoidal part
2249 *
2250  jj = 1
2251  lcmtc = lcmt00
2252 *
2253  DO 370 jblk = 1, nblks
2254 *
2255  IF( jblk.EQ.1 ) THEN
2256  jb = inbloc
2257  low = 1 - inbloc
2258  ELSE IF( jblk.EQ.nblks ) THEN
2259  jb = lnbloc
2260  low = 1 - nb
2261  ELSE
2262  jb = nb
2263  low = 1 - nb
2264  END IF
2265 *
2266  DO 360 jk = jj, jj + jb - 1
2267 *
2268  ii = 1
2269  lcmtr = lcmtc
2270 *
2271  DO 350 iblk = 1, mblks
2272 *
2273  IF( iblk.EQ.1 ) THEN
2274  ib = imbloc
2275  upp = imbloc - 1
2276  ELSE IF( iblk.EQ.mblks ) THEN
2277  ib = lmbloc
2278  upp = mb - 1
2279  ELSE
2280  ib = mb
2281  upp = mb - 1
2282  END IF
2283 *
2284 * Blocks are IB by JB
2285 *
2286  IF( lcmtr.GT.upp ) THEN
2287 *
2288  DO 300 ik = ii, ii + ib - 1
2289  dummy = cmplx( pb_srand( 0 ),
2290  $ pb_srand( 0 ) )
2291  300 CONTINUE
2292 *
2293  ELSE IF( lcmtr.GE.low ) THEN
2294 *
2295  jtmp = jk - jj + 1
2296  mnb = max( 0, -lcmtr )
2297 *
2298  IF( jtmp.LE.min( mnb, jb ) ) THEN
2299 *
2300  DO 310 ik = ii, ii + ib - 1
2301  a( ik, jk ) = cmplx( pb_srand( 0 ),
2302  $ pb_srand( 0 ) )
2303  310 CONTINUE
2304 *
2305  ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
2306  $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
2307 *
2308  itmp = ii + jtmp + lcmtr - 1
2309 *
2310  DO 320 ik = ii, itmp - 1
2311  dummy = cmplx( pb_srand( 0 ),
2312  $ pb_srand( 0 ) )
2313  320 CONTINUE
2314 *
2315  IF( itmp.LE.( ii + ib - 1 ) ) THEN
2316  dummy = cmplx( pb_srand( 0 ),
2317  $ -pb_srand( 0 ) )
2318  a( itmp, jk ) = cmplx( real( dummy ),
2319  $ zero )
2320  END IF
2321 *
2322  DO 330 ik = itmp + 1, ii + ib - 1
2323  a( ik, jk ) = cmplx( pb_srand( 0 ),
2324  $ pb_srand( 0 ) )
2325  330 CONTINUE
2326 *
2327  END IF
2328 *
2329  ELSE
2330 *
2331  DO 340 ik = ii, ii + ib - 1
2332  a( ik, jk ) = cmplx( pb_srand( 0 ),
2333  $ pb_srand( 0 ) )
2334  340 CONTINUE
2335 *
2336  END IF
2337 *
2338  ii = ii + ib
2339 *
2340  IF( iblk.EQ.1 ) THEN
2341 *
2342 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
2343 *
2344  lcmtr = lcmtr - jmp( jmp_npimbloc )
2345  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
2346  $ ib0 )
2347 *
2348  ELSE
2349 *
2350 * Jump NPROW * MB rows
2351 *
2352  lcmtr = lcmtr - jmp( jmp_npmb )
2353  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
2354  $ ib0 )
2355 *
2356  END IF
2357 *
2358  ib1( 1 ) = ib0( 1 )
2359  ib1( 2 ) = ib0( 2 )
2360 *
2361  350 CONTINUE
2362 *
2363 * Jump one column
2364 *
2365  CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
2366 *
2367  ib1( 1 ) = ib0( 1 )
2368  ib1( 2 ) = ib0( 2 )
2369  ib2( 1 ) = ib0( 1 )
2370  ib2( 2 ) = ib0( 2 )
2371 *
2372  360 CONTINUE
2373 *
2374  jj = jj + jb
2375 *
2376  IF( jblk.EQ.1 ) THEN
2377 *
2378 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
2379 *
2380  lcmtc = lcmtc + jmp( jmp_nqinbloc )
2381  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
2382 *
2383  ELSE
2384 *
2385 * Jump NPCOL * NB columns
2386 *
2387  lcmtc = lcmtc + jmp( jmp_nqnb )
2388  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
2389 *
2390  END IF
2391 *
2392  ib1( 1 ) = ib0( 1 )
2393  ib1( 2 ) = ib0( 2 )
2394  ib2( 1 ) = ib0( 1 )
2395  ib2( 2 ) = ib0( 2 )
2396  ib3( 1 ) = ib0( 1 )
2397  ib3( 2 ) = ib0( 2 )
2398 *
2399  370 CONTINUE
2400 *
2401  ELSE
2402 *
2403 * generate upper trapezoidal part
2404 *
2405  ii = 1
2406  lcmtr = lcmt00
2407 *
2408  DO 450 iblk = 1, mblks
2409 *
2410  IF( iblk.EQ.1 ) THEN
2411  ib = imbloc
2412  upp = imbloc - 1
2413  ELSE IF( iblk.EQ.mblks ) THEN
2414  ib = lmbloc
2415  upp = mb - 1
2416  ELSE
2417  ib = mb
2418  upp = mb - 1
2419  END IF
2420 *
2421  DO 440 ik = ii, ii + ib - 1
2422 *
2423  jj = 1
2424  lcmtc = lcmtr
2425 *
2426  DO 430 jblk = 1, nblks
2427 *
2428  IF( jblk.EQ.1 ) THEN
2429  jb = inbloc
2430  low = 1 - inbloc
2431  ELSE IF( jblk.EQ.nblks ) THEN
2432  jb = lnbloc
2433  low = 1 - nb
2434  ELSE
2435  jb = nb
2436  low = 1 - nb
2437  END IF
2438 *
2439 * Blocks are IB by JB
2440 *
2441  IF( lcmtc.LT.low ) THEN
2442 *
2443  DO 380 jk = jj, jj + jb - 1
2444  dummy = cmplx( pb_srand( 0 ),
2445  $ -pb_srand( 0 ) )
2446  380 CONTINUE
2447 *
2448  ELSE IF( lcmtc.LE.upp ) THEN
2449 *
2450  itmp = ik - ii + 1
2451  mnb = max( 0, lcmtc )
2452 *
2453  IF( itmp.LE.min( mnb, ib ) ) THEN
2454 *
2455  DO 390 jk = jj, jj + jb - 1
2456  a( ik, jk ) = cmplx( pb_srand( 0 ),
2457  $ -pb_srand( 0 ) )
2458  390 CONTINUE
2459 *
2460  ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2461  $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2462 *
2463  jtmp = jj + itmp - lcmtc - 1
2464 *
2465  DO 400 jk = jj, jtmp - 1
2466  dummy = cmplx( pb_srand( 0 ),
2467  $ -pb_srand( 0 ) )
2468  400 CONTINUE
2469 *
2470  IF( jtmp.LE.( jj + jb - 1 ) ) THEN
2471  dummy = cmplx( pb_srand( 0 ),
2472  $ -pb_srand( 0 ) )
2473  a( ik, jtmp ) = cmplx( real( dummy ),
2474  $ zero )
2475  END IF
2476 *
2477  DO 410 jk = jtmp + 1, jj + jb - 1
2478  a( ik, jk ) = cmplx( pb_srand( 0 ),
2479  $ -pb_srand( 0 ) )
2480  410 CONTINUE
2481 *
2482  END IF
2483 *
2484  ELSE
2485 *
2486  DO 420 jk = jj, jj + jb - 1
2487  a( ik, jk ) = cmplx( pb_srand( 0 ),
2488  $ -pb_srand( 0 ) )
2489  420 CONTINUE
2490 *
2491  END IF
2492 *
2493  jj = jj + jb
2494 *
2495  IF( jblk.EQ.1 ) THEN
2496 *
2497 * Jump INBLOC + ( NPCOL - 1 ) * NB columns
2498 *
2499  lcmtc = lcmtc + jmp( jmp_nqinbloc )
2500  CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2501  $ ib0 )
2502 *
2503  ELSE
2504 *
2505 * Jump NPCOL * NB columns
2506 *
2507  lcmtc = lcmtc + jmp( jmp_nqnb )
2508  CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2509  $ ib0 )
2510 *
2511  END IF
2512 *
2513  ib1( 1 ) = ib0( 1 )
2514  ib1( 2 ) = ib0( 2 )
2515 *
2516  430 CONTINUE
2517 *
2518 * Jump one row
2519 *
2520  CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2521 *
2522  ib1( 1 ) = ib0( 1 )
2523  ib1( 2 ) = ib0( 2 )
2524  ib2( 1 ) = ib0( 1 )
2525  ib2( 2 ) = ib0( 2 )
2526 *
2527  440 CONTINUE
2528 *
2529  ii = ii + ib
2530 *
2531  IF( iblk.EQ.1 ) THEN
2532 *
2533 * Jump IMBLOC + ( NPROW - 1 ) * MB rows
2534 *
2535  lcmtr = lcmtr - jmp( jmp_npimbloc )
2536  CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2537 *
2538  ELSE
2539 *
2540 * Jump NPROW * MB rows
2541 *
2542  lcmtr = lcmtr - jmp( jmp_npmb )
2543  CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2544 *
2545  END IF
2546 *
2547  ib1( 1 ) = ib0( 1 )
2548  ib1( 2 ) = ib0( 2 )
2549  ib2( 1 ) = ib0( 1 )
2550  ib2( 2 ) = ib0( 2 )
2551  ib3( 1 ) = ib0( 1 )
2552  ib3( 2 ) = ib0( 2 )
2553 *
2554  450 CONTINUE
2555 *
2556  END IF
2557 *
2558  END IF
2559 *
2560  RETURN
2561 *
2562 * End of PB_CLAGEN
2563 *
2564  END
2565  REAL FUNCTION PB_SRAND( IDUMM )
2566 *
2567 * -- PBLAS test routine (version 2.0) --
2568 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2569 * and University of California, Berkeley.
2570 * April 1, 1998
2571 *
2572 * .. Scalar Arguments ..
2573  INTEGER idumm
2574 * ..
2575 *
2576 * Purpose
2577 * =======
2578 *
2579 * PB_SRAND generates the next number in the random sequence. This func-
2580 * tion ensures that this number will be in the interval ( -1.0, 1.0 ).
2581 *
2582 * Arguments
2583 * =========
2584 *
2585 * IDUMM (local input) INTEGER
2586 * This argument is ignored, but necessary to a FORTRAN 77 func-
2587 * tion.
2588 *
2589 * Further Details
2590 * ===============
2591 *
2592 * On entry, the array IRAND stored in the common block RANCOM contains
2593 * the information (2 integers) required to generate the next number in
2594 * the sequence X( n ). This number is computed as
2595 *
2596 * X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2597 *
2598 * where the constant d is the largest 32 bit positive integer. The
2599 * array IRAND is then updated for the generation of the next number
2600 * X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2601 * The constants a and c should have been preliminarily stored in the
2602 * array IACS as 2 pairs of integers. The initial set up of IRAND and
2603 * IACS is performed by the routine PB_SETRAN.
2604 *
2605 * -- Written on April 1, 1998 by
2606 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2607 *
2608 * =====================================================================
2609 *
2610 * .. Parameters ..
2611  REAL one, two
2612  PARAMETER ( one = 1.0e+0, two = 2.0e+0 )
2613 * ..
2614 * .. External Functions ..
2615  REAL pb_sran
2616  EXTERNAL pb_sran
2617 * ..
2618 * .. Executable Statements ..
2619 *
2620  pb_srand = one - two * pb_sran( idumm )
2621 *
2622  RETURN
2623 *
2624 * End of PB_SRAND
2625 *
2626  END
2627  REAL function pb_sran( idumm )
2628 *
2629 * -- PBLAS test routine (version 2.0) --
2630 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2631 * and University of California, Berkeley.
2632 * April 1, 1998
2633 *
2634 * .. Scalar Arguments ..
2635  INTEGER idumm
2636 * ..
2637 *
2638 * Purpose
2639 * =======
2640 *
2641 * PB_SRAN generates the next number in the random sequence.
2642 *
2643 * Arguments
2644 * =========
2645 *
2646 * IDUMM (local input) INTEGER
2647 * This argument is ignored, but necessary to a FORTRAN 77 func-
2648 * tion.
2649 *
2650 * Further Details
2651 * ===============
2652 *
2653 * On entry, the array IRAND stored in the common block RANCOM contains
2654 * the information (2 integers) required to generate the next number in
2655 * the sequence X( n ). This number is computed as
2656 *
2657 * X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2658 *
2659 * where the constant d is the largest 32 bit positive integer. The
2660 * array IRAND is then updated for the generation of the next number
2661 * X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2662 * The constants a and c should have been preliminarily stored in the
2663 * array IACS as 2 pairs of integers. The initial set up of IRAND and
2664 * IACS is performed by the routine PB_SETRAN.
2665 *
2666 * -- Written on April 1, 1998 by
2667 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2668 *
2669 * =====================================================================
2670 *
2671 * .. Parameters ..
2672  REAL divfac, pow16
2673  PARAMETER ( divfac = 2.147483648e+9,
2674  $ pow16 = 6.5536e+4 )
2675 * ..
2676 * .. Local Arrays ..
2677  INTEGER j( 2 )
2678 * ..
2679 * .. External Subroutines ..
2680  EXTERNAL pb_ladd, pb_lmul
2681 * ..
2682 * .. Intrinsic Functions ..
2683  INTRINSIC real
2684 * ..
2685 * .. Common Blocks ..
2686  INTEGER iacs( 4 ), irand( 2 )
2687  common /rancom/ irand, iacs
2688 * ..
2689 * .. Save Statements ..
2690  SAVE /rancom/
2691 * ..
2692 * .. Executable Statements ..
2693 *
2694  pb_sran = ( real( irand( 1 ) ) + pow16 * real( irand( 2 ) ) ) /
2695  $ divfac
2696 *
2697  CALL pb_lmul( irand, iacs, j )
2698  CALL pb_ladd( j, iacs( 3 ), irand )
2699 *
2700  RETURN
2701 *
2702 * End of PB_SRAN
2703 *
2704  END
cmplx
float cmplx[2]
Definition: pblas.h:132
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
pclagen
subroutine pclagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: pcblastst.f:8491
pb_lmul
subroutine pb_lmul(K, J, I)
Definition: pblastst.f:4559
pb_clascal
subroutine pb_clascal(UPLO, M, N, IOFFD, ALPHA, A, LDA)
Definition: pcblastst.f:10244
pb_desctrans
subroutine pb_desctrans(DESCIN, DESCOUT)
Definition: pblastst.f:2964
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
pb_clagen
subroutine pb_clagen(UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB, LNBLOC, JMP, IMULADD)
Definition: pcblastst.f:10425
pcladom
subroutine pcladom(INPLACE, N, ALPHA, A, IA, JA, DESCA)
Definition: pcblastst.f:8894
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_locinfo
subroutine pb_locinfo(I, INB, NB, MYROC, SRCPROC, NPROCS, ILOCBLK, ILOCOFF, MYDIST)
Definition: pblastst.f:3910
pclascal
subroutine pclascal(TYPE, M, N, ALPHA, A, IA, JA, DESCA)
Definition: pcblastst.f:7983
min
#define min(A, B)
Definition: pcgemr.c:181