diff --git a/PBLAS/SRC/PTZBLAS/cvvdotc.f b/PBLAS/SRC/PTZBLAS/cvvdotc.f index 2d5c1b68..67c29b50 100644 --- a/PBLAS/SRC/PTZBLAS/cvvdotc.f +++ b/PBLAS/SRC/PTZBLAS/cvvdotc.f @@ -54,13 +54,16 @@ SUBROUTINE CVVDOTC( N, DOT, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX CDOTC - EXTERNAL CDOTC +* .. Local Scalars .. + COMPLEX DOTC +* .. +* .. External Subroutines .. + EXTERNAL CCDOTC * .. * .. Executable Statements .. * - DOT = DOT + CDOTC( N, X, INCX, Y, INCY ) + CALL CCDOTC( N, DOTC, X, INCX, Y, INCY ) + DOT = DOT + DOTC * RETURN * diff --git a/PBLAS/SRC/PTZBLAS/cvvdotu.f b/PBLAS/SRC/PTZBLAS/cvvdotu.f index 567c44de..cc302ca0 100644 --- a/PBLAS/SRC/PTZBLAS/cvvdotu.f +++ b/PBLAS/SRC/PTZBLAS/cvvdotu.f @@ -54,13 +54,16 @@ SUBROUTINE CVVDOTU( N, DOT, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX CDOTU - EXTERNAL CDOTU +* .. Local Scalars .. + COMPLEX DOTU +* .. +* .. External Subroutines .. + EXTERNAL CCDOTU * .. * .. Executable Statements .. * - DOT = DOT + CDOTU( N, X, INCX, Y, INCY ) + CALL CCDOTU( N, DOTU, X, INCX, Y, INCY ) + DOT = DOT + DOTU * RETURN * diff --git a/PBLAS/SRC/PTZBLAS/zvvdotc.f b/PBLAS/SRC/PTZBLAS/zvvdotc.f index 683a9a67..6c4070f3 100644 --- a/PBLAS/SRC/PTZBLAS/zvvdotc.f +++ b/PBLAS/SRC/PTZBLAS/zvvdotc.f @@ -54,13 +54,16 @@ SUBROUTINE ZVVDOTC( N, DOT, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX*16 ZDOTC - EXTERNAL ZDOTC +* .. Local Scalars .. + COMPLEX*16 DOTC +* .. +* .. External Subroutines .. + EXTERNAL ZZDOTC * .. * .. Executable Statements .. * - DOT = DOT + ZDOTC( N, X, INCX, Y, INCY ) + CALL ZZDOTC( N, DOTC, X, INCX, Y, INCY ) + DOT = DOT + DOTC * RETURN * diff --git a/PBLAS/SRC/PTZBLAS/zvvdotu.f b/PBLAS/SRC/PTZBLAS/zvvdotu.f index 180aaf1a..d83ed547 100644 --- a/PBLAS/SRC/PTZBLAS/zvvdotu.f +++ b/PBLAS/SRC/PTZBLAS/zvvdotu.f @@ -54,13 +54,16 @@ SUBROUTINE ZVVDOTU( N, DOT, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX*16 ZDOTU - EXTERNAL ZDOTU +* .. Local Scalars .. + COMPLEX*16 DOTU +* .. +* .. External Subroutines .. + EXTERNAL ZZDOTU * .. * .. Executable Statements .. * - DOT = DOT + ZDOTU( N, X, INCX, Y, INCY ) + CALL ZZDOTU( N, DOTU, X, INCX, Y, INCY ) + DOT = DOT + DOTU * RETURN * diff --git a/SRC/clanv2.f b/SRC/clanv2.f index 4f9a5d92..2880c0e9 100644 --- a/SRC/clanv2.f +++ b/SRC/clanv2.f @@ -55,13 +55,10 @@ SUBROUTINE CLANV2( A, B, C, D, RT1, RT2, CS, SN ) * .. * .. Local Scalars .. COMPLEX AA, BB, DD, T, TEMP, TEMP2, U, X, Y -* .. -* .. External Functions .. - COMPLEX CLADIV - EXTERNAL CLADIV + REAL CR, CI * .. * .. External Subroutines .. - EXTERNAL CLARTG + EXTERNAL CLARTG, SLADIV * .. * .. Intrinsic Functions .. INTRINSIC REAL, CMPLX, CONJG, AIMAG, SQRT @@ -97,9 +94,13 @@ SUBROUTINE CLANV2( A, B, C, D, RT1, RT2, CS, SN ) SN = CMPLX( RZERO, RONE )*CS ELSE TEMP = SQRT( B+C ) - TEMP2 = CLADIV( SQRT( B ), TEMP ) + CALL SLADIV( REAL( SQRT( B ) ), AIMAG( SQRT( B ) ), + $ REAL( TEMP ), AIMAG( TEMP ), CR, CI ) + TEMP2 = CMPLX( CR, CI ) CS = REAL( TEMP2 ) - SN = CLADIV( SQRT( C ), TEMP ) + CALL SLADIV( REAL( SQRT( C ) ), AIMAG( SQRT( C ) ), + $ REAL( TEMP ), AIMAG( TEMP ), CR, CI ) + SN = CMPLX( CR, CI ) END IF B = B - C C = ZERO @@ -114,7 +115,9 @@ SUBROUTINE CLANV2( A, B, C, D, RT1, RT2, CS, SN ) Y = SQRT( X*X+U ) IF( REAL( X )*REAL( Y )+AIMAG( X )*AIMAG( Y ).LT.RZERO ) $ Y = -Y - T = T - CLADIV( U, ( X+Y ) ) + CALL SLADIV( REAL( U ), AIMAG( U ), + $ REAL( X+Y ), AIMAG( X+Y ), CR, CI ) + T = T - CMPLX( CR, CI ) * * Do one QR step with exact shift T - resulting 2 x 2 in * triangular form. diff --git a/SRC/pcdttrf.f b/SRC/pcdttrf.f index 2443fa9b..065817c4 100644 --- a/SRC/pcdttrf.f +++ b/SRC/pcdttrf.f @@ -376,13 +376,14 @@ SUBROUTINE PCDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, $ NB, NP, NPCOL, NPROW, NP_SAVE, ODD_SIZE, $ PART_OFFSET, PART_SIZE, RETURN_CODE, STORE_N_A, $ TEMP, WORK_SIZE_MIN, WORK_U + COMPLEX DOTC * .. * .. Local Arrays .. INTEGER DESCA_1XP( 7 ), PARAM_CHECK( 7, 3 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO, - $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLAMOV, + $ CAXPY, CCDOTC, CGEMM, CGERV2D, CGESD2D, CLAMOV, $ CLATCPY, CPBTRF, CPOTRF, CSYRK, CTBTRS, CTRMM, $ CTRRV2D, CTRSD2D, CTRSM, CTRTRS, DESC_CONVERT, $ GLOBCHK, PXERBLA, RESHAPE @@ -390,8 +391,7 @@ SUBROUTINE PCDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, * .. External Functions .. LOGICAL LSAME INTEGER NUMROC - COMPLEX CDOTC - EXTERNAL CDOTC, LSAME, NUMROC + EXTERNAL LSAME, NUMROC * .. * .. Intrinsic Functions .. INTRINSIC ICHAR, MIN, MOD @@ -741,8 +741,8 @@ SUBROUTINE PCDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, * * Calculate the update block for previous proc, E_i = GL_i{GU_i} * - AF( ODD_SIZE+3 ) = -CONE * - $ CDOTC( ODD_SIZE, AF( 1 ), 1, AF( WORK_U+1 ), 1 ) + CALL CCDOTC( ODD_SIZE, DOTC, AF( 1 ), 1, AF( WORK_U+1 ), 1 ) + AF( ODD_SIZE+3 ) = -CONE * DOTC * * * Initiate send of E_i to previous processor to overlap diff --git a/SRC/pchetd2.f b/SRC/pchetd2.f index b6825806..dd0a909d 100644 --- a/SRC/pchetd2.f +++ b/SRC/pchetd2.f @@ -228,17 +228,16 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, INTEGER IACOL, IAROW, ICOFFA, ICTXT, II, IK, IROFFA, J, $ JJ, JK, JN, LDA, LWMIN, MYCOL, MYROW, NPCOL, $ NPROW - COMPLEX ALPHA, TAUI + COMPLEX ALPHA, TAUI, DOTC * .. * .. External Subroutines .. - EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, CAXPY, CGEBR2D, - $ CGEBS2D, CHK1MAT, CHEMV, + EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, CAXPY, CCDOTC, + $ CGEBR2D, CGEBS2D, CHK1MAT, CHEMV, $ CHER2, CLARFG, INFOG2L, PXERBLA * .. * .. External Functions .. LOGICAL LSAME - COMPLEX CDOTC - EXTERNAL LSAME, CDOTC + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, REAL @@ -333,8 +332,9 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * Compute w := x - 1/2 * tau * (x'*v) * v * - ALPHA = -HALF*TAUI*CDOTC( J, TAU( JJ ), 1, - $ A( II+JK*LDA ), 1 ) + CALL CCDOTC( J, DOTC, TAU( JJ ), 1, A( II+JK*LDA ), + $ 1 ) + ALPHA = -HALF*TAUI*DOTC CALL CAXPY( J, ALPHA, A( II+JK*LDA ), 1, $ TAU( JJ ), 1 ) * @@ -413,8 +413,9 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * Compute w := x - 1/2 * tau * (x'*v) * v * - ALPHA = -HALF*TAUI*CDOTC( N-J, TAU( JK ), 1, - $ A( IK+1+(JK-1)*LDA ), 1 ) + CALL CCDOTC( N-J, DOTC, TAU( JK ), 1, + $ A( IK+1+(JK-1)*LDA ), 1 ) + ALPHA = -HALF*TAUI*DOTC CALL CAXPY( N-J, ALPHA, A( IK+1+(JK-1)*LDA ), $ 1, TAU( JK ), 1 ) * diff --git a/SRC/pclarfg.f b/SRC/pclarfg.f index babd0df8..3c969e25 100644 --- a/SRC/pclarfg.f +++ b/SRC/pclarfg.f @@ -153,16 +153,16 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, * .. Local Scalars .. INTEGER ICTXT, IIAX, INDXTAU, IXCOL, IXROW, J, JJAX, $ KNT, MYCOL, MYROW, NPCOL, NPROW - REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM + REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM, CR, + $ CI * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, CGEBR2D, CGEBS2D, PCSCAL, - $ PCSSCAL, INFOG2L, PSCNRM2 + $ PCSSCAL, INFOG2L, PSCNRM2, SLADIV * .. * .. External Functions .. REAL SLAMCH, SLAPY3 - COMPLEX CLADIV - EXTERNAL CLADIV, SLAPY3, SLAMCH + EXTERNAL SLAPY3, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN @@ -265,7 +265,9 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU( INDXTAU ) = CMPLX( ( BETA-ALPHR ) / BETA, $ -ALPHI / BETA ) - ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA ) + CALL SLADIV( ONE, ZERO, REAL( ALPHA-BETA ), + $ AIMAG( ALPHA-BETA ), CR, CI ) + ALPHA = CMPLX( CR, CI ) CALL PCSCAL( N-1, ALPHA, X, IX, JX, DESCX, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy @@ -277,7 +279,9 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, ELSE TAU( INDXTAU ) = CMPLX( ( BETA-ALPHR ) / BETA, $ -ALPHI / BETA ) - ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA ) + CALL SLADIV( ONE, ZERO, REAL( ALPHA-BETA ), + $ AIMAG( ALPHA-BETA ), CR, CI ) + ALPHA = CMPLX( CR, CI ) CALL PCSCAL( N-1, ALPHA, X, IX, JX, DESCX, INCX ) ALPHA = BETA END IF diff --git a/SRC/pclattrs.f b/SRC/pclattrs.f index 0d12a8b9..8551e077 100644 --- a/SRC/pclattrs.f +++ b/SRC/pclattrs.f @@ -271,7 +271,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ JINC, JLAST, LDA, LDX, MB, MYCOL, MYROW, NB, $ NPCOL, NPROW, RSRC REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, - $ XBND, XJ + $ XBND, XJ, CR, CI REAL XMAX( 1 ) COMPLEX CSUMJ, TJJS, USCAL, XJTMP, ZDUM * .. @@ -279,14 +279,13 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, LOGICAL LSAME INTEGER ISAMAX REAL PSLAMCH - COMPLEX CLADIV - EXTERNAL LSAME, ISAMAX, PSLAMCH, CLADIV + EXTERNAL LSAME, ISAMAX, PSLAMCH * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, SGSUM2D, SSCAL, INFOG2L, $ PSCASUM, PSLABAD, PXERBLA, PCAMAX, PCAXPY, $ PCDOTC, PCDOTU, PCSSCAL, PCLASET, PCSCAL, - $ PCTRSV, CGEBR2D, CGEBS2D + $ PCTRSV, CGEBR2D, CGEBS2D, SLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, CMPLX, CONJG, AIMAG, MAX, MIN @@ -657,7 +656,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF * X( J ) = CLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) XJ = CABS1( XJTMP ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN @@ -687,7 +688,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF * X( J ) = CLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) XJ = CABS1( XJTMP ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN @@ -815,7 +818,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) - USCAL = CLADIV( USCAL, TJJS ) + CALL SLADIV( REAL( USCAL ), AIMAG( USCAL ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + USCAL = CMPLX( CR, CI ) END IF IF( REC.LT.ONE ) THEN CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) @@ -857,7 +862,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) CALL PCDOTU( J-1, CSUMJ, A, IA, JA+J-1, DESCA, 1, $ X, IX, JX, DESCX, 1 ) - ZDUM = CLADIV( ZDUM, USCAL ) + CALL SLADIV( REAL( ZDUM ), AIMAG( ZDUM ), + $ REAL( USCAL ), AIMAG( USCAL ), CR, CI) + ZDUM = CMPLX( CR, CI ) CALL PCSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) ELSE IF( J.LT.N ) THEN * DO 140 I = J + 1, N @@ -867,7 +874,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) CALL PCDOTU( N-J, CSUMJ, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) - ZDUM = CLADIV( ZDUM, USCAL ) + CALL SLADIV( REAL( ZDUM ), AIMAG( ZDUM ), + $ REAL( USCAL ), AIMAG( USCAL ), CR, CI) + ZDUM = CMPLX( CR, CI ) CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) END IF IF( MYCOL.EQ.ITMP2X ) THEN @@ -929,7 +938,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF END IF * X( J ) = CLADIV( X( J ), TJJS ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -949,7 +960,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = CLADIV( X( J ), TJJS ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -976,7 +989,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * product has already been divided by 1/A(j,j). * * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ - XJTMP = CLADIV( XJTMP, TJJS ) - CSUMJ + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -1034,7 +1049,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) - USCAL = CLADIV( USCAL, TJJS ) + CALL SLADIV( REAL( USCAL ), AIMAG( USCAL ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + USCAL = CMPLX( CR, CI ) END IF IF( REC.LT.ONE ) THEN CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) @@ -1077,7 +1094,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) CALL PCDOTC( J-1, CSUMJ, A, IA, JA+J-1, DESCA, 1, $ X, IX, JX, DESCX, 1 ) - ZDUM = CLADIV( CONE, ZDUM ) + CALL SLADIV( ONE, ZERO, + $ REAL( ZDUM ), AIMAG( ZDUM ), CR, CI ) + ZDUM = CMPLX( CR, CI ) CALL PCSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) ELSE IF( J.LT.N ) THEN * DO 190 I = J + 1, N @@ -1088,7 +1107,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) CALL PCDOTC( N-J, CSUMJ, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) - ZDUM = CLADIV( CONE, ZDUM ) + CALL SLADIV( ONE, ZERO, + $ REAL( ZDUM ), AIMAG( ZDUM ), CR, CI ) + ZDUM = CMPLX( CR, CI ) CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) END IF IF( MYCOL.EQ.ITMP2X ) THEN @@ -1150,7 +1171,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF END IF * X( J ) = CLADIV( X( J ), TJJS ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP ELSE IF( TJJ.GT.ZERO ) THEN @@ -1168,7 +1191,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = CLADIV( X( J ), TJJS ) - XJTMP = CLADIV( XJTMP, TJJS ) + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP ELSE @@ -1191,7 +1216,9 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * product has already been divided by 1/A(j,j). * * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ - XJTMP = CLADIV( XJTMP, TJJS ) - CSUMJ + CALL SLADIV( REAL( XJTMP ), AIMAG( XJTMP ), + $ REAL( TJJS ), AIMAG( TJJS ), CR, CI ) + XJTMP = CMPLX( CR, CI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP END IF diff --git a/SRC/pclauu2.f b/SRC/pclauu2.f index ee1c2d91..59bdd4f1 100644 --- a/SRC/pclauu2.f +++ b/SRC/pclauu2.f @@ -131,15 +131,15 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) INTEGER IACOL, IAROW, ICURR, IDIAG, IIA, IOFFA, JJA, $ LDA, MYCOL, MYROW, NA, NPCOL, NPROW REAL AII + COMPLEX DOTC * .. * .. External Subroutines .. - EXTERNAL BLACS_GRIDINFO, CGEMV, CLACGV, + EXTERNAL BLACS_GRIDINFO, CCDOTC, CGEMV, CLACGV, $ CSSCAL, INFOG2L * .. * .. External Functions .. LOGICAL LSAME - COMPLEX CDOTC - EXTERNAL CDOTC, LSAME + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, REAL @@ -170,8 +170,8 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) DO 10 NA = N-1, 1, -1 AII = A( IDIAG ) ICURR = IDIAG + LDA - A( IDIAG ) = AII*AII + REAL( CDOTC( NA, A( ICURR ), LDA, - $ A( ICURR ), LDA ) ) + CALL CCDOTC( NA, DOTC, A( ICURR ), LDA, A( ICURR ), LDA ) + A( IDIAG ) = AII*AII + REAL( DOTC ) CALL CLACGV( NA, A( ICURR ), LDA ) CALL CGEMV( 'No transpose', N-NA-1, NA, ONE, $ A( IOFFA+LDA ), LDA, A( ICURR ), LDA, diff --git a/SRC/pdtrord.f b/SRC/pdtrord.f index 6206ff45..63e9457a 100644 --- a/SRC/pdtrord.f +++ b/SRC/pdtrord.f @@ -487,10 +487,10 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, MMAX( 1 ) = M MMIN( 1 ) = M IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, + $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX( 1 ), 1, -1, $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) - $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, + $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN( 1 ), 1, -1, $ -1, -1, -1, -1 ) IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN M = MMAX( 1 ) diff --git a/SRC/pstrord.f b/SRC/pstrord.f index 4bd7785b..6960914a 100644 --- a/SRC/pstrord.f +++ b/SRC/pstrord.f @@ -487,10 +487,10 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, MMAX( 1 ) = M MMIN( 1 ) = M IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, + $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX( 1 ), 1, -1, $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) - $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, + $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN( 1 ), 1, -1, $ -1, -1, -1, -1 ) IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN M = MMAX( 1 ) diff --git a/SRC/pstrsen.f b/SRC/pstrsen.f index 83dfd567..7f6d4eec 100644 --- a/SRC/pstrsen.f +++ b/SRC/pstrsen.f @@ -526,11 +526,11 @@ SUBROUTINE PSTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, MMAX( 1 ) = M MMIN( 1 ) = M IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, - $ -1, -1, -1, -1 ) + $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX( 1 ), 1, -1, + $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) - $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, - $ -1, -1, -1, -1 ) + $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN( 1 ), 1, -1, + $ -1, -1, -1, -1 ) IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN M = MMAX( 1 ) IF( NPROCS.GT.1 ) diff --git a/SRC/pzdttrf.f b/SRC/pzdttrf.f index 65b116cf..47006a1e 100644 --- a/SRC/pzdttrf.f +++ b/SRC/pzdttrf.f @@ -376,6 +376,7 @@ SUBROUTINE PZDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, $ NB, NP, NPCOL, NPROW, NP_SAVE, ODD_SIZE, $ PART_OFFSET, PART_SIZE, RETURN_CODE, STORE_N_A, $ TEMP, WORK_SIZE_MIN, WORK_U + COMPLEX*16 DOTC * .. * .. Local Arrays .. INTEGER DESCA_1XP( 7 ), PARAM_CHECK( 7, 3 ) @@ -385,13 +386,12 @@ SUBROUTINE PZDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, $ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZAXPY, $ ZGEMM, ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY, $ ZPBTRF, ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D, - $ ZTRSD2D, ZTRSM, ZTRTRS + $ ZTRSD2D, ZTRSM, ZTRTRS, ZZDOTC * .. * .. External Functions .. LOGICAL LSAME INTEGER NUMROC - COMPLEX*16 ZDOTC - EXTERNAL LSAME, NUMROC, ZDOTC + EXTERNAL LSAME, NUMROC * .. * .. Intrinsic Functions .. INTRINSIC ICHAR, MIN, MOD @@ -741,8 +741,8 @@ SUBROUTINE PZDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK, * * Calculate the update block for previous proc, E_i = GL_i{GU_i} * - AF( ODD_SIZE+3 ) = -CONE * - $ ZDOTC( ODD_SIZE, AF( 1 ), 1, AF( WORK_U+1 ), 1 ) + CALL ZZDOTC( ODD_SIZE, DOTC, AF( 1 ), 1, AF( WORK_U+1 ), 1 ) + AF( ODD_SIZE+3 ) = -CONE * DOTC * * * Initiate send of E_i to previous processor to overlap diff --git a/SRC/pzhetd2.f b/SRC/pzhetd2.f index fc326a43..329fca86 100644 --- a/SRC/pzhetd2.f +++ b/SRC/pzhetd2.f @@ -228,17 +228,16 @@ SUBROUTINE PZHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, INTEGER IACOL, IAROW, ICOFFA, ICTXT, II, IK, IROFFA, J, $ JJ, JK, JN, LDA, LWMIN, MYCOL, MYROW, NPCOL, $ NPROW - COMPLEX*16 ALPHA, TAUI + COMPLEX*16 ALPHA, TAUI, DOTC * .. * .. External Subroutines .. EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, CHK1MAT, INFOG2L, $ PXERBLA, ZAXPY, ZGEBR2D, ZGEBS2D, - $ ZHEMV, ZHER2, ZLARFG + $ ZHEMV, ZHER2, ZLARFG, ZZDOTC * .. * .. External Functions .. LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX @@ -333,8 +332,9 @@ SUBROUTINE PZHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * Compute w := x - 1/2 * tau * (x'*v) * v * - ALPHA = -HALF*TAUI*ZDOTC( J, TAU( JJ ), 1, - $ A( II+JK*LDA ), 1 ) + CALL ZZDOTC( J, DOTC, TAU( JJ ), 1, A( II+JK*LDA ), + $ 1 ) + ALPHA = -HALF*TAUI*DOTC CALL ZAXPY( J, ALPHA, A( II+JK*LDA ), 1, $ TAU( JJ ), 1 ) * @@ -413,8 +413,9 @@ SUBROUTINE PZHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * Compute w := x - 1/2 * tau * (x'*v) * v * - ALPHA = -HALF*TAUI*ZDOTC( N-J, TAU( JK ), 1, - $ A( IK+1+(JK-1)*LDA ), 1 ) + CALL ZZDOTC( N-J, DOTC, TAU( JK ), 1, + $ A( IK+1+(JK-1)*LDA ), 1 ) + ALPHA = -HALF*TAUI*DOTC CALL ZAXPY( N-J, ALPHA, A( IK+1+(JK-1)*LDA ), $ 1, TAU( JK ), 1 ) * diff --git a/SRC/pzlarfg.f b/SRC/pzlarfg.f index 010dbe9c..90a2bc63 100644 --- a/SRC/pzlarfg.f +++ b/SRC/pzlarfg.f @@ -153,17 +153,17 @@ SUBROUTINE PZLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, * .. Local Scalars .. INTEGER ICTXT, IIAX, INDXTAU, IXCOL, IXROW, J, JJAX, $ KNT, MYCOL, MYROW, NPCOL, NPROW - DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM + DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM, ZR, + $ ZI * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PDZNRM2, $ ZGEBR2D, ZGEBS2D, PZSCAL, - $ PZDSCAL + $ PZDSCAL, DLADIV * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3 - COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, DLAPY3, ZLADIV + EXTERNAL DLAMCH, DLAPY3 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN @@ -266,7 +266,9 @@ SUBROUTINE PZLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU( INDXTAU ) = DCMPLX( ( BETA-ALPHR ) / BETA, $ -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL DLADIV( ONE, ZERO, DBLE( ALPHA-BETA ), + $ DIMAG( ALPHA-BETA ), ZR, ZI ) + ALPHA = DCMPLX( ZR, ZI ) CALL PZSCAL( N-1, ALPHA, X, IX, JX, DESCX, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy @@ -278,7 +280,9 @@ SUBROUTINE PZLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, ELSE TAU( INDXTAU ) = DCMPLX( ( BETA-ALPHR ) / BETA, $ -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL DLADIV( ONE, ZERO, DBLE( ALPHA-BETA ), + $ DIMAG( ALPHA-BETA ), ZR, ZI ) + ALPHA = DCMPLX( ZR, ZI ) CALL PZSCAL( N-1, ALPHA, X, IX, JX, DESCX, INCX ) ALPHA = BETA END IF diff --git a/SRC/pzlattrs.f b/SRC/pzlattrs.f index 5a542095..e0cbc584 100644 --- a/SRC/pzlattrs.f +++ b/SRC/pzlattrs.f @@ -271,7 +271,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ JINC, JLAST, LDA, LDX, MB, MYCOL, MYROW, NB, $ NPCOL, NPROW, RSRC DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, - $ XBND, XJ + $ XBND, XJ, ZR, ZI COMPLEX*16 CSUMJ, TJJS, USCAL, XJTMP, ZDUM DOUBLE PRECISION XMAX( 1 ) * .. @@ -279,14 +279,13 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION PDLAMCH - COMPLEX*16 ZLADIV - EXTERNAL LSAME, IDAMAX, PDLAMCH, ZLADIV + EXTERNAL LSAME, IDAMAX, PDLAMCH * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, DGSUM2D, DSCAL, INFOG2L, $ PDLABAD, PDZASUM, PXERBLA, PZAMAX, PZAXPY, $ PZDOTC, PZDOTU, PZDSCAL, PZLASET, PZSCAL, - $ PZTRSV, ZGEBR2D, ZGEBS2D + $ PZTRSV, ZGEBR2D, ZGEBS2D, DLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN @@ -657,7 +656,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF * X( J ) = ZLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) XJ = CABS1( XJTMP ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN @@ -687,7 +688,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF * X( J ) = ZLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) XJ = CABS1( XJTMP ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN @@ -815,7 +818,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) - USCAL = ZLADIV( USCAL, TJJS ) + CALL DLADIV( DBLE( USCAL ), DIMAG( USCAL ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + USCAL = DCMPLX( ZR, ZI ) END IF IF( REC.LT.ONE ) THEN CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) @@ -857,7 +862,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) CALL PZDOTU( J-1, CSUMJ, A, IA, JA+J-1, DESCA, 1, $ X, IX, JX, DESCX, 1 ) - ZDUM = ZLADIV( ZDUM, USCAL ) + CALL DLADIV( DBLE( ZDUM ), DIMAG( ZDUM ), + $ DBLE( USCAL ), DIMAG( USCAL ), ZR, ZI) + ZDUM = DCMPLX( ZR, ZI ) CALL PZSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) ELSE IF( J.LT.N ) THEN * DO 140 I = J + 1, N @@ -867,7 +874,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) CALL PZDOTU( N-J, CSUMJ, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) - ZDUM = ZLADIV( ZDUM, USCAL ) + CALL DLADIV( DBLE( ZDUM ), DIMAG( ZDUM ), + $ DBLE( USCAL ), DIMAG( USCAL ), ZR, ZI) + ZDUM = DCMPLX( ZR, ZI ) CALL PZSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) END IF IF( MYCOL.EQ.ITMP2X ) THEN @@ -929,7 +938,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF END IF * X( J ) = ZLADIV( X( J ), TJJS ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -949,7 +960,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = ZLADIV( X( J ), TJJS ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -976,7 +989,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * product has already been divided by 1/A(j,j). * * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ - XJTMP = ZLADIV( XJTMP, TJJS ) - CSUMJ + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ THEN X( IROWX ) = XJTMP @@ -1034,7 +1049,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) - USCAL = ZLADIV( USCAL, TJJS ) + CALL DLADIV( DBLE( USCAL ), DIMAG( USCAL ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + USCAL = DCMPLX( ZR, ZI ) END IF IF( REC.LT.ONE ) THEN CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) @@ -1077,7 +1094,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) CALL PZDOTC( J-1, CSUMJ, A, IA, JA+J-1, DESCA, 1, $ X, IX, JX, DESCX, 1 ) - ZDUM = ZLADIV( CONE, ZDUM ) + CALL DLADIV( ONE, ZERO, + $ DBLE( ZDUM ), DIMAG( ZDUM ), ZR, ZI ) + ZDUM = DCMPLX( ZR, ZI ) CALL PZSCAL( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1 ) ELSE IF( J.LT.N ) THEN * DO 190 I = J + 1, N @@ -1088,7 +1107,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) CALL PZDOTC( N-J, CSUMJ, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) - ZDUM = ZLADIV( CONE, ZDUM ) + CALL DLADIV( ONE, ZERO, + $ DBLE( ZDUM ), DIMAG( ZDUM ), ZR, ZI ) + ZDUM = DCMPLX( ZR, ZI ) CALL PZSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) END IF IF( MYCOL.EQ.ITMP2X ) THEN @@ -1150,7 +1171,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF END IF * X( J ) = ZLADIV( X( J ), TJJS ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP ELSE IF( TJJ.GT.ZERO ) THEN @@ -1168,7 +1191,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = ZLADIV( X( J ), TJJS ) - XJTMP = ZLADIV( XJTMP, TJJS ) + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP ELSE @@ -1191,7 +1216,9 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * product has already been divided by 1/A(j,j). * * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ - XJTMP = ZLADIV( XJTMP, TJJS ) - CSUMJ + CALL DLADIV( DBLE( XJTMP ), DIMAG( XJTMP ), + $ DBLE( TJJS ), DIMAG( TJJS ), ZR, ZI ) + XJTMP = DCMPLX( ZR, ZI ) IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP END IF diff --git a/SRC/pzlauu2.f b/SRC/pzlauu2.f index 354d93d9..25ba8823 100644 --- a/SRC/pzlauu2.f +++ b/SRC/pzlauu2.f @@ -131,15 +131,15 @@ SUBROUTINE PZLAUU2( UPLO, N, A, IA, JA, DESCA ) INTEGER IACOL, IAROW, ICURR, IDIAG, IIA, IOFFA, JJA, $ LDA, MYCOL, MYROW, NA, NPCOL, NPROW DOUBLE PRECISION AII + COMPLEX*16 DOTC * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, ZDSCAL, ZGEMV, - $ ZLACGV + $ ZLACGV, ZZDOTC * .. * .. External Functions .. LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, DBLE @@ -170,8 +170,8 @@ SUBROUTINE PZLAUU2( UPLO, N, A, IA, JA, DESCA ) DO 10 NA = N-1, 1, -1 AII = A( IDIAG ) ICURR = IDIAG + LDA - A( IDIAG ) = AII*AII + DBLE( ZDOTC( NA, A( ICURR ), LDA, - $ A( ICURR ), LDA ) ) + CALL ZZDOTC( NA, DOTC, A( ICURR ), LDA, A( ICURR ), LDA ) + A( IDIAG ) = AII*AII + DBLE( DOTC ) CALL ZLACGV( NA, A( ICURR ), LDA ) CALL ZGEMV( 'No transpose', N-NA-1, NA, ONE, $ A( IOFFA+LDA ), LDA, A( ICURR ), LDA, diff --git a/SRC/pzpotf2.f b/SRC/pzpotf2.f index 91c7f479..8b2695ba 100644 --- a/SRC/pzpotf2.f +++ b/SRC/pzpotf2.f @@ -152,19 +152,19 @@ SUBROUTINE PZPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) $ IOFFA, IROFF, J, JJA, LDA, MYCOL, MYROW, $ NPCOL, NPROW DOUBLE PRECISION AJJ + COMPLEX*16 DOT * .. * .. External Subroutines .. EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, CHK1MAT, IGEBR2D, $ IGEBS2D, INFOG2L, PB_TOPGET, PXERBLA, ZGEMV, - $ ZLACGV, ZDSCAL + $ ZLACGV, ZDSCAL, ZZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MOD, SQRT * .. * .. External Functions .. LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME * .. * .. Executable Statements .. * @@ -233,8 +233,8 @@ SUBROUTINE PZPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * * Compute U(J,J) and test for non-positive-definiteness. * - AJJ = DBLE( A( IDIAG ) ) - - $ ZDOTC( J-JA, A( IOFFA ), 1, A( IOFFA ), 1 ) + CALL ZZDOTC( J-JA, DOT, A( IOFFA ), 1, A( IOFFA ), 1 ) + AJJ = DBLE( A( IDIAG ) - DOT ) IF( AJJ.LE.ZERO ) THEN A( IDIAG ) = AJJ INFO = J - JA + 1 @@ -299,8 +299,9 @@ SUBROUTINE PZPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * * Compute L(J,J) and test for non-positive-definiteness. * - AJJ = DBLE( A( IDIAG ) ) - - $ ZDOTC( J-JA, A( IOFFA ), LDA, A( IOFFA ), LDA ) + CALL ZZDOTC( J-JA, DOT, A( IOFFA ), LDA, A( IOFFA ), + $ LDA ) + AJJ = DBLE( A( IDIAG ) - DOT ) IF ( AJJ.LE.ZERO ) THEN A( IDIAG ) = AJJ INFO = J - JA + 1 diff --git a/SRC/zlanv2.f b/SRC/zlanv2.f index f7534827..43d88a58 100644 --- a/SRC/zlanv2.f +++ b/SRC/zlanv2.f @@ -55,13 +55,10 @@ SUBROUTINE ZLANV2( A, B, C, D, RT1, RT2, CS, SN ) * .. * .. Local Scalars .. COMPLEX*16 AA, BB, DD, T, TEMP, TEMP2, U, X, Y -* .. -* .. External Functions .. - COMPLEX*16 ZLADIV - EXTERNAL ZLADIV + DOUBLE PRECISION ZR, ZI * .. * .. External Subroutines .. - EXTERNAL ZLARTG + EXTERNAL ZLARTG, DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, SQRT @@ -97,9 +94,13 @@ SUBROUTINE ZLANV2( A, B, C, D, RT1, RT2, CS, SN ) SN = DCMPLX( RZERO, RONE )*CS ELSE TEMP = SQRT( B+C ) - TEMP2 = ZLADIV( SQRT( B ), TEMP ) + CALL DLADIV( DBLE( SQRT( B ) ), DIMAG( SQRT( B ) ), + $ DBLE( TEMP ), DIMAG( TEMP ), ZR, ZI ) + TEMP2 = DCMPLX( ZR, ZI ) CS = DBLE( TEMP2 ) - SN = ZLADIV( SQRT( C ), TEMP ) + CALL DLADIV( DBLE( SQRT( C ) ), DIMAG( SQRT( C ) ), + $ DBLE( TEMP ), DIMAG( TEMP ), ZR, ZI ) + SN = DCMPLX( ZR, ZI ) END IF B = B - C C = ZERO @@ -114,7 +115,9 @@ SUBROUTINE ZLANV2( A, B, C, D, RT1, RT2, CS, SN ) Y = SQRT( X*X+U ) IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO ) $ Y = -Y - T = T - ZLADIV( U, ( X+Y ) ) + CALL DLADIV( DBLE( U ), DIMAG( U ), + $ DBLE( X+Y ), DIMAG( X+Y ), ZR, ZI ) + T = T - DCMPLX( ZR, ZI ) * * Do one QR step with exact shift T - resulting 2 x 2 in * triangular form. diff --git a/TOOLS/LAPACK/claghe.f b/TOOLS/LAPACK/claghe.f index f9e4a03d..b2fcebd8 100644 --- a/TOOLS/LAPACK/claghe.f +++ b/TOOLS/LAPACK/claghe.f @@ -64,16 +64,15 @@ SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * .. Local Scalars .. INTEGER I, J REAL WN - COMPLEX ALPHA, TAU, WA, WB + COMPLEX ALPHA, TAU, WA, WB, DOTC * .. * .. External Subroutines .. - EXTERNAL CAXPY, CGEMV, CGERC, CHEMV, CHER2, CLARNV, - $ CSCAL, XERBLA + EXTERNAL CAXPY, CCDOTC, CGEMV, CGERC, CHEMV, CHER2, + $ CLARNV, CSCAL, XERBLA * .. * .. External Functions .. REAL SCNRM2 - COMPLEX CDOTC - EXTERNAL SCNRM2, CDOTC + EXTERNAL SCNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, REAL @@ -134,7 +133,8 @@ SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( y, u ) * u * - ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL CCDOTC( N-I+1, DOTC, WORK( N+1 ), 1, WORK, 1 ) + ALPHA = -HALF*TAU*DOTC CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) @@ -176,7 +176,8 @@ SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( y, u ) * u * - ALPHA = -HALF*TAU*CDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL CCDOTC( N-K-I+1, DOTC, WORK, 1, A( K+I, I ), 1 ) + ALPHA = -HALF*TAU*DOTC CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply hermitian rank-2 update to A(k+i:n,k+i:n) diff --git a/TOOLS/LAPACK/clagsy.f b/TOOLS/LAPACK/clagsy.f index 8b356c94..cfda5a88 100644 --- a/TOOLS/LAPACK/clagsy.f +++ b/TOOLS/LAPACK/clagsy.f @@ -64,16 +64,15 @@ SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * .. Local Scalars .. INTEGER I, II, J, JJ REAL WN - COMPLEX ALPHA, TAU, WA, WB + COMPLEX ALPHA, TAU, WA, WB, DOTC * .. * .. External Subroutines .. - EXTERNAL CAXPY, CGEMV, CGERC, CLACGV, CLARNV, CSCAL, - $ CSYMV, XERBLA + EXTERNAL CAXPY, CCDOTC, CGEMV, CGERC, CLACGV, CLARNV, + $ CSCAL, CSYMV, XERBLA * .. * .. External Functions .. REAL SCNRM2 - COMPLEX CDOTC - EXTERNAL SCNRM2, CDOTC + EXTERNAL SCNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL @@ -136,7 +135,8 @@ SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( u, y ) * u * - ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 ) + CALL CCDOTC( N-I+1, DOTC, WORK, 1, WORK( N+1 ), 1 ) + ALPHA = -HALF*TAU*DOTC CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) @@ -188,7 +188,8 @@ SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( u, y ) * u * - ALPHA = -HALF*TAU*CDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 ) + CALL CCDOTC( N-K-I+1, DOTC, A( K+I, I ), 1, WORK, 1 ) + ALPHA = -HALF*TAU*DOTC CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) diff --git a/TOOLS/LAPACK/zlaghe.f b/TOOLS/LAPACK/zlaghe.f index 0e86fc33..5df4f511 100644 --- a/TOOLS/LAPACK/zlaghe.f +++ b/TOOLS/LAPACK/zlaghe.f @@ -64,16 +64,15 @@ SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION WN - COMPLEX*16 ALPHA, TAU, WA, WB + COMPLEX*16 ALPHA, TAU, WA, WB, DOTC * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZHEMV, ZHER2, - $ ZLARNV, ZSCAL + $ ZLARNV, ZSCAL, ZZDOTC * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 - COMPLEX*16 ZDOTC - EXTERNAL DZNRM2, ZDOTC + EXTERNAL DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX @@ -134,7 +133,8 @@ SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( y, u ) * u * - ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL ZZDOTC( N-I+1, DOTC, WORK( N+1 ), 1, WORK, 1 ) + ALPHA = -HALF*TAU*DOTC CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) @@ -176,7 +176,8 @@ SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( y, u ) * u * - ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL ZZDOTC( N-K-I+1, DOTC, WORK, 1, A( K+I, I ), 1 ) + ALPHA = -HALF*TAU*DOTC CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply hermitian rank-2 update to A(k+i:n,k+i:n) diff --git a/TOOLS/LAPACK/zlagsy.f b/TOOLS/LAPACK/zlagsy.f index 7adb609b..19532702 100644 --- a/TOOLS/LAPACK/zlagsy.f +++ b/TOOLS/LAPACK/zlagsy.f @@ -64,16 +64,15 @@ SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * .. Local Scalars .. INTEGER I, II, J, JJ DOUBLE PRECISION WN - COMPLEX*16 ALPHA, TAU, WA, WB + COMPLEX*16 ALPHA, TAU, WA, WB, DOTC * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZLACGV, ZLARNV, - $ ZSCAL, ZSYMV + $ ZSCAL, ZSYMV, ZZDOTC * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 - COMPLEX*16 ZDOTC - EXTERNAL DZNRM2, ZDOTC + EXTERNAL DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX @@ -136,7 +135,8 @@ SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( u, y ) * u * - ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 ) + CALL ZZDOTC( N-I+1, DOTC, WORK, 1, WORK( N+1 ), 1 ) + ALPHA = -HALF*TAU*DOTC CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) @@ -188,7 +188,8 @@ SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * compute v := y - 1/2 * tau * ( u, y ) * u * - ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 ) + CALL ZZDOTC( N-K-I+1, DOTC, A( K+I, I ), 1, WORK, 1 ) + ALPHA = -HALF*TAU*DOTC CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) diff --git a/TOOLS/ccdotc.f b/TOOLS/ccdotc.f index 65a797fc..6d4d883c 100644 --- a/TOOLS/ccdotc.f +++ b/TOOLS/ccdotc.f @@ -21,13 +21,41 @@ SUBROUTINE CCDOTC( N, DOTC, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX CDOTC - EXTERNAL CDOTC +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG * .. * .. Executable Statements .. * - DOTC = CDOTC( N, X, INCX, Y, INCY ) + CTEMP = (0.0d0,0.0d0) + DOTC = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,N + CTEMP = CTEMP + CONJG(X(I))*Y(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + CONJG(X(IX))*Y(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DOTC = CTEMP * RETURN * diff --git a/TOOLS/ccdotu.f b/TOOLS/ccdotu.f index c53111bf..561d5db8 100644 --- a/TOOLS/ccdotu.f +++ b/TOOLS/ccdotu.f @@ -21,13 +21,38 @@ SUBROUTINE CCDOTU( N, DOTU, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX CDOTU - EXTERNAL CDOTU +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY * .. * .. Executable Statements .. * - DOTU = CDOTU( N, X, INCX, Y, INCY ) + CTEMP = (0.0d0,0.0d0) + DOTU = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,N + CTEMP = CTEMP + X(I)*Y(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + X(IX)*Y(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DOTU = CTEMP * RETURN * diff --git a/TOOLS/zzdotc.f b/TOOLS/zzdotc.f index 9ca48d5b..3c65e1ca 100644 --- a/TOOLS/zzdotc.f +++ b/TOOLS/zzdotc.f @@ -21,13 +21,41 @@ SUBROUTINE ZZDOTC( N, DOTC, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX*16 ZDOTC - EXTERNAL ZDOTC +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG * .. * .. Executable Statements .. * - DOTC = ZDOTC( N, X, INCX, Y, INCY ) + ZTEMP = (0.0d0,0.0d0) + DOTC = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,N + ZTEMP = ZTEMP + DCONJG(X(I))*Y(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(X(IX))*Y(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DOTC = ZTEMP * RETURN * diff --git a/TOOLS/zzdotu.f b/TOOLS/zzdotu.f index 6fba3e09..d4cb3760 100644 --- a/TOOLS/zzdotu.f +++ b/TOOLS/zzdotu.f @@ -21,13 +21,38 @@ SUBROUTINE ZZDOTU( N, DOTU, X, INCX, Y, INCY ) * * ===================================================================== * -* .. External Functions .. - COMPLEX*16 ZDOTU - EXTERNAL ZDOTU +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY * .. * .. Executable Statements .. * - DOTU = ZDOTU( N, X, INCX, Y, INCY ) + ZTEMP = (0.0d0,0.0d0) + DOTU = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,N + ZTEMP = ZTEMP + X(I)*Y(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + X(IX)*Y(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DOTU = ZTEMP * RETURN *