3 SUBROUTINE pcsepqtq( MS, NV, THRESH, Q, IQ, JQ, DESCQ, C, IC, JC,
4 $ DESCC, PROCDIST, ICLUSTR, GAP, WORK, LWORK,
13 INTEGER IC, INFO, IQ, JC, JQ, LWORK, MS, NV, RES
18 INTEGER DESCC( * ), DESCQ( * ), ICLUSTR( * ),
20 REAL GAP( * ), WORK( * )
21 COMPLEX C( * ), Q( * )
175 INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
176 $ MB_, NB_, RSRC_, CSRC_, LLD_
177 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
178 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
179 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
180 COMPLEX ZERO, ONE, NEGONE
181 PARAMETER ( ZERO = 0.0e+0, one = 1.0e+0,
189 INTEGER CLUSTER, FIRSTP, IMAX, IMIN, JMAX, JMIN, LWMIN,
190 $ MQ0, MYCOL, MYROW, NEXTP, NP0, NPCOL, NPROW
191 REAL NORM, QTQNRM2, ULP
195 REAL PCLANGE, PSLAMCH
196 EXTERNAL numroc, pclange, pslamch
204 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
209 ulp = pslamch( descc( ctxt_ ),
'P' )
211 CALL blacs_gridinfo( descc( ctxt_ ), nprow, npcol, myrow, mycol )
213 CALL chk1mat( ms, 1, ms, 2, iq, jq, descq, 7, info )
214 CALL chk1mat( nv, 1, ms, 2, ic, jc, descc, 11, info )
217 np0 = numroc( nv, descc( mb_ ), 0, 0, nprow )
218 mq0 = numroc( nv, descc( nb_ ), 0, 0, npcol )
220 lwmin = 2 +
max( descc( mb_ ), 2 )*( 2*np0+mq0 )
224 ELSE IF( jq.NE.1 )
THEN
226 ELSE IF( ic.NE.1 )
THEN
228 ELSE IF( jc.NE.1 )
THEN
230 ELSE IF( lwork.LT.lwmin )
THEN
236 CALL pxerbla( descc( ctxt_ ),
'PCSEPQTQ', -info )
242 CALL pclaset(
'A', nv, nv, zero, one, c, ic, jc, descc )
246 IF( nv*ms.GT.0 )
THEN
247 CALL pcgemm(
'Conjugate transpose',
'N', nv, nv, ms, negone, q,
248 $ 1, 1, descq, q, 1, 1, descq, one, c, 1, 1, descc )
253 norm = pclange(
'1', nv, nv, c, 1, 1, descc, work )
254 qtqnrm = norm / ( real(
max( ms, 1 ) )*ulp )
258 DO 20 firstp = 1, nprow*npcol
259 IF( procdist( firstp ).GE.iclustr( 2*( cluster-1 )+1 ) )
264 imin = iclustr( 2*cluster-1 )
265 jmax = iclustr( 2*cluster )
271 DO 40 nextp = firstp, nprow*npcol
272 imax = procdist( nextp )
276 CALL pcmatadd( imax-imin+1, jmax-jmin+1, zero, c, imin, jmin,
277 $ descc,
cmplx( gap( cluster ) / 0.01e+0 ), c,
278 $ imin, jmin, descc )
279 CALL pcmatadd( jmax-jmin+1, imax-imin+1, zero, c, jmin, imin,
280 $ descc,
cmplx( gap( cluster ) / 0.01e+0 ), c,
281 $ jmin, imin, descc )
284 IF( iclustr( 2*cluster ).LT.procdist( nextp+1 ) )
289 cluster = cluster + 1
295 norm = pclange(
'1', nv, nv, c, 1, 1, descc, work )
297 qtqnrm2 = norm / ( real(
max( ms, 1 ) )*ulp )
299 IF( qtqnrm2.GT.thresh )
THEN