From 9c909f06cf51a3d00252323ce52aba46cc64ab41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tiziano=20M=C3=BCller?= Date: Thu, 25 Jun 2020 18:36:46 +0200 Subject: [PATCH 1/2] fix argument mismatches in the SRC --- SRC/pclarf.f | 80 +++++++++++++++++----------------- SRC/pclarfc.f | 88 ++++++++++++++++++------------------- SRC/pclarz.f | 111 ++++++++++++++++++++++++----------------------- SRC/pclarzc.f | 115 +++++++++++++++++++++++++------------------------ SRC/pclattrs.f | 55 +++++++++++------------ SRC/pclawil.f | 53 +++++++++++------------ SRC/pctrevc.f | 20 +++++---- SRC/pdhseqr.f | 36 ++++++++-------- SRC/pdlacon.f | 36 ++++++++-------- SRC/pdlarf.f | 80 +++++++++++++++++----------------- SRC/pdlarz.f | 100 +++++++++++++++++++++--------------------- SRC/pdlawil.f | 48 ++++++++++----------- SRC/pdstebz.f | 20 ++++----- SRC/pdtrord.f | 43 +++++++++++------- SRC/pdtrsen.f | 24 ++++++----- SRC/pshseqr.f | 36 ++++++++-------- SRC/pslacon.f | 36 +++++++++------- SRC/pslarf.f | 80 +++++++++++++++++----------------- SRC/pslarz.f | 100 +++++++++++++++++++++--------------------- SRC/pslawil.f | 50 +++++++++++---------- SRC/psstebz.f | 20 ++++----- SRC/pstrord.f | 45 +++++++++++-------- SRC/pstrsen.f | 22 ++++++---- SRC/pzlarf.f | 80 +++++++++++++++++----------------- SRC/pzlarfc.f | 88 ++++++++++++++++++------------------- SRC/pzlarz.f | 103 +++++++++++++++++++++---------------------- SRC/pzlarzc.f | 111 ++++++++++++++++++++++++----------------------- SRC/pzlattrs.f | 55 +++++++++++------------ SRC/pzlawil.f | 49 +++++++++++---------- SRC/pztrevc.f | 20 +++++---- 30 files changed, 927 insertions(+), 877 deletions(-) diff --git a/SRC/pclarf.f b/SRC/pclarf.f index f941e46..371f710 100644 --- a/SRC/pclarf.f +++ b/SRC/pclarf.f @@ -242,7 +242,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - COMPLEX TAULOC + COMPLEX TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, CCOPY, CGEBR2D, CGEBS2D, @@ -336,7 +336,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -345,7 +345,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -363,8 +363,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -379,9 +379,9 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -398,7 +398,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, V( IOFFV ), 1, + CALL CGERC( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -421,9 +421,9 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -441,7 +441,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -471,7 +471,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -480,7 +480,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -500,8 +500,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -516,18 +516,18 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL CGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MP+1 CALL CGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -547,8 +547,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -577,9 +577,9 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -597,7 +597,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFV.GT.0 .AND. IOFFC.GT.0 ) - $ CALL CGERC( MP, NQ, -TAULOC, WORK, 1, + $ CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), $ LDC ) END IF @@ -621,9 +621,9 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -641,8 +641,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -667,7 +667,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -676,7 +676,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -694,8 +694,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -720,18 +720,18 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL CGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQ+1 CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -750,8 +750,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFC.GT.0 ) - $ CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + $ CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -770,7 +770,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -779,7 +779,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -797,8 +797,8 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pclarfc.f b/SRC/pclarfc.f index d6a2d3b..f84c493 100644 --- a/SRC/pclarfc.f +++ b/SRC/pclarfc.f @@ -242,7 +242,7 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - COMPLEX TAULOC + COMPLEX TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, CCOPY, CGEBR2D, CGEBS2D, @@ -336,17 +336,17 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAULOC, 1, IVROW, MYCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -364,8 +364,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -380,9 +380,9 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -399,7 +399,7 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, V( IOFFV ), 1, + CALL CGERC( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -422,9 +422,9 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -442,7 +442,7 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -472,17 +472,17 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAULOC, $ 1, IVROW, MYCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -500,8 +500,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), 1, - $ C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -516,18 +516,18 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL CGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * IPW = MP+1 CALL CGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -545,8 +545,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), 1, - $ C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -575,9 +575,9 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -594,7 +594,7 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK, 1, + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), LDC ) END IF * @@ -617,9 +617,9 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -637,8 +637,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -663,17 +663,17 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, $ 1, MYROW, IVCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -691,8 +691,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -716,18 +716,18 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL CGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * IPW = NQ+1 CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -745,8 +745,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -765,17 +765,17 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, 1, $ MYROW, IVCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -793,8 +793,8 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL CGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pclarz.f b/SRC/pclarz.f index 9ba730c..673860a 100644 --- a/SRC/pclarz.f +++ b/SRC/pclarz.f @@ -251,7 +251,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - COMPLEX TAULOC + COMPLEX TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, CAXPY, CCOPY, CGEBR2D, @@ -370,7 +370,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -379,7 +379,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -402,9 +402,9 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -420,9 +420,9 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -445,11 +445,11 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK, + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -471,9 +471,9 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -496,10 +496,10 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -530,16 +530,16 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * - CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAULOC, - $ 1, IVROW, MYCOL ) + CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, + $ TAULOC( 1 ), 1, IVROW, MYCOL ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -562,10 +562,10 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -580,18 +580,18 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL CGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MPV+1 CALL CGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -614,10 +614,10 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -646,9 +646,9 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -669,13 +669,13 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * IF( MPC2.GT.0 .AND. NQV.GT.0 ) - $ CALL CGERC( MPC2, NQV, -TAULOC, WORK, 1, + $ CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), $ LDC ) END IF @@ -699,9 +699,9 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -720,13 +720,14 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), + $ WORK( IPW ), 1, WORK, 1, + $ C( IOFFC2 ), LDC ) END IF * END IF @@ -751,16 +752,16 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * - CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, - $ 1, MYROW, IVCOL ) + CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, + $ TAULOC( 1 ), 1, MYROW, IVCOL ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -779,13 +780,13 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -809,18 +810,18 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL CGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQV+1 CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -840,13 +841,13 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -865,7 +866,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -874,7 +875,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -893,13 +894,13 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pclarzc.f b/SRC/pclarzc.f index f1bc21e..b6d3b6d 100644 --- a/SRC/pclarzc.f +++ b/SRC/pclarzc.f @@ -251,7 +251,7 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - COMPLEX TAULOC + COMPLEX TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, CAXPY, CCOPY, CGEBR2D, @@ -370,17 +370,17 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAULOC, 1, IVROW, MYCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -403,9 +403,9 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -421,9 +421,9 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -446,11 +446,11 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK, + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -472,9 +472,9 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -497,10 +497,10 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -531,17 +531,17 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAULOC, $ 1, IVROW, MYCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -564,10 +564,10 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -582,18 +582,18 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL CGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * IPW = MPV+1 CALL CGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -616,10 +616,10 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL CAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL CGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -648,9 +648,9 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -671,12 +671,12 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK, 1, + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), LDC ) END IF * @@ -699,9 +699,9 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -720,13 +720,14 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), + $ WORK( IPW ), 1, WORK, 1, + $ C( IOFFC2 ), LDC ) END IF * END IF @@ -751,17 +752,17 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, $ 1, MYROW, IVCOL ) - TAULOC = CONJG( TAULOC ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -780,13 +781,13 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -810,18 +811,18 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL CGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = CONJG( TAU( IIV ) ) + TAULOC( 1 ) = CONJG( TAU( IIV ) ) * ELSE * IPW = NQV+1 CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = CONJG( WORK( IPW ) ) + TAULOC( 1 ) = CONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -841,13 +842,13 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -866,17 +867,17 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = CONJG( TAU( JJV ) ) + TAULOC( 1 ) = CONJG( TAU( JJV ) ) * ELSE * - CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, 1, - $ MYROW, IVCOL ) - TAULOC = CONJG( TAULOC ) + CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, + $ TAULOC( 1 ), 1, MYROW, IVCOL ) + TAULOC( 1 ) = CONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -895,13 +896,13 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL CAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL CGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pclattrs.f b/SRC/pclattrs.f index c744aea..0d12a8b 100644 --- a/SRC/pclattrs.f +++ b/SRC/pclattrs.f @@ -271,7 +271,8 @@ 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, XMAX + $ XBND, XJ + REAL XMAX( 1 ) COMPLEX CSUMJ, TJJS, USCAL, XJTMP, ZDUM * .. * .. External Functions .. @@ -391,11 +392,11 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Compute a bound on the computed solution vector to see if the * Level 2 PBLAS routine PCTRSV can be used. * - XMAX = ZERO + XMAX( 1 ) = ZERO CALL PCAMAX( N, ZDUM, IMAX, X, IX, JX, DESCX, 1 ) - XMAX = CABS2( ZDUM ) + XMAX( 1 ) = CABS2( ZDUM ) CALL SGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, -1, -1 ) - XBND = XMAX + XBND = XMAX( 1 ) * IF( NOTRAN ) THEN * @@ -590,16 +591,16 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * * Use a Level 1 PBLAS solve, scaling intermediate results. * - IF( XMAX.GT.BIGNUM*HALF ) THEN + IF( XMAX( 1 ).GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * - SCALE = ( BIGNUM*HALF ) / XMAX + SCALE = ( BIGNUM*HALF ) / XMAX( 1 ) CALL PCSSCAL( N, SCALE, X, IX, JX, DESCX, 1 ) - XMAX = BIGNUM + XMAX( 1 ) = BIGNUM ELSE - XMAX = XMAX*TWO + XMAX( 1 ) = XMAX( 1 )*TWO END IF * IF( NOTRAN ) THEN @@ -651,7 +652,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = CLADIV( X( J ), TJJS ) @@ -682,7 +683,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = CLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) @@ -706,7 +707,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XJTMP = CONE XJ = ONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 90 CONTINUE * @@ -715,7 +716,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * IF( XJ.GT.ONE ) THEN REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN + IF( CNORM( J ).GT.( BIGNUM-XMAX( 1 ) )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * @@ -724,7 +725,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XJTMP = XJTMP*REC SCALE = SCALE*REC END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX( 1 ) ) ) THEN * * Scale x by 1/2. * @@ -743,7 +744,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCAXPY( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1, X, $ IX, JX, DESCX, 1 ) CALL PCAMAX( J-1, ZDUM, IMAX, X, IX, JX, DESCX, 1 ) - XMAX = CABS1( ZDUM ) + XMAX( 1 ) = CABS1( ZDUM ) CALL SGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, $ -1, -1 ) END IF @@ -757,7 +758,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCAXPY( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) CALL PCAMAX( N-J, ZDUM, I, X, IX+J, JX, DESCX, 1 ) - XMAX = CABS1( ZDUM ) + XMAX( 1 ) = CABS1( ZDUM ) CALL SGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, $ -1, -1 ) END IF @@ -785,7 +786,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJ = CABS1( XJTMP ) USCAL = CMPLX( TSCAL ) - REC = ONE / MAX( XMAX, ONE ) + REC = ONE / MAX( XMAX( 1 ), ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). @@ -820,7 +821,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * @@ -924,7 +925,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = CLADIV( X( J ), TJJS ) @@ -945,7 +946,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = CLADIV( X( J ), TJJS ) XJTMP = CLADIV( XJTMP, TJJS ) @@ -966,7 +967,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJTMP = CONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 110 CONTINUE ELSE @@ -981,7 +982,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, X( IROWX ) = XJTMP END IF END IF - XMAX = MAX( XMAX, CABS1( XJTMP ) ) + XMAX( 1 ) = MAX( XMAX( 1 ), CABS1( XJTMP ) ) 120 CONTINUE * ELSE @@ -1004,7 +1005,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJ = CABS1( XJTMP ) USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) + REC = ONE / MAX( XMAX( 1 ), ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). @@ -1039,7 +1040,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * @@ -1145,7 +1146,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = CLADIV( X( J ), TJJS ) @@ -1164,7 +1165,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = CLADIV( X( J ), TJJS ) XJTMP = CLADIV( XJTMP, TJJS ) @@ -1181,7 +1182,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ X( IROWX ) = CONE XJTMP = CONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 130 CONTINUE ELSE @@ -1194,7 +1195,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP END IF - XMAX = MAX( XMAX, CABS1( XJTMP ) ) + XMAX( 1 ) = MAX( XMAX( 1 ), CABS1( XJTMP ) ) 140 CONTINUE END IF SCALE = SCALE / TSCAL diff --git a/SRC/pclawil.f b/SRC/pclawil.f index 24a49b9..b33b3b1 100644 --- a/SRC/pclawil.f +++ b/SRC/pclawil.f @@ -124,11 +124,10 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) $ MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, $ RSRC, UP REAL S - COMPLEX CDUM, H11, H12, H21, H22, H33S, H44S, V1, V2, - $ V3 + COMPLEX CDUM, H22, H33S, H44S, V1, V2 * .. * .. Local Arrays .. - COMPLEX BUF( 4 ) + COMPLEX BUF( 4 ), V3( 1 ), H11( 1 ), H12( 1 ), H21( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, CGERV2D, CGESD2D @@ -181,18 +180,18 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NPCOL.GT.1 ) THEN CALL CGERV2D( CONTXT, 1, 1, V3, 1, MYROW, LEFT ) ELSE - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF IF( NUM.GT.1 ) THEN CALL CGERV2D( CONTXT, 4, 1, BUF, 4, UP, LEFT ) - H11 = BUF( 1 ) - H21 = BUF( 2 ) - H12 = BUF( 3 ) + H11( 1 ) = BUF( 1 ) + H21( 1 ) = BUF( 2 ) + H12( 1 ) = BUF( 3 ) H22 = BUF( 4 ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) END IF END IF @@ -223,22 +222,22 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, RSRC, JSRC ) IF( NUM.GT.1 ) THEN - CALL CGERV2D( CONTXT, 1, 1, H11, 1, UP, LEFT ) + CALL CGERV2D( CONTXT, 1, 1, H11( 1 ), 1, UP, LEFT ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) END IF IF( NPROW.GT.1 ) THEN CALL CGERV2D( CONTXT, 1, 1, H12, 1, UP, MYCOL ) ELSE - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) END IF IF( NPCOL.GT.1 ) THEN - CALL CGERV2D( CONTXT, 1, 1, H21, 1, MYROW, LEFT ) + CALL CGERV2D( CONTXT, 1, 1, H21( 1 ), 1, MYROW, LEFT ) ELSE - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) END IF H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF END IF IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) @@ -247,24 +246,24 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( MODKM1.GT.1 ) THEN CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, RSRC, JSRC ) - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF * - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S-H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - S = CABS1( V1 ) + CABS1( V2 ) + CABS1( V3 ) + H44S = H44 - H11( 1 ) + H33S = H33 - H11( 1 ) + V1 = ( H33S*H44S-H43H34 ) / H21( 1 ) + H12( 1 ) + V2 = H22 - H11( 1 ) - H33S - H44S + S = CABS1( V1 ) + CABS1( V2 ) + CABS1( V3( 1 ) ) V1 = V1 / S V2 = V2 / S - V3 = V3 / S + V3( 1 ) = V3( 1 ) / S V( 1 ) = V1 V( 2 ) = V2 - V( 3 ) = V3 + V( 3 ) = V3( 1 ) * RETURN * diff --git a/SRC/pctrevc.f b/SRC/pctrevc.f index d0a3043..bf6c52b 100644 --- a/SRC/pctrevc.f +++ b/SRC/pctrevc.f @@ -218,11 +218,12 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ ITMP2, J, K, KI, LDT, LDVL, LDVR, LDW, MB, $ MYCOL, MYROW, NB, NPCOL, NPROW, RSRC REAL SELF - REAL OVFL, REMAXD, SCALE, SMIN, SMLNUM, ULP, UNFL + REAL OVFL, REMAXD, SCALE, SMLNUM, ULP, UNFL COMPLEX CDUM, REMAXC, SHIFT * .. * .. Local Arrays .. INTEGER DESCW( DLEN_ ) + REAL SMIN( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -355,13 +356,13 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ GO TO 70 END IF * - SMIN = ZERO + SMIN( 1 ) = ZERO SHIFT = CZERO CALL INFOG2L( KI, KI, DESCT, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, ITMP1, ITMP2 ) IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN SHIFT = T( ( ICOL-1 )*LDT+IROW ) - SMIN = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) + SMIN( 1 ) = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) END IF CALL SGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SMIN, 1, -1, -1 ) CALL CGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SHIFT, 1, -1, -1 ) @@ -396,8 +397,9 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN T( ( ICOL-1 )*LDT+IROW ) = T( ( ICOL-1 )*LDT+IROW ) - $ SHIFT - IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN ) THEN - T( ( ICOL-1 )*LDT+IROW ) = CMPLX( SMIN ) + IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN( 1 ) ) + $ THEN + T( ( ICOL-1 )*LDT+IROW ) = CMPLX( SMIN( 1 ) ) END IF END IF 50 CONTINUE @@ -467,13 +469,13 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ GO TO 110 END IF * - SMIN = ZERO + SMIN( 1 ) = ZERO SHIFT = CZERO CALL INFOG2L( KI, KI, DESCT, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, ITMP1, ITMP2 ) IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN SHIFT = T( ( ICOL-1 )*LDT+IROW ) - SMIN = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) + SMIN( 1 ) = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) END IF CALL SGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SMIN, 1, -1, -1 ) CALL CGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SHIFT, 1, -1, -1 ) @@ -507,8 +509,8 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN T( ( ICOL-1 )*LDT+IROW ) = T( ( ICOL-1 )*LDT+IROW ) - $ SHIFT - IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN ) - $ T( ( ICOL-1 )*LDT+IROW ) = CMPLX( SMIN ) + IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN( 1 ) ) + $ T( ( ICOL-1 )*LDT+IROW ) = CMPLX( SMIN( 1 ) ) END IF 90 CONTINUE * diff --git a/SRC/pdhseqr.f b/SRC/pdhseqr.f index ffc3652..6e0f751 100644 --- a/SRC/pdhseqr.f +++ b/SRC/pdhseqr.f @@ -259,11 +259,12 @@ SUBROUTINE PDHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, $ HRSRC4, HCSRC4, LIWKOPT LOGICAL INITZ, LQUERY, WANTT, WANTZ, PAIR, BORDER DOUBLE PRECISION TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3, - $ DUM4, ELEM1, ELEM2, ELEM3, ELEM4, + $ DUM4, ELEM1, ELEM4, $ CS, SN, ELEM5, TMP, LWKOPT * .. * .. Local Arrays .. INTEGER DESCH2( DLEN_ ) + DOUBLE PRECISION ELEM2( 1 ), ELEM3( 1 ) * .. * .. External Functions .. INTEGER PILAENVX, NUMROC, ICEIL @@ -566,28 +567,28 @@ SUBROUTINE PDHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN ELEM1 = H((JLOC1-1)*LLDH+ILOC1) IF( K.LT.N ) THEN - ELEM3 = H((JLOC1-1)*LLDH+ILOC1+1) + ELEM3( 1 ) = H((JLOC1-1)*LLDH+ILOC1+1) ELSE - ELEM3 = ZERO + ELEM3( 1 ) = ZERO END IF - IF( ELEM3.NE.ZERO ) THEN - ELEM2 = H((JLOC1)*LLDH+ILOC1) + IF( ELEM3( 1 ).NE.ZERO ) THEN + ELEM2( 1 ) = H((JLOC1)*LLDH+ILOC1) ELEM4 = H((JLOC1)*LLDH+ILOC1+1) - CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4, - $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), - $ SN, CS ) + CALL DLANV2( ELEM1, ELEM2( 1 ), ELEM3( 1 ), + $ ELEM4, WR( K ), WI( K ), WR( K+1 ), + $ WI( K+1 ), SN, CS ) PAIR = .TRUE. ELSE IF( K.GT.1 ) THEN TMP = H((JLOC1-2)*LLDH+ILOC1) IF( TMP.NE.ZERO ) THEN ELEM1 = H((JLOC1-2)*LLDH+ILOC1-1) - ELEM2 = H((JLOC1-1)*LLDH+ILOC1-1) - ELEM3 = H((JLOC1-2)*LLDH+ILOC1) + ELEM2( 1 ) = H((JLOC1-1)*LLDH+ILOC1-1) + ELEM3( 1 ) = H((JLOC1-2)*LLDH+ILOC1) ELEM4 = H((JLOC1-1)*LLDH+ILOC1) - CALL DLANV2( ELEM1, ELEM2, ELEM3, - $ ELEM4, WR( K-1 ), WI( K-1 ), - $ WR( K ), WI( K ), SN, CS ) + CALL DLANV2( ELEM1, ELEM2( 1 ), + $ ELEM3( 1 ), ELEM4, WR( K-1 ), + $ WI( K-1 ), WR( K ), WI( K ), SN, CS ) ELSE WR( K ) = ELEM1 END IF @@ -620,12 +621,12 @@ SUBROUTINE PDHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, CALL INFOG2L( K+1, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL, $ ILOC4, JLOC4, HRSRC4, HCSRC4 ) IF( MYROW.EQ.HRSRC2 .AND. MYCOL.EQ.HCSRC2 ) THEN - ELEM2 = H((JLOC2-1)*LLDH+ILOC2) + ELEM2( 1 ) = H((JLOC2-1)*LLDH+ILOC2) IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 ) $ CALL DGESD2D( ICTXT, 1, 1, ELEM2, 1, HRSRC1, HCSRC1) END IF IF( MYROW.EQ.HRSRC3 .AND. MYCOL.EQ.HCSRC3 ) THEN - ELEM3 = H((JLOC3-1)*LLDH+ILOC3) + ELEM3( 1 ) = H((JLOC3-1)*LLDH+ILOC3) IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 ) $ CALL DGESD2D( ICTXT, 1, 1, ELEM3, 1, HRSRC1, HCSRC1) END IF @@ -651,8 +652,9 @@ SUBROUTINE PDHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, ELEM5 = WORK(2) IF( ELEM5.EQ.ZERO ) THEN IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN - CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ), - $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS ) + CALL DLANV2( ELEM1, ELEM2( 1 ), ELEM3( 1 ), ELEM4, + $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), SN, + $ CS ) ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO ) $ THEN WR( K+1 ) = ELEM4 diff --git a/SRC/pdlacon.f b/SRC/pdlacon.f index b625d97..74b9eab 100644 --- a/SRC/pdlacon.f +++ b/SRC/pdlacon.f @@ -160,10 +160,10 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, INTEGER I, ICTXT, IFLAG, IIVX, IMAXROW, IOFFVX, IROFF, $ ITER, IVXCOL, IVXROW, J, JLAST, JJVX, JUMP, $ K, MYCOL, MYROW, NP, NPCOL, NPROW - DOUBLE PRECISION ALTSGN, ESTOLD, JLMAX, TEMP, XMAX + DOUBLE PRECISION ALTSGN, ESTOLD, JLMAX, XMAX * .. * .. Local Arrays .. - DOUBLE PRECISION WORK( 2 ) + DOUBLE PRECISION ESTWORK( 1 ), TEMP( 1 ), WORK( 2 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, DCOPY, DGEBR2D, DGEBS2D, @@ -184,6 +184,7 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * * Get grid parameters. * + ESTWORK( 1 ) = EST ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * @@ -215,21 +216,21 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, IF( N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN V( IOFFVX ) = X( IOFFVX ) - EST = ABS( V( IOFFVX ) ) - CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + ESTWORK( 1 ) = ABS( V( IOFFVX ) ) + CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF * ... QUIT GO TO 150 END IF - CALL PDASUM( N, EST, X, IX, JX, DESCX, 1 ) + CALL PDASUM( N, ESTWORK( 1 ), X, IX, JX, DESCX, 1 ) IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN - CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF END IF @@ -281,13 +282,13 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * 70 CONTINUE CALL DCOPY( NP, X( IOFFVX ), 1, V( IOFFVX ), 1 ) - ESTOLD = EST - CALL PDASUM( N, EST, V, IV, JV, DESCV, 1 ) + ESTOLD = ESTWORK( 1 ) + CALL PDASUM( N, ESTWORK( 1 ), V, IV, JV, DESCV, 1 ) IF( DESCV( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN - CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL DGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF END IF @@ -305,7 +306,7 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. * ALONG WITH IT, TEST FOR CYCLING. * - IF( IFLAG.EQ.0 .OR. EST.LE.ESTOLD ) + IF( IFLAG.EQ.0 .OR. ESTWORK( 1 ).LE.ESTOLD ) $ GO TO 120 * DO 100 I = IOFFVX, IOFFVX+NP-1 @@ -361,7 +362,7 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * X HAS BEEN OVERWRITTEN BY A*X * 140 CONTINUE - CALL PDASUM( N, TEMP, X, IX, JX, DESCX, 1 ) + CALL PDASUM( N, TEMP( 1 ), X, IX, JX, DESCX, 1 ) IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, TEMP, 1 ) @@ -370,15 +371,16 @@ SUBROUTINE PDLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, $ IVXROW, MYCOL ) END IF END IF - TEMP = TWO*( TEMP / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN + TEMP( 1 ) = TWO*( TEMP( 1 ) / DBLE( 3*N ) ) + IF( TEMP( 1 ).GT.ESTWORK( 1 ) ) THEN CALL DCOPY( NP, X( IOFFVX ), 1, V( IOFFVX ), 1 ) - EST = TEMP + ESTWORK( 1 ) = TEMP( 1 ) END IF * 150 CONTINUE KASE = 0 * + EST = ESTWORK( 1 ) RETURN * * End of PDLACON diff --git a/SRC/pdlarf.f b/SRC/pdlarf.f index 29da1ac..41368d6 100644 --- a/SRC/pdlarf.f +++ b/SRC/pdlarf.f @@ -241,7 +241,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - DOUBLE PRECISION TAULOC + DOUBLE PRECISION TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, DCOPY, DGEBR2D, DGEBS2D, @@ -335,7 +335,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -344,7 +344,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -362,8 +362,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL DGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL DGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -378,9 +378,9 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -397,8 +397,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL DGER( MP, NQ, -TAULOC, V( IOFFV ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL DGER( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -420,9 +420,9 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL DGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -440,7 +440,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL DGER( MP, NQ, -TAULOC, WORK, 1, + CALL DGER( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -470,7 +470,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -479,7 +479,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -499,8 +499,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL DGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL DGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -515,18 +515,18 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL DGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MP+1 CALL DGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -546,8 +546,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL DGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL DGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -576,9 +576,9 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -596,7 +596,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFV.GT.0 .AND. IOFFC.GT.0 ) - $ CALL DGER( MP, NQ, -TAULOC, WORK, 1, + $ CALL DGER( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), LDC ) END IF * @@ -619,9 +619,9 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL DGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -639,7 +639,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MP, NQ, -TAULOC, WORK( IPW ), 1, + CALL DGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -665,7 +665,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL DGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -674,7 +674,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -692,8 +692,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL DGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -718,18 +718,18 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL DGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQ+1 CALL DGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -748,8 +748,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFC.GT.0 ) - $ CALL DGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + $ CALL DGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -768,7 +768,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL DGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -777,7 +777,7 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -795,8 +795,8 @@ SUBROUTINE PDLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL DGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, WORK, + $ 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pdlarz.f b/SRC/pdlarz.f index b91282c..f45c137 100644 --- a/SRC/pdlarz.f +++ b/SRC/pdlarz.f @@ -250,7 +250,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - DOUBLE PRECISION TAULOC + DOUBLE PRECISION TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, DAXPY, DCOPY, DGEBR2D, @@ -369,7 +369,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -378,7 +378,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -401,9 +401,9 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL DAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL DAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL DGER( MPV, NQC2, -TAULOC, WORK, 1, + CALL DGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -419,9 +419,9 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -444,11 +444,11 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL DAXPY( NQC2, -TAULOC, WORK, + $ CALL DAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL DGER( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL DGER( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -470,9 +470,9 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL DGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -495,10 +495,10 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL DAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL DAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL DGER( MPV, NQC2, -TAULOC, WORK, 1, + CALL DGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -529,7 +529,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL DGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -538,7 +538,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -561,10 +561,10 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL DAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL DAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL DGER( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL DGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -579,18 +579,18 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL DGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MPV+1 CALL DGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -613,10 +613,10 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL DAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL DAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL DGER( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL DGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -645,9 +645,9 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -668,13 +668,13 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL DAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL DAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * IF( MPC2.GT.0 .AND. NQV.GT.0 ) - $ CALL DGER( MPC2, NQV, -TAULOC, WORK, 1, + $ CALL DGER( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), $ LDC ) END IF @@ -698,9 +698,9 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL DGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -719,13 +719,13 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL DAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL DAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL DGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -750,7 +750,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL DGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -759,7 +759,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -778,12 +778,12 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL DAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL DAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, + CALL DGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, $ WORK, 1, C( IOFFC2 ), LDC ) END IF * @@ -808,18 +808,18 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL DGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQV+1 CALL DGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -839,13 +839,13 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL DAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL DAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL DGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -864,7 +864,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL DGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -873,7 +873,7 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -892,13 +892,13 @@ SUBROUTINE PDLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL DAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL DAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL DGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL DGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pdlawil.f b/SRC/pdlawil.f index 90a4d74..e8bc3a0 100644 --- a/SRC/pdlawil.f +++ b/SRC/pdlawil.f @@ -120,10 +120,10 @@ SUBROUTINE PDLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) INTEGER CONTXT, DOWN, HBL, ICOL, IROW, JSRC, LDA, LEFT, $ MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, $ RSRC, UP - DOUBLE PRECISION H11, H12, H21, H22, H33S, H44S, S, V1, V2, V3 + DOUBLE PRECISION H22, H33S, H44S, S, V1, V2 * .. * .. Local Arrays .. - DOUBLE PRECISION BUF( 4 ) + DOUBLE PRECISION BUF( 4 ), H11( 1 ), H12( 1 ), H21( 1 ), V3( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, DGERV2D, DGESD2D, INFOG2L @@ -170,18 +170,18 @@ SUBROUTINE PDLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NPCOL.GT.1 ) THEN CALL DGERV2D( CONTXT, 1, 1, V3, 1, MYROW, LEFT ) ELSE - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF IF( NUM.GT.1 ) THEN CALL DGERV2D( CONTXT, 4, 1, BUF, 4, UP, LEFT ) - H11 = BUF( 1 ) - H21 = BUF( 2 ) - H12 = BUF( 3 ) + H11( 1 ) = BUF( 1 ) + H21( 1 ) = BUF( 2 ) + H12( 1 ) = BUF( 3 ) H22 = BUF( 4 ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) END IF END IF @@ -214,20 +214,20 @@ SUBROUTINE PDLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NUM.GT.1 ) THEN CALL DGERV2D( CONTXT, 1, 1, H11, 1, UP, LEFT ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) END IF IF( NPROW.GT.1 ) THEN CALL DGERV2D( CONTXT, 1, 1, H12, 1, UP, MYCOL ) ELSE - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) END IF IF( NPCOL.GT.1 ) THEN CALL DGERV2D( CONTXT, 1, 1, H21, 1, MYROW, LEFT ) ELSE - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) END IF H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF END IF IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) @@ -236,24 +236,24 @@ SUBROUTINE PDLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( MODKM1.GT.1 ) THEN CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, RSRC, JSRC ) - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF * - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S-H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) + H44S = H44 - H11( 1 ) + H33S = H33 - H11( 1 ) + V1 = ( H33S*H44S-H43H34 ) / H21( 1 ) + H12( 1 ) + V2 = H22 - H11( 1 ) - H33S - H44S + S = ABS( V1 ) + ABS( V2 ) + ABS( V3( 1 ) ) V1 = V1 / S V2 = V2 / S - V3 = V3 / S + V3( 1 ) = V3( 1 ) / S V( 1 ) = V1 V( 2 ) = V2 - V( 3 ) = V3 + V( 3 ) = V3( 1 ) * RETURN * diff --git a/SRC/pdstebz.f b/SRC/pdstebz.f index e7006f9..bf4dacc 100644 --- a/SRC/pdstebz.f +++ b/SRC/pdstebz.f @@ -246,14 +246,14 @@ SUBROUTINE PDSTEBZ( ICTXT, RANGE, ORDER, N, VL, VU, IL, IU, $ ITMP2, J, JB, K, LAST, LEXTRA, LREQ, MYCOL, $ MYROW, NALPHA, NBETA, NCMP, NEIGINT, NEXT, NGL, $ NGLOB, NGU, NINT, NPCOL, NPROW, OFFSET, - $ ONEDCONTEXT, P, PREV, REXTRA, RREQ, SELF, - $ TORECV + $ ONEDCONTEXT, P, PREV, REXTRA, RREQ, SELF DOUBLE PRECISION ALPHA, ATOLI, BETA, BNORM, DRECV, DSEND, GL, $ GU, INITVL, INITVU, LSAVE, MID, PIVMIN, RELTOL, $ SAFEMN, TMP1, TMP2, TNORM, ULP * .. * .. Local Arrays .. INTEGER IDUM( 5, 2 ) + INTEGER TORECV( 1, 1 ) * .. * .. Executable Statements .. * This is just to keep ftnchek happy @@ -784,14 +784,14 @@ SUBROUTINE PDSTEBZ( ICTXT, RANGE, ORDER, N, VL, VU, IL, IU, ELSE CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', 1, 1, TORECV, 1, 0, $ I-1 ) - IF( TORECV.NE.0 ) THEN - CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, IWORK, - $ TORECV, 0, I-1 ) - CALL DGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, WORK, - $ TORECV, 0, I-1 ) - CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, - $ IWORK( N+1 ), TORECV, 0, I-1 ) - DO 120 J = 1, TORECV + IF( TORECV( 1, 1 ).NE.0 ) THEN + CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ IWORK, TORECV( 1, 1 ), 0, I-1 ) + CALL DGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ WORK, TORECV( 1, 1 ), 0, I-1 ) + CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ IWORK( N+1 ), TORECV( 1, 1 ), 0, I-1 ) + DO 120 J = 1, TORECV( 1, 1 ) W( IWORK( J ) ) = WORK( J ) IBLOCK( IWORK( J ) ) = IWORK( N+J ) 120 CONTINUE diff --git a/SRC/pdtrord.f b/SRC/pdtrord.f index 1f37d8e..3870574 100644 --- a/SRC/pdtrord.f +++ b/SRC/pdtrord.f @@ -328,12 +328,13 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, $ EAST, WEST, ILOC4, SOUTH, NORTH, INDXS, $ ITT, JTT, ILEN, DLEN, INDXE, TRSRC1, TCSRC1, $ TRSRC2, TCSRC2, ILOS, DIR, TLIHI, TLILO, TLSEL, - $ ROUND, LAST, WIN0S, WIN0E, WINE, MMAX, MMIN + $ ROUND, LAST, WIN0S, WIN0E, WINE DOUBLE PRECISION ELEM, ELEM1, ELEM2, ELEM3, ELEM4, SN, CS, TMP, $ ELEM5 * .. * .. Local Arrays .. - INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 ) + INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 ), MMAX( 1 ), + $ MMIN( 1 ), INFODUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -483,16 +484,16 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, END IF IF( SELECT(K).NE.0 ) M = M + 1 10 CONTINUE - MMAX = M - MMIN = M + MMAX( 1 ) = M + MMIN( 1 ) = M IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, $ -1, -1, -1, -1 ) - IF( MMAX.GT.MMIN ) THEN - M = MMAX + IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN + M = MMAX( 1 ) IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, SELECT, N, $ -1, -1, -1, -1, -1 ) @@ -520,9 +521,11 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * * Global maximum on info. * - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, -1, -1, $ -1, -1 ) + INFO = INFODUM( 1 ) + END IF * * Return if some argument is incorrect. * @@ -1576,9 +1579,11 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * experienced a failure in the reordering. * MYIERR = IERR - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + IERR = INFODUM( 1 ) + END IF * IF( IERR.NE.0 ) THEN * @@ -1586,9 +1591,11 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * to swap. * IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1) - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + INFO = INFODUM( 1 ) + END IF GO TO 300 END IF * @@ -3245,9 +3252,11 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * experienced a failure in the reordering. * MYIERR = IERR - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + IERR = INFODUM( 1 ) + END IF * IF( IERR.NE.0 ) THEN * @@ -3255,9 +3264,11 @@ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * to swap. * IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1) - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + IERR = INFODUM( 1 ) + END IF GO TO 300 END IF * diff --git a/SRC/pdtrsen.f b/SRC/pdtrsen.f index 78c5599..c65ea91 100644 --- a/SRC/pdtrsen.f +++ b/SRC/pdtrsen.f @@ -354,13 +354,15 @@ SUBROUTINE PDTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP INTEGER ICOFFT12, ICTXT, IDUM1, IDUM2, IERR, ILOC1, $ IPW1, ITER, ITT, JLOC1, JTT, K, LIWMIN, LLDT, - $ LLDQ, LWMIN, MMAX, MMIN, MYROW, MYCOL, N1, N2, + $ LLDQ, LWMIN, MYROW, MYCOL, N1, N2, $ NB, NOEXSY, NPCOL, NPROCS, NPROW, SPACE, $ T12ROWS, T12COLS, TCOLS, TCSRC, TROWS, TRSRC, $ WRK1, IWRK1, WRK2, IWRK2, WRK3, IWRK3 - DOUBLE PRECISION DPDUM1, ELEM, EST, SCALE, RNORM + DOUBLE PRECISION ELEM, EST, SCALE, RNORM * .. Local Arrays .. - INTEGER DESCT12( DLEN_ ), MBNB2( 2 ) + INTEGER DESCT12( DLEN_ ), MBNB2( 2 ), MMAX( 1 ), + $ MMIN( 1 ) + DOUBLE PRECISION DPDUM1( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -521,16 +523,16 @@ SUBROUTINE PDTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, END IF IF( SELECT(K) ) M = M + 1 10 CONTINUE - MMAX = M - MMIN = M + 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 ) - IF( MMAX.GT.MMIN ) THEN - M = MMAX + $ 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 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, IWORK, N, $ -1, -1, -1, -1, -1 ) diff --git a/SRC/pshseqr.f b/SRC/pshseqr.f index 10eb24a..e8ecea9 100644 --- a/SRC/pshseqr.f +++ b/SRC/pshseqr.f @@ -259,11 +259,12 @@ SUBROUTINE PSHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, $ HRSRC4, HCSRC4, LIWKOPT LOGICAL INITZ, LQUERY, WANTT, WANTZ, PAIR, BORDER REAL TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3, - $ DUM4, ELEM1, ELEM2, ELEM3, ELEM4, + $ DUM4, ELEM1, ELEM4, $ CS, SN, ELEM5, TMP, LWKOPT * .. * .. Local Arrays .. INTEGER DESCH2( DLEN_ ) + REAL ELEM2( 1 ), ELEM3( 1 ) * .. * .. External Functions .. INTEGER PILAENVX, NUMROC, ICEIL @@ -566,28 +567,28 @@ SUBROUTINE PSHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN ELEM1 = H((JLOC1-1)*LLDH+ILOC1) IF( K.LT.N ) THEN - ELEM3 = H((JLOC1-1)*LLDH+ILOC1+1) + ELEM3( 1 ) = H((JLOC1-1)*LLDH+ILOC1+1) ELSE - ELEM3 = ZERO + ELEM3( 1 ) = ZERO END IF - IF( ELEM3.NE.ZERO ) THEN - ELEM2 = H((JLOC1)*LLDH+ILOC1) + IF( ELEM3( 1 ).NE.ZERO ) THEN + ELEM2( 1 ) = H((JLOC1)*LLDH+ILOC1) ELEM4 = H((JLOC1)*LLDH+ILOC1+1) - CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4, - $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), - $ SN, CS ) + CALL SLANV2( ELEM1, ELEM2( 1 ), ELEM3( 1 ), + $ ELEM4, WR( K ), WI( K ), WR( K+1 ), + $ WI( K+1 ), SN, CS ) PAIR = .TRUE. ELSE IF( K.GT.1 ) THEN TMP = H((JLOC1-2)*LLDH+ILOC1) IF( TMP.NE.ZERO ) THEN ELEM1 = H((JLOC1-2)*LLDH+ILOC1-1) - ELEM2 = H((JLOC1-1)*LLDH+ILOC1-1) - ELEM3 = H((JLOC1-2)*LLDH+ILOC1) + ELEM2( 1 ) = H((JLOC1-1)*LLDH+ILOC1-1) + ELEM3( 1 ) = H((JLOC1-2)*LLDH+ILOC1) ELEM4 = H((JLOC1-1)*LLDH+ILOC1) - CALL SLANV2( ELEM1, ELEM2, ELEM3, - $ ELEM4, WR( K-1 ), WI( K-1 ), - $ WR( K ), WI( K ), SN, CS ) + CALL SLANV2( ELEM1, ELEM2( 1 ), + $ ELEM3( 1 ), ELEM4, WR( K-1 ), + $ WI( K-1 ), WR( K ), WI( K ), SN, CS ) ELSE WR( K ) = ELEM1 END IF @@ -620,12 +621,12 @@ SUBROUTINE PSHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, CALL INFOG2L( K+1, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL, $ ILOC4, JLOC4, HRSRC4, HCSRC4 ) IF( MYROW.EQ.HRSRC2 .AND. MYCOL.EQ.HCSRC2 ) THEN - ELEM2 = H((JLOC2-1)*LLDH+ILOC2) + ELEM2( 1 ) = H((JLOC2-1)*LLDH+ILOC2) IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 ) $ CALL SGESD2D( ICTXT, 1, 1, ELEM2, 1, HRSRC1, HCSRC1) END IF IF( MYROW.EQ.HRSRC3 .AND. MYCOL.EQ.HCSRC3 ) THEN - ELEM3 = H((JLOC3-1)*LLDH+ILOC3) + ELEM3( 1 ) = H((JLOC3-1)*LLDH+ILOC3) IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 ) $ CALL SGESD2D( ICTXT, 1, 1, ELEM3, 1, HRSRC1, HCSRC1) END IF @@ -651,8 +652,9 @@ SUBROUTINE PSHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z, ELEM5 = WORK(2) IF( ELEM5.EQ.ZERO ) THEN IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN - CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ), - $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS ) + CALL SLANV2( ELEM1, ELEM2( 1 ), ELEM3( 1 ), ELEM4, + $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), SN, + $ CS ) ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO ) $ THEN WR( K+1 ) = ELEM4 diff --git a/SRC/pslacon.f b/SRC/pslacon.f index 20d27ff..673bf1a 100644 --- a/SRC/pslacon.f +++ b/SRC/pslacon.f @@ -160,10 +160,12 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, INTEGER I, ICTXT, IFLAG, IIVX, IMAXROW, IOFFVX, IROFF, $ ITER, IVXCOL, IVXROW, J, JLAST, JJVX, JUMP, $ K, MYCOL, MYROW, NP, NPCOL, NPROW - REAL ALTSGN, ESTOLD, JLMAX, TEMP, XMAX + REAL ALTSGN, ESTOLD, JLMAX, XMAX * .. * .. Local Arrays .. REAL WORK( 2 ) + REAL ESTWORK( 1 ) + REAL TEMP( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, IGSUM2D, INFOG2L, PSAMAX, @@ -184,6 +186,7 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * * Get grid parameters. * + ESTWORK( 1 ) = EST ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * @@ -215,21 +218,21 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, IF( N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN V( IOFFVX ) = X( IOFFVX ) - EST = ABS( V( IOFFVX ) ) - CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + ESTWORK( 1 ) = ABS( V( IOFFVX ) ) + CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF * ... QUIT GO TO 150 END IF - CALL PSASUM( N, EST, X, IX, JX, DESCX, 1 ) + CALL PSASUM( N, ESTWORK( 1 ), X, IX, JX, DESCX, 1 ) IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN - CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF END IF @@ -281,13 +284,13 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * 70 CONTINUE CALL SCOPY( NP, X( IOFFVX ), 1, V( IOFFVX ), 1 ) - ESTOLD = EST - CALL PSASUM( N, EST, V, IV, JV, DESCV, 1 ) + ESTOLD = ESTWORK( 1 ) + CALL PSASUM( N, ESTWORK( 1 ), V, IV, JV, DESCV, 1 ) IF( DESCV( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN - CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1 ) + CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1 ) ELSE - CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, EST, 1, + CALL SGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, ESTWORK, 1, $ IVXROW, MYCOL ) END IF END IF @@ -305,7 +308,7 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. * ALONG WITH IT, TEST FOR CYCLING. * - IF( IFLAG.EQ.0 .OR. EST.LE.ESTOLD ) + IF( IFLAG.EQ.0 .OR. ESTWORK( 1 ).LE.ESTOLD ) $ GO TO 120 * DO 100 I = IOFFVX, IOFFVX+NP-1 @@ -361,7 +364,7 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, * X HAS BEEN OVERWRITTEN BY A*X * 140 CONTINUE - CALL PSASUM( N, TEMP, X, IX, JX, DESCX, 1 ) + CALL PSASUM( N, TEMP( 1 ), X, IX, JX, DESCX, 1 ) IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN IF( MYROW.EQ.IVXROW ) THEN CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, TEMP, 1 ) @@ -370,15 +373,16 @@ SUBROUTINE PSLACON( N, V, IV, JV, DESCV, X, IX, JX, DESCX, ISGN, $ IVXROW, MYCOL ) END IF END IF - TEMP = TWO*( TEMP / REAL( 3*N ) ) - IF( TEMP.GT.EST ) THEN + TEMP( 1 ) = TWO*( TEMP( 1 ) / REAL( 3*N ) ) + IF( TEMP( 1 ).GT.ESTWORK( 1 ) ) THEN CALL SCOPY( NP, X( IOFFVX ), 1, V( IOFFVX ), 1 ) - EST = TEMP + ESTWORK( 1 ) = TEMP( 1 ) END IF * 150 CONTINUE KASE = 0 * + EST = ESTWORK( 1 ) RETURN * * End of PSLACON diff --git a/SRC/pslarf.f b/SRC/pslarf.f index c1d3a15..39de0ed 100644 --- a/SRC/pslarf.f +++ b/SRC/pslarf.f @@ -241,7 +241,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - REAL TAULOC + REAL TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBSTRNV, @@ -335,7 +335,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -344,7 +344,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -362,8 +362,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL SGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL SGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -378,9 +378,9 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -397,8 +397,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL SGER( MP, NQ, -TAULOC, V( IOFFV ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL SGER( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -420,9 +420,9 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL SGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -440,7 +440,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL SGER( MP, NQ, -TAULOC, WORK, 1, + CALL SGER( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -470,7 +470,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -479,7 +479,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -499,8 +499,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL SGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL SGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -515,18 +515,18 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL SGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MP+1 CALL SGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -546,8 +546,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL SGER( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL SGER( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -576,9 +576,9 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -596,7 +596,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFV.GT.0 .AND. IOFFC.GT.0 ) - $ CALL SGER( MP, NQ, -TAULOC, WORK, 1, + $ CALL SGER( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), LDC ) END IF * @@ -619,9 +619,9 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL SGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -639,7 +639,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MP, NQ, -TAULOC, WORK( IPW ), 1, + CALL SGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -665,7 +665,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL SGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -674,7 +674,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -692,8 +692,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL SGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1 + $ , WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -718,18 +718,18 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL SGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQ+1 CALL SGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -748,8 +748,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFC.GT.0 ) - $ CALL SGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + $ CALL SGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -768,7 +768,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL SGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -777,7 +777,7 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -795,8 +795,8 @@ SUBROUTINE PSLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL SGER( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, WORK, + $ 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pslarz.f b/SRC/pslarz.f index aa70db7..8901530 100644 --- a/SRC/pslarz.f +++ b/SRC/pslarz.f @@ -250,7 +250,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - REAL TAULOC + REAL TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBSTRNV, @@ -369,7 +369,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -378,7 +378,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -401,9 +401,9 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL SAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL SAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL SGER( MPV, NQC2, -TAULOC, WORK, 1, + CALL SGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -419,9 +419,9 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -444,11 +444,11 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL SAXPY( NQC2, -TAULOC, WORK, + $ CALL SAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL SGER( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL SGER( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -470,9 +470,9 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL SGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -495,10 +495,10 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL SAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL SAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL SGER( MPV, NQC2, -TAULOC, WORK, 1, + CALL SGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -529,7 +529,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL SGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -538,7 +538,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -561,10 +561,10 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL SAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL SAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL SGER( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL SGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -579,18 +579,18 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL SGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MPV+1 CALL SGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -613,10 +613,10 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL SAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL SAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL SGER( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL SGER( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -645,9 +645,9 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -668,13 +668,13 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL SAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL SAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * IF( MPC2.GT.0 .AND. NQV.GT.0 ) - $ CALL SGER( MPC2, NQV, -TAULOC, WORK, 1, + $ CALL SGER( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), $ LDC ) END IF @@ -698,9 +698,9 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL SGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -719,13 +719,13 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL SAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL SAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL SGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -750,7 +750,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL SGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -759,7 +759,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -778,12 +778,12 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL SAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL SAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, + CALL SGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, $ WORK, 1, C( IOFFC2 ), LDC ) END IF * @@ -808,18 +808,18 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL SGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQV+1 CALL SGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -839,13 +839,13 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL SAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL SAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL SGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -864,7 +864,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL SGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -873,7 +873,7 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -892,13 +892,13 @@ SUBROUTINE PSLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL SAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL SAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL SGER( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL SGER( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pslawil.f b/SRC/pslawil.f index e04c16b..671e08e 100644 --- a/SRC/pslawil.f +++ b/SRC/pslawil.f @@ -120,10 +120,14 @@ SUBROUTINE PSLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) INTEGER CONTXT, DOWN, HBL, ICOL, IROW, JSRC, LDA, LEFT, $ MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, $ RSRC, UP - REAL H11, H12, H21, H22, H33S, H44S, S, V1, V2, V3 + REAL H22, H33S, H44S, S, V1, V2 * .. * .. Local Arrays .. REAL BUF( 4 ) + REAL H11( 1 ) + REAL H12( 1 ) + REAL H21( 1 ) + REAL V3( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, SGERV2D, SGESD2D, INFOG2L @@ -170,18 +174,18 @@ SUBROUTINE PSLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NPCOL.GT.1 ) THEN CALL SGERV2D( CONTXT, 1, 1, V3, 1, MYROW, LEFT ) ELSE - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF IF( NUM.GT.1 ) THEN CALL SGERV2D( CONTXT, 4, 1, BUF, 4, UP, LEFT ) - H11 = BUF( 1 ) - H21 = BUF( 2 ) - H12 = BUF( 3 ) + H11( 1 ) = BUF( 1 ) + H21( 1 ) = BUF( 2 ) + H12( 1 ) = BUF( 3 ) H22 = BUF( 4 ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) END IF END IF @@ -214,20 +218,20 @@ SUBROUTINE PSLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NUM.GT.1 ) THEN CALL SGERV2D( CONTXT, 1, 1, H11, 1, UP, LEFT ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) END IF IF( NPROW.GT.1 ) THEN CALL SGERV2D( CONTXT, 1, 1, H12, 1, UP, MYCOL ) ELSE - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) END IF IF( NPCOL.GT.1 ) THEN CALL SGERV2D( CONTXT, 1, 1, H21, 1, MYROW, LEFT ) ELSE - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) END IF H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF END IF IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) @@ -236,24 +240,24 @@ SUBROUTINE PSLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( MODKM1.GT.1 ) THEN CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, RSRC, JSRC ) - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF * - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S-H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) + H44S = H44 - H11( 1 ) + H33S = H33 - H11( 1 ) + V1 = ( H33S*H44S-H43H34 ) / H21( 1 ) + H12( 1 ) + V2 = H22 - H11( 1 ) - H33S - H44S + S = ABS( V1 ) + ABS( V2 ) + ABS( V3( 1 ) ) V1 = V1 / S V2 = V2 / S - V3 = V3 / S + V3( 1 ) = V3( 1 ) / S V( 1 ) = V1 V( 2 ) = V2 - V( 3 ) = V3 + V( 3 ) = V3( 1 ) * RETURN * diff --git a/SRC/psstebz.f b/SRC/psstebz.f index a8a2496..7e588a9 100644 --- a/SRC/psstebz.f +++ b/SRC/psstebz.f @@ -244,14 +244,14 @@ SUBROUTINE PSSTEBZ( ICTXT, RANGE, ORDER, N, VL, VU, IL, IU, $ ITMP2, J, JB, K, LAST, LEXTRA, LREQ, MYCOL, $ MYROW, NALPHA, NBETA, NCMP, NEIGINT, NEXT, NGL, $ NGLOB, NGU, NINT, NPCOL, NPROW, OFFSET, - $ ONEDCONTEXT, P, PREV, REXTRA, RREQ, SELF, - $ TORECV + $ ONEDCONTEXT, P, PREV, REXTRA, RREQ, SELF REAL ALPHA, ATOLI, BETA, BNORM, DRECV, DSEND, GL, $ GU, INITVL, INITVU, LSAVE, MID, PIVMIN, RELTOL, $ SAFEMN, TMP1, TMP2, TNORM, ULP * .. * .. Local Arrays .. INTEGER IDUM( 5, 2 ) + INTEGER TORECV( 1, 1 ) * .. * .. Executable Statements .. * This is just to keep ftnchek happy @@ -774,14 +774,14 @@ SUBROUTINE PSSTEBZ( ICTXT, RANGE, ORDER, N, VL, VU, IL, IU, ELSE CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', 1, 1, TORECV, 1, 0, $ I-1 ) - IF( TORECV.NE.0 ) THEN - CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, IWORK, - $ TORECV, 0, I-1 ) - CALL SGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, WORK, - $ TORECV, 0, I-1 ) - CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV, 1, - $ IWORK( N+1 ), TORECV, 0, I-1 ) - DO 120 J = 1, TORECV + IF( TORECV( 1, 1 ).NE.0 ) THEN + CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ IWORK, TORECV( 1, 1 ), 0, I-1 ) + CALL SGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ WORK, TORECV( 1, 1 ), 0, I-1 ) + CALL IGEBR2D( ONEDCONTEXT, 'ALL', ' ', TORECV( 1, 1 ), 1, + $ IWORK( N+1 ), TORECV( 1, 1 ), 0, I-1 ) + DO 120 J = 1, TORECV( 1, 1 ) W( IWORK( J ) ) = WORK( J ) IBLOCK( IWORK( J ) ) = IWORK( N+J ) 120 CONTINUE diff --git a/SRC/pstrord.f b/SRC/pstrord.f index 3562242..5cdb549 100644 --- a/SRC/pstrord.f +++ b/SRC/pstrord.f @@ -328,12 +328,13 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, $ EAST, WEST, ILOC4, SOUTH, NORTH, INDXS, $ ITT, JTT, ILEN, DLEN, INDXE, TRSRC1, TCSRC1, $ TRSRC2, TCSRC2, ILOS, DIR, TLIHI, TLILO, TLSEL, - $ ROUND, LAST, WIN0S, WIN0E, WINE, MMAX, MMIN + $ ROUND, LAST, WIN0S, WIN0E, WINE REAL ELEM, ELEM1, ELEM2, ELEM3, ELEM4, SN, CS, TMP, $ ELEM5 * .. * .. Local Arrays .. - INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 ) + INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 ), MMAX( 1 ), + $ MMIN( 1 ), INFODUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -483,16 +484,16 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, END IF IF( SELECT(K).NE.0 ) M = M + 1 10 CONTINUE - MMAX = M - MMIN = M + MMAX( 1 ) = M + MMIN( 1 ) = M IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, $ -1, -1, -1, -1 ) - IF( MMAX.GT.MMIN ) THEN - M = MMAX + IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN + M = MMAX( 1 ) IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, SELECT, N, $ -1, -1, -1, -1, -1 ) @@ -520,9 +521,11 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * * Global maximum on info. * - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1, - $ -1, -1 ) + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, -1, + $ -1, -1, -1 ) + INFO = INFODUM( 1 ) + END IF * * Return if some argument is incorrect. * @@ -1576,9 +1579,11 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * experienced a failure in the reordering. * MYIERR = IERR - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + IERR = INFODUM( 1 ) + END IF * IF( IERR.NE.0 ) THEN * @@ -1586,9 +1591,11 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * to swap. * IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1) - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + INFO = INFODUM( 1 ) + END IF GO TO 300 END IF * @@ -3245,9 +3252,11 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * experienced a failure in the reordering. * MYIERR = IERR - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + IERR = INFODUM( 1 ) + END IF * IF( IERR.NE.0 ) THEN * @@ -3255,9 +3264,11 @@ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT, * to swap. * IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1) - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, $ -1, -1, -1, -1 ) + INFO = INFODUM( 1 ) + END IF GO TO 300 END IF * diff --git a/SRC/pstrsen.f b/SRC/pstrsen.f index 6219bdb..1922e8f 100644 --- a/SRC/pstrsen.f +++ b/SRC/pstrsen.f @@ -354,13 +354,15 @@ SUBROUTINE PSTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP INTEGER ICOFFT12, ICTXT, IDUM1, IDUM2, IERR, ILOC1, $ IPW1, ITER, ITT, JLOC1, JTT, K, LIWMIN, LLDT, - $ LLDQ, LWMIN, MMAX, MMIN, MYROW, MYCOL, N1, N2, + $ LLDQ, LWMIN, MYROW, MYCOL, N1, N2, $ NB, NOEXSY, NPCOL, NPROCS, NPROW, SPACE, $ T12ROWS, T12COLS, TCOLS, TCSRC, TROWS, TRSRC, $ WRK1, IWRK1, WRK2, IWRK2, WRK3, IWRK3 - REAL DPDUM1, ELEM, EST, SCALE, RNORM + REAL ELEM, EST, SCALE, RNORM * .. Local Arrays .. - INTEGER DESCT12( DLEN_ ), MBNB2( 2 ) + INTEGER DESCT12( DLEN_ ), MBNB2( 2 ), MMAX( 1 ), + $ MMIN( 1 ), INFODUM( 1 ) + REAL DPDUM1( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -521,16 +523,16 @@ SUBROUTINE PSTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, END IF IF( SELECT(K) ) M = M + 1 10 CONTINUE - MMAX = M - MMIN = M + MMAX( 1 ) = M + MMIN( 1 ) = M IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1, $ -1, -1, -1, -1 ) IF( NPROCS.GT.1 ) $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1, $ -1, -1, -1, -1 ) - IF( MMAX.GT.MMIN ) THEN - M = MMAX + IF( MMAX( 1 ).GT.MMIN( 1 ) ) THEN + M = MMAX( 1 ) IF( NPROCS.GT.1 ) $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, IWORK, N, $ -1, -1, -1, -1, -1 ) @@ -602,9 +604,11 @@ SUBROUTINE PSTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT, * * Global maximum on info * - IF( NPROCS.GT.1 ) - $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1, + IF( NPROCS.GT.1 ) THEN + CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFODUM, 1, -1, -1, -1, $ -1, -1 ) + INFO = INFODUM( 1 ) + END IF * * Return if some argument is incorrect * diff --git a/SRC/pzlarf.f b/SRC/pzlarf.f index df65912..7bff287 100644 --- a/SRC/pzlarf.f +++ b/SRC/pzlarf.f @@ -242,7 +242,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - COMPLEX*16 TAULOC + COMPLEX*16 TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBZTRNV, @@ -336,7 +336,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -345,7 +345,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -363,8 +363,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -379,9 +379,9 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -398,7 +398,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, V( IOFFV ), 1, + CALL ZGERC( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -421,9 +421,9 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -441,7 +441,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -471,7 +471,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -480,7 +480,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -500,8 +500,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -516,18 +516,18 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL ZGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MP+1 CALL ZGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -547,8 +547,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - v * w' * IF( IOFFC.GT.0 ) - $ CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + $ CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -577,9 +577,9 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -597,7 +597,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFV.GT.0 .AND. IOFFC.GT.0 ) - $ CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, + $ CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), $ LDC ) END IF @@ -621,9 +621,9 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -641,8 +641,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -667,7 +667,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -676,7 +676,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -694,8 +694,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -720,18 +720,18 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL ZGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQ+1 CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -750,8 +750,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * sub( C ) := sub( C ) - w * v' * IF( IOFFC.GT.0 ) - $ CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + $ CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -770,7 +770,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -779,7 +779,7 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -797,8 +797,8 @@ SUBROUTINE PZLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pzlarfc.f b/SRC/pzlarfc.f index eb469fc..ddd7ec6 100644 --- a/SRC/pzlarfc.f +++ b/SRC/pzlarfc.f @@ -242,7 +242,7 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ IOFFV, IPW, IROFF, IVCOL, IVROW, JJC, JJV, LDC, $ LDV, MYCOL, MYROW, MP, NCC, NCV, NPCOL, NPROW, $ NQ, RDEST - COMPLEX*16 TAULOC + COMPLEX*16 TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBZTRNV, @@ -336,17 +336,17 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAULOC, 1, IVROW, MYCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -364,8 +364,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -380,9 +380,9 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYCOL.EQ.ICCOL ) THEN * - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -399,7 +399,7 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, V( IOFFV ), 1, + CALL ZGERC( MP, NQ, -TAULOC( 1 ), V( IOFFV ), 1, $ WORK, 1, C( IOFFC ), LDC ) END IF * @@ -422,9 +422,9 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = MP+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -442,7 +442,7 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * @@ -472,17 +472,17 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAULOC, $ 1, IVROW, MYCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -500,8 +500,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), 1, - $ C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * ELSE @@ -516,18 +516,18 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( JJV ) CALL ZGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * IPW = MP+1 CALL ZGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -545,8 +545,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - v * w' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, WORK( IPW ), 1, - $ C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC ), LDC ) END IF * END IF @@ -575,9 +575,9 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * IF( MYROW.EQ.ICROW ) THEN * - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -594,7 +594,7 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK, 1, + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC ), LDC ) END IF * @@ -617,9 +617,9 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, IPW = NQ+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -637,8 +637,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -663,17 +663,17 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, $ 1, MYROW, IVCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -691,8 +691,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF @@ -716,18 +716,18 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, WORK(IPW) = TAU( IIV ) CALL ZGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * IPW = NQ+1 CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -745,8 +745,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * ELSE @@ -765,17 +765,17 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, 1, $ MYROW, IVCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -793,8 +793,8 @@ SUBROUTINE PZLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MP, NQ, -TAULOC, WORK( IPW ), 1, WORK, 1, - $ C( IOFFC ), LDC ) + CALL ZGERC( MP, NQ, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC ), LDC ) END IF * END IF diff --git a/SRC/pzlarz.f b/SRC/pzlarz.f index fefc133..abf6288 100644 --- a/SRC/pzlarz.f +++ b/SRC/pzlarz.f @@ -251,7 +251,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - COMPLEX*16 TAULOC + COMPLEX*16 TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBZTRNV, @@ -370,7 +370,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -379,7 +379,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -402,9 +402,9 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -420,9 +420,9 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -445,11 +445,11 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK, + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -471,9 +471,9 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -496,10 +496,10 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -530,7 +530,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * @@ -539,7 +539,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -562,10 +562,10 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -580,18 +580,18 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL ZGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * IPW = MPV+1 CALL ZGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -614,10 +614,10 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -646,9 +646,9 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -669,13 +669,13 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * IF( MPC2.GT.0 .AND. NQV.GT.0 ) - $ CALL ZGERC( MPC2, NQV, -TAULOC, WORK, 1, + $ CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), $ LDC ) END IF @@ -699,9 +699,9 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -720,13 +720,14 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), + $ WORK( IPW ), 1, WORK, 1, + $ C( IOFFC2 ), LDC ) END IF * END IF @@ -751,7 +752,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -760,7 +761,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -779,13 +780,13 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -809,18 +810,18 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL ZGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = TAU( IIV ) + TAULOC( 1 ) = TAU( IIV ) * ELSE * IPW = NQV+1 CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = WORK( IPW ) + TAULOC( 1 ) = WORK( IPW ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -840,13 +841,13 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -865,7 +866,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = TAU( JJV ) + TAULOC( 1 ) = TAU( JJV ) * ELSE * @@ -874,7 +875,7 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -893,13 +894,13 @@ SUBROUTINE PZLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pzlarzc.f b/SRC/pzlarzc.f index 936caec..2c574ff 100644 --- a/SRC/pzlarzc.f +++ b/SRC/pzlarzc.f @@ -251,7 +251,7 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IVCOL, IVROW, JJC1, JJC2, JJV, LDC, LDV, MPC2, $ MPV, MYCOL, MYROW, NCC, NCV, NPCOL, NPROW, $ NQC2, NQV, RDEST - COMPLEX*16 TAULOC + COMPLEX*16 TAULOC( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, PB_TOPGET, PBZTRNV, @@ -370,17 +370,17 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAULOC, 1, IVROW, MYCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -403,9 +403,9 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -421,9 +421,9 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYCOL.EQ.ICCOL2 ) THEN * - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -446,11 +446,11 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK, + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK, $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, V( IOFFV ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -472,9 +472,9 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = MPV+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW, $ IVCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -497,10 +497,10 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), $ LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * @@ -531,17 +531,17 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1, $ TAU( IIV ), 1 ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAULOC, $ 1, IVROW, MYCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -564,10 +564,10 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -582,18 +582,18 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( JJV ) CALL ZGEBS2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * IPW = MPV+1 CALL ZGEBR2D( ICTXT, 'Rowwise', ROWBTOP, IPW, 1, WORK, $ IPW, MYROW, IVCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C )' * v * @@ -616,10 +616,10 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * sub( C ) := sub( C ) - v * w' * IF( MYROW.EQ.ICROW1 ) - $ CALL ZAXPY( NQC2, -TAULOC, WORK( IPW ), + $ CALL ZAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ), $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC ) - CALL ZGERC( MPV, NQC2, -TAULOC, WORK, 1, WORK( IPW ), - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1, + $ WORK( IPW ), 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -648,9 +648,9 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * IF( MYROW.EQ.ICROW2 ) THEN * - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -671,12 +671,12 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ ICCOL2 ) * IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK, 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK, 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK, 1, + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK, 1, $ V( IOFFV ), LDV, C( IOFFC2 ), LDC ) END IF * @@ -699,9 +699,9 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, IPW = NQV+1 CALL ZGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW, $ MYCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -720,13 +720,14 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), $ RDEST, ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, - $ C( IOFFC1 ), 1 ) + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), + $ 1, C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), + $ WORK( IPW ), 1, WORK, 1, + $ C( IOFFC2 ), LDC ) END IF * END IF @@ -751,17 +752,17 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, $ TAU( JJV ), 1 ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, $ 1, MYROW, IVCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -780,13 +781,13 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, - $ WORK, 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), + $ 1, WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF @@ -810,18 +811,18 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, WORK( IPW ) = TAU( IIV ) CALL ZGEBS2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW ) - TAULOC = DCONJG( TAU( IIV ) ) + TAULOC( 1 ) = DCONJG( TAU( IIV ) ) * ELSE * IPW = NQV+1 CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, IPW, 1, $ WORK, IPW, IVROW, MYCOL ) - TAULOC = DCONJG( WORK( IPW ) ) + TAULOC( 1 ) = DCONJG( WORK( IPW ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -841,13 +842,13 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * ELSE @@ -866,17 +867,17 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * CALL ZGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, TAU( JJV ), $ 1 ) - TAULOC = DCONJG( TAU( JJV ) ) + TAULOC( 1 ) = DCONJG( TAU( JJV ) ) * ELSE * CALL ZGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, TAULOC, 1, $ MYROW, IVCOL ) - TAULOC = DCONJG( TAULOC ) + TAULOC( 1 ) = DCONJG( TAULOC( 1 ) ) * END IF * - IF( TAULOC.NE.ZERO ) THEN + IF( TAULOC( 1 ).NE.ZERO ) THEN * * w := sub( C ) * v * @@ -895,13 +896,13 @@ SUBROUTINE PZLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ WORK( IPW ), MAX( 1, MPC2 ), RDEST, $ ICCOL2 ) IF( MYCOL.EQ.ICCOL1 ) - $ CALL ZAXPY( MPC2, -TAULOC, WORK( IPW ), 1, + $ CALL ZAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1, $ C( IOFFC1 ), 1 ) * * sub( C ) := sub( C ) - w * v' * - CALL ZGERC( MPC2, NQV, -TAULOC, WORK( IPW ), 1, WORK, - $ 1, C( IOFFC2 ), LDC ) + CALL ZGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1, + $ WORK, 1, C( IOFFC2 ), LDC ) END IF * END IF diff --git a/SRC/pzlattrs.f b/SRC/pzlattrs.f index 819e476..5a54209 100644 --- a/SRC/pzlattrs.f +++ b/SRC/pzlattrs.f @@ -271,8 +271,9 @@ 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, XMAX + $ XBND, XJ COMPLEX*16 CSUMJ, TJJS, USCAL, XJTMP, ZDUM + DOUBLE PRECISION XMAX( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -391,11 +392,11 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * Compute a bound on the computed solution vector to see if the * Level 2 PBLAS routine PZTRSV can be used. * - XMAX = ZERO + XMAX( 1 ) = ZERO CALL PZAMAX( N, ZDUM, IMAX, X, IX, JX, DESCX, 1 ) - XMAX = CABS2( ZDUM ) + XMAX( 1 ) = CABS2( ZDUM ) CALL DGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, -1, -1 ) - XBND = XMAX + XBND = XMAX( 1 ) * IF( NOTRAN ) THEN * @@ -590,16 +591,16 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * * Use a Level 1 PBLAS solve, scaling intermediate results. * - IF( XMAX.GT.BIGNUM*HALF ) THEN + IF( XMAX( 1 ).GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * - SCALE = ( BIGNUM*HALF ) / XMAX + SCALE = ( BIGNUM*HALF ) / XMAX( 1 ) CALL PZDSCAL( N, SCALE, X, IX, JX, DESCX, 1 ) - XMAX = BIGNUM + XMAX( 1 ) = BIGNUM ELSE - XMAX = XMAX*TWO + XMAX( 1 ) = XMAX( 1 )*TWO END IF * IF( NOTRAN ) THEN @@ -651,7 +652,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = ZLADIV( X( J ), TJJS ) @@ -682,7 +683,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = ZLADIV( X( J ), TJJS ) * XJ = CABS1( X( J ) ) @@ -706,7 +707,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XJTMP = CONE XJ = ONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 90 CONTINUE * @@ -715,7 +716,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * IF( XJ.GT.ONE ) THEN REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN + IF( CNORM( J ).GT.( BIGNUM-XMAX( 1 ) )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * @@ -724,7 +725,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, XJTMP = XJTMP*REC SCALE = SCALE*REC END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX( 1 ) ) ) THEN * * Scale x by 1/2. * @@ -743,7 +744,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZAXPY( J-1, ZDUM, A, IA, JA+J-1, DESCA, 1, X, $ IX, JX, DESCX, 1 ) CALL PZAMAX( J-1, ZDUM, IMAX, X, IX, JX, DESCX, 1 ) - XMAX = CABS1( ZDUM ) + XMAX( 1 ) = CABS1( ZDUM ) CALL DGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, $ -1, -1 ) END IF @@ -757,7 +758,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZAXPY( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) CALL PZAMAX( N-J, ZDUM, I, X, IX+J, JX, DESCX, 1 ) - XMAX = CABS1( ZDUM ) + XMAX( 1 ) = CABS1( ZDUM ) CALL DGSUM2D( CONTXT, 'Row', ' ', 1, 1, XMAX, 1, $ -1, -1 ) END IF @@ -785,7 +786,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJ = CABS1( XJTMP ) USCAL = DCMPLX( TSCAL ) - REC = ONE / MAX( XMAX, ONE ) + REC = ONE / MAX( XMAX( 1 ), ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). @@ -820,7 +821,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * @@ -924,7 +925,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = ZLADIV( X( J ), TJJS ) @@ -945,7 +946,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = ZLADIV( X( J ), TJJS ) XJTMP = ZLADIV( XJTMP, TJJS ) @@ -966,7 +967,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJTMP = CONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 110 CONTINUE ELSE @@ -981,7 +982,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, X( IROWX ) = XJTMP END IF END IF - XMAX = MAX( XMAX, CABS1( XJTMP ) ) + XMAX( 1 ) = MAX( XMAX( 1 ), CABS1( XJTMP ) ) 120 CONTINUE * ELSE @@ -1004,7 +1005,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF XJ = CABS1( XJTMP ) USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) + REC = ONE / MAX( XMAX( 1 ), ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). @@ -1039,7 +1040,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * @@ -1145,7 +1146,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF END IF * X( J ) = ZLADIV( X( J ), TJJS ) @@ -1164,7 +1165,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PZDSCAL( N, REC, X, IX, JX, DESCX, 1 ) XJTMP = XJTMP*REC SCALE = SCALE*REC - XMAX = XMAX*REC + XMAX( 1 ) = XMAX( 1 )*REC END IF * X( J ) = ZLADIV( X( J ), TJJS ) XJTMP = ZLADIV( XJTMP, TJJS ) @@ -1181,7 +1182,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ X( IROWX ) = CONE XJTMP = CONE SCALE = ZERO - XMAX = ZERO + XMAX( 1 ) = ZERO END IF 130 CONTINUE ELSE @@ -1194,7 +1195,7 @@ SUBROUTINE PZLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, IF( ( MYROW.EQ.ITMP1X ) .AND. ( MYCOL.EQ.ITMP2X ) ) $ X( IROWX ) = XJTMP END IF - XMAX = MAX( XMAX, CABS1( XJTMP ) ) + XMAX( 1 ) = MAX( XMAX( 1 ), CABS1( XJTMP ) ) 140 CONTINUE END IF SCALE = SCALE / TSCAL diff --git a/SRC/pzlawil.f b/SRC/pzlawil.f index e89a9a3..7e502ef 100644 --- a/SRC/pzlawil.f +++ b/SRC/pzlawil.f @@ -124,11 +124,10 @@ SUBROUTINE PZLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) $ MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, $ RSRC, UP DOUBLE PRECISION S - COMPLEX*16 CDUM, H11, H12, H21, H22, H33S, H44S, V1, V2, - $ V3 + COMPLEX*16 CDUM, H22, H33S, H44S, V1, V2 * .. * .. Local Arrays .. - COMPLEX*16 BUF( 4 ) + COMPLEX*16 BUF( 4 ), H11( 1 ), H12( 1 ), H21( 1 ), V3( 1 ) * .. * .. External Subroutines .. EXTERNAL BLACS_GRIDINFO, INFOG2L, ZGERV2D, ZGESD2D @@ -181,18 +180,18 @@ SUBROUTINE PZLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NPCOL.GT.1 ) THEN CALL ZGERV2D( CONTXT, 1, 1, V3, 1, MYROW, LEFT ) ELSE - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF IF( NUM.GT.1 ) THEN CALL ZGERV2D( CONTXT, 4, 1, BUF, 4, UP, LEFT ) - H11 = BUF( 1 ) - H21 = BUF( 2 ) - H12 = BUF( 3 ) + H11( 1 ) = BUF( 1 ) + H21( 1 ) = BUF( 2 ) + H12( 1 ) = BUF( 3 ) H22 = BUF( 4 ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) END IF END IF @@ -225,20 +224,20 @@ SUBROUTINE PZLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( NUM.GT.1 ) THEN CALL ZGERV2D( CONTXT, 1, 1, H11, 1, UP, LEFT ) ELSE - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) END IF IF( NPROW.GT.1 ) THEN CALL ZGERV2D( CONTXT, 1, 1, H12, 1, UP, MYCOL ) ELSE - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) END IF IF( NPCOL.GT.1 ) THEN CALL ZGERV2D( CONTXT, 1, 1, H21, 1, MYROW, LEFT ) ELSE - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) END IF H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF END IF IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) @@ -247,24 +246,24 @@ SUBROUTINE PZLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) IF( MODKM1.GT.1 ) THEN CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, RSRC, JSRC ) - H11 = A( ( ICOL-3 )*LDA+IROW-2 ) - H21 = A( ( ICOL-3 )*LDA+IROW-1 ) - H12 = A( ( ICOL-2 )*LDA+IROW-2 ) + H11( 1 ) = A( ( ICOL-3 )*LDA+IROW-2 ) + H21( 1 ) = A( ( ICOL-3 )*LDA+IROW-1 ) + H12( 1 ) = A( ( ICOL-2 )*LDA+IROW-2 ) H22 = A( ( ICOL-2 )*LDA+IROW-1 ) - V3 = A( ( ICOL-2 )*LDA+IROW ) + V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF * - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S-H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - S = CABS1( V1 ) + CABS1( V2 ) + CABS1( V3 ) + H44S = H44 - H11( 1 ) + H33S = H33 - H11( 1 ) + V1 = ( H33S*H44S-H43H34 ) / H21( 1 ) + H12( 1 ) + V2 = H22 - H11( 1 ) - H33S - H44S + S = CABS1( V1 ) + CABS1( V2 ) + CABS1( V3( 1 ) ) V1 = V1 / S V2 = V2 / S - V3 = V3 / S + V3( 1 ) = V3( 1 ) / S V( 1 ) = V1 V( 2 ) = V2 - V( 3 ) = V3 + V( 3 ) = V3( 1 ) * RETURN * diff --git a/SRC/pztrevc.f b/SRC/pztrevc.f index 0536475..3b27286 100644 --- a/SRC/pztrevc.f +++ b/SRC/pztrevc.f @@ -218,11 +218,12 @@ SUBROUTINE PZTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ ITMP2, J, K, KI, LDT, LDVL, LDVR, LDW, MB, $ MYCOL, MYROW, NB, NPCOL, NPROW, RSRC REAL SELF - DOUBLE PRECISION OVFL, REMAXD, SCALE, SMIN, SMLNUM, ULP, UNFL + DOUBLE PRECISION OVFL, REMAXD, SCALE, SMLNUM, ULP, UNFL COMPLEX*16 CDUM, REMAXC, SHIFT * .. * .. Local Arrays .. INTEGER DESCW( DLEN_ ) + DOUBLE PRECISION SMIN( 1 ) * .. * .. External Functions .. LOGICAL LSAME @@ -355,13 +356,13 @@ SUBROUTINE PZTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ GO TO 70 END IF * - SMIN = ZERO + SMIN( 1 ) = ZERO SHIFT = CZERO CALL INFOG2L( KI, KI, DESCT, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, ITMP1, ITMP2 ) IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN SHIFT = T( ( ICOL-1 )*LDT+IROW ) - SMIN = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) + SMIN( 1 ) = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) END IF CALL DGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SMIN, 1, -1, -1 ) CALL ZGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SHIFT, 1, -1, -1 ) @@ -396,8 +397,9 @@ SUBROUTINE PZTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN T( ( ICOL-1 )*LDT+IROW ) = T( ( ICOL-1 )*LDT+IROW ) - $ SHIFT - IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN ) THEN - T( ( ICOL-1 )*LDT+IROW ) = DCMPLX( SMIN ) + IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN( 1 ) ) + $ THEN + T( ( ICOL-1 )*LDT+IROW ) = DCMPLX( SMIN( 1 ) ) END IF END IF 50 CONTINUE @@ -467,13 +469,13 @@ SUBROUTINE PZTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ GO TO 110 END IF * - SMIN = ZERO + SMIN( 1 ) = ZERO SHIFT = CZERO CALL INFOG2L( KI, KI, DESCT, NPROW, NPCOL, MYROW, MYCOL, $ IROW, ICOL, ITMP1, ITMP2 ) IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN SHIFT = T( ( ICOL-1 )*LDT+IROW ) - SMIN = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) + SMIN( 1 ) = MAX( ULP*( CABS1( SHIFT ) ), SMLNUM ) END IF CALL DGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SMIN, 1, -1, -1 ) CALL ZGSUM2D( CONTXT, 'ALL', ' ', 1, 1, SHIFT, 1, -1, -1 ) @@ -507,8 +509,8 @@ SUBROUTINE PZTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, IF( ( MYROW.EQ.ITMP1 ) .AND. ( MYCOL.EQ.ITMP2 ) ) THEN T( ( ICOL-1 )*LDT+IROW ) = T( ( ICOL-1 )*LDT+IROW ) - $ SHIFT - IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN ) - $ T( ( ICOL-1 )*LDT+IROW ) = DCMPLX( SMIN ) + IF( CABS1( T( ( ICOL-1 )*LDT+IROW ) ).LT.SMIN( 1 ) ) + $ T( ( ICOL-1 )*LDT+IROW ) = DCMPLX( SMIN( 1 ) ) END IF 90 CONTINUE * From 189c84001bcd564296a475c5c757afc9f337e828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tiziano=20M=C3=BCller?= Date: Thu, 25 Jun 2020 18:37:34 +0200 Subject: [PATCH 2/2] use -std=legacy for tests with GCC-10+ --- BLACS/TESTING/CMakeLists.txt | 10 +++++++--- PBLAS/TESTING/CMakeLists.txt | 7 ++++--- PBLAS/TIMING/CMakeLists.txt | 5 +++-- TESTING/EIG/CMakeLists.txt | 3 +++ TESTING/LIN/CMakeLists.txt | 4 ++++ 5 files changed, 21 insertions(+), 8 deletions(-) diff --git a/BLACS/TESTING/CMakeLists.txt b/BLACS/TESTING/CMakeLists.txt index d8846b5..4e91ac2 100644 --- a/BLACS/TESTING/CMakeLists.txt +++ b/BLACS/TESTING/CMakeLists.txt @@ -1,10 +1,14 @@ -set(FTestObj +set(FTestObj blacstest.f btprim.f tools.f) +if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + set_source_files_properties(blacstest.f PROPERTIES COMPILE_FLAGS "-std=legacy") +endif() + add_executable(xFbtest ${FTestObj}) target_link_libraries(xFbtest scalapack) -set(CTestObj +set(CTestObj Cbt.c) set_property( @@ -46,4 +50,4 @@ add_test(xFbtest -DRUNTIMEDIR=${CMAKE_RUNTIME_OUTPUT_DIRECTORY} -DSOURCEDIR=${CMAKE_CURRENT_SOURCE_DIR} -P ${CMAKE_CURRENT_SOURCE_DIR}/runtest.cmake - ) \ No newline at end of file + ) diff --git a/PBLAS/TESTING/CMakeLists.txt b/PBLAS/TESTING/CMakeLists.txt index e60f5e4..ee77091 100644 --- a/PBLAS/TESTING/CMakeLists.txt +++ b/PBLAS/TESTING/CMakeLists.txt @@ -10,7 +10,7 @@ set (zpbtcom pzblastst.f dlamch.f ${pbtcom}) set_property( SOURCE ${PblasErrorHandler} - APPEND PROPERTY COMPILE_DEFINITIONS TestingPblas + APPEND PROPERTY COMPILE_DEFINITIONS TestingPblas ) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/PBLAS/TESTING) @@ -74,5 +74,6 @@ add_test(dpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb3tst) add_test(cpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb3tst) add_test(zpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb3tst) - - +if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=legacy" ) # local to this directory +endif() diff --git a/PBLAS/TIMING/CMakeLists.txt b/PBLAS/TIMING/CMakeLists.txt index 763330f..208bbc3 100644 --- a/PBLAS/TIMING/CMakeLists.txt +++ b/PBLAS/TIMING/CMakeLists.txt @@ -74,5 +74,6 @@ add_test(dpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb3tim) add_test(cpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb3tim) add_test(zpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb3tim) - - +if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=legacy" ) # local to this directory +endif() diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt index 97c7036..19a1f34 100644 --- a/TESTING/EIG/CMakeLists.txt +++ b/TESTING/EIG/CMakeLists.txt @@ -97,3 +97,6 @@ target_link_libraries(xzheevr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) target_link_libraries(xshseqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) target_link_libraries(xdhseqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) +if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=legacy" ) # local to this directory +endif() diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 55a53e9..65f169b 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -110,3 +110,7 @@ target_link_libraries(xsls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) target_link_libraries(xdls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) target_link_libraries(xcls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) target_link_libraries(xzls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + +if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=legacy" ) # local to this directory +endif()