From d5f793763f332f2dd0f43063dc38862534ad412d Mon Sep 17 00:00:00 2001 From: Pierre Jolivet Date: Sun, 6 Sep 2020 17:40:17 +0200 Subject: [PATCH 1/2] [c,z]dotc => [cc,zz]dotc --- CHANGES | 2 ++ PARPACK/SRC/BLACS/pcgetv0.f | 8 ++++---- PARPACK/SRC/BLACS/pcnaitr.f | 10 +++++----- PARPACK/SRC/BLACS/pcnaup2.f | 6 +++--- PARPACK/SRC/BLACS/pcneupd.f | 6 +++--- PARPACK/SRC/BLACS/pzgetv0.f | 8 ++++---- PARPACK/SRC/BLACS/pznaitr.f | 10 +++++----- PARPACK/SRC/BLACS/pznaup2.f | 6 +++--- PARPACK/SRC/BLACS/pzneupd.f | 6 +++--- PARPACK/SRC/MPI/pcgetv0.f | 8 ++++---- PARPACK/SRC/MPI/pcnaitr.f | 10 +++++----- PARPACK/SRC/MPI/pcnaup2.f | 6 +++--- PARPACK/SRC/MPI/pcneupd.f | 6 +++--- PARPACK/SRC/MPI/pzgetv0.f | 8 ++++---- PARPACK/SRC/MPI/pznaitr.f | 10 +++++----- PARPACK/SRC/MPI/pznaup2.f | 6 +++--- PARPACK/SRC/MPI/pzneupd.f | 6 +++--- SRC/Makefile.am | 4 ++-- SRC/ccdotc.f | 36 ++++++++++++++++++++++++++++++++++++ SRC/cgetv0.f | 8 ++++---- SRC/cnaitr.f | 10 +++++----- SRC/cnaup2.f | 6 +++--- SRC/cneupd.f | 6 +++--- SRC/zgetv0.f | 8 ++++---- SRC/znaitr.f | 10 +++++----- SRC/znaup2.f | 6 +++--- SRC/zneupd.f | 6 +++--- SRC/zzdotc.f | 36 ++++++++++++++++++++++++++++++++++++ 28 files changed, 166 insertions(+), 92 deletions(-) create mode 100644 SRC/ccdotc.f create mode 100644 SRC/zzdotc.f diff --git a/CHANGES b/CHANGES index c566b5067..b4966e8a9 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,7 @@ arpack-ng - 3.9.0 +* Avoid calling [c|z]dotc for better portability on macOS + [ Dima Pasechnik ] * [BUG FIX] autotools: replace obsolete AC_TRY_COMPILE macros. * Support for NAG's nagfor Fortran compiler diff --git a/PARPACK/SRC/BLACS/pcgetv0.f b/PARPACK/SRC/BLACS/pcgetv0.f index 191d70fdc..e74fe56ba 100644 --- a/PARPACK/SRC/BLACS/pcgetv0.f +++ b/PARPACK/SRC/BLACS/pcgetv0.f @@ -197,8 +197,8 @@ subroutine pcgetv0 Real & pscnorm2, slapy2 Complex - & cdotc - external cdotc, pscnorm2, slapy2 + & ccdotc + external ccdotc, pscnorm2, slapy2 c c %-----------------% c | Data Statements | @@ -335,7 +335,7 @@ subroutine pcgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) + cnorm = ccdotc (n, resid, 1, workd, 1) call cgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm0 = sqrt(slapy2(real (cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then @@ -394,7 +394,7 @@ subroutine pcgetv0 end if c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) + cnorm = ccdotc (n, resid, 1, workd, 1) call cgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm = sqrt(slapy2(real (cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pcnaitr.f b/PARPACK/SRC/BLACS/pcnaitr.f index 04fa1cbe5..305948141 100644 --- a/PARPACK/SRC/BLACS/pcnaitr.f +++ b/PARPACK/SRC/BLACS/pcnaitr.f @@ -303,10 +303,10 @@ subroutine pcnaitr c %--------------------% c Complex - & cdotc + & ccdotc Real & pslamch, pscnorm2, clanhs, slapy2 - external cdotc, pscnorm2, clanhs, pslamch, slapy2 + external ccdotc, pscnorm2, clanhs, pslamch, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -573,7 +573,7 @@ subroutine pcnaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) call cgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then @@ -647,7 +647,7 @@ subroutine pcnaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) call cgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then @@ -749,7 +749,7 @@ subroutine pcnaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) call cgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pcnaup2.f b/PARPACK/SRC/BLACS/pcnaup2.f index 757b12c38..bb5703763 100644 --- a/PARPACK/SRC/BLACS/pcnaup2.f +++ b/PARPACK/SRC/BLACS/pcnaup2.f @@ -254,10 +254,10 @@ subroutine pcnaup2 c %--------------------% c Complex - & cdotc + & ccdotc Real & pscnorm2, pslamch, slapy2 - external cdotc, pscnorm2, pslamch, slapy2 + external ccdotc, pscnorm2, pslamch, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -767,7 +767,7 @@ subroutine pcnaup2 end if c if (bmat .eq. 'G') then - cmpnorm = cdotc (n, resid, 1, workd, 1) + cmpnorm = ccdotc (n, resid, 1, workd, 1) call cgsum2d( comm, 'All', ' ', 1, 1, cmpnorm, 1, -1, -1 ) rnorm = sqrt(slapy2(real(cmpnorm),aimag(cmpnorm))) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pcneupd.f b/PARPACK/SRC/BLACS/pcneupd.f index da4a9ec55..ad2a080db 100644 --- a/PARPACK/SRC/BLACS/pcneupd.f +++ b/PARPACK/SRC/BLACS/pcneupd.f @@ -340,8 +340,8 @@ subroutine pcneupd external scnrm2,pslamch,slapy2 c Complex - & cdotc - external cdotc + & ccdotc + external ccdotc c c %---------------------% c | Intrinsic Functions | @@ -743,7 +743,7 @@ subroutine pcneupd c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = cdotc(j, workl(ihbds), 1, + workev(j) = ccdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/PARPACK/SRC/BLACS/pzgetv0.f b/PARPACK/SRC/BLACS/pzgetv0.f index c1d173f08..17354c1c8 100644 --- a/PARPACK/SRC/BLACS/pzgetv0.f +++ b/PARPACK/SRC/BLACS/pzgetv0.f @@ -197,8 +197,8 @@ subroutine pzgetv0 Double precision & pdznorm2 , dlapy2 Complex*16 - & zdotc - external zdotc , pdznorm2 , dlapy2 + & zzdotc + external zzdotc , pdznorm2 , dlapy2 c c %-----------------% c | Data Statements | @@ -335,7 +335,7 @@ subroutine pzgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) + cnorm = zzdotc (n, resid, 1, workd, 1) call zgsum2d ( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm0 = sqrt(dlapy2 (dble (cnorm),dimag (cnorm))) else if (bmat .eq. 'I') then @@ -394,7 +394,7 @@ subroutine pzgetv0 end if c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) + cnorm = zzdotc (n, resid, 1, workd, 1) call zgsum2d ( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm = sqrt(dlapy2 (dble (cnorm),dimag (cnorm))) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pznaitr.f b/PARPACK/SRC/BLACS/pznaitr.f index 92db7fe7a..cd1ba01e0 100644 --- a/PARPACK/SRC/BLACS/pznaitr.f +++ b/PARPACK/SRC/BLACS/pznaitr.f @@ -303,10 +303,10 @@ subroutine pznaitr c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & pdlamch, pdznorm2, zlanhs, dlapy2 - external zdotc, pdznorm2, zlanhs, pdlamch, dlapy2 + external zzdotc, pdznorm2, zlanhs, pdlamch, dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -573,7 +573,7 @@ subroutine pznaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) call zgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then @@ -647,7 +647,7 @@ subroutine pznaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) call zgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then @@ -749,7 +749,7 @@ subroutine pznaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) call zgsum2d( comm, 'All', ' ', 1, 1, cnorm, 1, -1, -1 ) rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pznaup2.f b/PARPACK/SRC/BLACS/pznaup2.f index 1610a5885..8fff22fc1 100644 --- a/PARPACK/SRC/BLACS/pznaup2.f +++ b/PARPACK/SRC/BLACS/pznaup2.f @@ -254,10 +254,10 @@ subroutine pznaup2 c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & pdznorm2, pdlamch, dlapy2 - external zdotc, pdznorm2, pdlamch, dlapy2 + external zzdotc, pdznorm2, pdlamch, dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -767,7 +767,7 @@ subroutine pznaup2 end if c if (bmat .eq. 'G') then - cmpnorm = zdotc (n, resid, 1, workd, 1) + cmpnorm = zzdotc (n, resid, 1, workd, 1) call zgsum2d( comm, 'All', ' ', 1, 1, cmpnorm, 1, -1, -1 ) rnorm = sqrt(dlapy2(dble(cmpnorm),dimag(cmpnorm))) else if (bmat .eq. 'I') then diff --git a/PARPACK/SRC/BLACS/pzneupd.f b/PARPACK/SRC/BLACS/pzneupd.f index c2f508f28..af76f06e2 100644 --- a/PARPACK/SRC/BLACS/pzneupd.f +++ b/PARPACK/SRC/BLACS/pzneupd.f @@ -340,8 +340,8 @@ subroutine pzneupd external dznrm2,pdlamch,dlapy2 c Complex*16 - & zdotc - external zdotc + & zzdotc + external zzdotc c c %---------------------% c | Intrinsic Functions | @@ -743,7 +743,7 @@ subroutine pzneupd c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = zdotc(j, workl(ihbds), 1, + workev(j) = zzdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/PARPACK/SRC/MPI/pcgetv0.f b/PARPACK/SRC/MPI/pcgetv0.f index 72677a502..24fe8a0f1 100644 --- a/PARPACK/SRC/MPI/pcgetv0.f +++ b/PARPACK/SRC/MPI/pcgetv0.f @@ -200,8 +200,8 @@ subroutine pcgetv0 Real & pscnorm2, slapy2 Complex - & cdotc - external cdotc, pscnorm2, slapy2 + & ccdotc + external ccdotc, pscnorm2, slapy2 c c %-----------------% c | Data Statements | @@ -331,7 +331,7 @@ subroutine pcgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm_buf = cdotc (n, resid, 1, workd, 1) + cnorm_buf = ccdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -393,7 +393,7 @@ subroutine pcgetv0 end if c if (bmat .eq. 'G') then - cnorm_buf = cdotc (n, resid, 1, workd, 1) + cnorm_buf = ccdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pcnaitr.f b/PARPACK/SRC/MPI/pcnaitr.f index fe246ea02..6e3cd98d3 100644 --- a/PARPACK/SRC/MPI/pcnaitr.f +++ b/PARPACK/SRC/MPI/pcnaitr.f @@ -307,10 +307,10 @@ subroutine pcnaitr c %--------------------% c Complex - & cdotc + & ccdotc Real & pslamch10, pscnorm2, clanhs, slapy2 - external cdotc, pscnorm2, clanhs, pslamch10, slapy2 + external ccdotc, pscnorm2, clanhs, pslamch10, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -576,7 +576,7 @@ subroutine pcnaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = cdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = ccdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -653,7 +653,7 @@ subroutine pcnaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = cdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = ccdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -758,7 +758,7 @@ subroutine pcnaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = cdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = ccdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pcnaup2.f b/PARPACK/SRC/MPI/pcnaup2.f index 4b0d6ceb6..acff48309 100644 --- a/PARPACK/SRC/MPI/pcnaup2.f +++ b/PARPACK/SRC/MPI/pcnaup2.f @@ -257,10 +257,10 @@ subroutine pcnaup2 c %--------------------% c Complex - & cdotc + & ccdotc Real & pscnorm2, pslamch10, slapy2 - external cdotc, pscnorm2, pslamch10, slapy2 + external ccdotc, pscnorm2, pslamch10, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -770,7 +770,7 @@ subroutine pcnaup2 end if c if (bmat .eq. 'G') then - cmpnorm_buf = cdotc (n, resid, 1, workd, 1) + cmpnorm_buf = ccdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cmpnorm_buf], buf2, 1, & MPI_COMPLEX, MPI_SUM, comm, ierr ) cmpnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pcneupd.f b/PARPACK/SRC/MPI/pcneupd.f index 8ced1df65..2618a6f07 100644 --- a/PARPACK/SRC/MPI/pcneupd.f +++ b/PARPACK/SRC/MPI/pcneupd.f @@ -340,8 +340,8 @@ subroutine pcneupd external scnrm2,pslamch10,slapy2 c Complex - & cdotc - external cdotc + & ccdotc + external ccdotc c c %---------------------% c | Intrinsic Functions | @@ -743,7 +743,7 @@ subroutine pcneupd c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = cdotc(j, workl(ihbds), 1, + workev(j) = ccdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/PARPACK/SRC/MPI/pzgetv0.f b/PARPACK/SRC/MPI/pzgetv0.f index 29f18f5be..94fb705f3 100644 --- a/PARPACK/SRC/MPI/pzgetv0.f +++ b/PARPACK/SRC/MPI/pzgetv0.f @@ -200,8 +200,8 @@ subroutine pzgetv0 Double precision & pdznorm2 , dlapy2 Complex*16 - & zdotc - external zdotc , pdznorm2 , dlapy2 + & zzdotc + external zzdotc , pdznorm2 , dlapy2 c c %-----------------% c | Data Statements | @@ -331,7 +331,7 @@ subroutine pzgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm_buf = zdotc (n, resid, 1, workd, 1) + cnorm_buf = zzdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX , MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -393,7 +393,7 @@ subroutine pzgetv0 end if c if (bmat .eq. 'G') then - cnorm_buf = zdotc (n, resid, 1, workd, 1) + cnorm_buf = zzdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX , MPI_SUM, comm, ierr ) cnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pznaitr.f b/PARPACK/SRC/MPI/pznaitr.f index 4ec77e4e2..29a757f83 100644 --- a/PARPACK/SRC/MPI/pznaitr.f +++ b/PARPACK/SRC/MPI/pznaitr.f @@ -307,10 +307,10 @@ subroutine pznaitr c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & pdlamch10, pdznorm2, zlanhs, dlapy2 - external zdotc, pdznorm2, zlanhs, pdlamch10, dlapy2 + external zzdotc, pdznorm2, zlanhs, pdlamch10, dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -576,7 +576,7 @@ subroutine pznaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = zdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = zzdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -653,7 +653,7 @@ subroutine pznaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = zdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = zzdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) @@ -758,7 +758,7 @@ subroutine pznaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm_buf = zdotc (n, resid, 1, workd(ipj), 1) + cnorm_buf = zzdotc (n, resid, 1, workd(ipj), 1) call MPI_ALLREDUCE( [cnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX, MPI_SUM, comm, ierr ) cnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pznaup2.f b/PARPACK/SRC/MPI/pznaup2.f index 785219796..7ea119839 100644 --- a/PARPACK/SRC/MPI/pznaup2.f +++ b/PARPACK/SRC/MPI/pznaup2.f @@ -257,10 +257,10 @@ subroutine pznaup2 c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & pdznorm2, pdlamch10, dlapy2 - external zdotc, pdznorm2, pdlamch10, dlapy2 + external zzdotc, pdznorm2, pdlamch10, dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -770,7 +770,7 @@ subroutine pznaup2 end if c if (bmat .eq. 'G') then - cmpnorm_buf = zdotc (n, resid, 1, workd, 1) + cmpnorm_buf = zzdotc (n, resid, 1, workd, 1) call MPI_ALLREDUCE( [cmpnorm_buf], buf2, 1, & MPI_DOUBLE_COMPLEX, MPI_SUM, comm, ierr ) cmpnorm = buf2(1) diff --git a/PARPACK/SRC/MPI/pzneupd.f b/PARPACK/SRC/MPI/pzneupd.f index 7b6e7fe14..395cfee66 100644 --- a/PARPACK/SRC/MPI/pzneupd.f +++ b/PARPACK/SRC/MPI/pzneupd.f @@ -340,8 +340,8 @@ subroutine pzneupd external dznrm2,pdlamch10,dlapy2 c Complex*16 - & zdotc - external zdotc + & zzdotc + external zzdotc c c %---------------------% c | Intrinsic Functions | @@ -743,7 +743,7 @@ subroutine pzneupd c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = zdotc(j, workl(ihbds), 1, + workev(j) = zzdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/SRC/Makefile.am b/SRC/Makefile.am index 8471035ed..1eac0d763 100644 --- a/SRC/Makefile.am +++ b/SRC/Makefile.am @@ -9,10 +9,10 @@ DSRC = dnaitr.f dnapps.f dnaup2.f dnaupd.f dnconv.f dneigh.f dneupd.f dngets.f d dgetv0.f dsortc.f dsortr.f dsesrt.f dstqrb.f CSRC = cnaitr.f cnapps.f cnaup2.f cnaupd.f cneigh.f cneupd.f cngets.f cstatn.f \ - cgetv0.f csortc.f + cgetv0.f csortc.f ccdotc.f ZSRC = znaitr.f znapps.f znaup2.f znaupd.f zneigh.f zneupd.f zngets.f zstatn.f \ - zgetv0.f zsortc.f + zgetv0.f zsortc.f zzdotc.f if ICB SSRC += icbass.F90 icbasn.F90 diff --git a/SRC/ccdotc.f b/SRC/ccdotc.f new file mode 100644 index 000000000..f0f94f422 --- /dev/null +++ b/SRC/ccdotc.f @@ -0,0 +1,36 @@ + complex function ccdotc(n,zx,incx,zy,incy) +c +c forms the dot product of a vector. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + complex zx(*),zy(*),ztemp + integer i,incx,incy,ix,iy,n + ztemp = (0.0d0,0.0d0) + ccdotc = (0.0d0,0.0d0) + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + ztemp = ztemp + conjg(zx(ix))*zy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ccdotc = ztemp + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + ztemp = ztemp + conjg(zx(i))*zy(i) + 30 continue + ccdotc = ztemp + return + end diff --git a/SRC/cgetv0.f b/SRC/cgetv0.f index a91ef9264..c231eadcb 100644 --- a/SRC/cgetv0.f +++ b/SRC/cgetv0.f @@ -177,8 +177,8 @@ subroutine cgetv0 Real & scnrm2, slapy2 Complex - & cdotc - external cdotc, scnrm2, slapy2 + & ccdotc + external ccdotc, scnrm2, slapy2 c c %-----------------% c | Data Statements | @@ -293,7 +293,7 @@ subroutine cgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) + cnorm = ccdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = scnrm2(n, resid, 1) @@ -350,7 +350,7 @@ subroutine cgetv0 end if c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) + cnorm = ccdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) diff --git a/SRC/cnaitr.f b/SRC/cnaitr.f index bebd82360..3759760df 100644 --- a/SRC/cnaitr.f +++ b/SRC/cnaitr.f @@ -280,10 +280,10 @@ subroutine cnaitr c %--------------------% c Complex - & cdotc + & ccdotc Real & slamch, scnrm2, clanhs, slapy2 - external cdotc, scnrm2, clanhs, slamch, slapy2 + external ccdotc, scnrm2, clanhs, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -550,7 +550,7 @@ subroutine cnaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = scnrm2(n, resid, 1) @@ -622,7 +622,7 @@ subroutine cnaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) @@ -722,7 +722,7 @@ subroutine cnaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) + cnorm = ccdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = scnrm2(n, resid, 1) diff --git a/SRC/cnaup2.f b/SRC/cnaup2.f index 3f106f05b..e36154247 100644 --- a/SRC/cnaup2.f +++ b/SRC/cnaup2.f @@ -247,10 +247,10 @@ subroutine cnaup2 c %--------------------% c Complex - & cdotc + & ccdotc Real & scnrm2, slamch, slapy2 - external cdotc, scnrm2, slamch, slapy2 + external ccdotc, scnrm2, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | @@ -754,7 +754,7 @@ subroutine cnaup2 end if c if (bmat .eq. 'G') then - cmpnorm = cdotc (n, resid, 1, workd, 1) + cmpnorm = ccdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) diff --git a/SRC/cneupd.f b/SRC/cneupd.f index 34a78f70b..29154ce37 100644 --- a/SRC/cneupd.f +++ b/SRC/cneupd.f @@ -325,8 +325,8 @@ subroutine cneupd(rvec , howmny, select, d , external scnrm2, slamch, slapy2 c Complex - & cdotc - external cdotc + & ccdotc + external ccdotc c c %-----------------------% c | Executable Statements | @@ -731,7 +731,7 @@ subroutine cneupd(rvec , howmny, select, d , c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = cdotc(j, workl(ihbds), 1, + workev(j) = ccdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/SRC/zgetv0.f b/SRC/zgetv0.f index ef15a1e81..1fbd50851 100644 --- a/SRC/zgetv0.f +++ b/SRC/zgetv0.f @@ -177,8 +177,8 @@ subroutine zgetv0 Double precision & dznrm2, dlapy2 Complex*16 - & zdotc - external zdotc, dznrm2, dlapy2 + & zzdotc + external zzdotc, dznrm2, dlapy2 c c %-----------------% c | Data Statements | @@ -293,7 +293,7 @@ subroutine zgetv0 c first = .FALSE. if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) + cnorm = zzdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = dznrm2(n, resid, 1) @@ -350,7 +350,7 @@ subroutine zgetv0 end if c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) + cnorm = zzdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) diff --git a/SRC/znaitr.f b/SRC/znaitr.f index 4af4fa144..240412ca0 100644 --- a/SRC/znaitr.f +++ b/SRC/znaitr.f @@ -280,10 +280,10 @@ subroutine znaitr c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & dlamch, dznrm2, zlanhs, dlapy2 - external zdotc, dznrm2, zlanhs, dlamch, dlapy2 + external zzdotc, dznrm2, zlanhs, dlamch, dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -550,7 +550,7 @@ subroutine znaitr c %-------------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = dznrm2(n, resid, 1) @@ -622,7 +622,7 @@ subroutine znaitr c %------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) @@ -722,7 +722,7 @@ subroutine znaitr c %-----------------------------------------------------% c if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) + cnorm = zzdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = dznrm2(n, resid, 1) diff --git a/SRC/znaup2.f b/SRC/znaup2.f index 7ce7643f4..0ab01dd0e 100644 --- a/SRC/znaup2.f +++ b/SRC/znaup2.f @@ -247,10 +247,10 @@ subroutine znaup2 c %--------------------% c Complex*16 - & zdotc + & zzdotc Double precision & dznrm2 , dlamch , dlapy2 - external zdotc , dznrm2 , dlamch , dlapy2 + external zzdotc , dznrm2 , dlamch , dlapy2 c c %---------------------% c | Intrinsic Functions | @@ -754,7 +754,7 @@ subroutine znaup2 end if c if (bmat .eq. 'G') then - cmpnorm = zdotc (n, resid, 1, workd, 1) + cmpnorm = zzdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2 (dble (cmpnorm),aimag (cmpnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2 (n, resid, 1) diff --git a/SRC/zneupd.f b/SRC/zneupd.f index 6f3d99d73..92e7dc998 100644 --- a/SRC/zneupd.f +++ b/SRC/zneupd.f @@ -325,8 +325,8 @@ subroutine zneupd(rvec , howmny, select, d , external dznrm2, dlamch, dlapy2 c Complex*16 - & zdotc - external zdotc + & zzdotc + external zzdotc c c %-----------------------% c | Executable Statements | @@ -731,7 +731,7 @@ subroutine zneupd(rvec , howmny, select, d , c | inner product can be set to j. | c %------------------------------------------% c - workev(j) = zdotc(j, workl(ihbds), 1, + workev(j) = zzdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c diff --git a/SRC/zzdotc.f b/SRC/zzdotc.f new file mode 100644 index 000000000..a98c34230 --- /dev/null +++ b/SRC/zzdotc.f @@ -0,0 +1,36 @@ + double complex function zzdotc(n,zx,incx,zy,incy) +c +c forms the dot product of a vector. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*),ztemp + integer i,incx,incy,ix,iy,n + ztemp = (0.0d0,0.0d0) + zzdotc = (0.0d0,0.0d0) + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + ztemp = ztemp + conjg(zx(ix))*zy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + zzdotc = ztemp + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + ztemp = ztemp + conjg(zx(i))*zy(i) + 30 continue + zzdotc = ztemp + return + end From 1fd6c1c89c2720a6e1747d264964302901e60490 Mon Sep 17 00:00:00 2001 From: Franck HOUSSEN Date: Sun, 17 Apr 2022 21:55:13 +0200 Subject: [PATCH 2/2] John Doe John Doe --- CHANGES | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index b4966e8a9..89cf253f7 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,6 @@ arpack-ng - 3.9.0 - + +[ John Doe ] * Avoid calling [c|z]dotc for better portability on macOS [ Dima Pasechnik ]