[Bug fortran/16944] New: compiler segmentation fault - could not isolate fault
paulthomas2 at wanadoo dot fr
gcc-bugzilla@gcc.gnu.org
Mon Aug 9 14:43:00 GMT 2004
! $ ../bin/gfortran bug10.f90 -o test
! bug10.f90:150: internal compiler error: Segmentation fault
! Please submit a full bug report,
! with preprocessed source if appropriate.
! See <URL:http://gcc.gnu.org/bugs.html> for instructions.
!! I am sorry but I was unable to isolate this problem in a shorter bit of
sample code.
! copyright 1996 Loren P. Meissner -- May be distributed if this line is included.
! Gauss elimination with vector subscripts
! Example 5.17a
module Gauss_Elimination
! specification part
implicit none
integer, parameter :: LOW = Selected_Real_Kind (6), HIGH =
Selected_Real_Kind (12)
real (kind = LOW) :: R_Norm
real (kind = LOW), allocatable, private :: Save_A(:, :), LU(:, :), R(:), W(:)
integer, private :: N
integer, private, allocatable :: P(:)
logical, private :: Saved = .FALSE., Exist = .FALSE.
private :: Reduce ! Private procedure in module
! procedure part
contains
subroutine Factor (A, B, X, E, X_Norm, E_Norm, Flag) ! Module procedure
(public)
! This subroutine solves the system of simultaneous linear algebraic
equations
! A x = b, where A is an n by n matrix and x and b are vectors of length n.
! A and B are assumed-shape arrays supplied by the calling program.
! X, E, X_Norm, E_Norm, and Flag are computed and returned by Factor.
! E is the error vector computed as A e = r, where r = B - A x(calculated).
! Factor does not change A or B.
! On return from Factor, X contains the solution vector and E contains the
error
! vector. X_Norm and E_Norm contain the (Euclidean vector) norms of X
and E,
! respectively. However, if Flag is false, the contents of X, E,
X_Norm, and
! E_Norm are unpredictable, since the algorithm may have short-circuited
! somewhere in the middle.
! The problem size N, a copy of A, and the LU decomposition matrix (with
! permutation vector P) are saved in the module as private arrays, and
are not
! changed except when Factor is called.
! The subroutine Solve may be called to solve additional systems with the
same
! matrix A, between successful (i.e., Flag = true) calls to Factor.
! Call Solve with a new right-hand side B whose length equals the
original N.
! Solve will compute the solution vector X, the corresponding error
vector E,
! and the norms.
! DUMMY ARGUMENTS
real (kind = LOW), intent (in) :: A(:, :), B(:)
real (kind = LOW), intent (out) :: X(:), E(:), X_Norm, E_Norm
logical, intent(out) :: Flag
! LOCAL DATA
integer :: I, J, M, I_Temp
real (kind = LOW) :: Temp
! start subroutine Factor
! Set Flag to false for quick error exit
Flag = .FALSE.
! Determine problem size; allocate and initialize private arrays
N = Size (A, dim = 1)
if ((Size (A, dim = 2) /= N) .or. (Size (B) /= N) .or. &
(Size (X) /= N) .or. (Size (E) /= N)) stop " Size incompatibility." !
Error
allocate (Save_A(N, N), LU(N, N), R(N), W(N), P(N))
print *, " Arrays Save_A, LU, R, W, P have been allocated: ", N
Exist = .TRUE.
Save_A = A
LU = A
P = (/ (I, I = 1, N) /)
! Store row norms in W
W = (/ (MaxVal(Abs (LU(I, :))), I = 1, N) /)
if (Any (W == 0)) then !
Error
print *, " Row norms: ", W
stop " One of the row norms is zero. "
end if
! Perform factorization A = L * U with scaled partial pivoting.
do M = 1, N
! Reduce column M and choose Pivot
Temp = 0.0
I_Temp = 0
do I = M, N
! LU(P(...), ...) has a Vector Subscript
LU(P(I), M) = Reduce (LU(P(I), M), LU(P(I), 1: M - 1), LU(P(1: M - 1),
M))
if (Abs (LU(P(I), M) / W(P(I))) > Temp) then
Temp = Abs (LU(P(I), M) / W(P(I)))
I_Temp = I
end if
end do
if (Temp <= 0.0) stop " All pivot candidates are zero. " !
Error
call Permute (M, I_Temp)
! Reduce row M
do J = M + 1, N
! LU(P(...), ...) has a Vector Subscript
LU(P(M), J) = Reduce (LU(P(M), J), LU(P(M), 1 : M - 1), LU(P(1: M -
1), J)) / LU(P(M), M)
end do
end do
print *, " LU Factors"
do I = 1, N
print *, LU(I, 1: I - 1), "|", LU(I, I: N)
end do
! Apply LU with P to right-hand side B; compute residual (private) and error.
Saved = .TRUE. ! Module has stored the
Factors.
call Solve (B, X, E, X_Norm, E_Norm)
if (E_Norm < X_Norm / 2.0) Flag =.TRUE.
Saved = Flag ! Module has stored the Factors ready to Solve
again
return
contains
subroutine Permute (I, J) ! Internal procedure in Factor
integer, intent(in) :: I, J
integer :: Temp
! start subroutine Permute
Temp = P(I)
P(I) = P(J)
P(J) = Temp
return
end subroutine Permute
end subroutine Factor
subroutine Unsolve ( )
! start subroutine Unsolve
Saved = .FALSE.
if (Exist) then
print *, " Time to deallocate Save_A, LU, R, W, P: ", N
deallocate (Save_A, LU, R, W, P)
end if
Exist = .FALSE.
return
end subroutine Unsolve
function Reduce (A, Row, Col) result (Sum) ! Module procedure (private)
! DUMMY ARGUMENTS
real (kind = LOW), intent (in) :: A, Row(:), Col(:)
real (kind = LOW) :: Sum
! start function Reduce
! Change A, Row, and Col to HIGH precision;
! Compute A - Row times Col;
! Change result to LOW precision.
Sum = Real (Real (A, Kind = HIGH) - Dot_Product (Real (Row, Kind = HIGH),
Real (Col, Kind = HIGH)), Kind = LOW)
return
end function Reduce
subroutine Solve (B, X, E, X_Norm, E_Norm) ! Module procedure
(private)
! DUMMY ARGUMENTS
real (kind = LOW), intent (in) :: B(:)
real (kind = LOW), intent (out) :: X(:), X_Norm, E(:), E_Norm
! start subroutine Solve
if ((Size (B) /= N) .or. (Size (X) /= N) .or. (Size (E) /= N) .or. .not.
Saved) then
print *, " B, X, or E is the wrong size. "
print *, Size(B), Size(X), Size(E), " ", Saved
X = 0.0_LOW
E = 0.0_LOW
X_Norm = 0.0_LOW
E_Norm = Huge (1.0_LOW)
return
end if
call For_Bak (B, X, X_Norm) ! Destroys W
call Residual (B, R, R_Norm)
! The two following print statements are optional and can be deleted:
print *, " Residual Norm and Residual Vector: ", R_Norm
print *, R
call For_Bak (R, E, E_Norm) ! Destroys W
return
contains
subroutine For_Bak (B, X, X_Norm) ! Internal procedure in Solve
! This subroutine performs forward and backward substitution,
! using LU and P stored at the latest call to Factor.
! B is a right-hand side vector.
! The result will be returned in X, and its Euclidean norm in X_Norm.
! DUMMY ARGUMENTS
real (kind = LOW), intent (in) :: B(:)
real (kind = LOW), intent (out) :: X(:), X_Norm
! LOCAL DATA
integer :: K
real (kind = LOW) :: SXX
! start subroutine For_Bak
SXX = 0.0_LOW
do K = 1, N
W(K) = Reduce (B(P(K)), LU(P(K), 1: K - 1), W(1: K - 1)) / LU(P(K), K)
end do
do K = N, 1, -1
X(K) = Reduce (W(K), LU(P(K), K + 1: N), X(K + 1: N))
SXX = SXX + X(K) ** 2
end do
X_Norm = SqRt (SXX)
return
end subroutine For_Bak
subroutine Residual (B, R, R_Norm) ! Internal procedure in
Solve
! Uses Save_A from latest call to Factor
! DUMMY ARGUMENTS
real (kind = LOW), intent (in) :: B(:)
real (kind = LOW), intent (out) :: R(:), R_Norm
! LOCAL DATA
integer :: I
real (kind = LOW) :: SRR
! start subroutine Residual
SRR = 0.0_LOW
do I = 1, N
R(I) = Reduce (B(I), Save_A(I, :), X)
SRR = SRR + R(I) ** 2
end do
R_Norm = SqRt (SRR)
return
end subroutine Residual
end subroutine Solve
end module Gauss_Elimination
program Driver
use Gauss_Elimination
implicit none
integer :: EoF, N
real (kind = LOW), allocatable :: A(:, :), B(:), X(:), E(:)
real (kind = LOW) :: X_Norm, E_Norm
integer :: I
logical :: Flag
! start program Driver
open (11, file = "GauData.txt", position = "REWIND")
do
read (11, *, iostat = EoF) N
if (EoF < 0) stop " End of data file reached. "
print *
print *, " Allocating A, B, X, E: ", N
print *
allocate (A(N, N), B(N), X(N), E(N))
do I = 1, N ! Read input matrix A by rows and echo print it.
read (11, *) A(I, :)
print *, A(I, :)
end do
do I = 1, N ! Generate columns of Identity matrix, one at a time,
and solve.
print *, " Column ", I
B = 0.0
B(I) = 1.0
if (I == 1) then
call Factor (A, B, X, E, X_Norm, E_Norm, Flag)
if (Flag) then
print *, " X_Norm, E_Norm, X, E: ", X_Norm, E_Norm
print *, X
print *, E
print *, " OK: ", Flag
else
print *, " Factor cannot solve this one."
exit
end if
else
call Solve (B, X, E, X_Norm, E_Norm)
print *, " X_Norm, E_Norm, X, E: ", X_Norm, E_Norm
print *, X
print *, E
end if
end do
call Unsolve ()
print *, " Time to deallocate A, B, X, E: ", N
deallocate (A, B, X, E)
end do
stop
end program Driver
contents of gaudata.txt ***********
4
1 2 2 0
1 0 4 0
1 4 1 0
0 0 1 1
1
1
0
--
Summary: compiler segmentation fault - could not isolate fault
Product: gcc
Version: 3.5.0
Status: UNCONFIRMED
Severity: normal
Priority: P2
Component: fortran
AssignedTo: unassigned at gcc dot gnu dot org
ReportedBy: paulthomas2 at wanadoo dot fr
CC: bdavis at gcc dot gnu dot org,gcc-bugs at gcc dot gnu
dot org
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=16944
More information about the Gcc-bugs
mailing list