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