From 645db9e6472283408563e3e2dc99c5deb8272c5d Mon Sep 17 00:00:00 2001 From: Dima Pasechnik Date: Sun, 17 Oct 2021 18:34:40 +0100 Subject: [PATCH] Fortran intrinsic: replace non standard (dimag) function with standard (aimag) one. (#318) Fortran intrinsic: replace non standard (dimag) function with standard (aimag) one. Nagfor compiler fix. --- CHANGES | 2 +- SRC/zgetv0.f | 4 ++-- SRC/znaitr.f | 16 ++++++++-------- SRC/znapps.f | 10 +++++----- SRC/znaup2.f | 14 +++++++------- SRC/zneupd.f | 4 ++-- SRC/zsortc.f | 14 +++++++------- 7 files changed, 32 insertions(+), 32 deletions(-) diff --git a/CHANGES b/CHANGES index 973f76f2c..c566b5067 100644 --- a/CHANGES +++ b/CHANGES @@ -2,7 +2,7 @@ arpack-ng - 3.9.0 [ Dima Pasechnik ] * [BUG FIX] autotools: replace obsolete AC_TRY_COMPILE macros. - +* Support for NAG's nagfor Fortran compiler [ Franck Houssen ] * [BUG FIX] autotools: ICB must be checked first (MPI changes compilers). diff --git a/SRC/zgetv0.f b/SRC/zgetv0.f index ff5c2b193..ef15a1e81 100644 --- a/SRC/zgetv0.f +++ b/SRC/zgetv0.f @@ -294,7 +294,7 @@ subroutine zgetv0 first = .FALSE. if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) - rnorm0 = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) + rnorm0 = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = dznrm2(n, resid, 1) end if @@ -351,7 +351,7 @@ subroutine zgetv0 c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) - rnorm = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) + rnorm = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if diff --git a/SRC/znaitr.f b/SRC/znaitr.f index 1c5aa57f1..4af4fa144 100644 --- a/SRC/znaitr.f +++ b/SRC/znaitr.f @@ -289,7 +289,7 @@ subroutine znaitr c | Intrinsic Functions | c %---------------------% c - intrinsic dimag, dble, max, sqrt + intrinsic aimag, dble, max, sqrt c c %-----------------% c | Data statements | @@ -551,7 +551,7 @@ subroutine znaitr c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) - wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) + wnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = dznrm2(n, resid, 1) end if @@ -581,7 +581,7 @@ subroutine znaitr call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c - if (j .gt. 1) h(j,j-1) = dcmplx(betaj, rzero) + if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero, Kind=Kind(0d0)) c call arscnd (t4) c @@ -623,7 +623,7 @@ subroutine znaitr c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) - rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) + rnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if @@ -723,7 +723,7 @@ subroutine znaitr c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) + rnorm1 = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = dznrm2(n, resid, 1) end if @@ -811,11 +811,11 @@ subroutine znaitr c | REFERENCE: LAPACK subroutine zlahqr | c %--------------------------------------------% c - tst1 = dlapy2(dble(h(i,i)),dimag(h(i,i))) - & + dlapy2(dble(h(i+1,i+1)), dimag(h(i+1,i+1))) + tst1 = dlapy2(dble(h(i,i)),aimag(h(i,i))) + & + dlapy2(dble(h(i+1,i+1)), aimag(h(i+1,i+1))) if( tst1.eq.dble(zero) ) & tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) ) - if( dlapy2(dble(h(i+1,i)),dimag(h(i+1,i))) .le. + if( dlapy2(dble(h(i+1,i)),aimag(h(i+1,i))) .le. & max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue diff --git a/SRC/znapps.f b/SRC/znapps.f index 6d8d12a89..792fe6168 100644 --- a/SRC/znapps.f +++ b/SRC/znapps.f @@ -198,7 +198,7 @@ subroutine znapps c | Intrinsics Functions | c %----------------------% c - intrinsic abs, dimag, conjg, dcmplx, max, min, dble + intrinsic abs, aimag, conjg, cmplx, max, min, dble c c %---------------------% c | Statement Functions | @@ -206,7 +206,7 @@ subroutine znapps c Double precision & zabs1 - zabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) + zabs1( cdum ) = abs( dble( cdum ) ) + abs( aimag( cdum ) ) c c %----------------% c | Data statements | @@ -405,12 +405,12 @@ subroutine znapps c do 120 j=1,kev if ( dble( h(j+1,j) ) .lt. rzero .or. - & dimag( h(j+1,j) ) .ne. rzero ) then - t = h(j+1,j) / dlapy2(dble(h(j+1,j)),dimag(h(j+1,j))) + & aimag( h(j+1,j) ) .ne. rzero ) then + t = h(j+1,j) / dlapy2(dble(h(j+1,j)),aimag(h(j+1,j))) call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) call zscal( min(j+2, kplusp), t, h(1,j+1), 1 ) call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) - h(j+1,j) = dcmplx( dble( h(j+1,j) ), rzero ) + h(j+1,j) = cmplx( dble( h(j+1,j) ), rzero, Kind=Kind(0d0) ) end if 120 continue c diff --git a/SRC/znaup2.f b/SRC/znaup2.f index b814cf158..7ce7643f4 100644 --- a/SRC/znaup2.f +++ b/SRC/znaup2.f @@ -256,7 +256,7 @@ subroutine znaup2 c | Intrinsic Functions | c %---------------------% c - intrinsic dimag , dble , min, max + intrinsic aimag , dble , min, max c c %-----------------------% c | Executable Statements | @@ -489,8 +489,8 @@ subroutine znaup2 c do 25 i = 1, nev rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)), - & dimag (ritz(np+i)) ) ) - if ( dlapy2 (dble (bounds(np+i)),dimag (bounds(np+i))) + & aimag (ritz(np+i)) ) ) + if ( dlapy2 (dble (bounds(np+i)),aimag (bounds(np+i))) & .le. tol*rtemp ) then nconv = nconv + 1 end if @@ -550,7 +550,7 @@ subroutine znaup2 c | rnorm to zneupd if needed | c %------------------------------------------% - h(3,1) = dcmplx (rnorm,rzero) + h(3,1) = cmplx (rnorm,rzero,Kind=Kind(0d0)) c c %----------------------------------------------% c | Sort Ritz values so that converged Ritz | @@ -575,7 +575,7 @@ subroutine znaup2 c do 35 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), - & dimag (ritz(j)) ) ) + & aimag (ritz(j)) ) ) bounds(j) = bounds(j)/rtemp 35 continue c @@ -596,7 +596,7 @@ subroutine znaup2 c do 40 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), - & dimag (ritz(j)) ) ) + & aimag (ritz(j)) ) ) bounds(j) = bounds(j)*rtemp 40 continue c @@ -755,7 +755,7 @@ subroutine znaup2 c if (bmat .eq. 'G') then cmpnorm = zdotc (n, resid, 1, workd, 1) - rnorm = sqrt(dlapy2 (dble (cmpnorm),dimag (cmpnorm))) + rnorm = sqrt(dlapy2 (dble (cmpnorm),aimag (cmpnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2 (n, resid, 1) end if diff --git a/SRC/zneupd.f b/SRC/zneupd.f index 9889e30eb..6f3d99d73 100644 --- a/SRC/zneupd.f +++ b/SRC/zneupd.f @@ -516,11 +516,11 @@ subroutine zneupd(rvec , howmny, select, d , do 11 j = 1,ncv rtemp = max(eps23, & dlapy2 ( dble(workl(irz+ncv-j)), - & dimag(workl(irz+ncv-j)) )) + & aimag(workl(irz+ncv-j)) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & dlapy2( dble(workl(ibd+jj-1)), - & dimag(workl(ibd+jj-1)) ) + & aimag(workl(ibd+jj-1)) ) & .le. tol*rtemp) then select(jj) = .true. numcnv = numcnv + 1 diff --git a/SRC/zsortc.f b/SRC/zsortc.f index 2db8bf305..6ea37a42f 100644 --- a/SRC/zsortc.f +++ b/SRC/zsortc.f @@ -96,7 +96,7 @@ subroutine zsortc (which, apply, n, x, y) c | Intrinsic Functions | c %--------------------% Intrinsic - & dble, dimag + & dble, aimag c c %-----------------------% c | Executable Statements | @@ -119,8 +119,8 @@ subroutine zsortc (which, apply, n, x, y) c if (j.lt.0) go to 30 c - temp1 = dlapy2(dble(x(j)),dimag(x(j))) - temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) + temp1 = dlapy2(dble(x(j)),aimag(x(j))) + temp2 = dlapy2(dble(x(j+igap)),aimag(x(j+igap))) c if (temp1.gt.temp2) then temp = x(j) @@ -156,8 +156,8 @@ subroutine zsortc (which, apply, n, x, y) c if (j .lt. 0) go to 60 c - temp1 = dlapy2(dble(x(j)),dimag(x(j))) - temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) + temp1 = dlapy2(dble(x(j)),aimag(x(j))) + temp2 = dlapy2(dble(x(j+igap)),aimag(x(j+igap))) c if (temp1.lt.temp2) then temp = x(j) @@ -259,7 +259,7 @@ subroutine zsortc (which, apply, n, x, y) c if (j.lt.0) go to 150 c - if (dimag(x(j)).gt.dimag(x(j+igap))) then + if (aimag(x(j)).gt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp @@ -292,7 +292,7 @@ subroutine zsortc (which, apply, n, x, y) c if (j.lt.0) go to 180 c - if (dimag(x(j)).lt.dimag(x(j+igap))) then + if (aimag(x(j)).lt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp