OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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.NE. IF( INFO0 ) THEN
784 CALL PXERBLA( ICTXT, 'pclagen', -INFO )
785 RETURN
786 END IF
787*
788* Quick return if possible
789*
790.LE..OR..LE. IF( ( M0 )( N0 ) )
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.OR..OR. IF( SYMM HERM 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.OR..OR..NOT. IF( SYMM HERM ( 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.GE. IF( IOFFDA0 ) 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.EQ. IF( N0 )
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.LT. IF( DESCA2( RSRC_ )0 ) THEN
1109 PMB = MB
1110 ELSE
1111 PMB = NPROW * MB
1112 END IF
1113.LT. IF( DESCA2( CSRC_ )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.GT. GODOWN = ( LCMT00IUPP )
1123.LT. GOLEFT = ( LCMT00ILOW )
1124*
1125.NOT..AND..NOT. IF( GODOWN GOLEFT ) THEN
1126*
1127* LCMT00 >= ILOW && LCMT00 <= IUPP
1128*
1129.GE. IF( LCMT000 ) 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.LT. GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
1147.NOT. GODOWN = 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.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) 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.GT..AND..GE. IF( MBLKD0 LCMTILOW ) THEN
1172.EQ. IF( MBLKD1 )
1173 $ MBLOC = LMBLOC
1174.GE. IF( LCMT0 ) 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.GT..AND..LT. IF( NBLKS0 LCMT00LOW ) 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.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
1225.EQ. IF( NBLKD1 )
1226 $ NBLOC = LNBLOC
1227.GE. IF( LCMT0 ) 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.GT. IF( NBLKS0 ) THEN
1262.EQ. IF( NBLKS1 )
1263 $ NBLOC = LNBLOC
1264 120 CONTINUE
1265.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) 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.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
1279.EQ. IF( MBLKD1 )
1280 $ MBLOC = LMBLOC
1281.GE. IF( LCMT0 ) 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.LE..OR..LE. IF( M0 N0 )
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.EQ. IF( JBLK1 ) THEN
1664 JB = INBLOC
1665.EQ. ELSE IF( JBLKNBLKS ) 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.EQ. IF( IBLK1 ) THEN
1678 IB = IMBLOC
1679.EQ. ELSE IF( IBLKMBLKS ) 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.EQ. IF( IBLK1 ) 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) THEN
1759 IB = IMBLOC
1760.EQ. ELSE IF( IBLKMBLKS ) 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.EQ. IF( JBLK1 ) THEN
1773 JB = INBLOC
1774.EQ. ELSE IF( JBLKNBLKS ) 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) 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.EQ. IF( JBLK1 ) THEN
1858 JB = INBLOC
1859 LOW = 1 - INBLOC
1860.EQ. ELSE IF( JBLKNBLKS ) 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.EQ. IF( IBLK1 ) THEN
1876 IB = IMBLOC
1877 UPP = IMBLOC - 1
1878.EQ. ELSE IF( IBLKMBLKS ) 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.GT. IF( LCMTRUPP ) 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.GE. ELSE IF( LCMTRLOW ) THEN
1896*
1897 JTMP = JK - JJ + 1
1898 MNB = MAX( 0, -LCMTR )
1899*
1900.LE. IF( JTMPMIN( 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.GE..AND. ELSE IF( ( JTMP( MNB + 1 ) )
1908.LE. $ ( JTMPMIN( 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.EQ. IF( IBLK1 ) 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) THEN
2006 IB = IMBLOC
2007 UPP = IMBLOC - 1
2008.EQ. ELSE IF( IBLKMBLKS ) 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.EQ. IF( JBLK1 ) THEN
2024 JB = INBLOC
2025 LOW = 1 - INBLOC
2026.EQ. ELSE IF( JBLKNBLKS ) 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.LT. IF( LCMTCLOW ) THEN
2037*
2038 DO 180 JK = JJ, JJ + JB - 1
2039 DUMMY = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
2040 180 CONTINUE
2041*
2042.LE. ELSE IF( LCMTCUPP ) THEN
2043*
2044 ITMP = IK - II + 1
2045 MNB = MAX( 0, LCMTC )
2046*
2047.LE. IF( ITMPMIN( 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.GE..AND. ELSE IF( ( ITMP( MNB + 1 ) )
2055.LE. $ ( ITMPMIN( 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) 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.EQ. IF( IBLK1 ) THEN
2155 IB = IMBLOC
2156.EQ. ELSE IF( IBLKMBLKS ) 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.EQ. IF( JBLK1 ) THEN
2169 JB = INBLOC
2170.EQ. ELSE IF( JBLKNBLKS ) 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) 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.EQ. IF( JBLK1 ) THEN
2256 JB = INBLOC
2257 LOW = 1 - INBLOC
2258.EQ. ELSE IF( JBLKNBLKS ) 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.EQ. IF( IBLK1 ) THEN
2274 IB = IMBLOC
2275 UPP = IMBLOC - 1
2276.EQ. ELSE IF( IBLKMBLKS ) 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.GT. IF( LCMTRUPP ) 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.GE. ELSE IF( LCMTRLOW ) THEN
2294*
2295 JTMP = JK - JJ + 1
2296 MNB = MAX( 0, -LCMTR )
2297*
2298.LE. IF( JTMPMIN( 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.GE..AND. ELSE IF( ( JTMP( MNB + 1 ) )
2306.LE. $ ( JTMPMIN( 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.LE. IF( ITMP( 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.EQ. IF( IBLK1 ) 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) THEN
2411 IB = IMBLOC
2412 UPP = IMBLOC - 1
2413.EQ. ELSE IF( IBLKMBLKS ) 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.EQ. IF( JBLK1 ) THEN
2429 JB = INBLOC
2430 LOW = 1 - INBLOC
2431.EQ. ELSE IF( JBLKNBLKS ) 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.LT. IF( LCMTCLOW ) 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.LE. ELSE IF( LCMTCUPP ) THEN
2449*
2450 ITMP = IK - II + 1
2451 MNB = MAX( 0, LCMTC )
2452*
2453.LE. IF( ITMPMIN( 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.GE..AND. ELSE IF( ( ITMP( MNB + 1 ) )
2461.LE. $ ( ITMPMIN( 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.LE. IF( JTMP( 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.EQ. IF( JBLK1 ) 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.EQ. IF( IBLK1 ) 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:136
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
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_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_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
pclagen
subroutine pclagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition pcblastim.f:510
pclascal
subroutine pclascal(type, m, n, alpha, a, ia, ja, desca)
Definition pcblastim.f:2
pcladom
subroutine pcladom(inplace, n, alpha, a, ia, ja, desca)
Definition pcblastim.f:913
pb_clagen
subroutine pb_clagen(uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
Definition pcblastim.f:1501
pb_clascal
subroutine pb_clascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pcblastim.f:1320