DragonFly On-Line Manual Pages
PCHENGST(l) ) PCHENGST(l)
NAME
SYNOPSIS
SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB,
DESCB, SCALE, WORK, LWORK, INFO )
CHARACTER UPLO
INTEGER IA, IB, IBTYPE, INFO, JA, JB, LWORK, N
REAL SCALE
INTEGER DESCA( * ), DESCB( * )
COMPLEX A( * ), B( * ), WORK( * )
COMPLEX ONEHALF, ONE, MONE
REAL RONE
PARAMETER ( ONEHALF = ( 0.5E0, 0.0E0 ), ONE = ( 1.0E0, 0.0E0 ),
MONE = ( -1.0E0, 0.0E0 ), RONE = 1.0E0 )
INTEGER DLEN_, CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
PARAMETER ( DLEN_ = 9, CTXT_ = 2, MB_ = 5, NB_ = 6, RSRC_ = 7,
CSRC_ = 8, LLD_ = 9 )
LOGICAL LQUERY, UPPER
INTEGER I, IACOL, IAROW, IBCOL, IBROW, ICOFFA, ICOFFB, ICTXT,
INDAA, INDG, INDR, INDRT, IROFFA, IROFFB, J, K, KB, LWMIN, LWOPT,
MYCOL, MYROW, NB, NP0, NPCOL, NPK, NPROW, NQ0, POSTK
INTEGER DESCAA( DLEN_ ), DESCG( DLEN_ ), DESCR( DLEN_ ), DESCRT(
DLEN_ ), IDUM1( 2 ), IDUM2( 2 )
LOGICAL LSAME
INTEGER INDXG2P, NUMROC
EXTERNAL LSAME, INDXG2P, NUMROC
EXTERNAL BLACS_GRIDINFO, CHK1MAT, DESCSET, PCGEMM, PCHEGST, PCHEMM,
PCHER2K, PCHK2MAT, PCLACPY, PCTRSM, PXERBLA
INTRINSIC CMPLX, CONJG, ICHAR, MAX, MIN, MOD, REAL
ICTXT = DESCA( CTXT_ )
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
SCALE = 1.0E0
NB = DESCA( MB_ )
INFO = 0
IF( NPROW.EQ.-1 ) THEN
INFO = -( 700+CTXT_ )
ELSE
UPPER = LSAME( UPLO, 'U' )
CALL CHK1MAT( N, 3, N, 3, IA, JA, DESCA, 7, INFO )
CALL CHK1MAT( N, 3, N, 3, IB, JB, DESCB, 11, INFO )
IF( INFO.EQ.0 ) THEN
IAROW = INDXG2P( IA, DESCA( MB_ ), MYROW, DESCA( RSRC_ ), NPROW )
IBROW = INDXG2P( IB, DESCB( MB_ ), MYROW, DESCB( RSRC_ ), NPROW )
IACOL = INDXG2P( JA, DESCA( NB_ ), MYCOL, DESCA( CSRC_ ), NPCOL )
IBCOL = INDXG2P( JB, DESCB( NB_ ), MYCOL, DESCB( CSRC_ ), NPCOL )
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
IROFFB = MOD( IB-1, DESCB( MB_ ) )
ICOFFB = MOD( JB-1, DESCB( NB_ ) )
NP0 = NUMROC( N, NB, 0, 0, NPROW )
NQ0 = NUMROC( N, NB, 0, 0, NPCOL )
LWMIN = MAX( NB*( NP0+1 ), 3*NB )
IF( IBTYPE.EQ.1 .AND. .NOT.UPPER ) THEN
LWOPT = 2*NP0*NB + NQ0*NB + NB*NB
ELSE
LWOPT = LWMIN
END IF
WORK( 1 ) = CMPLX( REAL( LWOPT ) )
LQUERY = ( LWORK.EQ.-1 )
IF( IBTYPE.LT.1 .OR. IBTYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IROFFA.NE.0 ) THEN
INFO = -5
ELSE IF( ICOFFA.NE.0 ) THEN
INFO = -6
ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
INFO = -( 700+NB_ )
ELSE IF( IROFFB.NE.0 .OR. IBROW.NE.IAROW ) THEN
INFO = -9
ELSE IF( ICOFFB.NE.0 .OR. IBCOL.NE.IACOL ) THEN
INFO = -10
ELSE IF( DESCB( MB_ ).NE.DESCA( MB_ ) ) THEN
INFO = -( 1100+MB_ )
ELSE IF( DESCB( NB_ ).NE.DESCA( NB_ ) ) THEN
INFO = -( 1100+NB_ )
ELSE IF( ICTXT.NE.DESCB( CTXT_ ) ) THEN
INFO = -( 1100+CTXT_ )
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
IDUM1( 1 ) = IBTYPE
IDUM2( 1 ) = 1
IF( UPPER ) THEN
IDUM1( 2 ) = ICHAR( 'U' )
ELSE
IDUM1( 2 ) = ICHAR( 'L' )
END IF
IDUM2( 2 ) = 2
CALL PCHK2MAT( N, 3, N, 3, IA, JA, DESCA, 7, N, 3, N, 3, IB, JB,
DESCB, 11, 2, IDUM1, IDUM2, INFO )
END IF
IF( INFO.NE.0 ) THEN
CALL PXERBLA( ICTXT, 'PCHENGST', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
IF( N.EQ.0 ) RETURN
IF( IBTYPE.NE.1 .OR. UPPER .OR. LWORK.LT.LWOPT ) THEN
CALL PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, DESCB,
SCALE, INFO )
RETURN
END IF
CALL DESCSET( DESCG, N, NB, NB, NB, IAROW, IACOL, ICTXT, NP0 )
CALL DESCSET( DESCR, N, NB, NB, NB, IAROW, IACOL, ICTXT, NP0 )
CALL DESCSET( DESCRT, NB, N, NB, NB, IAROW, IACOL, ICTXT, NB )
CALL DESCSET( DESCAA, NB, NB, NB, NB, IAROW, IACOL, ICTXT, NB )
INDG = 1
INDR = INDG + DESCG( LLD_ )*NB
INDAA = INDR + DESCR( LLD_ )*NB
INDRT = INDAA + DESCAA( LLD_ )*NB
DO 30 K = 1, N, NB
KB = MIN( N-K+1, NB )
POSTK = K + KB
NPK = N - POSTK + 1
CALL PCLACPY( 'A', N-POSTK+1, KB, B, POSTK+IB-1, K+JB-1, DESCB,
WORK( INDG ), POSTK, 1, DESCG )
CALL PCLACPY( 'A', N-POSTK+1, KB, A, POSTK+IA-1, K+JA-1, DESCA,
WORK( INDR ), POSTK, 1, DESCR )
CALL PCLACPY( 'A', KB, K-1, A, K+IA-1, JA, DESCA, WORK( INDRT ), 1,
1, DESCRT )
CALL PCLACPY( 'L', KB, KB, A, K+IA-1, K+JA-1, DESCA, WORK( INDR ),
K, 1, DESCR )
CALL PCTRSM( 'Right', 'L', 'N', 'N', NPK, KB, MONE, B, K+IB-1,
K+JB-1, DESCB, WORK( INDG ), POSTK, 1, DESCG )
CALL PCHEMM( 'Right', 'L', NPK, KB, ONEHALF, A, K+IA-1, K+JA-1,
DESCA, WORK( INDG ), POSTK, 1, DESCG, ONE, WORK( INDR ), POSTK, 1,
DESCR )
CALL PCHER2K( 'Lower', 'No T', NPK, KB, ONE, WORK( INDG ), POSTK,
1, DESCG, WORK( INDR ), POSTK, 1, DESCR, RONE, A, POSTK+IA-1,
POSTK+JA-1, DESCA )
CALL PCGEMM( 'No T', 'No Conj', NPK, K-1, KB, ONE, WORK( INDG ),
POSTK, 1, DESCG, WORK( INDRT ), 1, 1, DESCRT, ONE, A, POSTK+IA-1, JA,
DESCA )
CALL PCHEMM( 'Right', 'L', NPK, KB, ONE, WORK( INDR ), K, 1, DESCR,
WORK( INDG ), POSTK, 1, DESCG, ONE, A, POSTK+IA-1, K+JA-1, DESCA )
CALL PCTRSM( 'Left', 'Lower', 'No Conj', 'Non-unit', KB, K-1, ONE,
B, K+IB-1, K+JB-1, DESCB, A, K+IA-1, JA, DESCA )
CALL PCLACPY( 'L', KB, KB, A, K+IA-1, K+JA-1, DESCA, WORK( INDAA ),
1, 1, DESCAA )
IF( MYROW.EQ.DESCAA( RSRC_ ) .AND. MYCOL.EQ.DESCAA( CSRC_ ) ) THEN
DO 20 I = 1, KB
DO 10 J = 1, I
WORK( INDAA+J-1+( I-1 )*DESCAA( LLD_ ) ) = CONJG( WORK( INDAA+I-1+(
J-1 )*DESCAA( LLD_ ) ) )
10 CONTINUE
20 CONTINUE
END IF
CALL PCTRSM( 'Left', 'Lower', 'No Conj', 'Non-unit', KB, KB, ONE,
B, K+IB-1, K+JB-1, DESCB, WORK( INDAA ), 1, 1, DESCAA )
CALL PCTRSM( 'Right', 'Lower', 'Conj', 'Non-unit', KB, KB, ONE, B,
K+IB-1, K+JB-1, DESCB, WORK( INDAA ), 1, 1, DESCAA )
CALL PCLACPY( 'L', KB, KB, WORK( INDAA ), 1, 1, DESCAA, A, K+IA-1,
K+JA-1, DESCA )
CALL PCTRSM( 'Right', 'Lower', 'Conj', 'Non-unit', NPK, KB, ONE, B,
K+IB-1, K+JB-1, DESCB, A, POSTK+IA-1, K+JA-1, DESCA )
DESCR( CSRC_ ) = MOD( DESCR( CSRC_ )+1, NPCOL )
DESCG( CSRC_ ) = MOD( DESCG( CSRC_ )+1, NPCOL )
DESCRT( RSRC_ ) = MOD( DESCRT( RSRC_ )+1, NPROW )
DESCAA( RSRC_ ) = MOD( DESCAA( RSRC_ )+1, NPROW )
DESCAA( CSRC_ ) = MOD( DESCAA( CSRC_ )+1, NPCOL )
30 CONTINUE
WORK( 1 ) = CMPLX( REAL( LWOPT ) )
RETURN
END
PURPOSE
ScaLAPACK version 1.7 13 August 2001 PCHENGST(l)