229 $ D, E, HOUS, LHOUS, WORK, LWORK, INFO )
243 CHARACTER STAGE1, UPLO, VECT
244 INTEGER N, KD, LDAB, LHOUS, LWORK, INFO
248 COMPLEX AB( LDAB, * ), HOUS( * ), WORK( * )
256 parameter( rzero = 0.0e+0,
257 $ zero = ( 0.0e+0, 0.0e+0 ),
258 $ one = ( 1.0e+0, 0.0e+0 ) )
261 LOGICAL LQUERY, WANTQ, UPPER, AFTERS1
262 INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST,
263 $ ed, stind, edind, blklastind, colpt, thed,
264 $ stepercol, grsiz, thgrsiz, thgrnb, thgrid,
265 $ nbtiles, ttype, tid, nthreads, debug,
266 $ abdpos, abofdpos, dpos, ofdpos, awpos,
267 $ inda, indw, apos, sizea, lda, indv, indtau,
268 $ sicev, sizetau, ldv, lhmin, lwmin
276 INTRINSIC min, max, ceiling, real
281 EXTERNAL lsame, ilaenv2stage
290 afters1 = lsame( stage1,
'Y' )
291 wantq = lsame( vect,
'V' )
292 upper = lsame( uplo,
'U' )
293 lquery = ( lwork.EQ.-1 ) .OR. ( lhous.EQ.-1 )
297 ib = ilaenv2stage( 2,
'CHETRD_HB2ST', vect, n, kd, -1, -1 )
298 lhmin = ilaenv2stage( 3,
'CHETRD_HB2ST', vect, n, kd, ib, -1 )
299 lwmin = ilaenv2stage( 4,
'CHETRD_HB2ST', vect, n, kd, ib, -1 )
301 IF( .NOT.afters1 .AND. .NOT.lsame( stage1,
'N' ) )
THEN
303 ELSE IF( .NOT.lsame( vect,
'N' ) )
THEN
305 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
307 ELSE IF( n.LT.0 )
THEN
309 ELSE IF( kd.LT.0 )
THEN
311 ELSE IF( ldab.LT.(kd+1) )
THEN
313 ELSE IF( lhous.LT.lhmin .AND. .NOT.lquery )
THEN
315 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
325 CALL xerbla(
'CHETRD_HB2ST', -info )
327 ELSE IF( lquery )
THEN
345 indv = indtau + sizetau
362 awpos = inda + kd + 1
378 d( i ) = real( ab( abdpos, i ) )
401 d( i ) = real( ab( abdpos, i ) )
408 tmp = ab( abofdpos, i+1 )
410 ab( abofdpos, i+1 ) = abstmp
412 IF( abstmp.NE.rzero )
THEN
418 $ ab( abofdpos, i+2 ) = ab( abofdpos, i+2 )*tmp
425 tmp = ab( abofdpos, i )
427 ab( abofdpos, i ) = abstmp
429 IF( abstmp.NE.rzero )
THEN
435 $ ab( abofdpos, i+1 ) = ab( abofdpos, i+1 )*tmp
453 nbtiles = ceiling( real(n)/real(kd) )
454 stepercol = ceiling( real(shift)/real(grsiz) )
455 thgrnb = ceiling( real(n-1)/real(thgrsiz) )
457 CALL clacpy(
"A", kd+1, n, ab, ldab, work( apos ), lda )
458 CALL claset(
"A", kd, n, zero, zero, work( awpos ), lda )
475 DO 100 thgrid = 1, thgrnb
476 stt = (thgrid-1)*thgrsiz+1
477 thed = min( (stt + thgrsiz -1), (n-1))
481 DO 120 m = 1, stepercol
483 DO 130 sweepid = st, ed
485 myid = (i-sweepid)*(stepercol*grsiz)
487 IF ( myid.EQ.1 )
THEN
490 ttype = mod( myid, 2 ) + 2
493 IF( ttype.EQ.2 )
THEN
494 colpt = (myid/2)*kd + sweepid
499 colpt = ((myid+1)/2)*kd + sweepid
502 IF( ( stind.GE.edind-1 ).AND.
503 $ ( edind.EQ.n ) )
THEN
512#if defined(_OPENMP) && _OPENMP >= 201307
513 IF( ttype.NE.1 )
THEN
517 tid = omp_get_thread_num()
519 $ stind, edind, sweepid, n, kd, ib,
521 $ hous( indv ), hous( indtau ), ldv,
522 $ work( indw + tid*kd ) )
527 tid = omp_get_thread_num()
529 $ stind, edind, sweepid, n, kd, ib,
531 $ hous( indv ), hous( indtau ), ldv,
532 $ work( indw + tid*kd ) )
537 $ stind, edind, sweepid, n, kd, ib,
539 $ hous( indv ), hous( indtau ), ldv,
540 $ work( indw + tid*kd ) )
542 IF ( blklastind.GE.(n-1) )
THEN
561 d( i ) = real( work( dpos+(i-1)*lda ) )
569 e( i ) = real( work( ofdpos+i*lda ) )
573 e( i ) = real( work( ofdpos+(i-1)*lda ) )
subroutine chb2st_kernels(UPLO, WANTZ, TTYPE, ST, ED, SWEEP, N, NB, IB, A, LDA, V, TAU, LDVT, WORK)
CHB2ST_KERNELS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine chetrd_hb2st(STAGE1, VECT, UPLO, N, KD, AB, LDAB, D, E, HOUS, LHOUS, WORK, LWORK, INFO)
CHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T