fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-14 01:49:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fixed implicit none, to avoid idiotic type mistake.

Browse Source
This commit is contained in:
Salvatore Filippone
2007-08-21 13:10:15 +00:00
parent c30ec19bc4
commit 028c2f2c96
10 changed files with 91 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/serial/aux/ibsrch.f
+1
View File
@@ -29,6 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE.
C
C
subroutine ibsrch(ipos,key,n,v)
implicit none
integer ipos, key, n
integer v(n)
base/serial/aux/imsr.f90
+2
View File
@@ -33,6 +33,8 @@
! Parameters:
subroutine imsr(n,x,idir)
use psb_serial_mod
implicit none
integer :: n, idir
integer :: x(n)
base/serial/aux/imsru.f90
+1
View File
@@ -33,6 +33,7 @@
! Parameters:
subroutine imsru(n,x,idir,nout)
use psb_serial_mod
implicit none
integer :: n, idir,nout
integer :: x(n)
base/serial/aux/imsrx.f90
+1
View File
@@ -33,6 +33,7 @@
! Parameters:
subroutine imsrx(n,x,indx,idir,flag)
use psb_serial_mod
implicit none
integer :: n,idir,flag
integer :: x(n)
integer :: indx(n)
base/serial/aux/isaperm.f
+2
View File
@@ -45,6 +45,8 @@ C
* *
***********************************************************************
LOGICAL FUNCTION ISAPERM(N,IP)
implicit none
C .. Scalar Arguments ..
INTEGER N
C ..
base/serial/aux/isr.f90
+31 -26
View File
@@ -31,6 +31,7 @@
subroutine isr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP.
@@ -40,8 +41,9 @@ subroutine isr(n,x,dir)
integer :: x(n)
! ..
! .. Local Scalars ..
integer i, j, xx, ilx, iux, istp, piv, lpiv
integer it1, n1, n2
integer :: xx, xk, piv, xt
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
@@ -77,29 +79,29 @@ subroutine isr(n,x,dir)
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
it1 = x(j)
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
i = ilx - 1
j = iux + 1
@@ -113,19 +115,19 @@ subroutine isr(n,x,dir)
!
! Ensure finite termination for next loop
!
it1 = xk
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = it1
x(i) = xt
if (j > i) then
it1 = x(i)
xt = x(i)
x(i) = x(j)
x(j) = it1
x(j) = xt
else
exit outer_up
end if
@@ -202,29 +204,29 @@ subroutine isr(n,x,dir)
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
it1 = x(j)
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
it1 = x(i)
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = it1
x(lpiv) = xt
i = ilx - 1
j = iux + 1
@@ -238,19 +240,19 @@ subroutine isr(n,x,dir)
!
! Ensure finite termination for next loop
!
it1 = xk
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = it1
x(i) = xt
if (j > i) then
it1 = x(i)
xt = x(i)
x(i) = x(j)
x(j) = it1
x(j) = xt
else
exit outer_dw
end if
@@ -311,6 +313,8 @@ subroutine isr(n,x,dir)
contains
subroutine iisr_up(n,x)
implicit none
integer :: n
integer :: x(n)
integer :: i,j
@@ -332,6 +336,7 @@ contains
end subroutine iisr_up
subroutine iisr_dw(n,x)
implicit none
integer :: n
integer :: x(n)
integer :: i,j
base/serial/aux/isrx.f90
+50 -46
View File
@@ -30,6 +30,7 @@
!!$
subroutine isrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort with indices into original positions.
! 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)
! ..
! .. Local Scalars ..
integer i, j, ii, xx, ilx, iux, istp, piv, lpiv
integer it1, it2, n1, n2
integer :: xx, piv, xk, xt
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
@@ -88,40 +90,40 @@ subroutine isrx(n,x,indx,dir,flag)
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
it1 = x(j)
it2 = indx(j)
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
@@ -136,22 +138,22 @@ subroutine isrx(n,x,indx,dir,flag)
!
! Ensure finite termination for next loop
!
it1 = xk
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = it1
x(i) = xt
if (j > i) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = it1
indx(j) = it2
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
@@ -229,40 +231,40 @@ subroutine isrx(n,x,indx,dir,flag)
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
it1 = x(j)
it2 = indx(j)
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = it1
indx(lpiv) = it2
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
@@ -277,22 +279,22 @@ subroutine isrx(n,x,indx,dir,flag)
!
! Ensure finite termination for next loop
!
it1 = xk
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = it1
x(i) = xt
if (j > i) then
it1 = x(i)
it2 = indx(i)
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = it1
indx(j) = it2
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
@@ -353,6 +355,7 @@ subroutine isrx(n,x,indx,dir,flag)
contains
subroutine iisrx_up(n,x,indx)
implicit none
integer :: n
integer :: x(n)
integer :: indx(n)
@@ -378,6 +381,7 @@ contains
end subroutine iisrx_up
subroutine iisrx_dw(n,x,indx)
implicit none
integer :: n
integer :: x(n)
integer :: indx(n)
base/serial/aux/issrch.f
+1
View File
@@ -29,6 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE.
C
C
subroutine issrch(ipos,key,n,v)
implicit none
integer ipos, key, n
integer v(n)
base/serial/aux/msort_dw.f90
+1
View File
@@ -68,6 +68,7 @@
!
!
subroutine msort_dw(n,k,l,iret)
implicit none
integer n, iret
integer k(n),l(0:n+1)
!
base/serial/aux/msort_up.f90
+1
View File
@@ -68,6 +68,7 @@
!
!
subroutine msort_up(n,k,l,iret)
implicit none
integer n, iret
integer k(n),l(0:n+1)
!