PZHENTRD(3) MathKeisan ScaLAPACK routine PZHENTRD(3)
NAME
SYNOPSIS
SUBROUTINE PZHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, LWORK,
RWORK, LRWORK, INFO )
CHARACTER UPLO
INTEGER IA, INFO, JA, LRWORK, LWORK, N
INTEGER DESCA( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 A( * ), TAU( * ), WORK( * )
INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
MB_, NB_, RSRC_, CSRC_, LLD_
PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, RSRC_
= 7, CSRC_ = 8, LLD_ = 9 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
LOGICAL LQUERY, UPPER
CHARACTER COLCTOP, ROWCTOP
INTEGER ANB, CTXTB, I, IACOL, IAROW, ICOFFA, ICTXT, IINFO,
INDB, INDRD, INDRE, INDTAU, INDW, IPW, IROFFA, J,
JB, JX, K, KK, LLRWORK, LLWORK, LRWMIN, LWMIN,
MINSZ, MYCOL, MYCOLB, MYROW, MYROWB, NB, NP,
NPCOL, NPCOLB, NPROW, NPROWB, NPS, NQ, ONEPMIN,
ONEPRMIN, SQNPC, TTLRWMIN, TTLWMIN
INTEGER DESCB( DLEN_ ), DESCW( DLEN_ ), IDUM1( 3 ), IDUM2(
3 )
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
BLACS_GRIDINIT, CHK1MAT, DESCSET, IGAMN2D,
PCHK1MAT, PDLAMR1D, PB_TOPGET, PB_TOPSET, PXERBLA,
PZELSET, PZHER2K, PZHETD2, PZHETTRD, PZLAMR1D,
PZLATRD, PZTRMR2D, ZHETRD
LOGICAL LSAME
INTEGER INDXG2L, INDXG2P, NUMROC, PJLAENV
EXTERNAL LSAME, INDXG2L, INDXG2P, NUMROC, PJLAENV
INTRINSIC DBLE, DCMPLX, ICHAR, INT, MAX, MIN, MOD, SQRT
IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
RSRC_.LT.0 )RETURN
ICTXT = DESCA( CTXT_ )
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL
)
INFO = 0
IF( NPROW.EQ.-1 ) THEN
INFO = -( 600+CTXT_ )
ELSE
CALL CHK1MAT( N, 2, N, 2, IA, JA, DESCA, 6, INFO )
UPPER = LSAME( UPLO, 'U' )
IF( INFO.EQ.0 ) THEN
NB = DESCA( NB_ )
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
IAROW = INDXG2P( IA, NB, MYROW, DESCA( RSRC_ ), NPROW )
IACOL = INDXG2P( JA, NB, MYCOL, DESCA( CSRC_ ), NPCOL )
NP = NUMROC( N, NB, MYROW, IAROW, NPROW )
NQ = MAX( 1, NUMROC( N+JA-1, NB, MYCOL, DESCA( CSRC_
), NPCOL ) )
LWMIN = MAX( ( NP+1 )*NB, 3*NB )
ANB = PJLAENV( ICTXT, 3, 'PZHETTRD', 'L', 0, 0, 0, 0 )
MINSZ = PJLAENV( ICTXT, 5, 'PZHETTRD', 'L', 0, 0, 0, 0 )
SQNPC = INT( SQRT( DBLE( NPROW*NPCOL ) ) )
NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
TTLWMIN = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+2 )*NPS
LRWMIN = 1
TTLRWMIN = 2*NPS
WORK( 1 ) = DCMPLX( DBLE( TTLWMIN ) )
RWORK( 1 ) = DBLE( TTLRWMIN )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
IF(
INFO = -1
ELSE IF( IROFFA.NE.ICOFFA .OR. ICOFFA.NE.0 ) THEN
INFO = -5
ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
INFO = -( 600+NB_ )
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
IF( UPPER ) THEN
IDUM1( 1 ) = ICHAR( 'U' )
ELSE
IDUM1( 1 ) = ICHAR( 'L' )
END IF
IDUM2( 1 ) = 1
IF( LWORK.EQ.-1 ) THEN
IDUM1( 2 ) = -1
ELSE
IDUM1( 2 ) = 1
END IF
IDUM2( 2 ) = 11
IF( LRWORK.EQ.-1 ) THEN
IDUM1( 3 ) = -1
ELSE
IDUM1( 3 ) = 1
END IF
IDUM2( 3 ) = 13
CALL PCHK1MAT( N, 2, N, 2, IA, JA, DESCA, 6, 3, IDUM1,
IDUM2, INFO )
END IF
IF( INFO.NE.0 ) THEN
CALL PXERBLA( ICTXT, 'PZHENTRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
IF( N.EQ.0 ) RETURN
ONEPMIN = N*N + 3*N + 1
LLWORK = LWORK
CALL IGAMN2D( ICTXT, 'A', ' ', 1, 1, LLWORK, 1, 1, -1,
-1, -1, -1 )
ONEPRMIN = 2*N
LLRWORK = LRWORK
CALL IGAMN2D( ICTXT, 'A', ' ', 1, 1, LLRWORK, 1, 1, -1,
-1, -1, -1 )
NPROWB = 0
IF( ( N.LT.MINSZ .OR. SQNPC.EQ.1 ) .AND.
LLWORK.GE.ONEPMIN .AND. LLRWORK.GE.ONEPRMIN .AND.
.NOT.UPPER ) THEN
NPROWB = 1
NPS = N
ELSE
IF( LLWORK.GE.TTLWMIN .AND. LLRWORK.GE.TTLRWMIN .AND.
.NOT. UPPER ) THEN
NPROWB = SQNPC
END IF
END IF
IF( NPROWB.GE.1 ) THEN
NPCOLB = NPROWB
SQNPC = NPROWB
INDB = 1
INDRD = 1
INDRE = INDRD + NPS
INDTAU = INDB + NPS*NPS
INDW = INDTAU + NPS
LLWORK = LLWORK - INDW + 1
CALL BLACS_GET( ICTXT, 10, CTXTB )
CALL BLACS_GRIDINIT( CTXTB, 'Row major', SQNPC, SQNPC )
CALL BLACS_GRIDINFO( CTXTB, NPROWB, NPCOLB, MYROWB,
MYCOLB )
CALL DESCSET( DESCB, N, N, 1, 1, 0, 0, CTXTB, NPS )
CALL PZTRMR2D( UPLO, 'N', N, N, A, IA, JA, DESCA, WORK(
INDB ), 1, 1, DESCB, ICTXT )
IF( NPROWB.GT.0 ) THEN
IF( NPROWB.EQ.1 ) THEN
CALL ZHETRD( UPLO, N, WORK( INDB ), NPS, RWORK( INDRD
), RWORK( INDRE ), WORK( INDTAU ), WORK( INDW ),
LLWORK, INFO )
ELSE
CALL PZHETTRD( 'L', N, WORK( INDB ), 1, 1, DESCB,
RWORK( INDRD ), RWORK( INDRE ), WORK( INDTAU ),
WORK( INDW ), LLWORK, INFO )
END IF
END IF
CALL PDLAMR1D( N-1, RWORK( INDRE ), 1, 1, DESCB, E, 1,
JA, DESCA )
CALL PDLAMR1D( N, RWORK( INDRD ), 1, 1, DESCB, D, 1,
JA, DESCA )
CALL PZLAMR1D( N, WORK( INDTAU ), 1, 1, DESCB, TAU, 1,
JA, DESCA )
CALL PZTRMR2D( UPLO, 'N', N, N, WORK( INDB ), 1, 1,
DESCB, A, IA, JA, DESCA, ICTXT )
IF( MYROWB.GE.0 ) CALL BLACS_GRIDEXIT( CTXTB )
ELSE
CALL PB_TOPGET( ICTXT, 'Combine', 'Columnwise', COLCTOP
)
CALL PB_TOPGET( ICTXT, 'Combine', 'Rowwise', ROWCTOP )
CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise',
'1-tree' )
CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise', '1-tree' )
IPW = NP*NB + 1
IF( UPPER ) THEN
KK = MOD( JA+N-1, NB )
IF( KK.EQ.0 ) KK = NB
CALL DESCSET( DESCW, N, NB, NB, NB, IAROW, INDXG2P(
JA+N-KK, NB, MYCOL, DESCA( CSRC_ ), NPCOL ),
ICTXT, MAX( 1, NP ) )
DO 10 K = N - KK + 1, NB + 1, -NB
JB = MIN( N-K+1, NB )
I = IA + K - 1
J = JA + K - 1
CALL PZLATRD( UPLO, K+JB-1, JB, A, IA, JA, DESCA, D, E,
TAU, WORK, 1, 1, DESCW, WORK( IPW ) )
CALL PZHER2K( UPLO, 'No transpose', K-1, JB, -CONE, A,
IA, J, DESCA, WORK, 1, 1, DESCW, ONE, A, IA, JA,
DESCA )
JX = MIN( INDXG2L( J, NB, 0, IACOL, NPCOL ), NQ )
CALL PZELSET( A, I-1, J, DESCA, DCMPLX( E( JX ) ) )
DESCW( CSRC_ ) = MOD( DESCW( CSRC_ )+NPCOL-1, NPCOL )
10 CONTINUE
CALL PZHETD2( UPLO, MIN( N, NB ), A, IA, JA, DESCA, D,
E, TAU, WORK, LWORK, IINFO )
ELSE
KK = MOD( JA+N-1, NB )
IF( KK.EQ.0 ) KK = NB
CALL DESCSET( DESCW, N, NB, NB, NB, IAROW, IACOL,
ICTXT, MAX( 1, NP ) )
DO 20 K = 1, N - NB, NB
I = IA + K - 1
J = JA + K - 1
CALL PZLATRD( UPLO, N-K+1, NB, A, I, J, DESCA, D, E,
TAU, WORK, K, 1, DESCW, WORK( IPW ) )
CALL PZHER2K( UPLO, 'No transpose', N-K-NB+1, NB,
-CONE, A, I+NB, J, DESCA, WORK, K+NB, 1, DESCW,
ONE, A, I+NB, J+NB, DESCA )
JX = MIN( INDXG2L( J+NB-1, NB, 0, IACOL, NPCOL ), NQ
)
CALL PZELSET( A, I+NB, J+NB-1, DESCA, DCMPLX( E( JX ) )
)
DESCW( CSRC_ ) = MOD( DESCW( CSRC_ )+1, NPCOL )
20 CONTINUE
CALL PZHETD2( UPLO, KK, A, IA+K-1, JA+K-1, DESCA, D, E,
TAU, WORK, LWORK, IINFO )
END IF
CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', COLCTOP
)
CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise', ROWCTOP )
END IF
WORK( 1 ) = DCMPLX( DBLE( TTLWMIN ) )
RWORK( 1 ) = DBLE( TTLRWMIN )
RETURN
END
PURPOSE
ScaLAPACK version 1.7 13 August 2001 PZHENTRD(3)