Skip to content

Commit

Permalink
modernize archaic (non-generic) Fortran intrinsics
Browse files Browse the repository at this point in the history 
git-svn-id: https://svn.r-project.org/R/trunk@86632 00db46b3-68df-0310-9c12-caf00c1e9a41
  • Loading branch information
ripley committed May 27, 2024
1 parent 7767796 commit 2d877f4
Show file tree
Hide file tree
Showing 9 changed files with 60 additions and 60 deletions.
4 changes: 2 additions & 2 deletions src/appl/dchdc.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ subroutine dchdc(a,lda,p,work,jpvt,job,info)
c
c
c blas daxpy,dswap
c fortran dsqrt
c fortran sqrt
c
c internal variables
c
Expand Down Expand Up @@ -205,7 +205,7 @@ subroutine dchdc(a,lda,p,work,jpvt,job,info)
c
c reduction step. pivoting is contained across the rows.
c
work(k) = dsqrt(a(k,k))
work(k) = sqrt(a(k,k))
a(k,k) = work(k)
if (p .lt. kp1) go to 260
do 250 j = kp1, p
Expand Down
8 changes: 4 additions & 4 deletions src/appl/dpbfa.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ subroutine dpbfa(abd,lda,n,m,info)
c
c m = (band width above diagonal)
c do 20 j = 1, n
c i1 = max0(1, j-m)
c i1 = max(1, j-m)
c do 10 i = i1, j
c k = i-j+m+1
c abd(k,j) = a(i,j)
Expand All @@ -58,7 +58,7 @@ subroutine dpbfa(abd,lda,n,m,info)
c subroutines and functions
c
c blas ddot
c fortran max0,sqrt
c fortran max,sqrt
c
c internal variables
c
Expand All @@ -72,8 +72,8 @@ subroutine dpbfa(abd,lda,n,m,info)
info = j
s = 0.0d0
ik = m + 1
jk = max0(j-m,1)
mu = max0(m+2-j,1)
jk = max(j-m,1)
mu = max(m+2-j,1)
if (m .lt. mu) go to 20
do 10 k = mu, m

Expand Down
6 changes: 3 additions & 3 deletions src/appl/dpbsl.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,7 @@ subroutine dpbsl(abd,lda,n,m,b)
c subroutines and functions
c
c blas daxpy,ddot
c fortran min0
c fortran min
c
c internal variables
c
Expand All @@ -60,7 +60,7 @@ subroutine dpbsl(abd,lda,n,m,b)
c solve trans(r)*y = b
c
do 10 k = 1, n
lm = min0(k-1,m)
lm = min(k-1,m)
la = m + 1 - lm
lb = k - lm
t = ddot(lm,abd(la,k),1,b(lb),1)
Expand All @@ -71,7 +71,7 @@ subroutine dpbsl(abd,lda,n,m,b)
c
do 20 kb = 1, n
k = n + 1 - kb
lm = min0(k-1,m)
lm = min(k-1,m)
la = m + 1 - lm
lb = k - lm
b(k) = b(k)/abd(m+1,k)
Expand Down
32 changes: 16 additions & 16 deletions src/appl/dpoco.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,7 +58,7 @@
c
c linpack dpofa
c blas daxpy,ddot,dscal,dasum
c fortran dabs,dmax1,dreal,dsign
c fortran abs,max,sign
c
subroutine dpoco(a,lda,n,rcond,z,info)
integer lda,n,info
Expand All @@ -79,13 +79,13 @@ subroutine dpoco(a,lda,n,rcond,z,info)
jm1 = j - 1
if (jm1 .lt. 1) go to 20
do 10 i = 1, jm1
z(i) = z(i) + dabs(a(i,j))
z(i) = z(i) + abs(a(i,j))
10 continue
20 continue
30 continue
anorm = 0.0d0
do 40 j = 1, n
anorm = dmax1(anorm,z(j))
anorm = max(anorm,z(j))
40 continue
c
c factor
Expand All @@ -106,24 +106,24 @@ subroutine dpoco(a,lda,n,rcond,z,info)
z(j) = 0.0d0
50 continue
do 110 k = 1, n
if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
if (dabs(ek-z(k)) .le. a(k,k)) go to 60
s = a(k,k)/dabs(ek-z(k))
if (z(k) .ne. 0.0d0) ek = sign(ek,-z(k))
if (abs(ek-z(k)) .le. a(k,k)) go to 60
s = a(k,k)/abs(ek-z(k))
call dscal(n,s,z,1)
ek = s*ek
60 continue
wk = ek - z(k)
wkm = -ek - z(k)
s = dabs(wk)
sm = dabs(wkm)
s = abs(wk)
sm = abs(wkm)
wk = wk/a(k,k)
wkm = wkm/a(k,k)
kp1 = k + 1
if (kp1 .gt. n) go to 100
do 70 j = kp1, n
sm = sm + dabs(z(j)+wkm*a(k,j))
sm = sm + abs(z(j)+wkm*a(k,j))
z(j) = z(j) + wk*a(k,j)
s = s + dabs(z(j))
s = s + abs(z(j))
70 continue
if (s .ge. sm) go to 90
t = wkm - wk
Expand All @@ -142,8 +142,8 @@ subroutine dpoco(a,lda,n,rcond,z,info)
c
do 130 kb = 1, n
k = n + 1 - kb
if (dabs(z(k)) .le. a(k,k)) go to 120
s = a(k,k)/dabs(z(k))
if (abs(z(k)) .le. a(k,k)) go to 120
s = a(k,k)/abs(z(k))
call dscal(n,s,z,1)
120 continue
z(k) = z(k)/a(k,k)
Expand All @@ -159,8 +159,8 @@ subroutine dpoco(a,lda,n,rcond,z,info)
c
do 150 k = 1, n
z(k) = z(k) - ddot(k-1,a(1,k),1,z(1),1)
if (dabs(z(k)) .le. a(k,k)) go to 140
s = a(k,k)/dabs(z(k))
if (abs(z(k)) .le. a(k,k)) go to 140
s = a(k,k)/abs(z(k))
call dscal(n,s,z,1)
ynorm = s*ynorm
140 continue
Expand All @@ -174,8 +174,8 @@ subroutine dpoco(a,lda,n,rcond,z,info)
c
do 170 kb = 1, n
k = n + 1 - kb
if (dabs(z(k)) .le. a(k,k)) go to 160
s = a(k,k)/dabs(z(k))
if (abs(z(k)) .le. a(k,k)) go to 160
s = a(k,k)/abs(z(k))
call dscal(n,s,z,1)
ynorm = s*ynorm
160 continue
Expand Down
10 changes: 5 additions & 5 deletions src/appl/dqrdc.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -76,7 +76,7 @@
c dqrdc uses the following functions and subprograms.
c
c blas daxpy,ddot,dscal,dswap,dnrm2
c fortran dabs,dmax1,min0,dsqrt
c fortran abs,max,min,sqrt
c
subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job)
integer ldx,n,p,job
Expand Down Expand Up @@ -137,7 +137,7 @@ subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job)
c
c perform the householder reduction of x.
c
lup = min0(n,p)
lup = min(n,p)
do 200 l = 1, lup
if (l .lt. pl .or. l .ge. pu) go to 120
c
Expand Down Expand Up @@ -182,12 +182,12 @@ subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job)
call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
if (j .lt. pl .or. j .gt. pu) go to 150
if (qraux(j) .eq. 0.0d0) go to 150
tt = 1.0d0 - (dabs(x(l,j))/qraux(j))**2
tt = dmax1(tt,0.0d0)
tt = 1.0d0 - (aabs(x(l,j))/qraux(j))**2
tt = max(tt,0.0d0)
t = tt
tt = 1.0d0 + 0.05d0*tt*(qraux(j)/work(j))**2
if (tt .eq. 1.0d0) go to 130
qraux(j) = qraux(j)*dsqrt(t)
qraux(j) = qraux(j)*sqrt(t)
go to 140
130 continue
qraux(j) = dnrm2(n-l,x(l+1,j),1)
Expand Down
2 changes: 1 addition & 1 deletion src/appl/dqrdc2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -81,7 +81,7 @@
c dqrdc2 uses the following functions and subprograms.
c
c blas daxpy,ddot,dscal,dnrm2
c fortran dabs,dmax1,min0,dsqrt
c fortran abs,max,min,sqrt
c
subroutine dqrdc2(x,ldx,n,p,tol,k,qraux,jpvt,work)
integer ldx,n,p
Expand Down
4 changes: 2 additions & 2 deletions src/appl/dqrsl.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -135,7 +135,7 @@
c dqrsl uses the following functions and subprograms.
c
c BLAS daxpy,dcopy,ddot
c Fortran dabs,min0,mod
c Fortran min,mod
c
subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
integer ldx,n,k,job,info
Expand All @@ -160,7 +160,7 @@ subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
cb = mod(job,1000)/100 .ne. 0
cr = mod(job,100)/10 .ne. 0
cxb = mod(job,10) .ne. 0
ju = min0(k,n-1)
ju = min(k,n-1)
c
c special action when n=1.
c
Expand Down
32 changes: 16 additions & 16 deletions src/appl/dsvdc.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -100,7 +100,7 @@
c
c external drot
c blas daxpy,ddot,dscal,dswap,dnrm2,drotg
c fortran dabs,dmax1,max0,min0,mod,dsqrt
c fortran abs,max,min,mod,sqrt
c
subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
integer ldx,n,p,ldu,ldv,job,info
Expand Down Expand Up @@ -132,17 +132,17 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
wantv = .false.
jobu = mod(job,100)/10
ncu = n
if (jobu .gt. 1) ncu = min0(n,p)
if (jobu .gt. 1) ncu = min(n,p)
if (jobu .ne. 0) wantu = .true.
if (mod(job,10) .ne. 0) wantv = .true.
c
c reduce x to bidiagonal form, storing the diagonal elements
c in s and the super-diagonal elements in e.
c
info = 0
nct = min0(n-1,p)
nrt = max0(0,min0(p-2,n))
lu = max0(nct,nrt)
nct = min(n-1,p)
nrt = max(0,min(p-2,n))
lu = max(nct,nrt)
if (lu .lt. 1) go to 170
do 160 l = 1, lu
lp1 = l + 1
Expand Down Expand Up @@ -226,7 +226,7 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
c
c set up the final bidiagonal matrix or order m.
c
m = min0(p,n+1)
m = min(p,n+1)
nctp1 = nct + 1
nrtp1 = nrt + 1
if (nct .lt. p) s(nctp1) = x(nctp1,nctp1)
Expand Down Expand Up @@ -329,9 +329,9 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
l = m - ll
c ...exit
if (l .eq. 0) go to 400
test = dabs(s(l)) + dabs(s(l+1))
ztest = test + dabs(e(l))
acc = dabs(test - ztest)/(1.0d-100 + test)
test = abs(s(l)) + abs(s(l+1))
ztest = test + abs(e(l))
acc = abs(test - ztest)/(1.0d-100 + test)
if (acc .gt. 1.d-15) goto 380
c if (ztest .ne. test) go to 380
e(l) = 0.0d0
Expand All @@ -351,11 +351,11 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
c ...exit
if (ls .eq. l) go to 440
test = 0.0d0
if (ls .ne. m) test = test + dabs(e(ls))
if (ls .ne. l + 1) test = test + dabs(e(ls-1))
ztest = test + dabs(s(ls))
if (ls .ne. m) test = test + abs(e(ls))
if (ls .ne. l + 1) test = test + abs(e(ls-1))
ztest = test + abs(s(ls))
c 1.0d-100 is to guard against a zero matrix, hence zero test
acc = dabs(test - ztest)/(1.0d-100 + test)
acc = abs(test - ztest)/(1.0d-100 + test)
if (acc .gt. 1.d-15) goto 420
c if (ztest .ne. test) go to 420
s(ls) = 0.0d0
Expand Down Expand Up @@ -432,8 +432,8 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
c
c calculate the shift.
c
scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),
* dabs(s(l)),dabs(e(l)))
scale = max(abs(s(m)),abs(s(m-1)),abs(e(m-1)),
* abs(s(l)),dabs(e(l)))
sm = s(m)/scale
smm1 = s(m-1)/scale
emm1 = e(m-1)/scale
Expand All @@ -443,7 +443,7 @@ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
c = (sm*emm1)**2
shift = 0.0d0
if (b .eq. 0.0d0 .and. c .eq. 0.0d0) go to 550
shift = dsqrt(b**2+c)
shift = sqrt(b**2+c)
if (b .lt. 0.0d0) shift = -shift
shift = c/(b + shift)
550 continue
Expand Down
22 changes: 11 additions & 11 deletions src/appl/dtrco.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,7 @@ subroutine dtrco(t,ldt,n,rcond,z,job)
c subroutines and functions
c
c blas daxpy,dscal,dasum
c fortran dabs,dmax1,dsign
c fortran abs,max,sign
c
c internal variables
c
Expand All @@ -69,7 +69,7 @@ subroutine dtrco(t,ldt,n,rcond,z,job)
if (lower) l = n + 1 - j
i1 = 1
if (lower) i1 = j
tnorm = dmax1(tnorm,dasum(l,t(i1,j),1))
tnorm = max(tnorm,dasum(l,t(i1,j),1))
10 continue
c
c rcond = 1/(norm(t)*(estimate of norm(inverse(t)))) .
Expand All @@ -88,16 +88,16 @@ subroutine dtrco(t,ldt,n,rcond,z,job)
do 100 kk = 1, n
k = kk
if (lower) k = n + 1 - kk
if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
if (dabs(ek-z(k)) .le. dabs(t(k,k))) go to 30
s = dabs(t(k,k))/dabs(ek-z(k))
if (z(k) .ne. 0.0d0) ek = sign(ek,-z(k))
if (abs(ek-z(k)) .le. abs(t(k,k))) go to 30
s = abs(t(k,k))/abs(ek-z(k))
call dscal(n,s,z,1)
ek = s*ek
30 continue
wk = ek - z(k)
wkm = -ek - z(k)
s = dabs(wk)
sm = dabs(wkm)
s = abs(wk)
sm = abs(wkm)
if (t(k,k) .eq. 0.0d0) go to 40
wk = wk/t(k,k)
wkm = wkm/t(k,k)
Expand All @@ -112,9 +112,9 @@ subroutine dtrco(t,ldt,n,rcond,z,job)
j2 = n
if (lower) j2 = k - 1
do 60 j = j1, j2
sm = sm + dabs(z(j)+wkm*t(k,j))
sm = sm + abs(z(j)+wkm*t(k,j))
z(j) = z(j) + wk*t(k,j)
s = s + dabs(z(j))
s = s + abs(z(j))
60 continue
if (s .ge. sm) go to 80
w = wkm - wk
Expand All @@ -136,8 +136,8 @@ subroutine dtrco(t,ldt,n,rcond,z,job)
do 130 kk = 1, n
k = n + 1 - kk
if (lower) k = kk
if (dabs(z(k)) .le. dabs(t(k,k))) go to 110
s = dabs(t(k,k))/dabs(z(k))
if (abs(z(k)) .le. abs(t(k,k))) go to 110
s = abs(t(k,k))/abs(z(k))
call dscal(n,s,z,1)
ynorm = s*ynorm
110 continue
Expand Down

0 comments on commit 2d877f4

Please sign in to comment.