3
4
5
6
7
8
9
10 INTEGER IA, IHI, ILO, INFO, JA, LWORK, N
11
12
13 INTEGER DESCA( * )
14 COMPLEX*16 A( * ), TAU( * ), WORK( * )
15
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 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
198 $ LLD_, MB_, M_, NB_, N_, RSRC_
199 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
200 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
201 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
202 COMPLEX*16 ONE, ZERO
203 parameter( one = ( 1.0d+0, 0.0d+0 ),
204 $ zero = ( 0.0d+0, 0.0d+0 ) )
205
206
207 LOGICAL LQUERY
208 CHARACTER COLCTOP, ROWCTOP
209 INTEGER I, IACOL, IAROW, IB, ICOFFA, ICTXT, IHIP,
210 $ IHLP, IIA, IINFO, ILCOL, ILROW, IMCOL, INLQ,
211 $ IOFF, IPT, IPW, IPY, IROFFA, J, JJ, JJA, JY,
212 $ K, L, LWMIN, MYCOL, MYROW, NB, NPCOL, NPROW,
213 $ NQ
214 COMPLEX*16 EI
215
216
217 INTEGER DESCY( DLEN_ ), IDUM1( 3 ), IDUM2( 3 )
218
219
223
224
225 INTEGER INDXG2P, NUMROC
227
228
229 INTRINSIC dble, dcmplx,
max,
min, mod
230
231
232
233
234
235 ictxt = desca( ctxt_ )
236 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
237
238
239
240 info = 0
241 IF( nprow.EQ.-1 ) THEN
242 info = -(700+ctxt_)
243 ELSE
244 CALL chk1mat( n, 1, n, 1, ia, ja, desca, 7, info )
245 IF( info.EQ.0 ) THEN
246 nb = desca( nb_ )
247 iroffa = mod( ia-1, nb )
248 icoffa = mod( ja-1, nb )
249 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
250 $ iia, jja, iarow, iacol )
251 ihip =
numroc( ihi+iroffa, nb, myrow, iarow, nprow )
252 ioff = mod( ia+ilo-2, nb )
253 ilrow =
indxg2p( ia+ilo-1, nb, myrow, desca( rsrc_ ),
254 $ nprow )
255 ihlp =
numroc( ihi-ilo+ioff+1, nb, myrow, ilrow, nprow )
256 ilcol =
indxg2p( ja+ilo-1, nb, mycol, desca( csrc_ ),
257 $ npcol )
258 inlq =
numroc( n-ilo+ioff+1, nb, mycol, ilcol, npcol )
259 lwmin = nb*( nb +
max( ihip+1, ihlp+inlq ) )
260
261 work( 1 ) = dcmplx( dble( lwmin ) )
262 lquery = ( lwork.EQ.-1 )
263 IF( ilo.LT.1 .OR. ilo.GT.
max( 1, n ) )
THEN
264 info = -2
265 ELSE IF( ihi.LT.
min( ilo, n ) .OR. ihi.GT.n )
THEN
266 info = -3
267 ELSE IF( iroffa.NE.icoffa .OR. iroffa.NE.0 ) THEN
268 info = -6
269 ELSE IF( desca( mb_ ).NE.desca( nb_ ) ) THEN
270 info = -(700+nb_)
271 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
272 info = -10
273 END IF
274 END IF
275 idum1( 1 ) = ilo
276 idum2( 1 ) = 2
277 idum1( 2 ) = ihi
278 idum2( 2 ) = 3
279 IF( lwork.EQ.-1 ) THEN
280 idum1( 3 ) = -1
281 ELSE
282 idum1( 3 ) = 1
283 END IF
284 idum2( 3 ) = 10
285 CALL pchk1mat( n, 1, n, 1, ia, ja, desca, 7, 3, idum1, idum2,
286 $ info )
287 END IF
288
289 IF( info.NE.0 ) THEN
290 CALL pxerbla( ictxt,
'PZGEHRD', -info )
291 RETURN
292 ELSE IF( lquery ) THEN
293 RETURN
294 END IF
295
296
297
298 nq =
numroc( ja+n-2, nb, mycol, desca( csrc_ ), npcol )
299 CALL infog1l( ja+ilo-2, nb, npcol, mycol, desca( csrc_ ), jj,
300 $ imcol )
301 DO 10 j = jja,
min( jj, nq )
302 tau( j ) = zero
303 10 CONTINUE
304
305 CALL infog1l( ja+ihi-1, nb, npcol, mycol, desca( csrc_ ), jj,
306 $ imcol )
307 DO 20 j = jj, nq
308 tau( j ) = zero
309 20 CONTINUE
310
311
312
313 IF( ihi-ilo.LE.0 )
314 $ RETURN
315
316 CALL pb_topget( ictxt, 'Combine', 'Columnwise', colctop )
317 CALL pb_topget( ictxt, 'Combine', 'Rowwise', rowctop )
318 CALL pb_topset( ictxt, 'Combine', 'Columnwise', '1-tree' )
319 CALL pb_topset( ictxt, 'Combine', 'Rowwise', '1-tree' )
320
321 ipt = 1
322 ipy = ipt + nb * nb
323 ipw = ipy + ihip * nb
324 CALL descset( descy, ihi+iroffa, nb, nb, nb, iarow, ilcol, ictxt,
326
327 k = ilo
328 ib = nb - ioff
329 jy = ioff + 1
330
331
332
333 DO 30 l = 1, ihi-ilo+ioff-nb, nb
334 i = ia + k - 1
335 j = ja + k - 1
336
337
338
339
340
341 CALL pzlahrd( ihi, k, ib, a, ia, j, desca, tau, work( ipt ),
342 $ work( ipy ), 1, jy, descy, work( ipw ) )
343
344
345
346
347
348 CALL pzelset2( ei, a, i+ib, j+ib-1, desca, one )
349 CALL pzgemm( 'No transpose', 'Conjugate transpose', ihi,
350 $ ihi-k-ib+1, ib, -one, work( ipy ), 1, jy, descy,
351 $ a, i+ib, j, desca, one, a, ia, j+ib, desca )
352 CALL pzelset( a, i+ib, j+ib-1, desca, ei )
353
354
355
356
357 CALL pzlarfb(
'Left',
'Conjugate transpose',
'Forward',
358 $ 'Columnwise', ihi-k, n-k-ib+1, ib, a, i+1, j,
359 $ desca, work( ipt ), a, i+1, j+ib, desca,
360 $ work( ipy ) )
361
362 k = k + ib
363 ib = nb
364 jy = 1
365 descy( csrc_ ) = mod( descy( csrc_ ) + 1, npcol )
366
367 30 CONTINUE
368
369
370
371 CALL pzgehd2( n, k, ihi, a, ia, ja, desca, tau, work, lwork,
372 $ iinfo )
373
374 CALL pb_topset( ictxt, 'Combine', 'Columnwise', colctop )
375 CALL pb_topset( ictxt, 'Combine', 'Rowwise', rowctop )
376
377 work( 1 ) = dcmplx( dble( lwmin ) )
378
379 RETURN
380
381
382
subroutine chk1mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, info)
subroutine descset(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld)
integer function indxg2p(indxglob, nb, iproc, isrcproc, nprocs)
subroutine infog1l(gindx, nb, nprocs, myroc, isrcproc, lindx, rocsrc)
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pchk1mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, nextra, ex, expos, info)
subroutine pxerbla(ictxt, srname, info)
subroutine pzelset2(alpha, a, ia, ja, desca, beta)
subroutine pzelset(a, ia, ja, desca, alpha)
subroutine pzgehd2(n, ilo, ihi, a, ia, ja, desca, tau, work, lwork, info)
subroutine pzlahrd(n, k, nb, a, ia, ja, desca, tau, t, y, iy, jy, descy, work)
subroutine pzlarfb(side, trans, direct, storev, m, n, k, v, iv, jv, descv, t, c, ic, jc, descc, work)