PCHENTRD(3) MathKeisan ScaLAPACK routine PCHENTRD(3)
NAME
SYNOPSIS
SUBROUTINE PCHENTRD( 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( * )
REAL D( * ), E( * ), RWORK( * )
COMPLEX 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 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
COMPLEX CONE
PARAMETER ( CONE = ( 1.0E+0, 0.0E+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, CHETRD, CHK1MAT, DESCSET, IGAMN2D,
PCELSET, PCHER2K, PCHETD2, PCHETTRD, PCHK1MAT,
PCLAMR1D, PCLATRD, PCTRMR2D, PSLAMR1D, PB_TOPGET,
PB_TOPSET, PXERBLA
LOGICAL LSAME
INTEGER INDXG2L, INDXG2P, NUMROC, PJLAENV
EXTERNAL LSAME, INDXG2L, INDXG2P, NUMROC, PJLAENV
INTRINSIC CMPLX, ICHAR, INT, MAX, MIN, MOD, REAL, 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, 'PCHETTRD', 'L', 0, 0, 0, 0 )
MINSZ = PJLAENV( ICTXT, 5, 'PCHETTRD', 'L', 0, 0, 0, 0 )
SQNPC = INT( SQRT( REAL( 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 ) = CMPLX( REAL( TTLWMIN ) )
RWORK( 1 ) = REAL( 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, 'PCHENTRD', -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 PCTRMR2D( 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 CHETRD( UPLO, N, WORK( INDB ), NPS, RWORK( INDRD
), RWORK( INDRE ), WORK( INDTAU ), WORK( INDW ),
LLWORK, INFO )
ELSE
CALL PCHETTRD( 'L', N, WORK( INDB ), 1, 1, DESCB,
RWORK( INDRD ), RWORK( INDRE ), WORK( INDTAU ),
WORK( INDW ), LLWORK, INFO )
END IF
END IF
CALL PSLAMR1D( N-1, RWORK( INDRE ), 1, 1, DESCB, E, 1,
JA, DESCA )
CALL PSLAMR1D( N, RWORK( INDRD ), 1, 1, DESCB, D, 1,
JA, DESCA )
CALL PCLAMR1D( N, WORK( INDTAU ), 1, 1, DESCB, TAU, 1,
JA, DESCA )
CALL PCTRMR2D( 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 PCLATRD( UPLO, K+JB-1, JB, A, IA, JA, DESCA, D, E,
TAU, WORK, 1, 1, DESCW, WORK( IPW ) )
CALL PCHER2K( 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 PCELSET( A, I-1, J, DESCA, CMPLX( E( JX ) ) )
DESCW( CSRC_ ) = MOD( DESCW( CSRC_ )+NPCOL-1, NPCOL )
10 CONTINUE
CALL PCHETD2( 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 PCLATRD( UPLO, N-K+1, NB, A, I, J, DESCA, D, E,
TAU, WORK, K, 1, DESCW, WORK( IPW ) )
CALL PCHER2K( 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 PCELSET( A, I+NB, J+NB-1, DESCA, CMPLX( E( JX ) )
)
DESCW( CSRC_ ) = MOD( DESCW( CSRC_ )+1, NPCOL )
20 CONTINUE
CALL PCHETD2( 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 ) = CMPLX( REAL( TTLWMIN ) )
RWORK( 1 ) = REAL( TTLRWMIN )
RETURN
END
PURPOSE
ScaLAPACK version 1.7 13 August 2001 PCHENTRD(3)