SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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_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_ladd
subroutine pb_ladd(j, k, i)
Definition pblastst.f:4480
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_setran
subroutine pb_setran(iran, iac)
Definition pblastst.f:4759
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastst.f:3910
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastst.f:2742
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastst.f:4559
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastst.f:4648
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastst.f:4302
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastst.f:4196
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastst.f:2964
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastst.f:4045
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822
pb_sran
real function pb_sran(idumm)
Definition pcblastst.f:11552
pb_srand
real function pb_srand(idumm)
Definition pcblastst.f:11490
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pb_slascal
subroutine pb_slascal(uplo, m, n, ioffd, alpha, a, lda)
Definition psblastst.f:9558
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
pslascal
subroutine pslascal(type, m, n, alpha, a, ia, ja, desca)
Definition psblastst.f:7338
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
pxerbla
subroutine pxerbla(ictxt, srname, info)
Definition pxerbla.f:2