3
4
5
6
7
8
9
10 CHARACTER SIDE, TRANS, VECT
11 INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N
12
13
14 INTEGER DESCA( * ), DESCC( * )
15 COMPLEX*16 A( * ), C( * ), TAU( * ), WORK( * )
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
284 $ LLD_, MB_, M_, NB_, N_, RSRC_
285 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
286 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
287 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
288
289
290 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
291 CHARACTER TRANST
292 INTEGER IAA, IACOL, IAROW, ICC, ICCOL, ICOFFA, ICOFFC,
293 $ ICROW, ICTXT, IINFO, IROFFA, IROFFC, JAA, JCC,
294 $ LCM, LCMP, LCMQ, LWMIN, MI, MPC0, MQA0, MYCOL,
295 $ MYROW, NI, NPA0, NPCOL, NPROW, NQ, NQC0
296
297
298 INTEGER IDUM1( 5 ), IDUM2( 5 )
299
300
303
304
305 LOGICAL LSAME
306 INTEGER ILCM, INDXG2P, NUMROC
308
309
310 INTRINSIC dble, dcmplx, ichar,
max, mod
311
312
313
314
315
316 ictxt = desca( ctxt_ )
317 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
318
319
320
321 info = 0
322 IF( nprow.EQ.-1 ) THEN
323 info = -(1000+ctxt_)
324 ELSE
325 applyq =
lsame( vect,
'Q' )
326 left =
lsame( side,
'L' )
327 notran =
lsame( trans,
'N' )
328
329
330
331 IF( left ) THEN
332 nq = m
333 IF( ( applyq .AND. nq.GE.k ) .OR.
334 $ ( .NOT.applyq .AND. nq.GT.k ) ) THEN
335 iaa = ia
336 jaa = ja
337 mi = m
338 ni = n
339 icc = ic
340 jcc = jc
341 ELSE
342 iaa = ia + 1
343 jaa = ja
344 mi = m - 1
345 ni = n
346 icc = ic + 1
347 jcc = jc
348 END IF
349
350 IF( applyq ) THEN
351 CALL chk1mat( m, 4, k, 6, ia, ja, desca, 10, info )
352 ELSE
353 CALL chk1mat( k, 6, m, 4, ia, ja, desca, 10, info )
354 END IF
355 ELSE
356 nq = n
357 IF( ( applyq .AND. nq.GE.k ) .OR.
358 $ ( .NOT.applyq .AND. nq.GT.k ) ) THEN
359 iaa = ia
360 jaa = ja
361 mi = m
362 ni = n
363 icc = ic
364 jcc = jc
365 ELSE
366 iaa = ia
367 jaa = ja + 1
368 mi = m
369 ni = n - 1
370 icc = ic
371 jcc = jc + 1
372 END IF
373
374 IF( applyq ) THEN
375 CALL chk1mat( n, 5, k, 6, ia, ja, desca, 10, info )
376 ELSE
377 CALL chk1mat( k, 6, n, 5, ia, ja, desca, 10, info )
378 END IF
379 END IF
380 CALL chk1mat( m, 4, n, 5, ic, jc, descc, 15, info )
381
382 IF( info.EQ.0 ) THEN
383 iroffa = mod( iaa-1, desca( mb_ ) )
384 icoffa = mod( jaa-1, desca( nb_ ) )
385 iroffc = mod( icc-1, descc( mb_ ) )
386 icoffc = mod( jcc-1, descc( nb_ ) )
387 iacol =
indxg2p( jaa, desca( nb_ ), mycol, desca( csrc_ ),
388 $ npcol )
389 iarow =
indxg2p( iaa, desca( mb_ ), myrow, desca( rsrc_ ),
390 $ nprow )
391 icrow =
indxg2p( icc, descc( mb_ ), myrow, descc( rsrc_ ),
392 $ nprow )
393 iccol =
indxg2p( jcc, descc( nb_ ), mycol, descc( csrc_ ),
394 $ npcol )
395 mpc0 =
numroc( mi+iroffc, descc( mb_ ), myrow, icrow,
396 $ nprow )
397 nqc0 =
numroc( ni+icoffc, descc( nb_ ), mycol, iccol,
398 $ npcol )
399
400 IF( applyq ) THEN
401 IF( left ) THEN
402 lwmin =
max( ( desca( nb_ ) * ( desca( nb_ ) - 1 ) )
403 $ / 2, ( mpc0 + nqc0 ) * desca( nb_ ) ) +
404 $ desca( nb_ ) * desca( nb_ )
405 ELSE
406 npa0 =
numroc( ni+iroffa, desca( mb_ ), myrow, iarow,
407 $ nprow )
408 lcm =
ilcm( nprow, npcol )
409 lcmq = lcm / npcol
410 lwmin =
max( ( desca( nb_ ) * ( desca( nb_ ) - 1 ) )
412 $ ni+icoffc, desca( nb_ ), 0, 0, npcol ),
413 $ desca( nb_ ), 0, 0, lcmq ), mpc0 ) ) *
414 $ desca( nb_ ) ) + desca( nb_ ) * desca( nb_ )
415 END IF
416 ELSE
417
418 IF( left ) THEN
419 mqa0 =
numroc( mi+icoffa, desca( nb_ ), mycol, iacol,
420 $ npcol )
421 lcm =
ilcm( nprow, npcol )
422 lcmp = lcm / nprow
423 lwmin =
max( ( desca( mb_ ) * ( desca( mb_ ) - 1 ) )
425 $ mi+iroffc, desca( mb_ ), 0, 0, nprow ),
426 $ desca( mb_ ), 0, 0, lcmp ), nqc0 ) ) *
427 $ desca( mb_ ) ) + desca( mb_ ) * desca( mb_ )
428 ELSE
429 lwmin =
max( ( desca( mb_ ) * ( desca( mb_ ) - 1 ) )
430 $ / 2, ( mpc0 + nqc0 ) * desca( mb_ ) ) +
431 $ desca( mb_ ) * desca( mb_ )
432 END IF
433
434 END IF
435
436 work( 1 ) = dcmplx( dble( lwmin ) )
437 lquery = ( lwork.EQ.-1 )
438 IF( .NOT.applyq .AND. .NOT.
lsame( vect,
'P' ) )
THEN
439 info = -1
440 ELSE IF( .NOT.left .AND. .NOT.
lsame( side,
'R' ) )
THEN
441 info = -2
442 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'C' ) )
THEN
443 info = -3
444 ELSE IF( k.LT.0 ) THEN
445 info = -6
446 ELSE IF( applyq .AND. .NOT.left .AND.
447 $ desca( mb_ ).NE.descc( nb_ ) ) THEN
448 info = -(1000+nb_)
449 ELSE IF( applyq .AND. left .AND. iroffa.NE.iroffc ) THEN
450 info = -13
451 ELSE IF( applyq .AND. left .AND. iarow.NE.icrow ) THEN
452 info = -13
453 ELSE IF( .NOT.applyq .AND. left .AND.
454 $ icoffa.NE.iroffc ) THEN
455 info = -13
456 ELSE IF( .NOT.applyq .AND. .NOT.left .AND.
457 $ iacol.NE.iccol ) THEN
458 info = -14
459 ELSE IF( applyq .AND. .NOT.left .AND.
460 $ iroffa.NE.icoffc ) THEN
461 info = -14
462 ELSE IF( .NOT.applyq .AND. .NOT.left .AND.
463 $ icoffa.NE.icoffc ) THEN
464 info = -14
465 ELSE IF( applyq .AND. left .AND.
466 $ desca( mb_ ).NE.descc( mb_ ) ) THEN
467 info = -(1500+mb_)
468 ELSE IF( .NOT.applyq .AND. left .AND.
469 $ desca( mb_ ).NE.descc( mb_ ) ) THEN
470 info = -(1500+mb_)
471 ELSE IF( applyq .AND. .NOT.left .AND.
472 $ desca( mb_ ).NE.descc( nb_ ) ) THEN
473 info = -(1500+nb_)
474 ELSE IF( .NOT.applyq .AND. .NOT.left .AND.
475 $ desca( nb_ ).NE.descc( nb_ ) ) THEN
476 info = -(1500+nb_)
477 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
478 info = -17
479 END IF
480 END IF
481
482 IF( applyq ) THEN
483 idum1( 1 ) = ichar( 'Q' )
484 ELSE
485 idum1( 1 ) = ichar( 'P' )
486 END IF
487 idum2( 1 ) = 1
488 IF( left ) THEN
489 idum1( 2 ) = ichar( 'L' )
490 ELSE
491 idum1( 2 ) = ichar( 'R' )
492 END IF
493 idum2( 2 ) = 2
494 IF( notran ) THEN
495 idum1( 3 ) = ichar( 'N' )
496 ELSE
497 idum1( 3 ) = ichar( 'C' )
498 END IF
499 idum2( 3 ) = 3
500 idum1( 4 ) = k
501 idum2( 4 ) = 6
502 IF( lwork.EQ.-1 ) THEN
503 idum1( 5 ) = -1
504 ELSE
505 idum1( 5 ) = 1
506 END IF
507 idum2( 5 ) = 17
508 IF( applyq ) THEN
509 IF( left ) THEN
510 CALL pchk2mat( m, 4, k, 6, ia, ja, desca, 10, m, 4, n,
511 $ 5, ic, jc, descc, 15, 5, idum1, idum2,
512 $ info )
513 ELSE
514 CALL pchk2mat( n, 5, k, 6, ia, ja, desca, 10, m, 4, n,
515 $ 5, ic, jc, descc, 15, 5, idum1, idum2,
516 $ info )
517 END IF
518 ELSE
519 IF( left ) THEN
520 CALL pchk2mat( k, 6, m, 4, ia, ja, desca, 10, m, 4, n,
521 $ 5, ic, jc, descc, 15, 5, idum1, idum2,
522 $ info )
523 ELSE
524 CALL pchk2mat( k, 6, n, 5, ia, ja, desca, 10, m, 4, n,
525 $ 5, ic, jc, descc, 15, 5, idum1, idum2,
526 $ info )
527 END IF
528 END IF
529 END IF
530
531 IF( info.NE.0 ) THEN
532 CALL pxerbla( ictxt,
'PZUNMBR', -info )
533 RETURN
534 ELSE IF( lquery ) THEN
535 RETURN
536 END IF
537
538
539
540 IF( m.EQ.0 .OR. n.EQ.0 )
541 $ RETURN
542
543 IF( applyq ) THEN
544
545
546
547 IF( nq.GE.k ) THEN
548
549
550
551 CALL pzunmqr( side, trans, m, n, k, a, ia, ja, desca, tau,
552 $ c, ic, jc, descc, work, lwork, iinfo )
553 ELSE IF( nq.GT.1 ) THEN
554
555
556
557 CALL pzunmqr( side, trans, mi, ni, nq-1, a, ia+1, ja, desca,
558 $ tau, c, icc, jcc, descc, work, lwork, iinfo )
559 END IF
560 ELSE
561
562
563
564 IF( notran ) THEN
565 transt = 'C'
566 ELSE
567 transt = 'N'
568 END IF
569 IF( nq.GT.k ) THEN
570
571
572
573 CALL pzunmlq( side, transt, m, n, k, a, ia, ja, desca, tau,
574 $ c, ic, jc, descc, work, lwork, iinfo )
575 ELSE IF( nq.GT.1 ) THEN
576
577
578
579 CALL pzunmlq( side, transt, mi, ni, nq-1, a, ia, ja+1,
580 $ desca, tau, c, icc, jcc, descc, work, lwork,
581 $ iinfo )
582 END IF
583 END IF
584
585 work( 1 ) = dcmplx( dble( lwmin ) )
586
587 RETURN
588
589
590
subroutine chk1mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, info)
integer function ilcm(m, n)
integer function indxg2p(indxglob, nb, iproc, isrcproc, nprocs)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pchk1mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, nextra, ex, expos, info)
subroutine pchk2mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, mb, mbpos0, nb, nbpos0, ib, jb, descb, descbpos0, nextra, ex, expos, info)
subroutine pxerbla(ictxt, srname, info)
subroutine pzunmlq(side, trans, m, n, k, a, ia, ja, desca, tau, c, ic, jc, descc, work, lwork, info)
subroutine pzunmqr(side, trans, m, n, k, a, ia, ja, desca, tau, c, ic, jc, descc, work, lwork, info)