fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fixed implicit none, to avoid idiotic type mistake.

Browse Source
psblas3-type-indexed
Salvatore Filippone 18 years ago
parent c30ec19bc4
commit 028c2f2c96
10 changed files with 91 additions and 72 deletions
Show Stats Download Patch File Download Diff File

1
base/serial/aux/ibsrch.f
Unescape Escape View File

@ -29,6 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE.
C C
C C
subroutine ibsrch(ipos,key,n,v) subroutine ibsrch(ipos,key,n,v)
implicit none
integer ipos, key, n integer ipos, key, n
integer v(n) integer v(n)

2
base/serial/aux/imsr.f90
Unescape Escape View File

@ -33,6 +33,8 @@
! Parameters: ! Parameters:
subroutine imsr(n,x,idir) subroutine imsr(n,x,idir)
use psb_serial_mod use psb_serial_mod
implicit none
integer :: n, idir integer :: n, idir
integer :: x(n) integer :: x(n)

1
base/serial/aux/imsru.f90
Unescape Escape View File

@ -33,6 +33,7 @@
! Parameters: ! Parameters:
subroutine imsru(n,x,idir,nout) subroutine imsru(n,x,idir,nout)
use psb_serial_mod use psb_serial_mod
implicit none
integer :: n, idir,nout integer :: n, idir,nout
integer :: x(n) integer :: x(n)

1
base/serial/aux/imsrx.f90
Unescape Escape View File

@ -33,6 +33,7 @@
! Parameters: ! Parameters:
subroutine imsrx(n,x,indx,idir,flag) subroutine imsrx(n,x,indx,idir,flag)
use psb_serial_mod use psb_serial_mod
implicit none
integer :: n,idir,flag integer :: n,idir,flag
integer :: x(n) integer :: x(n)
integer :: indx(n) integer :: indx(n)

2
base/serial/aux/isaperm.f
Unescape Escape View File

@ -45,6 +45,8 @@ C
* * * *
*********************************************************************** ***********************************************************************
LOGICAL FUNCTION ISAPERM(N,IP) LOGICAL FUNCTION ISAPERM(N,IP)
implicit none
C .. Scalar Arguments .. C .. Scalar Arguments ..
INTEGER N INTEGER N
C .. C ..

57
base/serial/aux/isr.f90
Unescape Escape View File

@ -31,6 +31,7 @@
subroutine isr(n,x,dir) subroutine isr(n,x,dir)
use psb_serial_mod use psb_serial_mod
implicit none
! !
! Quicksort. ! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP. ! Adapted from a number of sources, including Don Knuth's TAOCP.
@ -40,8 +41,9 @@ subroutine isr(n,x,dir)
integer :: x(n) integer :: x(n)
! .. ! ..
! .. Local Scalars .. ! .. Local Scalars ..
integer i, j, xx, ilx, iux, istp, piv, lpiv integer :: xx, xk, piv, xt
integer it1, n1, n2 integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16 integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack) integer :: istack(nparms,maxstack)
@ -77,29 +79,29 @@ subroutine isr(n,x,dir)
lpiv = (i+j)/2 lpiv = (i+j)/2
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
it1 = x(j) xt = x(j)
x(j) = x(lpiv) x(j) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -113,19 +115,19 @@ subroutine isr(n,x,dir)
! !
! Ensure finite termination for next loop ! Ensure finite termination for next loop
! !
it1 = xk xt = xk
x(i) = piv x(i) = piv
in_up2:do in_up2:do
j = j - 1 j = j - 1
xk = x(j) xk = x(j)
if (xk <= piv) exit in_up2 if (xk <= piv) exit in_up2
end do in_up2 end do in_up2
x(i) = it1 x(i) = xt
if (j > i) then if (j > i) then
it1 = x(i) xt = x(i)
x(i) = x(j) x(i) = x(j)
x(j) = it1 x(j) = xt
else else
exit outer_up exit outer_up
end if end if
@ -202,29 +204,29 @@ subroutine isr(n,x,dir)
lpiv = (i+j)/2 lpiv = (i+j)/2
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
it1 = x(j) xt = x(j)
x(j) = x(lpiv) x(j) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
it1 = x(i) xt = x(i)
x(i) = x(lpiv) x(i) = x(lpiv)
x(lpiv) = it1 x(lpiv) = xt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -238,19 +240,19 @@ subroutine isr(n,x,dir)
! !
! Ensure finite termination for next loop ! Ensure finite termination for next loop
! !
it1 = xk xt = xk
x(i) = piv x(i) = piv
in_dw2:do in_dw2:do
j = j - 1 j = j - 1
xk = x(j) xk = x(j)
if (xk >= piv) exit in_dw2 if (xk >= piv) exit in_dw2
end do in_dw2 end do in_dw2
x(i) = it1 x(i) = xt
if (j > i) then if (j > i) then
it1 = x(i) xt = x(i)
x(i) = x(j) x(i) = x(j)
x(j) = it1 x(j) = xt
else else
exit outer_dw exit outer_dw
end if end if
@ -311,6 +313,8 @@ subroutine isr(n,x,dir)
contains contains
subroutine iisr_up(n,x) subroutine iisr_up(n,x)
implicit none
integer :: n integer :: n
integer :: x(n) integer :: x(n)
integer :: i,j integer :: i,j
@ -332,6 +336,7 @@ contains
end subroutine iisr_up end subroutine iisr_up
subroutine iisr_dw(n,x) subroutine iisr_dw(n,x)
implicit none
integer :: n integer :: n
integer :: x(n) integer :: x(n)
integer :: i,j integer :: i,j

96
base/serial/aux/isrx.f90
Unescape Escape View File

@ -30,6 +30,7 @@
!!$ !!$
subroutine isrx(n,x,indx,dir,flag) subroutine isrx(n,x,indx,dir,flag)
use psb_serial_mod use psb_serial_mod
implicit none
! !
! Quicksort with indices into original positions. ! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP. ! Adapted from a number of sources, including Don Knuth's TAOCP.
@ -39,8 +40,9 @@ subroutine isrx(n,x,indx,dir,flag)
integer :: x(n), indx(n) integer :: x(n), indx(n)
! .. ! ..
! .. Local Scalars .. ! .. Local Scalars ..
integer i, j, ii, xx, ilx, iux, istp, piv, lpiv integer :: xx, piv, xk, xt
integer it1, it2, n1, n2 integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16 integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack) integer :: istack(nparms,maxstack)
@ -88,40 +90,40 @@ subroutine isrx(n,x,indx,dir,flag)
lpiv = (i+j)/2 lpiv = (i+j)/2
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
it1 = x(j) xt = x(j)
it2 = indx(j) ixt = indx(j)
x(j) = x(lpiv) x(j) = x(lpiv)
indx(j) = indx(lpiv) indx(j) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -136,22 +138,22 @@ subroutine isrx(n,x,indx,dir,flag)
! !
! Ensure finite termination for next loop ! Ensure finite termination for next loop
! !
it1 = xk xt = xk
x(i) = piv x(i) = piv
in_up2:do in_up2:do
j = j - 1 j = j - 1
xk = x(j) xk = x(j)
if (xk <= piv) exit in_up2 if (xk <= piv) exit in_up2
end do in_up2 end do in_up2
x(i) = it1 x(i) = xt
if (j > i) then if (j > i) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(j) x(i) = x(j)
indx(i) = indx(j) indx(i) = indx(j)
x(j) = it1 x(j) = xt
indx(j) = it2 indx(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -229,40 +231,40 @@ subroutine isrx(n,x,indx,dir,flag)
lpiv = (i+j)/2 lpiv = (i+j)/2
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
it1 = x(j) xt = x(j)
it2 = indx(j) ixt = indx(j)
x(j) = x(lpiv) x(j) = x(lpiv)
indx(j) = indx(lpiv) indx(j) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(lpiv) x(i) = x(lpiv)
indx(i) = indx(lpiv) indx(i) = indx(lpiv)
x(lpiv) = it1 x(lpiv) = xt
indx(lpiv) = it2 indx(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -277,22 +279,22 @@ subroutine isrx(n,x,indx,dir,flag)
! !
! Ensure finite termination for next loop ! Ensure finite termination for next loop
! !
it1 = xk xt = xk
x(i) = piv x(i) = piv
in_dw2:do in_dw2:do
j = j - 1 j = j - 1
xk = x(j) xk = x(j)
if (xk >= piv) exit in_dw2 if (xk >= piv) exit in_dw2
end do in_dw2 end do in_dw2
x(i) = it1 x(i) = xt
if (j > i) then if (j > i) then
it1 = x(i) xt = x(i)
it2 = indx(i) ixt = indx(i)
x(i) = x(j) x(i) = x(j)
indx(i) = indx(j) indx(i) = indx(j)
x(j) = it1 x(j) = xt
indx(j) = it2 indx(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -353,6 +355,7 @@ subroutine isrx(n,x,indx,dir,flag)
contains contains
subroutine iisrx_up(n,x,indx) subroutine iisrx_up(n,x,indx)
implicit none
integer :: n integer :: n
integer :: x(n) integer :: x(n)
integer :: indx(n) integer :: indx(n)
@ -378,6 +381,7 @@ contains
end subroutine iisrx_up end subroutine iisrx_up
subroutine iisrx_dw(n,x,indx) subroutine iisrx_dw(n,x,indx)
implicit none
integer :: n integer :: n
integer :: x(n) integer :: x(n)
integer :: indx(n) integer :: indx(n)

1
base/serial/aux/issrch.f
Unescape Escape View File

@ -29,6 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE.
C C
C C
subroutine issrch(ipos,key,n,v) subroutine issrch(ipos,key,n,v)
implicit none
integer ipos, key, n integer ipos, key, n
integer v(n) integer v(n)

1
base/serial/aux/msort_dw.f90
Unescape Escape View File

@ -68,6 +68,7 @@
! !
! !
subroutine msort_dw(n,k,l,iret) subroutine msort_dw(n,k,l,iret)
implicit none
integer n, iret integer n, iret
integer k(n),l(0:n+1) integer k(n),l(0:n+1)
! !

1
base/serial/aux/msort_up.f90
Unescape Escape View File

@ -68,6 +68,7 @@
! !
! !
subroutine msort_up(n,k,l,iret) subroutine msort_up(n,k,l,iret)
implicit none
integer n, iret integer n, iret
integer k(n),l(0:n+1) integer k(n),l(0:n+1)
! !

Write Preview
Loading…
Cancel
Save