OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-dev/or1k-gcc/gcc/testsuite
    from Rev 694 to Rev 695
    ↔ Reverse comparison
  •

Rev 694 → Rev 695

/gfortran.fortran-torture/execute/intrinsic_associated_2.f90
0,0 → 1,36
! Program to test the ASSOCIATED intrinsic with cross-kinds
program intrinsic_associated_2
logical*4 :: t4, L44, L48
logical*8 :: t8, L84, L88
real*4, pointer :: a4p(:, :)
real*8, pointer :: a8p(:, :)
real*4, target :: a4(10, 10)
real*8, target :: a8(10, 10)
t4 = .true.
t8 = .true.
t8 = t4
a4p => a4
a8p => a8
L44 = t4 .and. associated (a4p, a4)
L84 = t8 .and. associated (a4p, a4)
L48 = t4 .and. associated (a8p, a8)
L88 = t8 .and. associated (a8p, a8)
if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort ()
nullify (a4p, a8p)
L44 = t4 .and. associated (a4p, a4)
L84 = t8 .and. associated (a4p, a4)
L48 = t4 .and. associated (a8p, a8)
L88 = t8 .and. associated (a8p, a8)
if (L44 .and. L84 .and. L48 .and. L88) call abort ()
 
a4p => a4(1:10:2, 1:10:2)
a8p => a8(1:4, 1:4)
L44 = t4 .and. associated (a4p, a4(1:10:2, 1:10:2))
L84 = t8 .and. associated (a4p, a4(1:10:2, 1:10:2))
L48 = t4 .and. associated (a8p, a8(1:4, 1:4))
L88 = t8 .and. associated (a8p, a8(1:4, 1:4))
if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort ()
end
 
/gfortran.fortran-torture/execute/intrinsic_sign.f90
0,0 → 1,31
! Program to test SIGN intrinsic
program intrinsic_sign
implicit none
integer i, j
real r, s
 
i = 2
j = 3
if (sign (i, j) .ne. 2) call abort
i = 4
j = -5
if (sign (i, j) .ne. -4) call abort
i = -6
j = 7
if (sign (i, j) .ne. 6) call abort
i = -8
j = -9
if (sign (i, j) .ne. -8) call abort
r = 1
s = 2
if (sign (r, s) .ne. 1) call abort
r = 1
s = -2
if (sign (r, s) .ne. -1) call abort
s = 0
if (sign (r, s) .ne. 1) call abort
! Will fail on machines which cannot represent negative zero.
s = -s ! Negative zero
if (sign (r, s) .ne. -1) call abort
end program
 
/gfortran.fortran-torture/execute/entry_3.f90
0,0 → 1,40
subroutine f1 (n, *, i)
integer n, i
if (i .ne. 42) call abort ()
entry e1 (n, *)
if (n .eq. 1) return 1
if (n .eq. 2) return
return
entry e2 (n, i, *, *, *)
if (i .ne. 46) call abort ()
if (n .ge. 4) return
return n
entry e3 (n, i)
if ((i .ne. 48) .or. (n .ne. 61)) call abort ()
end subroutine
 
program alt_return
implicit none
 
call f1 (1, *10, 42)
20 continue
call abort ()
10 continue
call f1 (2, *20, 42)
call f1 (3, *20, 42)
call e1 (2, *20)
call e1 (1, *30)
call abort ()
30 continue
call e2 (1, 46, *40, *20, *20)
call abort ()
40 continue
call e2 (2, 46, *20, *50, *20)
call abort ()
50 continue
call e2 (3, 46, *20, *20, *60)
call abort ()
60 continue
call e2 (4, 46, *20, *20, *20)
call e3 (61, 48)
end program
/gfortran.fortran-torture/execute/write_logical.f90
0,0 → 1,23
! PR 14334, L edit descriptor does not work
!
! this test uses L1 and L4 to print TRUE and FALSE
logical true,false
character*10 b
true = .TRUE.
false = .FALSE.
b = ''
write (b, '(L1)') true
if (b(1:1) .ne. 'T') call abort
 
b = ''
write (b, '(L1)') false
if (b(1:1) .ne. 'F') call abort
 
b = ''
write(b, '(L4)') true
if (b(1:4) .ne. ' T') call abort
 
b = ''
write(b, '(L4)') false
if (b(1:4) .ne. ' F') call abort
end
/gfortran.fortran-torture/execute/entry_5.f90
0,0 → 1,51
! Test alternate entry points for functions when the result types
! of all entry points match
 
function f1 (str, i, j) result (r)
character str*(*), r1*(*), r2*(*), r*(*)
integer i, j
r = str (i:j)
return
entry e1 (str, i, j) result (r1)
i = i + 1
entry e2 (str, i, j) result (r2)
j = j - 1
r2 = str (i:j)
end function
 
function f3 () result (r)
character r3*5, r4*5, r*5
integer i
r = 'ABCDE'
return
entry e3 (i) result (r3)
entry e4 (i) result (r4)
if (i .gt. 0) then
r3 = 'abcde'
else
r4 = 'UVWXY'
endif
end function
 
program entrytest
character f1*16, e1*16, e2*16, str*16, ret*16
character f3*5, e3*5, e4*5
integer i, j
str = 'ABCDEFGHIJ'
i = 2
j = 6
ret = f1 (str, i, j)
if ((i .ne. 2) .or. (j .ne. 6)) call abort ()
if (ret .ne. 'BCDEF') call abort ()
ret = e1 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 5)) call abort ()
if (ret .ne. 'CDE') call abort ()
ret = e2 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 4)) call abort ()
if (ret .ne. 'CD') call abort ()
if (f3 () .ne. 'ABCDE') call abort ()
if (e3 (1) .ne. 'abcde') call abort ()
if (e4 (1) .ne. 'abcde') call abort ()
if (e3 (0) .ne. 'UVWXY') call abort ()
if (e4 (0) .ne. 'UVWXY') call abort ()
end program
/gfortran.fortran-torture/execute/contained2.f90
0,0 → 1,28
! Program to check resolution of symbols with the same name
program contained2
implicit none
integer var1
var1 = 42
if (f1() .ne. 1) call abort
call f2()
if (var1 .ne. 42) call abort
contains
 
function f1 ()
implicit none
integer f1
integer var1
integer f2
var1 = 1
f2 = var1
f1 = f2
end function
 
subroutine f2()
implicit none
if (f1() .ne. 1) call abort
end subroutine
 
end program
/gfortran.fortran-torture/execute/intrinsic_abs.f90
0,0 → 1,33
! Program to test the ABS intrinsic
program intrinsic_abs
implicit none
integer i
real(kind=4) r
real(kind=8) q
complex z
 
i = 42
i = abs(i)
if (i .ne. 42) call abort
i = -43
i = abs(i)
if (i .ne. 43) call abort
 
r = 42.0
r = abs(r)
if (r .ne. 42.0) call abort
r = -43.0
r = abs(r)
if (r .ne. 43.0) call abort
 
q = 42.0_8
q = abs(q)
if (q .ne. 42.0_8) call abort
q = -43.0_8
q = abs(q)
if (q .ne. 43.0_8) call abort
 
z = (3, 4)
r = abs(z)
if (r .ne. 5) call abort
end program
/gfortran.fortran-torture/execute/entry_7.f90
0,0 → 1,106
! Test alternate entry points for functions when the result types
! of all entry points match
 
function f1 (a)
integer a, b
integer, pointer :: f1, e1
allocate (f1)
f1 = 15 + a
return
entry e1 (b)
allocate (e1)
e1 = 42 + b
end function
function f2 ()
real, pointer :: f2, e2
entry e2 ()
allocate (e2)
e2 = 45
end function
function f3 ()
double precision, pointer :: f3, e3
entry e3 ()
allocate (f3)
f3 = 47
end function
function f4 (a) result (r)
double precision a, b
double precision, pointer :: r, s
allocate (r)
r = 15 + a
return
entry e4 (b) result (s)
allocate (s)
s = 42 + b
end function
function f5 () result (r)
integer, pointer :: r, s
entry e5 () result (s)
allocate (r)
r = 45
end function
function f6 () result (r)
real, pointer :: r, s
entry e6 () result (s)
allocate (s)
s = 47
end function
 
program entrytest
interface
function f1 (a)
integer a
integer, pointer :: f1
end function
function e1 (b)
integer b
integer, pointer :: e1
end function
function f2 ()
real, pointer :: f2
end function
function e2 ()
real, pointer :: e2
end function
function f3 ()
double precision, pointer :: f3
end function
function e3 ()
double precision, pointer :: e3
end function
function f4 (a)
double precision a
double precision, pointer :: f4
end function
function e4 (b)
double precision b
double precision, pointer :: e4
end function
function f5 ()
integer, pointer :: f5
end function
function e5 ()
integer, pointer :: e5
end function
function f6 ()
real, pointer :: f6
end function
function e6 ()
real, pointer :: e6
end function
end interface
double precision d
if (f1 (6) .ne. 21) call abort ()
if (e1 (7) .ne. 49) call abort ()
if (f2 () .ne. 45) call abort ()
if (e2 () .ne. 45) call abort ()
if (f3 () .ne. 47) call abort ()
if (e3 () .ne. 47) call abort ()
d = 17
if (f4 (d) .ne. 32) call abort ()
if (e4 (d) .ne. 59) call abort ()
if (f5 () .ne. 45) call abort ()
if (e5 () .ne. 45) call abort ()
if (f6 () .ne. 47) call abort ()
if (e6 () .ne. 47) call abort ()
end
/gfortran.fortran-torture/execute/strarray_2.f90
0,0 → 1,14
subroutine foo(i,c)
character c
integer i
character(1),parameter :: hex_chars(0:15)=&
(/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/)
 
c = hex_chars(i)
end
 
program strarray_2
character c
call foo(3,c)
if (c.ne.'3') call abort()
end
/gfortran.fortran-torture/execute/logical_select_1.f90
0,0 → 1,55
LOGICAL :: L = .FALSE.
 
SELECT CASE (L)
CASE (.TRUE.)
CALL abort
CASE (.FALSE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (L)
CASE (.TRUE., .FALSE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (L)
CASE (.FALSE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (L)
CASE (.NOT. .TRUE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (.NOT. L)
CASE (.TRUE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (Truth_or_Dare() .OR. L)
CASE (.TRUE.)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
CONTAINS
 
FUNCTION Truth_or_Dare ()
LOGICAL Truth_or_Dare
Truth_or_Dare = .TRUE.
END FUNCTION
 
END
 
/gfortran.fortran-torture/execute/entry_9.f90
0,0 → 1,24
! Test alternate entry points for functions when the result types
! of all entry points match
 
function f1 (a)
integer a, f1, e1
f1 = 15 + a
return
entry e1
e1 = 42
end function
function f2 ()
real f2, e2
entry e2
e2 = 45
end function
 
program entrytest
integer f1, e1
real f2, e2
if (f1 (6) .ne. 21) call abort ()
if (e1 () .ne. 42) call abort ()
if (f2 () .ne. 45) call abort ()
if (e2 () .ne. 45) call abort ()
end
/gfortran.fortran-torture/execute/strarray_4.f90
0,0 → 1,39
program strarray_4
character(len=5), dimension(2) :: c
c(1) = "Hello"
c(2) = "World"
 
call foo1(c)
call foo2(c, 2)
call foo3(c, 5, 2)
contains
subroutine foo1(a)
implicit none
character(len=5), dimension(2) :: a
character(len=5), dimension(2) :: b
 
b = a;
if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort
end subroutine
 
subroutine foo2(a, m)
implicit none
integer m
character(len=5), dimension(m) :: a
character(len=5), dimension(m) :: b
 
b = a
if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort
end subroutine
 
subroutine foo3(a, n, m)
implicit none
integer n, m
character(len=n), dimension(m) :: a
character(len=n), dimension(m) :: b
 
b = a
if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort
end subroutine
end program
/gfortran.fortran-torture/execute/arrayarg2.f90
0,0 → 1,21
! Program to test array arguments which depend on other array arguments
program arrayarg2
integer, dimension(5) :: a, b
 
a = (/1, 2, 3, 4, 5/)
b = (/2, 3, 4, 5, 6/)
call test (a, b)
 
if (any (b .ne. (/4, 7, 10, 13, 16/))) call abort
contains
subroutine test (x1, x2)
implicit none
integer, dimension(1:), intent(in) :: x1
integer, dimension(1:), intent(inout) :: x2
integer, dimension(1:size(x1)) :: x3
 
x3 = x1 * 2
x2 = x2 + x3
end subroutine test
end program
/gfortran.fortran-torture/execute/intrinsic_dotprod.f90
0,0 → 1,25
! Program to test the DOT_PRODUCT intrinsic
program testforall
implicit none
integer, dimension (3) :: a
integer, dimension (3) :: b
real, dimension(3) :: c
real r
complex, dimension (2) :: z1
complex, dimension (2) :: z2
complex z
 
a = (/1, 2, 3/);
b = (/4, 5, 6/);
c = (/4, 5, 6/);
 
if (dot_product(a, b) .ne. 32) call abort
 
r = dot_product(a, c)
if (abs(r - 32.0) .gt. 0.001) call abort
 
z1 = (/(1.0, 2.0), (2.0, 3.0)/)
z2 = (/(3.0, 4.0), (4.0, 5.0)/)
z = dot_product (z1, z2)
if (abs (z - (34.0, -4.0)) .gt. 0.001) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_spread.f90
0,0 → 1,17
program foo
integer, dimension (2, 3) :: a
integer, dimension (2, 2, 3) :: b
character (len=80) line1, line2, line3
 
a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/))
b = spread (a, 1, 2)
if (any (b .ne. reshape ((/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6/), &
(/2, 2, 3/)))) &
call abort
write(line1, 9000) b
write(line2, 9000) spread (a, 1, 2)
if (line1 /= line2) call abort
write(line3, 9000) spread (a, 1, 2) + 0
if (line1 /= line3) call abort
9000 format(12I3)
end program
/gfortran.fortran-torture/execute/intrinsic_transpose.f90
0,0 → 1,24
! Program to test the transpose intrinsic
program intrinsic_transpose
integer, dimension (3, 3) :: a, b
complex(kind=8), dimension (2, 2) :: c, d
complex(kind=4), dimension (2, 2) :: e
 
a = 0
b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = transpose (b)
if (any (a .ne. reshape ((/1, 4, 7, 2, 5, 8, 3, 6, 9/), (/3, 3/)))) &
call abort
c = (0.0, 0.0)
d = reshape ((/(1d0,2d0), (3d0, 4d0), (5d0, 6d0), (7d0, 8d0)/), (/2, 2/))
c = transpose (d);
if (any (c .ne. reshape ((/(1d0, 2d0), (5d0, 6d0), &
(3d0, 4d0), (7d0, 8d0)/), (/2, 2/)))) &
call abort ();
e = reshape ((/(1.0,2.0), (3.0, 4.0), (5.0, 6.0), (7.0, 8.0)/), (/2, 2/))
e = transpose (e);
if (any (e .ne. reshape ((/(1.0, 2.0), (5.0, 6.0), &
(3.0, 4.0), (7.0, 8.0)/), (/2, 2/)))) &
call abort ();
end program
/gfortran.fortran-torture/execute/forall_2.f90
0,0 → 1,20
!program to test nested forall construct and forall mask
program test
implicit none
integer a(4,4)
integer i, j
 
do i=1,4
do j=1,4
a(j,i) = j-i
enddo
enddo
forall (i=2:4, a(1,i).GT.-2)
forall (j=1:4, a(j,2).GT.0)
a(j,i) = a(j,i-1)
end forall
end forall
if (any (a.ne.reshape ((/0,1,2,3,-1,0,2,3,-2,-1,0,1,-3,-2,-1,0/),&
(/4,4/)))) call abort
end
 
/gfortran.fortran-torture/execute/intrinsic_achar.f90
0,0 → 1,9
! Program to test the ACHAR and IACHAR intrinsics
program intrinsic_achar
integer i
 
i = 32
if (achar(i) .ne. " ") call abort
i = iachar("A")
if ((i .ne. 65) .or. char(i) .ne. "A") call abort
end program
/gfortran.fortran-torture/execute/strcommon_1.f90
0,0 → 1,28
! PR14081 character variables in common blocks.
 
subroutine test1
implicit none
common /block/ c
character(len=12) :: c
 
if (c .ne. "Hello World") call abort
end subroutine
 
subroutine test2
implicit none
common /block/ a
character(len=6), dimension(2) :: a
 
if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort
end subroutine
 
program strcommon_1
implicit none
common /block/ s, t
character(len=6) :: s, t
s = "Hello "
t = "World "
call test1
call test2
end program
 
/gfortran.fortran-torture/execute/forall_4.f90
0,0 → 1,27
! Program to test nested forall
program forall2
implicit none
integer a(4,4,2)
integer i, j, k, n
 
a(:,:,1) = reshape((/ 1, 2, 3, 4,&
5, 6, 7, 8,&
9,10,11,12,&
13,14,15,16/), (/4,4/))
a(:,:,2) = a(:,:,1) + 16
n=4
k=1
! Mirror half the matrix
forall (i=k:n)
forall (j=1:5-i)
a(i,j,:) = a(j,i,:)
end forall
end forall
 
if (any (a(:,:,1) &
.ne. reshape((/ 1, 5, 9,13,&
2, 6,10, 8,&
3, 7,11,12,&
4,14,15,16/),(/4,4/)))) call abort
if (any (a(:,:,2) .ne. a(:,:,1) + 16)) call abort
end
/gfortran.fortran-torture/execute/forall_6.f90
0,0 → 1,25
! Program to test FORALL with scalar pointer assignment inside it.
program forall_6
type element
real, pointer :: p
end type
 
type (element) q(5)
real, target, dimension(5) :: t
integer i;
 
t = (/1.0, 2.0, 3.0, 4.0, 5.0/)
 
do i = 1,5
q(i)%p => t(i)
end do
 
forall (i = 1:5)
q(i)%p => q(6 - i)%p
end forall
 
 
do i = 1,5
if (q(i)%p .ne. t(6 - i)) call abort
end do
end
/gfortran.fortran-torture/execute/empty_format.f90
0,0 → 1,14
! from NIST test FM406.FOR
CHARACTER*10 A10VK
A10VK = 'XXXXXXXXXX'
WRITE(A10VK,39110)
39110 FORMAT()
!
! the empty format should fill the target of the internal
! write with blanks.
!
IF (A10VK.NE.'') THEN
! PRINT*,A10VK
CALL ABORT
ENDIF
END
/gfortran.fortran-torture/execute/specifics.f90
0,0 → 1,311
! Program to test intrinsic functions as actual arguments
!
! Please keep the content of this file in sync with gfortran.dg/specifics_1.f90
subroutine test_c(fn, val, res)
complex fn
complex val, res
 
if (diff(fn(val),res)) call abort
contains
function diff(a,b)
complex a,b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_z(fn, val, res)
double complex fn
double complex val, res
 
if (diff(fn(val),res)) call abort
contains
function diff(a,b)
double complex a,b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_cabs(fn, val, res)
real fn, res
complex val
 
if (diff(fn(val),res)) call abort
contains
function diff(a,b)
real a,b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_cdabs(fn, val, res)
double precision fn, res
double complex val
 
if (diff(fn(val),res)) call abort
contains
function diff(a,b)
double precision a,b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_r(fn, val, res)
real fn
real val, res
 
if (diff(fn(val), res)) call abort
contains
function diff(a, b)
real a, b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_d(fn, val, res)
double precision fn
double precision val, res
 
if (diff(fn(val), res)) call abort
contains
function diff(a, b)
double precision a, b
logical diff
diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine
 
subroutine test_r2(fn, val1, val2, res)
real fn
real val1, val2, res
 
if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
real a, b
logical diff
diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine
 
subroutine test_d2(fn, val1, val2, res)
double precision fn
double precision val1, val2, res
 
if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
double precision a, b
logical diff
diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine
 
subroutine test_dprod(fn)
double precision fn
if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
end subroutine
 
subroutine test_nint(fn,val,res)
integer fn, res
real val
if (res .ne. fn(val)) call abort
end subroutine
 
subroutine test_idnint(fn,val,res)
integer fn, res
double precision val
if (res .ne. fn(val)) call abort
end subroutine
 
subroutine test_idim(fn,val1,val2,res)
integer fn, res, val1, val2
if (res .ne. fn(val1,val2)) call abort
end subroutine
 
subroutine test_iabs(fn,val,res)
integer fn, res, val
if (res .ne. fn(val)) call abort
end subroutine
 
subroutine test_len(fn,val,res)
integer fn, res
character(len=*) val
if (res .ne. fn(val)) call abort
end subroutine
 
subroutine test_index(fn,val1,val2,res)
integer fn, res
character(len=*) val1, val2
if (fn(val1,val2) .ne. res) call abort
end subroutine
 
program specifics
intrinsic abs
intrinsic aint
intrinsic anint
intrinsic acos
intrinsic acosh
intrinsic asin
intrinsic asinh
intrinsic atan
intrinsic atanh
intrinsic cos
intrinsic sin
intrinsic tan
intrinsic cosh
intrinsic sinh
intrinsic tanh
intrinsic alog
intrinsic alog10
intrinsic exp
intrinsic sign
intrinsic isign
intrinsic amod
 
intrinsic dabs
intrinsic dint
intrinsic dnint
intrinsic dacos
intrinsic dacosh
intrinsic dasin
intrinsic dasinh
intrinsic datan
intrinsic datanh
intrinsic dcos
intrinsic dsin
intrinsic dtan
intrinsic dcosh
intrinsic dsinh
intrinsic dtanh
intrinsic dlog
intrinsic dlog10
intrinsic dexp
intrinsic dsign
intrinsic dmod
 
intrinsic conjg
intrinsic ccos
intrinsic cexp
intrinsic clog
intrinsic csin
intrinsic csqrt
 
intrinsic dconjg
intrinsic cdcos
intrinsic cdexp
intrinsic cdlog
intrinsic cdsin
intrinsic cdsqrt
intrinsic zcos
intrinsic zexp
intrinsic zlog
intrinsic zsin
intrinsic zsqrt
 
intrinsic cabs
intrinsic cdabs
intrinsic zabs
 
intrinsic dprod
 
intrinsic nint
intrinsic idnint
intrinsic dim
intrinsic ddim
intrinsic idim
intrinsic iabs
intrinsic mod
intrinsic len
intrinsic index
 
intrinsic aimag
intrinsic dimag
 
call test_r (abs, -1.0, abs(-1.0))
call test_r (aint, 1.7, aint(1.7))
call test_r (anint, 1.7, anint(1.7))
call test_r (acos, 0.5, acos(0.5))
call test_r (acosh, 1.5, acosh(1.5))
call test_r (asin, 0.5, asin(0.5))
call test_r (asinh, 0.5, asinh(0.5))
call test_r (atan, 0.5, atan(0.5))
call test_r (atanh, 0.5, atanh(0.5))
call test_r (cos, 1.0, cos(1.0))
call test_r (sin, 1.0, sin(1.0))
call test_r (tan, 1.0, tan(1.0))
call test_r (cosh, 1.0, cosh(1.0))
call test_r (sinh, 1.0, sinh(1.0))
call test_r (tanh, 1.0, tanh(1.0))
call test_r (alog, 2.0, alog(2.0))
call test_r (alog10, 2.0, alog10(2.0))
call test_r (exp, 1.0, exp(1.0))
call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
call test_d (dabs, -1d0, abs(-1d0))
call test_d (dint, 1.7d0, 1d0)
call test_d (dnint, 1.7d0, 2d0)
call test_d (dacos, 0.5d0, dacos(0.5d0))
call test_d (dacosh, 1.5d0, dacosh(1.5d0))
call test_d (dasin, 0.5d0, dasin(0.5d0))
call test_d (dasinh, 0.5d0, dasinh(0.5d0))
call test_d (datan, 0.5d0, datan(0.5d0))
call test_d (datanh, 0.5d0, datanh(0.5d0))
call test_d (dcos, 1d0, dcos(1d0))
call test_d (dsin, 1d0, dsin(1d0))
call test_d (dtan, 1d0, dtan(1d0))
call test_d (dcosh, 1d0, dcosh(1d0))
call test_d (dsinh, 1d0, dsinh(1d0))
call test_d (dtanh, 1d0, dtanh(1d0))
call test_d (dlog, 2d0, dlog(2d0))
call test_d (dlog10, 2d0, dlog10(2d0))
call test_d (dexp, 1d0, dexp(1d0))
call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
 
call test_dprod (dprod)
 
call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))
 
call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0)))
call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0)))
call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0)))
call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0)))
call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0)))
 
call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0)))
call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.)))
call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0)))
 
call test_nint (nint, -1.2, nint(-1.2))
call test_idnint (idnint, -1.2d0, idnint(-1.2d0))
call test_idim (isign, -42, 17, isign(-42, 17))
call test_idim (idim, -42, 17, idim(-42,17))
call test_idim (idim, 42, 17, idim(42,17))
call test_r2 (dim, 1.2, -4., dim(1.2, -4.))
call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0))
call test_iabs (iabs, -7, iabs(-7))
call test_idim (mod, 5, 2, mod(5,2))
call test_len (len, "foobar", len("foobar"))
call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))
 
end program
 
/gfortran.fortran-torture/execute/function_module_1.f90
0,0 → 1,36
! This can fail because BB is not resolved correctly.
module M1
 
INTEGER p
 
CONTAINS
subroutine AA ()
implicit NONE
p = BB ()
CONTAINS
subroutine AA_1 ()
implicit NONE
integer :: i
i = BB ()
end subroutine
 
function BB()
integer :: BB
BB = 1
end function
end subroutine
 
function BB()
implicit NONE
integer :: BB
BB = 2
end function
end module
 
program P1
USE M1
implicit none
p = 0
call AA ()
if (p /= 1) call abort
end
/gfortran.fortran-torture/execute/write_a_1.f90
0,0 → 1,14
! pr 15311
! output with 'A' edit descriptor
program write_a_1
character*25 s
! string = format
write(s,'(A11)') "hello world"
if (s.ne."hello world") call abort
! string < format
write(s,'(A2)') "hello world"
if (s.ne."he") call abort
! string > format
write(s,'(A18)') "hello world"
if (s.ne." hello world") call abort
end
/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90
0,0 → 1,40
! Check we do the right thing with extreme values.
! From PR12704
program intrinsic_mmloc_3
integer, dimension(2) :: d
integer, dimension(2,2) :: a
logical, dimension(2) :: k
logical, dimension(2,2) :: l
 
k = .true.
l = .true.
 
d = -huge (d)
if (maxloc (d, 1) .ne. 1) call abort ()
 
d = huge (d)
if (minloc (d, 1) .ne. 1) call abort ()
 
d = -huge (d)
if (maxloc (d, 1, k) .ne. 1) call abort ()
 
d = huge (d)
if (minloc (d, 1, k) .ne. 1) call abort ()
 
a = -huge (a)
d = maxloc (a)
if (any (d .ne. 1)) call abort ()
 
a = huge (a)
d = minloc (a)
if (any (d .ne. 1)) call abort ()
 
a = -huge (a)
d = maxloc (a, l)
if (any (d .ne. 1)) call abort ()
 
a = huge (a)
d = minloc (a, l)
if (any (d .ne. 1)) call abort ()
 
end program
/gfortran.fortran-torture/execute/st_function_1.f90
0,0 → 1,23
! Check that character valued statement functions honour length parameters
program st_function_1
character(8) :: foo
character(15) :: bar
character(6) :: p
character (7) :: s
foo(p) = p // "World"
bar(p) = p // "World"
! Expression longer than function, actual arg shorter than dummy.
call check (foo("Hello"), "Hello Wo") ! { dg-warning "Character length of actual argument shorter" }
 
! Expression shorter than function, actual arg longer than dummy.
! Result shorter than type
s = "Hello"
call check (bar(s), "Hello World ")
contains
subroutine check(a, b)
character (len=*) :: a, b
 
if ((a .ne. b) .or. (len(a) .ne. len(b))) call abort ()
end subroutine
end program
/gfortran.fortran-torture/execute/backspace.f90
0,0 → 1,14
! pr 15755
implicit none
character*1 C
open(10)
write(10,*)'a'
write(10,*)'b'
write(10,*)'c'
rewind(10)
read(10,*)C
backspace(10)
read(10,*) C
if (C.ne.'a') call abort
close(10,STATUS='DELETE')
end
/gfortran.fortran-torture/execute/der_init_3.f90
0,0 → 1,12
! PR15365
! Default initializers were being missed
program main
type xyz
integer :: x = 123
end type xyz
 
type (xyz) :: a !! ok
type (xyz) b !!! not initialized !!!
if (a%x.ne.123) call abort
if (b%x.ne.123) call abort
end
/gfortran.fortran-torture/execute/forall.f90
0,0 → 1,17
! Program to test the FORALL construct
program testforall
implicit none
integer, dimension (3, 3) :: a
integer, dimension (3) :: b
integer i
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));
 
forall (i=1:3)
b(i) = sum (a(:, i))
end forall
 
if (b(1) .ne. 6) call abort
if (b(2) .ne. 15) call abort
if (b(3) .ne. 24) call abort
end program
/gfortran.fortran-torture/execute/der_init_5.f90
0,0 → 1,16
! Check that null initialization of pointer components works.
! PR 15969 prompted these
! the commented out tests are cases where we still fail
program der_init_5
type t
type(t), pointer :: a => NULL()
real, pointer :: b => NULL()
character, pointer :: c => NULL()
integer, pointer, dimension(:) :: d => NULL()
end type t
type (t) :: p
if (associated(p%a)) call abort()
if (associated(p%b)) call abort()
! if (associated(p%c)) call abort()
if (associated(p%d)) call abort()
end
/gfortran.fortran-torture/execute/intrinsic_shape.f90
0,0 → 1,22
! Program to test the shape intrinsic
program testbounds
implicit none
real, dimension(:, :), allocatable :: a
integer, dimension(2) :: j
integer i
 
allocate (a(3:8, 6:7))
 
j = shape (a);
if (any (j .ne. (/ 6, 2 /))) call abort
 
call test(a)
contains
 
subroutine test (a)
real, dimension (1:, 1:) :: a
 
if (any (shape (a) .ne. (/ 6, 2 /))) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/common_size.f90
0,0 → 1,10
! The size of common 'com1' should be 80, instead of 112.
program common_size
real (kind=8) a(8)
real (kind=8) b(5), c(5)
common /com1/b,c
equivalence (a(1), b(2))
b = 100
c = 200
if ((a (4) .ne. 100) .or. (a(5) .ne. 200)) call abort
end
/gfortran.fortran-torture/execute/intrinsic_bitops.f90
0,0 → 1,32
! Program to test intrinsic bitops
program intrinsic_bitops
implicit none
integer(kind=4) :: i, j, k, o, t
integer(kind=8) :: a, b, c
 
o = 0
i = 2
j = 3
k = 12
a = 5
if (.not. btest (i, o+1)) call abort
if (btest (i, o+2)) call abort
if (iand (i, j) .ne. 2) call abort
if (ibclr (j, o+1) .ne. 1) call abort
if (ibclr (j, o+2) .ne. 3) call abort
if (ibits (k, o+1, o+2) .ne. 2) call abort
if (ibset (j, o+1) .ne. 3) call abort
if (ibset (j, o+2) .ne. 7) call abort
if (ieor (i, j) .ne. 1) call abort
if (ior (i, j) .ne. 3) call abort
if (ishft (k, o+2) .ne. 48) call abort
if (ishft (k, o-3) .ne. 1) call abort
if (ishft (k, o) .ne. 12) call abort
if (ishftc (k, o+30) .ne. 3) call abort
if (ishftc (k, o-30) .ne. 48) call abort
if (ishftc (k, o+1, o+3) .ne. 9) call abort
if (not (i) .ne. -3) call abort
if (ishftc (a, 1, bit_size(a)) .ne. 10) call abort
if (ishftc (1, 1, 32) .ne. 2) call abort
end program
/gfortran.fortran-torture/execute/internal_write.f90
0,0 → 1,11
! PR 14901
! Internal writes were appending CR after the last char
! written by the format statement.
CHARACTER*10 A
WRITE(A,'(3HGCC)')
IF (A.NE.'GCC ') THEN
! PRINT*,'A was not filled correctly by internal write'
! PRINT*,' A = ',A
CALL ABORT
ENDIF
END
/gfortran.fortran-torture/execute/getarg_1.f90
0,0 → 1,30
! Check that getarg does somethig sensible.
program getarg_1
CHARACTER*10 ARGS, ARGS2
INTEGER*4 I
INTEGER*2 I2
I = 0
CALL GETARG(I,ARGS)
! This should return the invoking command. The actual value depends
! on the OS, but a blank string is wrong no matter what.
! ??? What about deep embedded systems?
 
I2 = 0
CALL GETARG(I2,ARGS2)
if (args2.ne.args) call abort
 
if (args.eq.'') call abort
I = 1
CALL GETARG(I,ARGS)
if (args.ne.'') call abort
I = -1
CALL GETARG(I,ARGS)
if (args.ne.'') call abort
! Assume we won't have been called with more that 4 args.
I = 4
CALL GETARG(I,ARGS)
if (args.ne.'') call abort
I = 1000
CALL GETARG(I,ARGS)
if (args.ne.'') call abort
end
/gfortran.fortran-torture/execute/math.f90
0,0 → 1,100
! Program to test mathematical intrinsics
subroutine dotest (n, val4, val8, known)
implicit none
real(kind=4) val4, known
real(kind=8) val8
integer n
 
if (abs (val4 - known) .gt. 0.001) call abort
if (abs (real (val8, kind=4) - known) .gt. 0.001) call abort
end subroutine
 
subroutine dotestc (n, val4, val8, known)
implicit none
complex(kind=4) val4, known
complex(kind=8) val8
integer n
if (abs (val4 - known) .gt. 0.001) call abort
if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) call abort
end subroutine
 
program testmath
implicit none
real(kind=4) r, two4, half4
real(kind=8) q, two8, half8
complex(kind=4) cr
complex(kind=8) cq
external dotest, dotestc
 
two4 = 2.0
two8 = 2.0_8
half4 = 0.5
half8 = 0.5_8
r = sin (two4)
q = sin (two8)
call dotest (1, r, q, 0.9093)
r = cos (two4)
q = cos (two8)
call dotest (2, r, q, -0.4161)
r = tan (two4)
q = tan (two8)
call dotest (3, r, q, -2.1850)
r = asin (half4)
q = asin (half8)
call dotest (4, r, q, 0.5234)
r = acos (half4)
q = acos (half8)
call dotest (5, r, q, 1.0472)
r = atan (half4)
q = atan (half8)
call dotest (6, r, q, 0.4636)
r = atan2 (two4, half4)
q = atan2 (two8, half8)
call dotest (7, r, q, 1.3258)
r = exp (two4)
q = exp (two8)
call dotest (8, r, q, 7.3891)
r = log (two4)
q = log (two8)
call dotest (9, r, q, 0.6931)
r = log10 (two4)
q = log10 (two8)
call dotest (10, r, q, 0.3010)
r = sinh (two4)
q = sinh (two8)
call dotest (11, r, q, 3.6269)
r = cosh (two4)
q = cosh (two8)
call dotest (12, r, q, 3.7622)
r = tanh (two4)
q = tanh (two8)
call dotest (13, r, q, 0.9640)
r = sqrt (two4)
q = sqrt (two8)
call dotest (14, r, q, 1.4142)
 
r = atan2 (0.0, 1.0)
q = atan2 (0.0_8, 1.0_8)
call dotest (15, r, q, 0.0)
r = atan2 (-1.0, 1.0)
q = atan2 (-1.0_8, 1.0_8)
call dotest (16, r, q, -0.7854)
r = atan2 (0.0, -1.0)
q = atan2 (0.0_8, -1.0_8)
call dotest (17, r, q, 3.1416)
r = atan2 (-1.0, -1.0)
q = atan2 (-1.0_8, -1.0_8)
call dotest (18, r, q, -2.3562)
r = atan2 (1.0, 0.0)
q = atan2 (1.0_8, 0.0_8)
call dotest (19, r, q, 1.5708)
r = atan2 (-1.0, 0.0)
q = atan2 (-1.0_8, 0.0_8)
call dotest (20, r, q, -1.5708)
 
cr = log ((-1.0, -1.0))
cq = log ((-1.0_8, -1.0_8))
call dotestc (21, cr, cq, (0.3466, -2.3562))
 
end program
 
/gfortran.fortran-torture/execute/intrinsic_mmloc.f90
0,0 → 1,117
! Program to test the MINLOC and MAXLOC intrinsics
program testmmloc
implicit none
integer, dimension (3, 3) :: a
integer, dimension (3) :: b
logical, dimension (3, 3) :: m, tr
integer i
character(len=10) line
 
a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/));
tr = .true.
 
b = minloc (a, 1)
if (b(1) .ne. 1) call abort
if (b(2) .ne. 2) call abort
if (b(3) .ne. 3) call abort
b = -1
write (line, 9000) minloc(a,1)
read (line, 9000) b
if (b(1) .ne. 1) call abort
if (b(2) .ne. 2) call abort
if (b(3) .ne. 3) call abort
 
m = .true.
m(1, 1) = .false.
m(1, 2) = .false.
b = minloc (a, 1, m)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 2) call abort
if (b(3) .ne. 3) call abort
b = minloc (a, 1, m .and. tr)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 2) call abort
if (b(3) .ne. 3) call abort
b = -1
write (line, 9000) minloc(a, 1, m)
read (line, 9000) b
if (b(1) .ne. 2) call abort
if (b(2) .ne. 2) call abort
if (b(3) .ne. 3) call abort
 
b(1:2) = minloc(a)
if (b(1) .ne. 1) call abort
if (b(2) .ne. 1) call abort
b = -1
write (line, 9000) minloc(a)
read (line, 9000) b
if (b(1) .ne. 1) call abort
if (b(2) .ne. 1) call abort
if (b(3) .ne. 0) call abort
 
b(1:2) = minloc(a, mask=m)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 1) call abort
b(1:2) = minloc(a, mask=m .and. tr)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 1) call abort
b = -1
write (line, 9000) minloc(a, mask=m)
read (line, 9000) b
if (b(1) .ne. 2) call abort
if (b(2) .ne. 1) call abort
if (b(3) .ne. 0) call abort
 
b = maxloc (a, 1)
if (b(1) .ne. 3) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 1) call abort
b = -1
write (line, 9000) maxloc(a, 1)
read (line, 9000) b
if (b(1) .ne. 3) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 1) call abort
 
m = .true.
m(1, 2) = .false.
m(1, 3) = .false.
b = maxloc (a, 1, m)
if (b(1) .ne. 3) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 2) call abort
b = maxloc (a, 1, m .and. tr)
if (b(1) .ne. 3) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 2) call abort
b = -1
write (line, 9000) maxloc(a, 1, m)
read (line, 9000) b
if (b(1) .ne. 3) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 2) call abort
 
b(1:2) = maxloc(a)
if (b(1) .ne. 1) call abort
if (b(2) .ne. 3) call abort
b = -1
write (line, 9000) maxloc(a)
read (line, 9000) b
if (b(1) .ne. 1) call abort
if (b(2) .ne. 3) call abort
 
b(1:2) = maxloc(a, mask=m)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 3) call abort
b(1:2) = maxloc(a, mask=m .and. tr)
if (b(1) .ne. 2) call abort
if (b(2) .ne. 3) call abort
b = -1
write (line, 9000) maxloc(a, mask=m)
read (line, 9000) b
if (b(1) .ne. 2) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 0) call abort
 
9000 format (3I3)
end program
/gfortran.fortran-torture/execute/retarray.f90
0,0 → 1,45
! Program to test functions returning arrays
 
program testfnarray
implicit none
integer, dimension (6, 5) :: a
integer n
 
! These first two shouldn't require a temporary.
a = 0
a = test(6, 5)
if (a(1,1) .ne. 42) call abort
if (a(6,5) .ne. 43) call abort
 
a = 0
a(1:6:2, 2:5) = test2()
if (a(1,2) .ne. 42) call abort
if (a(5,5) .ne. 43) call abort
 
a = 1
! This requires a temporary
a = test(6, 5) - a
if (a(1,1) .ne. 41) call abort
if (a(6,5) .ne. 42) call abort
 
contains
 
function test (x, y)
implicit none
integer x, y
integer, dimension (1:x, 1:y) :: test
 
test(1, 1) = 42
test(x, y) = 43
end function
 
function test2 () result (foo)
implicit none
integer, dimension (3, 4) :: foo
 
foo(1, 1) = 42
foo(3, 4) = 43
end function
 
end program
 
/gfortran.fortran-torture/execute/data_2.f90
0,0 → 1,17
! Check more array variants of the data statement
program data_2
implicit none
type t
integer i
end type t
integer, dimension(3) :: a
type (t), dimension(3) :: b
integer, dimension(2,2) :: c
data a(:), b%i /1, 2, 3, 4, 5, 6/
data c(1, :), c(2, :) /7, 8, 9, 10/
 
if (any (a .ne. (/1, 2, 3/))) call abort ()
if (any (b%i .ne. (/4, 5, 6/))) call abort ()
if ((any (c(1, :) .ne. (/7, 8/))) &
.or. (any (c(2,:) .ne. (/9, 10/)))) call abort ()
end program
/gfortran.fortran-torture/execute/assumed_size.f90
0,0 → 1,39
! Program to test assumed size arrays
subroutine test2(p)
integer, dimension(2, *) :: p
 
if (any (p(:, 1:3) .ne. reshape((/1, 2, 4, 5, 7, 8/), (/2, 3/)))) &
call abort ()
end subroutine
 
program assumed_size
integer, dimension (3, 3) :: a
external test2
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
 
call test1(a, (/1, 2, 3, 4, 5, 6/))
if (a(1,1) .ne. 0) call abort
a(1, 1) = 1
call test1(a(1:2, :), (/1, 2, 4, 5, 7, 8/))
if (a(1,1) .ne. 0) call abort
a(1, 1) = 1
call test1(a(3:1:-1, :), (/3, 2, 1, 6, 5, 4/))
if (a(3,1) .ne. 0) call abort
a(3, 1) = 3
call test1(a(:, 2:3), (/4, 5, 6, 7, 8, 9/))
if (a(1, 2) .ne. 0) call abort
a(1, 2) = 4
call test2(a(1:2, :))
call test2((/1, 2, 4, 5, 7, 8/))
contains
subroutine test1(p, q)
integer, dimension(*) :: p
integer, dimension(1:) :: q
 
if (any (p(1:size(q)) .ne. q)) call abort ()
p(1) = 0
end subroutine
 
end program
/gfortran.fortran-torture/execute/where_2.f90
0,0 → 1,22
! Program to test the WHERE constructs
program where_2
integer temp(10), reduce(10)
temp = 10
reduce(1:3) = -1
reduce(4:6) = 0
reduce(7:8) = 5
reduce(9:10) = 10
 
WHERE (reduce < 0)
temp = 100
ELSE WHERE (reduce .EQ. 0)
temp = 200 + temp
ELSE WHERE
WHERE (reduce > 6) temp = temp + sum(reduce)
temp = 300 + temp
END WHERE
if (any (temp .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) &
call abort
end program
/gfortran.fortran-torture/execute/data_4.f90
0,0 → 1,6
CHARACTER*4 A(3),B(3),C(3)
DATA A /'A',"A",'A'/
DATA B /3*'A'/
DATA C /'A', 2*'A'/
IF (ANY(A.NE.B).OR.ANY(A.NE.C)) CALL ABORT
END
/gfortran.fortran-torture/execute/arraysave.f90
0,0 → 1,24
! Program to test arrays with the save attribute
program testarray
implicit none
integer, save, dimension (6, 5) :: a, b
 
a = 0
a(1, 1) = 42
a(6, 5) = 43
b(:,1:5) = a
 
call fn (a)
contains
subroutine fn (a)
implicit none
integer, dimension(1:, 1:) :: a
integer, dimension(2) :: b
b = ubound (a)
if (any (b .ne. (/6, 5/))) call abort
if (a(1, 1) .ne. 42) call abort
if (a(6, 5) .ne. 43) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/procarg.f90
0,0 → 1,29
! Pogram to test
subroutine myp (a)
implicit none
integer a
 
if (a .ne. 42) call abort
end subroutine
 
subroutine test2 (p)
implicit none
external p
 
call p(42)
end subroutine
 
subroutine test (p)
implicit none
external p, test2
 
call p(42)
call test2(p)
end subroutine
 
program arrayio
implicit none
external test, myp
 
call test (myp)
end program
/gfortran.fortran-torture/execute/where_4.f90
0,0 → 1,13
! Tests WHERE statement with a data dependency
program where_4
integer, dimension(5) :: a
integer, dimension(5) :: b
 
a = (/1, 2, 3, 4, 5/)
b = (/1, 0, 1, 0, 1/)
where (b .ne. 0)
a(:) = a(5:1:-1)
endwhere
if (any (a .ne. (/5, 2, 3, 4, 1/))) call abort
end program
/gfortran.fortran-torture/execute/der_init.f90
0,0 → 1,32
! Program to test derived type initializers and constructors
program der_init
implicit none
type t
integer :: i
integer :: j = 4
end type
integer :: m, n
 
! Explicit initializer
type (t) :: var = t(1, 2)
! Type (default) initializer
type (t) :: var2
! Initialization of arrays
type (t), dimension(2) :: var3
type (t), dimension(2) :: var4 = (/t(7, 9), t(8, 6)/)
 
if (var%i .ne. 1 .or. var%j .ne. 2) call abort
if (var2%j .ne. 4) call abort
var2 = t(6, 5)
if (var2%i .ne. 6 .or. var2%j .ne. 5) call abort
 
if ((var3(1)%j .ne. 4) .or. (var3(2)%j .ne. 4)) call abort
if ((var4(1)%i .ne. 7) .or. (var4(2)%i .ne. 8) &
.or. (var4(1)%j .ne. 9) .or. (var4(2)%j .ne. 6)) call abort
 
! Non-constant constructor
n = 1
m = 5
var2 = t(n, n + m)
if (var2%i .ne. 1 .or. var2%j .ne. 6) call abort
end program
/gfortran.fortran-torture/execute/scalarize2.f90
0,0 → 1,24
! Program to test the scalarizer
program testarray
implicit none
integer, dimension (:, :), allocatable :: a, b
integer n
 
allocate(a(6, 5), b(6, 5))
a = 0
do n = 1, 5
a(4, n) = n
end do
 
b(:, 5:1:-1) = a
a(1:5, 2) = a(4, :) + 1
 
! The following expression should cause loop reordering
a(:, 2:4) = a(:, 1:3)
 
do n = 1, 5
if (a(n, 3) .ne. (n + 1)) call abort
if (b(4, n) .ne. (6 - n)) call abort
end do
end program
 
/gfortran.fortran-torture/execute/where_6.f90
0,0 → 1,23
! Program to test WHERE inside FORALL and the WHERE assignment need temporary
program where_6
integer :: A(5,5)
 
A(1,:) = (/1,0,0,0,0/)
A(2,:) = (/2,1,1,1,0/)
A(3,:) = (/1,2,2,0,2/)
A(4,:) = (/2,1,0,2,3/)
A(5,:) = (/1,0,0,0,0/)
 
! Where inside FORALL.
! WHERE masks must be evaluated before executing the assignments
m=5
forall (I=1:4)
where (A(I,:) .EQ. 0)
A(1:m,I) = A(1:m,I+1) + I
elsewhere (A(I,:) >2)
A(I,1:m) = 6
endwhere
end forall
if (any (A .ne. reshape ((/1,2,6,2,1,0,1,2,1,2,0,1,2,5,0,0,1,6,2,0,0,0,2,&
6,0/), (/5, 5/)))) call abort
end
/gfortran.fortran-torture/execute/where_8.f90
0,0 → 1,28
program where_8
implicit none
type t
logical valid
integer :: s
integer, dimension(8) :: p
end type
type (t), dimension (5) :: v
integer i
 
v(:)%valid = (/.true., .true., .false., .true., .true./)
v(:)%s = (/1, 8, 999, 6, 2/)
v(1)%p(:) = (/9, 10, 0, 0, 0, 0, 0, 0/)
v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
v(5)%p(:) = (/11, 12, 0, 0, 0, 0, 0, 0/)
 
forall (i=1:5,v(i)%valid)
where (v(i)%p(1:v(i)%s).gt.4)
v(i)%p(1:v(i)%s) = 21
end where
end forall
 
if (any(v(1)%p(:) .ne. (/21, 10, 0, 0, 0, 0, 0, 0/))) call abort
if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 21, 21, 21, 21/))) call abort
if (any(v(4)%p(:) .ne. (/21, 21, 21, 21, 21, 21, 19, 20/))) call abort
if (any(v(5)%p(:) .ne. (/21, 21, 0, 0, 0, 0, 0, 0/))) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_si_kind.f90
0,0 → 1,35
! Program to test SELECTED_INT_KIND intrinsic function.
Program test_si_kind
integer*1 i1
integer*2 i2
integer*4 i4
integer*8 i8
integer res
real t
 
t = huge (i1)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 1) call abort
 
t = huge (i2)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 2) call abort
 
t = huge (i4)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 4) call abort
 
t = huge (i8)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 8) call abort
 
i4 = huge (i4)
res = selected_int_kind (i4)
if (res .ne. (-1)) call abort
 
end program
 
/gfortran.fortran-torture/execute/getarg_1.x
0,0 → 1,5
if [istarget "spu-*-*"] {
# We need -mstdmain to enable argument processing on SPU.
lappend additional_flags "-mstdmain"
}
return 0
/gfortran.fortran-torture/execute/contained.f90
0,0 → 1,16
program contained
implicit none
integer i
 
i = 0;
call testproc (40)
if (i .ne. 42) call abort
contains
subroutine testproc (p)
implicit none
integer p
 
if (p .ne. 40) call abort
i = p + 2
end subroutine
end program
/gfortran.fortran-torture/execute/equiv_5.f
0,0 → 1,225
C This testcase was miscompiled on i?86/x86_64, the scheduler
C swapped write to DMACH(1) with following read from SMALL(1),
C at -O2+, as the front-end didn't signal in any way this kind
C of type punning is ok.
C The testcase is from blas, http://www.netlib.org/blas/d1mach.f
 
DOUBLE PRECISION FUNCTION D1MACH(I)
INTEGER*4 I
C
C DOUBLE-PRECISION MACHINE CONSTANTS
C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C D1MACH( 5) = LOG10(B)
C
INTEGER*4 SMALL(2)
INTEGER*4 LARGE(2)
INTEGER*4 RIGHT(2)
INTEGER*4 DIVER(2)
INTEGER*4 LOG10(2)
INTEGER*4 SC, CRAY1(38), J
COMMON /D9MACH/ CRAY1
SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
DOUBLE PRECISION DMACH(5)
EQUIVALENCE (DMACH(1),SMALL(1))
EQUIVALENCE (DMACH(2),LARGE(1))
EQUIVALENCE (DMACH(3),RIGHT(1))
EQUIVALENCE (DMACH(4),DIVER(1))
EQUIVALENCE (DMACH(5),LOG10(1))
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
C MANY MACHINES YET.
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C ON THE NEXT LINE
DATA SC/0/
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C mail netlib@research.bell-labs.com
C send old1mach from blas
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
C
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C 32-BIT INTEGER*4S.
C DATA SMALL(1),SMALL(2) / 8388608, 0 /
C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
C DATA DIVER(1),DIVER(2) / 620756992, 0 /
C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
C
C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
IF (SC .NE. 987) THEN
DMACH(1) = 1.D13
IF ( SMALL(1) .EQ. 1117925532
* .AND. SMALL(2) .EQ. -448790528) THEN
* *** IEEE BIG ENDIAN ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2146435071
LARGE(2) = -1
RIGHT(1) = 1017118720
RIGHT(2) = 0
DIVER(1) = 1018167296
DIVER(2) = 0
LOG10(1) = 1070810131
LOG10(2) = 1352628735
ELSE IF ( SMALL(2) .EQ. 1117925532
* .AND. SMALL(1) .EQ. -448790528) THEN
* *** IEEE LITTLE ENDIAN ***
SMALL(2) = 1048576
SMALL(1) = 0
LARGE(2) = 2146435071
LARGE(1) = -1
RIGHT(2) = 1017118720
RIGHT(1) = 0
DIVER(2) = 1018167296
DIVER(1) = 0
LOG10(2) = 1070810131
LOG10(1) = 1352628735
ELSE IF ( SMALL(1) .EQ. -2065213935
* .AND. SMALL(2) .EQ. 10752) THEN
* *** VAX WITH D_FLOATING ***
SMALL(1) = 128
SMALL(2) = 0
LARGE(1) = -32769
LARGE(2) = -1
RIGHT(1) = 9344
RIGHT(2) = 0
DIVER(1) = 9472
DIVER(2) = 0
LOG10(1) = 546979738
LOG10(2) = -805796613
ELSE IF ( SMALL(1) .EQ. 1267827943
* .AND. SMALL(2) .EQ. 704643072) THEN
* *** IBM MAINFRAME ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2147483647
LARGE(2) = -1
RIGHT(1) = 856686592
RIGHT(2) = 0
DIVER(1) = 873463808
DIVER(2) = 0
LOG10(1) = 1091781651
LOG10(2) = 1352628735
ELSE IF ( SMALL(1) .EQ. 1120022684
* .AND. SMALL(2) .EQ. -448790528) THEN
* *** CONVEX C-1 ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2147483647
LARGE(2) = -1
RIGHT(1) = 1019215872
RIGHT(2) = 0
DIVER(1) = 1020264448
DIVER(2) = 0
LOG10(1) = 1072907283
LOG10(2) = 1352628735
ELSE IF ( SMALL(1) .EQ. 815547074
* .AND. SMALL(2) .EQ. 58688) THEN
* *** VAX G-FLOATING ***
SMALL(1) = 16
SMALL(2) = 0
LARGE(1) = -32769
LARGE(2) = -1
RIGHT(1) = 15552
RIGHT(2) = 0
DIVER(1) = 15568
DIVER(2) = 0
LOG10(1) = 1142112243
LOG10(2) = 2046775455
ELSE
DMACH(2) = 1.D27 + 1
DMACH(3) = 1.D27
LARGE(2) = LARGE(2) - RIGHT(2)
IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
CRAY1(1) = 67291416
DO 10 J = 1, 20
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
10 CONTINUE
CRAY1(22) = CRAY1(21) + 321322
DO 20 J = 22, 37
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
20 CONTINUE
IF (CRAY1(38) .EQ. SMALL(1)) THEN
* *** CRAY ***
CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
SMALL(2) = 0
CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
RIGHT(2) = 0
CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
DIVER(2) = 0
CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
ELSE
WRITE(*,9000)
STOP 779
END IF
ELSE
WRITE(*,9000)
STOP 779
END IF
END IF
SC = 987
END IF
* SANITY CHECK
IF (DMACH(4) .GE. 1.0D0) STOP 778
IF (I .LT. 1 .OR. I .GT. 5) THEN
WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
STOP
END IF
D1MACH = DMACH(I)
RETURN
9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
*' appropriate for your machine.')
* /* Standard C source for D1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*double d1mach_(long *i)
*{
* switch(*i){
* case 1: return DBL_MIN;
* case 2: return DBL_MAX;
* case 3: return DBL_EPSILON/FLT_RADIX;
* case 4: return DBL_EPSILON;
* case 5: return log10((double)FLT_RADIX);
* }
* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
* exit(1); return 0; /* some compilers demand return values */
*}
END
SUBROUTINE I1MCRY(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
INTEGER*4 A, A1, B, C, D
A1 = 16777216*B + C
A = 16777216*A1 + D
END
 
PROGRAM MAIN
DOUBLE PRECISION D1MACH
EXTERNAL D1MACH
PRINT *,D1MACH(1)
PRINT *,D1MACH(2)
PRINT *,D1MACH(3)
PRINT *,D1MACH(4)
PRINT *,D1MACH(5)
END
/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90
0,0 → 1,55
! Program to test AINT and ANINT intrinsics
 
subroutine real4test (op, res1, res2)
implicit none
real(kind=4) :: op
real(kind=4) :: res1, res2
 
if (diff(aint(op), res1) .or. &
diff(anint(op), res2)) call abort
contains
function diff(a, b)
real(kind=4) :: a, b
logical diff
 
diff = (abs (a - b) .gt. abs(a * 1e-6))
end function
end subroutine
 
subroutine real8test (op, res1, res2)
implicit none
real(kind=8) :: op
real(kind=8) :: res1, res2
 
if (diff(aint(op), res1) .or. &
diff(anint(op), res2)) call abort
contains
function diff(a, b)
real(kind=8) :: a, b
logical diff
 
diff = (abs(a - b) .gt. abs(a * 1e-6))
end function
end subroutine
 
program aint_aninttest
implicit none
 
call real4test (3.456, 3.0, 3.0)
call real4test (-2.798, -2.0, -3.0)
call real4test (3.678, 3.0, 4.0)
call real4test (-1.375, -1.0, -1.0)
call real4test (-0.5, 0.0,-1.0)
call real4test (0.4, 0.0,0.0)
 
call real8test (3.456_8, 3.0_8, 3.0_8)
call real8test (-2.798_8, -2.0_8, -3.0_8)
call real8test (3.678_8, 3.0_8, 4.0_8)
call real8test (-1.375_8, -1.0_8, -1.0_8)
call real8test (-0.5_8, 0.0_8,-1.0_8)
call real8test (0.4_8, 0.0_8,0.0_8)
 
! Check large numbers
call real4test (2e34, 2e34, 2e34)
call real4test (-2e34, -2e34, -2e34)
end program
/gfortran.fortran-torture/execute/equiv_1.f90
0,0 → 1,15
program prog
common /block/ i
equivalence (a, b, c), (i, j, k ,l)
a = 1.0
b = 2.0
c = 3.0
i = 1
j = 2
k = 3
l = 4
 
if ((a .ne. 3.0) .or. (b .ne. 3.0) .or. (c .ne. 3.0)) call abort ()
if ((i .ne. 4) .or. (j .ne. 4) .or. (k .ne. 4) .or. (l .ne. 4)) &
call abort ()
end program
/gfortran.fortran-torture/execute/intrinsic_scale.f90
0,0 → 1,29
!Program to test SCALE intrinsic function.
 
program test_scale
call test_real4 (3.0, 2)
call test_real4 (33.0, -2)
call test_real4 (-3., 2)
call test_real4 (0., 3)
call test_real8 (0._8, 3)
call test_real8 (3.0_8, 4)
call test_real8 (33.0_8, -4)
call test_real8 (-33._8, 4)
end
subroutine test_real4 (orig, i)
real x,y,orig
integer i
x = orig
y = x * (2.0 ** i)
x = scale (x, i)
if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end
 
subroutine test_real8 (orig, i)
real*8 x,y,orig
integer i
x = orig
y = x * (2.0 ** i)
x = scale (x, i)
if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end
/gfortran.fortran-torture/execute/where_10.f90
0,0 → 1,23
! Check whether conditional ELSEWHEREs work
! (with final unconditional ELSEWHERE)
program where_10
integer :: a(5)
integer :: b(5)
 
a = (/1, 2, 3, 4, 5/)
b = (/0, 0, 0, 0, 0/)
where (a .eq. 1)
b = 3
elsewhere (a .eq. 2)
b = 1
elsewhere (a .eq. 3)
b = 4
elsewhere (a .eq. 4)
b = 1
elsewhere
b = 5
endwhere
if (any (b .ne. (/3, 1, 4, 1, 5/))) &
call abort
end program
 
/gfortran.fortran-torture/execute/character_select_1.f90
0,0 → 1,12
CHARACTER(LEN=6) :: C = "STEVEN"
 
SELECT CASE (C)
CASE ("AAA":"EEE")
CALL abort
CASE ("R":"T")
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
END
 
/gfortran.fortran-torture/execute/equiv_3.f90
0,0 → 1,13
subroutine test1
type t
sequence
character(8) c
end type t
type(t) :: tc, td
equivalence (tc, td)
tc%c='abcdefgh'
if (tc%c.ne.'abcdefgh'.or.td%c(1:1).ne.'a') call abort
end subroutine test1
program main
call test1
end program main
/gfortran.fortran-torture/execute/where_12.f90
0,0 → 1,9
! Check empty WHEREs work
program where_12
integer :: a(5)
 
a = (/1, 2, 3, 4, 5/)
where (a .eq. 1)
endwhere
end program
 
/gfortran.fortran-torture/execute/scalarize.f90
0,0 → 1,23
! Program to test the scalarizer
program testarray
implicit none
integer, dimension (6, 5) :: a, b
integer n
 
a = 0
do n = 1, 5
a(4, n) = n
end do
 
b(:, 5:1:-1) = a
a(1:5, 2) = a(4, :) + 1
 
! The following expression should cause loop reordering
a(:, 2:4) = a(:, 1:3)
 
do n = 1, 5
if (a(n, 3) .ne. (n + 1)) call abort
if (b(4, n) .ne. (6 - n)) call abort
end do
end program
 
/gfortran.fortran-torture/execute/where_14.f90
0,0 → 1,15
! Check whether an empty ELSEWHERE works
program where_14
integer :: a(5)
integer :: b(5)
 
a = (/1, 2, 3, 4, 5/)
b = (/0, 0, 0, 0, 0/)
where (a .eq. 1)
b = 3
elsewhere
endwhere
if (any (b .ne. (/3, 0, 0, 0, 0/))) &
call abort
end program
 
/gfortran.fortran-torture/execute/pr32604.f90
0,0 → 1,61
MODULE TEST
IMPLICIT NONE
INTEGER, PARAMETER :: dp=KIND(0.0D0)
TYPE mulliken_restraint_type
INTEGER :: ref_count
REAL(KIND = dp) :: strength
REAL(KIND = dp) :: TARGET
INTEGER :: natoms
INTEGER, POINTER, DIMENSION(:) :: atoms
END TYPE mulliken_restraint_type
CONTAINS
SUBROUTINE INIT(mulliken)
TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken
ALLOCATE(mulliken%atoms(1))
mulliken%atoms(1)=1
mulliken%natoms=1
mulliken%target=0
mulliken%strength=0
END SUBROUTINE INIT
SUBROUTINE restraint_functional(mulliken_restraint_control,charges, &
charges_deriv,energy,order_p)
TYPE(mulliken_restraint_type), &
INTENT(IN) :: mulliken_restraint_control
REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv
REAL(KIND=dp), INTENT(OUT) :: energy, order_p
 
INTEGER :: I
REAL(KIND=dp) :: dum
 
charges_deriv=0.0_dp
order_p=0.0_dp
 
DO I=1,mulliken_restraint_control%natoms
order_p=order_p+charges(mulliken_restraint_control%atoms(I),1) &
-charges(mulliken_restraint_control%atoms(I),2)
ENDDO
energy=mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)**2
dum=2*mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)
DO I=1,mulliken_restraint_control%natoms
charges_deriv(mulliken_restraint_control%atoms(I),1)= dum
charges_deriv(mulliken_restraint_control%atoms(I),2)= -dum
ENDDO
END SUBROUTINE restraint_functional
 
END MODULE
 
USE TEST
IMPLICIT NONE
TYPE(mulliken_restraint_type) :: mulliken
REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv
REAL(KIND=dp) :: energy,order_p
ALLOCATE(charges(1,2),charges_deriv(1,2))
charges(1,1)=2.0_dp
charges(1,2)=1.0_dp
CALL INIT(mulliken)
CALL restraint_functional(mulliken,charges,charges_deriv,energy,order_p)
write(6,*) order_p
END
 
/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90
0,0 → 1,67
! Program to test MOD and MODULO intrinsics
subroutine integertest (ops, res)
implicit none
integer, dimension(2) :: ops
integer, dimension(2) :: res
 
if ((mod(ops(1), ops(2)) .ne. res(1)) .or. &
(modulo(ops(1), ops(2)) .ne. res(2))) call abort
end subroutine
 
subroutine real4test (ops, res)
implicit none
real(kind=4), dimension(2) :: ops
real(kind=4), dimension(2) :: res
 
if (diff(mod(ops(1), ops(2)), res(1)) .or. &
diff(modulo(ops(1), ops(2)), res(2))) call abort
contains
function diff(a, b)
real(kind=4) :: a, b
logical diff
 
diff = (abs (a - b) .gt. abs(a * 1e-6))
end function
end subroutine
 
subroutine real8test (ops, res)
implicit none
real(kind=8), dimension(2) :: ops
real(kind=8), dimension(2) :: res
 
if (diff(mod(ops(1), ops(2)), res(1)) .or. &
diff(modulo(ops(1), ops(2)), res(2))) call abort
contains
function diff(a, b)
real(kind=8) :: a, b
logical diff
 
diff = (abs(a - b) .gt. abs(a * 1e-6))
end function
end subroutine
 
program mod_modulotest
implicit none
 
call integertest ((/8, 5/), (/3, 3/))
call integertest ((/-8, 5/), (/-3, 2/))
call integertest ((/8, -5/), (/3, -2/))
call integertest ((/-8, -5/), (/-3, -3/))
call integertest ((/ 2, -1/), (/0, 0/))
 
call real4test ((/3.0, 2.5/), (/0.5, 0.5/))
call real4test ((/-3.0, 2.5/), (/-0.5, 2.0/))
call real4test ((/3.0, -2.5/), (/0.5, -2.0/))
call real4test ((/-3.0, -2.5/), (/-0.5, -0.5/))
call real4test ((/ 2.0, -1.0/), (/ 0.0, 0.0 /))
 
call real8test ((/3.0_8, 2.5_8/), (/0.5_8, 0.5_8/))
call real8test ((/-3.0_8, 2.5_8/), (/-0.5_8, 2.0_8/))
call real8test ((/3.0_8, -2.5_8/), (/0.5_8, -2.0_8/))
call real8test ((/-3.0_8, -2.5_8/), (/-0.5_8, -0.5_8/))
call real8test ((/ 2.0_8, -1.0_8/), (/ 0.0_8, 0.0_8 /))
! Check large numbers
call real4test ((/2e34, 1.0/), (/0.0, 0.0/))
call real4test ((/2e34, 1.5e34/), (/0.5e34, 0.5e34/))
end program
/gfortran.fortran-torture/execute/where_16.f90
0,0 → 1,39
! Check whether nested WHEREs work
program where_16
integer :: a(9)
integer :: b(9)
integer :: c(9)
 
a = (/0, 0, 0, 1, 1, 1, 2, 2, 2/)
b = (/0, 1, 2, 0, 1, 2, 0, 1, 2/)
c = (/0, 0, 0, 0, 0, 0, 0, 0, 0/)
 
where (a .eq. 0)
where (b .eq. 0)
c = 1
else where (b .eq. 1)
c = 2
else where
c = 3
endwhere
elsewhere (a .eq. 1)
where (b .eq. 0)
c = 4
else where (b .eq. 1)
c = 5
else where
c = 6
endwhere
elsewhere
where (b .eq. 0)
c = 7
else where (b .eq. 1)
c = 8
else where
c = 9
endwhere
endwhere
if (any (c .ne. (/1, 2, 3, 4, 5, 6, 7, 8, 9/))) &
call abort
end program
 
/gfortran.fortran-torture/execute/pr23373-2.f90
0,0 → 1,15
program main
implicit none
real, dimension (:), pointer :: x
x => null ()
x => test ()
if (.not. associated (x)) call abort
if (size (x) .ne. 10) call abort
contains
function test()
real, dimension (:), pointer :: test
if (associated (x)) call abort
allocate (test (10))
if (associated (x)) call abort
end function test
end program main
/gfortran.fortran-torture/execute/strret.f90
0,0 → 1,25
! Program to test caracter string return values
function test ()
implicit none
character(len=10) :: test
test = "World"
end function
 
function test2 () result (r)
implicit none
character(len=5) :: r
r = "Hello"
end function
 
program strret
implicit none
character(len=15) :: s
character(len=10) :: test
character(len=5) :: test2
 
s = test ()
if (s .ne. "World") call abort
 
s = "Hello " // test ()
if (s .ne. test2 () //" World") call abort
end
/gfortran.fortran-torture/execute/where18.f90
0,0 → 1,26
! Check to ensure mask is calculated first in WHERE
! statements.
program where_18
integer :: a(4)
integer :: b(3)
integer :: c(3)
equivalence (a(1), b(1)), (a(2), c(1))
 
a = (/1, 1, 1, 1/)
where (b .eq. 1)
c = 2
elsewhere (b .eq. 2)
c = 3
endwhere
if (any (a .ne. (/1, 2, 2, 2/))) &
call abort
 
a = (/1, 1, 1, 1/)
where (c .eq. 1)
b = 2
elsewhere (b .eq. 2)
b = 3
endwhere
if (any (a .ne. (/2, 2, 2, 1/))) &
call abort
end program
/gfortran.fortran-torture/execute/enum_2.f90
0,0 → 1,29
! Program to test the incremental assignment of enumerators
 
program main
implicit none
 
enum, bind (c)
enumerator :: red = 4 , yellow, blue
enumerator green
end enum
 
enum, bind (c)
enumerator :: sun = -10 , mon, tue
enumerator :: wed = 10, sat
end enum
 
 
if (red /= 4 ) call abort
if (yellow /= (red + 1)) call abort
if (blue /= (yellow + 1)) call abort
if (green /= (blue + 1)) call abort
 
if (sun /= -10 ) call abort
if (mon /= (sun + 1)) call abort
if (tue /= (mon + 1)) call abort
if (wed /= 10) call abort
if (sat /= (wed+1)) call abort
 
end program main
/gfortran.fortran-torture/execute/partparm.f90
0,0 → 1,15
! Program to test
subroutine test (p)
integer, dimension (3) :: p
 
if (any (p .ne. (/ 2, 4, 6/))) call abort
end subroutine
 
program partparm
implicit none
integer, dimension (2, 3) :: a
external test
 
a = reshape ((/ 1, 2, 3, 4, 5, 6/), (/ 2, 3/))
call test (a(2, :))
end program
/gfortran.fortran-torture/execute/enum_4.f90
0,0 → 1,19
! Program to test the default initialisation of enumerators inside different program unit
 
module mod
implicit none
enum, bind (c)
enumerator :: red , yellow, blue
enumerator :: green
end enum
end module mod
 
program main
use mod
implicit none
 
if (red /= 0 ) call abort
if (yellow /= 1) call abort
if (blue /= 2) call abort
if (green /= 3) call abort
end program main
/gfortran.fortran-torture/execute/intrinsic_trailz.f90
0,0 → 1,46
program test_intrinsic_trailz
implicit none
 
call test_trailz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
stop
 
contains
 
subroutine test_trailz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
integer(kind=1) :: z1, i1, e1
integer(kind=2) :: z2, i2, e2
integer(kind=4) :: z4, i4, e4
integer(kind=8) :: z8, i8, e8
 
if (trailz(0_1) /= 8) call abort()
if (trailz(0_2) /= 16) call abort()
if (trailz(0_4) /= 32) call abort()
if (trailz(0_8) /= 64) call abort()
 
if (trailz(1_1) /= 0) call abort()
if (trailz(1_2) /= 0) call abort()
if (trailz(1_4) /= 0) call abort()
if (trailz(1_8) /= 0) call abort()
 
if (trailz(8_1) /= 3) call abort()
if (trailz(8_2) /= 3) call abort()
if (trailz(8_4) /= 3) call abort()
if (trailz(8_8) /= 3) call abort()
 
if (trailz(z1) /= 8) call abort()
if (trailz(z2) /= 16) call abort()
if (trailz(z4) /= 32) call abort()
if (trailz(z8) /= 64) call abort()
 
if (trailz(i1) /= 0) call abort()
if (trailz(i2) /= 0) call abort()
if (trailz(i4) /= 0) call abort()
if (trailz(i8) /= 0) call abort()
 
if (trailz(e1) /= 3) call abort()
if (trailz(e2) /= 3) call abort()
if (trailz(e4) /= 3) call abort()
if (trailz(e8) /= 3) call abort()
end subroutine test_trailz
 
end program
/gfortran.fortran-torture/execute/common.f90
0,0 → 1,53
! Program to test COMMON and EQUIVALENCE.
program common
real (kind=8) a(8)
real (kind=8) b(5), c(5)
common /com1/b,c
equivalence (a(1), b(2))
b = 100
c = 200
call common_pass
call common_par (a, b,c)
call global_equiv
call local_equiv
end
 
! Use common block to pass values
subroutine common_pass
real (kind=8) a(8)
real (kind=8) b(5), c(5)
common /com1/b,c
equivalence (a(1), b(2))
if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
end subroutine
 
! Common variables as argument
subroutine common_par (a, b, c)
real (kind=8) a(8), b(5), c(5)
if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
if (any (b .ne. (/100,100,100,100,100/))) call abort
if (any (c .ne. (/200,200,200,200,200/))) call abort
end subroutine
 
! Global equivalence
subroutine global_equiv
real (kind=8) a(8), b(5), c(5), x(8), y(4), z(4)
common /com2/b, c, y, z
equivalence (a(1), b(2))
equivalence (x(4), y(1))
b = 100
c = 200
y = 300
z = 400
if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
if (any (x .ne. (/200,200,200,300,300,300,300,400/))) call abort
end
 
! Local equivalence
subroutine local_equiv
real (kind=8) a(8), b(10)
equivalence (a(1), b(3))
b(1:5) = 100
b(6:10) = 200
if (any (a .ne. (/100,100,100,200,200,200,200,200/))) call abort
end subroutine
/gfortran.fortran-torture/execute/intrinsic_index.f90
0,0 → 1,15
! Program to test the INDEX intrinsic
program test
character(len=10) a
integer w
if (index("FORTRAN", "R") .ne. 3) call abort
if (index("FORTRAN", "R", .TRUE.) .ne. 5) call abort
if (w ("FORTRAN") .ne. 3) call abort
end
 
function w(str)
character(len=7) str
integer w
w = index(str, "R")
end
 
/gfortran.fortran-torture/execute/iolength_2.f90
0,0 → 1,24
! Test that IOLENGTH works for derived types containing arrays
module iolength_2_mod
integer, parameter :: &
! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
int32 = selected_int_kind(9), &
! IEEE double precision, i.e. 8 bytes
dp = selected_real_kind(15, 307)
type foo
! This type should take up 5*4+4+8=32 bytes
integer(int32) :: a(5), b
real(dp) :: c
end type foo
end module iolength_2_mod
 
program iolength_2
use iolength_2_mod
implicit none
integer :: iol
type(foo) :: d
inquire (iolength = iol) d
if ( 32 /= iol) then
call abort
end if
end program iolength_2
/gfortran.fortran-torture/execute/equiv_init_1.f90
0,0 → 1,94
! Program to test initialization of equivalence blocks. PR13742.
! Some forms are not yet implemented. These are indicated by !!$
 
subroutine test0s
character*10 :: x = "abcdefghij"
character*10 :: y
equivalence (x,y)
 
character*10 :: xs(10)
character*10 :: ys(10)
equivalence (xs,ys)
data xs /10*"abcdefghij"/
 
if (y.ne."abcdefghij") call abort
if (ys(1).ne."abcdefghij") call abort
if (ys(10).ne."abcdefghij") call abort
end
subroutine test0
integer :: x = 123
integer :: y
equivalence (x,y)
if (y.ne.123) call abort
end
 
subroutine test1
integer :: a(3)
integer :: x = 1
integer :: y
integer :: z = 3
equivalence (a(1), x)
equivalence (a(3), z)
if (x.ne.1) call abort
if (z.ne.3) call abort
if (a(1).ne.1) call abort
if (a(3).ne.3) call abort
end
 
subroutine test2
integer :: x
integer :: z
integer :: a(3) = 123
equivalence (a(1), x)
equivalence (a(3), z)
if (x.ne.123) call abort
if (z.ne.123) call abort
end
 
subroutine test3
integer :: x
!!$ integer :: y = 2
integer :: z
integer :: a(3)
equivalence (a(1),x), (a(2),y), (a(3),z)
data a(1) /1/, a(3) /3/
if (x.ne.1) call abort
!!$ if (y.ne.2) call abort
if (z.ne.3) call abort
end
 
subroutine test4
integer a(2)
integer b(2)
integer c
equivalence (a(2),b(1)), (b(2),c)
data a/1,2/
data c/3/
if (b(1).ne.2) call abort
if (b(2).ne.3) call abort
end
 
!!$subroutine test5
!!$ integer a(2)
!!$ integer b(2)
!!$ integer c
!!$ equivalence (a(2),b(1)), (b(2),c)
!!$ data a(1)/1/
!!$ data b(1)/2/
!!$ data c/3/
!!$ if (a(2).ne.2) call abort
!!$ if (b(2).ne.3) call abort
!!$ print *, "Passed test5"
!!$end
program main
call test0s
call test0
call test1
call test2
call test3
call test4
!!$ call test5
end
 
/gfortran.fortran-torture/execute/nestcons.f90
0,0 → 1,9
! Program to test array expressions in array constructors.
program nestcons
implicit none
integer, parameter :: w1(3)= (/ 5, 6, 7/)
integer, dimension(6) :: w2
w2 = (/ 1, 2, w1(3:1:-1), 3 /)
if (any (w2 .ne. (/ 1, 2, 7, 6, 5, 3/))) call abort
end
/gfortran.fortran-torture/execute/intrinsic_nearest.x
0,0 → 1,6
if [istarget "spu-*-*"] {
# No Inf/NaN support on SPU.
return 1
}
add-ieee-options
return 0
/gfortran.fortran-torture/execute/list_read_1.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/select_1.f90
0,0 → 1,17
! from PR 15962, we used to require constant expressions instead of
! initialization expressions in case-statements
function j(k)
integer :: k
integer :: j
integer, parameter :: i(2) = (/1,2/)
 
select case(k)
case (1:size(i))
j = i(k)
case default
j = 0
end select
end function
 
if (j(2).NE.2 .OR. j(11).NE.0) call abort()
end
/gfortran.fortran-torture/execute/intrinsic_pack.f90
0,0 → 1,24
! Program to test the PACK intrinsic
program intrinsic_pack
integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/)
integer, dimension(3, 3) :: a
integer, dimension(6) :: b
 
a = reshape (val, (/3, 3/))
b = 0
b(1:6:3) = pack (a, a .ne. 0);
if (any (b(1:6:3) .ne. (/9, 7/))) call abort
b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/));
if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort
 
call tests_with_temp()
contains
subroutine tests_with_temp
! A few tests which involve a temporary
if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort
if (any (pack(a, .true.) .ne. val)) call abort
if (size(pack (a, .false.)) .ne. 0) call abort
if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort
 
end subroutine tests_with_temp
end program
/gfortran.fortran-torture/execute/parameter_2.f90
0,0 → 1,7
module m
parameter (p = -1.) ! negative numbers used to get output incorrectly
end module m
 
use m
if (p .ne. -1.) CALL abort()
end
/gfortran.fortran-torture/execute/intrinsic_unpack.f90
0,0 → 1,21
! Program to test the UNPACK intrinsic
program intrinsic_unpack
integer, dimension(3, 3) :: a, b
logical, dimension(3, 3) :: mask;
character(len=50) line1, line2
integer i
 
mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
&.false.,.false.,.true./), (/3, 3/));
a = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
b = unpack ((/2, 3, 4/), mask, a)
if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
call abort
write (line1,'(10I4)') b
write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a)
if (line1 .ne. line2) call abort
b = -1
b = unpack ((/2, 3, 4/), mask, 0)
if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
call abort
end program
/gfortran.fortran-torture/execute/read_null_string.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/a_edit_1.f90
0,0 → 1,17
! pr 15113
! Ax edit descriptor x larger than destination
! A edit descriptor with no field width segfaults
character*16 C
character*4 D
data C / 'ABCDEFGHIJKLMNOP'/
read(C,'(A7)')D
if (D.NE.'DEFG') then
! print*,D
call abort
endif
read(C,'(A)')D
if (D.NE.'ABCD') then
! print*,D
call abort
endif
end
/gfortran.fortran-torture/execute/elemental.f90
0,0 → 1,32
! Program to test elemental functions.
program test_elemental
implicit none
integer, dimension (2, 4) :: a
integer, dimension (2, 4) :: b
integer(kind = 8), dimension(2) :: c
 
a = reshape ((/2, 3, 4, 5, 6, 7, 8, 9/), (/2, 4/))
b = 0
b(2, :) = e_fn (a(1, :), 1)
if (any (b .ne. reshape ((/0, 1, 0, 3, 0, 5, 0, 7/), (/2, 4/)))) call abort
a = e_fn (a(:, 4:1:-1), 1 + b)
if (any (a .ne. reshape ((/7, 7, 5, 3, 3, -1, 1, -5/), (/2, 4/)))) call abort
! This tests intrinsic elemental conversion functions.
c = 2 * a(1, 1)
if (any (c .ne. 14)) call abort
 
! This triggered bug due to building ss chains in the wrong order.
b = 0;
a = a - e_fn (a, b)
if (any (a .ne. 0)) call abort
 
! Check expressions involving constants
a = e_fn (b + 1, 1)
if (any (a .ne. 0)) call abort
contains
 
elemental integer(kind=4) function e_fn (p, q)
integer, intent(in) :: p, q
e_fn = p - q
end function
end program
/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90
0,0 → 1,84
!Program to test EXPONENT and FRACTION intrinsic function.
 
program test_exponent_fraction
real x
integer*4 i
real*8 y
integer*8 j
equivalence (x, i), (y, j)
 
x = 3.
call test_4(x)
 
x = 0.
call test_4(x)
 
i = o'00000000001'
call test_4(x)
 
i = o'00010000000'
call test_4(x)
 
i = o'17700000000'
call test_4(x)
 
i = o'00004000001'
call test_4(x)
 
i = o'17737777777'
call test_4(x)
 
i = o'10000000000'
call test_4(x)
 
i = o'0000010000'
call test_4(x)
 
y = 0.5
call test_8(y)
 
y = 0.
call test_8(y)
 
j = o'00000000001'
call test_8(y)
 
y = 0.2938735877D-38
call test_8(y)
 
y = -1.469369D-39
call test_8(y)
 
y = z'7fe00000'
call test_8(y)
 
y = -5.739719D+42
call test_8(y)
end
 
subroutine test_4(x)
real*4 x,y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
y = (y * 2.) * (2. ** (z - 1))
else
y = (y / 2.) * (2. ** (z + 1))
end if
if (abs (x - y) .gt. spacing (max (abs (x), abs (y)))) call abort()
end
 
subroutine test_8(x)
real*8 x, y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
y = (y * 2._8) * (2._8 ** (z - 1))
else
y = (y / 2._8) * (2._8 ** (z + 1))
end if
if (abs (x - y) .gt. spacing (max (abs (x), abs(y)))) call abort()
end
 
/gfortran.fortran-torture/execute/stack_varsize.f90
0,0 → 1,30
! Program to test the stack variable size limit.
program stack
call sub1
call sub2 (1)
contains
 
! Local variables larger than 32768 in byte size shall be placed in static
! storage area, while others be put on stack by default.
subroutine sub1
real a, b(32768/4), c(32768/4+1)
integer m, n(1024,4), k(1024,1024)
a = 10.0
b = 20.0
c = 30.0
m = 10
n = 20
k = 30
if ((a .ne. 10.0).or.(b(1) .ne. 20.0).or.(c(1) .ne. 30.0)) call abort
if ((m .ne. 10).or.(n(256,4) .ne. 20).or.(k(1,1024) .ne. 30)) call abort
end subroutine
 
! Local variables defined in recursive subroutine are always put on stack.
recursive subroutine sub2 (n)
real a (32769)
a (1) = 42
if (n .ge. 1) call sub2 (n-1)
if (a(1) .ne. 42) call abort
a (1) = 0
end subroutine
end
/gfortran.fortran-torture/execute/optstring_1.f90
0,0 → 1,21
! Test optional character arguments. We still need to pass a string
! length for the absent arguments
program optional_string_1
implicit none
 
call test(1, "test");
call test(2, c=42, b="Hello World")
contains
subroutine test(i, a, b, c)
integer :: i
character(len=4), optional :: a
character(len=*), optional :: b
integer, optional :: c
if (i .eq. 1) then
if (a .ne. "test") call abort
else
if (b .ne. "Hello World") call abort
if (c .ne. 42) call abort
end if
end subroutine
end program
/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90
0,0 → 1,62
! Program to test SELECTED_REAL_KIND intrinsic function.
Program test_sr_kind
integer res, i4, i8, t
real*4 r4
real*8 r8
 
i4 = int (log10 (huge (r4)))
t = - int (log10 (tiny (r4)))
if (i4 .gt. t) i4 = t
 
i8 = int (log10 (huge (r8)))
t = - int (log10 (tiny (r8)))
if (i8 .gt. t) i8 = t
 
res = selected_real_kind (r = i4)
if (res .ne. 4) call abort
 
res = selected_real_kind (r = i8)
if (res .ne. 8) call abort
 
! We can in fact have kinds wider than r8. How do we want to check?
! res = selected_real_kind (r = (i8 + 1))
! if (res .ne. -2) call abort
 
res = selected_real_kind (p = precision (r4))
if (res .ne. 4) call abort
 
res = selected_real_kind (p = precision (r4), r = i4)
if (res .ne. 4) call abort
 
res = selected_real_kind (p = precision (r4), r = i8)
if (res .ne. 8) call abort
 
! res = selected_real_kind (p = precision (r4), r = i8 + 1)
! if (res .ne. -2) call abort
 
res = selected_real_kind (p = precision (r8))
if (res .ne. 8) call abort
 
res = selected_real_kind (p = precision (r8), r = i4)
if (res .ne. 8) call abort
 
res = selected_real_kind (p = precision (r8), r = i8)
if (res .ne. 8) call abort
 
! res = selected_real_kind (p = precision (r8), r = i8 + 1)
! if (res .ne. -2) call abort
 
! res = selected_real_kind (p = (precision (r8) + 1))
! if (res .ne. -1) call abort
 
! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
! if (res .ne. -1) call abort
 
! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
! if (res .ne. -1) call abort
 
! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
! if (res .ne. -3) call abort
 
end
 
/gfortran.fortran-torture/execute/csqrt_1.f90
0,0 → 1,78
! PR 14396
! These we failing on targets which do not provide the c99 complex math
! functions.
! Extracted from intrinsic77.f in the g77 testsuite.
logical fail
common /flags/ fail
fail = .false.
call square_root
if (fail) call abort
end
subroutine square_root
intrinsic sqrt, dsqrt, csqrt
real x, a
x = 4.0
a = 2.0
call c_r(SQRT(x),a,'SQRT(real)')
call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
call p_r_r(SQRT,x,a,'SQRT')
call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
end
subroutine failure(label)
! Report failure and set flag
character*(*) label
logical fail
common /flags/ fail
write(6,'(a,a,a)') 'Test ',label,' FAILED'
fail = .true.
end
subroutine c_r(a,b,label)
! Check if REAL a equals b, and fail otherwise
real a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_d(a,b,label)
! Check if DOUBLE PRECISION a equals b, and fail otherwise
double precision a, b
character*(*) label
if ( abs(a-b) .gt. 1.0d-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_c(a,b,label)
! Check if COMPLEX a equals b, and fail otherwise
complex a, b
character*(*) label
if ( abs(a-b) .gt. 1.0e-5 ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine p_r_r(f,x,a,label)
! Check if REAL f(x) equals a for REAL x
real f,x,a
character*(*) label
call c_r(f(x),a,label)
end
subroutine p_d_d(f,x,a,label)
! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
double precision f,x,a
character*(*) label
call c_d(f(x),a,label)
end
subroutine p_c_c(f,x,a,label)
! Check if COMPLEX f(x) equals a for COMPLEX x
complex f,x,a
character*(*) label
call c_c(f(x),a,label)
end
/gfortran.fortran-torture/execute/where21.f90
0,0 → 1,9
! { dg-do run }
! Test fix for PR fortran/30207.
program a
implicit none
integer, parameter :: i(4) = (/ 1, 1, 1, 1 /)
integer :: z(4) = (/ 1, 1, -1, -1 /)
where(z < 0) z(:) = 1
if (any(z /= i)) call abort
end program a
/gfortran.fortran-torture/execute/userop.f90
0,0 → 1,67
module uops
implicit none
interface operator (.foo.)
module procedure myfoo
end interface
 
interface operator (*)
module procedure boolmul
end interface
 
interface assignment (=)
module procedure int2bool
end interface
 
contains
function myfoo (lhs, rhs)
implicit none
integer myfoo
integer, intent(in) :: lhs, rhs
 
myfoo = lhs + rhs
end function
 
! This is deliberately different from integer multiplication
function boolmul (lhs, rhs)
implicit none
logical boolmul
logical, intent(IN) :: lhs, rhs
 
boolmul = lhs .and. .not. rhs
end function
 
subroutine int2bool (lhs, rhs)
implicit none
logical, intent(out) :: lhs
integer, intent(in) :: rhs
 
lhs = rhs .ne. 0
end subroutine
end module
 
program me
use uops
implicit none
integer i, j
logical b, c
 
b = .true.
c = .true.
if (b * c) call abort
c = .false.
if (.not. (b * c)) call abort
if (c * b) call abort
b = .false.
if (b * c) call abort
 
i = 0
b = i
if (b) call abort
i = 2
b = i
if (.not. b) call abort
 
j = 3
if ((i .foo. j) .ne. 5) call abort
end program
 
/gfortran.fortran-torture/execute/save_1.f90
0,0 → 1,29
subroutine foo (b)
logical b
integer i, j
character*24 s
save
if (b) then
i = 26
j = 131
s = 'This is a test string'
else
if (i .ne. 26 .or. j .ne. 131) call abort
if (s .ne. 'This is a test string') call abort
end if
end subroutine foo
subroutine bar (s)
character*42 s
if (s .ne. '0123456789012345678901234567890123456') call abort
call foo (.false.)
end subroutine bar
subroutine baz
character*42 s
! Just clobber stack a little bit.
s = '0123456789012345678901234567890123456'
call bar (s)
end subroutine baz
call foo (.true.)
call baz
call foo (.false.)
end
/gfortran.fortran-torture/execute/intrinsic_spacing.x
0,0 → 1,2
add-ieee-options
return 0
/gfortran.fortran-torture/execute/allocate.f90
0,0 → 1,38
! Test allocation and deallocation.
program test_allocate
call t1 (.true.)
call t1 (.false.)
call t2
contains
 
! Implicit deallocation and saved aloocated variables.
subroutine t1(first)
real, allocatable, save :: p(:)
real, allocatable :: q(:)
logical first
 
if (first) then
if (allocated (p)) call abort ()
else
if (.not. allocated (p)) call abort ()
end if
if (allocated (q)) call abort ()
 
if (first) then
allocate (p(5))
else
deallocate (p)
end if
allocate (q(5))
end subroutine
 
! Explicit deallocation.
subroutine t2()
real, allocatable :: r(:)
 
allocate (r(5))
pr = 1.0
deallocate (r)
if (allocated(r)) call abort ()
end subroutine
end program
/gfortran.fortran-torture/execute/backspace.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/module_interface_2.f90
0,0 → 1,29
! Test generic interfaces declared in modules.
! We used to get the name mangling wrong for these.
module module_interface_2
interface foo
subroutine myfoo (i)
integer i
end subroutine
module procedure bar
end interface
contains
subroutine bar (r)
real r
 
if (r .ne. 1.0) call abort ()
end subroutine
end module
 
subroutine myfoo (i)
integer i
 
if (i .ne. 42) call abort ()
end subroutine
 
program test
use module_interface_2
 
call foo (42)
call foo (1.0)
end program
/gfortran.fortran-torture/execute/common_init_1.f90
0,0 → 1,24
! Program to test initialization of common blocks.
subroutine test()
character(len=15) :: c
integer d, e
real f
common /block2/ c
common /block/ d, e, f
 
if ((d .ne. 42) .or. (e .ne. 43) .or. (f .ne. 2.0)) call abort ()
if (c .ne. "Hello World ") call abort ()
end subroutine
 
program prog
integer a(2)
real b
character(len=15) :: s
common /block/ a, b
common /block2/ s
data b, a/2.0, 42, 43/
data s /"Hello World"/
 
call test ()
end program
 
/gfortran.fortran-torture/execute/inquire_1.f90
0,0 → 1,9
! PR 14831
CHARACTER*4 BLANK
CHARACTER*10 ACCESS
OPEN(UNIT=9,ACCESS='SEQUENTIAL')
INQUIRE(UNIT=9,ACCESS=ACCESS,BLANK=BLANK)
IF(BLANK.NE.'NULL') CALL ABORT
IF(ACCESS.NE.'SEQUENTIAL') CALL ABORT
CLOSE(UNIT=9,STATUS='DELETE')
END
/gfortran.fortran-torture/execute/intrinsic_size.f90
0,0 → 1,37
! Program to test the SIZE intrinsics
program testsize
implicit none
real, dimension(:, :), allocatable :: a
integer, dimension(5) :: j
integer, dimension(2, 3) :: b
integer i
 
if (size (b(2, :), 1) .ne. 3) call abort
allocate (a(3:8, 5:7))
 
! With one parameter
if (size(a) .ne. 18) call abort
 
! With two parameters, assigning to an array
j = size(a, 1)
if (any (j .ne. (/6, 6, 6, 6, 6/))) call abort
 
! With a variable second parameter
i = 2
i = size(a, i)
if (i .ne. 3) call abort
 
call test(a)
contains
 
subroutine test (a)
real, dimension (1:, 1:) :: a
integer i
 
i = 2
if ((size(a, 1) .ne. 6) .or. (size(a, i) .ne. 3)) call abort
if (size (a) .ne. 18 ) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/open_replace.f90
0,0 → 1,6
! pr 16196
! open with 'REPLACE' creates the file if it does not exist.
PROGRAM iobug
OPEN(UNIT=10,FILE='gfcoutput.txt',status='REPLACE')
CLOSE(10,status='DELETE')
END PROGRAM iobug
/gfortran.fortran-torture/execute/intrinsic_trim.f90
0,0 → 1,23
! Program to test the TRIM and REPEAT intrinsics.
program intrinsic_trim
character(len=8) a
character(len=4) b,work
a='1234 '
b=work(8,a)
if (llt(b,"1234")) call abort()
a=' '
b=trim(a)
if (b .gt. "") call abort()
b='12'
a=repeat(b,0)
if (a .gt. "") call abort()
a=repeat(b,2)
if (a .ne. "12 12 ") call abort()
end
 
function work(i,a)
integer i
character(len=i) a
character(len=4) work
work = trim(a)
end
/gfortran.fortran-torture/execute/inquire_3.f90
0,0 → 1,14
! pr14836
OPEN(UNIT=9, ACCESS='DIRECT', RECL=80, FORM='UNFORMATTED')
INQUIRE(UNIT=9,NEXTREC=NREC)
WRITE(UNIT=9,REC=5) 1
INQUIRE(UNIT=9,NEXTREC=NREC)
! PRINT*,NREC
IF (NREC.NE.6) CALL ABORT
READ(UNIT=9,REC=1) MVI
INQUIRE(UNIT=9,NEXTREC=NREC)
IF (NREC.NE.2) CALL ABORT
! PRINT*,NREC
CLOSE(UNIT=9,STATUS='DELETE')
END
 
/gfortran.fortran-torture/execute/intrinsic_mmval.f90
0,0 → 1,45
! Program to test the MINVAL and MAXVAL intrinsics
program testmmval
implicit none
integer, dimension (3, 3) :: a
integer, dimension (3) :: b
logical, dimension (3, 3) :: m, tr
integer i
character (len=9) line
 
a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/));
 
tr = .true.
 
b = minval (a, 1)
if (any(b .ne. (/1, 4, 7/))) call abort
write (line, 9000) minval (a, 1)
if (line .ne. ' 1 4 7') call abort
 
m = .true.
m(1, 1) = .false.
m(1, 2) = .false.
b = minval (a, 1, m)
if (any(b .ne. (/2, 4, 7/))) call abort
b = minval (a, 1, m .and. tr)
if (any(b .ne. (/2, 4, 7/))) call abort
write (line, 9000) minval(a, 1, m)
if (line .ne. ' 2 4 7') call abort
 
b = maxval (a, 1)
if (any(b .ne. (/3, 6, 9/))) call abort
write (line, 9000) maxval (a, 1)
if (line .ne. ' 3 6 9') call abort
 
m = .true.
m(1, 2) = .false.
m(1, 3) = .false.
b = maxval (a, 1, m)
if (any(b .ne. (/3, 6, 8/))) call abort
b = maxval (a, 1, m .and. tr)
if (any(b .ne. (/3, 6, 8/))) call abort
write (line, 9000) maxval(a, 1, m)
if (line .ne. ' 3 6 8') call abort
 
9000 format(3I3)
end program
/gfortran.fortran-torture/execute/inquire_5.f90
0,0 → 1,32
! PR fortran/21647
program inquire_5
integer (kind = 8) :: unit8
logical (kind = 8) :: exist8
integer (kind = 4) :: unit4
logical (kind = 4) :: exist4
integer (kind = 2) :: unit2
logical (kind = 2) :: exist2
integer (kind = 1) :: unit1
logical (kind = 1) :: exist1
character (len = 6) :: del
unit8 = 78
open (file = 'inquire_5.txt', unit = unit8)
unit8 = -1
exist8 = .false.
unit4 = -1
exist4 = .false.
unit2 = -1
exist2 = .false.
unit1 = -1
exist1 = .false.
inquire (file = 'inquire_5.txt', number = unit8, exist = exist8)
if (unit8 .ne. 78 .or. .not. exist8) call abort
inquire (file = 'inquire_5.txt', number = unit4, exist = exist4)
if (unit4 .ne. 78 .or. .not. exist4) call abort
inquire (file = 'inquire_5.txt', number = unit2, exist = exist2)
if (unit2 .ne. 78 .or. .not. exist2) call abort
inquire (file = 'inquire_5.txt', number = unit1, exist = exist1)
if (unit1 .ne. 78 .or. .not. exist1) call abort
del = 'delete'
close (unit = 78, status = del)
end
/gfortran.fortran-torture/execute/random_1.f90
0,0 → 1,33
! PR15619
! Check that random_seed works as expected.
! Does not check the quality of random numbers, hence should never fail.
program test_random
implicit none
integer, allocatable :: seed(:)
real, dimension(10) :: a, b
integer n;
 
call random_seed (size=n)
allocate (seed(n))
! Exercise the generator a bit.
call random_number (a)
 
! Remeber the seed and get 10 more.
call random_seed (get=seed)
call random_number (a)
 
! Get the same 10 numbers in two blocks, remebering the seed in the middle
call random_seed (put=seed)
call random_number (b(1:5))
call random_seed(get=seed)
call random_number (b(6:10))
if (any (a .ne. b)) call abort
 
! Get the last 5 numbers again.
call random_seed (put=seed)
call random_number (b(6:10))
if (any (a .ne. b)) call abort
end program
 
 
/gfortran.fortran-torture/execute/entry_10.f90
0,0 → 1,13
function foo ()
foo = 4
foo = foo / 2
return
entry bar ()
bar = 9
bar = bar / 3
end
 
program entrytest
if (foo () .ne. 2) call abort ()
if (bar () .ne. 3) call abort ()
end
/gfortran.fortran-torture/execute/intrinsic_cshift.f90
0,0 → 1,43
! Program to test the cshift intrinsic
program intrinsic_cshift
integer, dimension(3, 3) :: a
integer, dimension(3, 3, 2) :: b
 
! Scalar shift
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = cshift (a, 1, 1)
if (any (a .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = cshift (a, -2, dim = 2)
if (any (a .ne. reshape ((/4, 5, 6, 7, 8, 9, 1, 2, 3/), (/3, 3/)))) &
call abort
 
! Array shift
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = cshift (a, (/1, 0, -1/))
if (any (a .ne. reshape ((/2, 3, 1, 4, 5, 6, 9, 7, 8/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = cshift (a, (/2, -2, 0/), dim = 2)
if (any (a .ne. reshape ((/7, 5, 3, 1, 8, 6, 4, 2, 9/), (/3, 3/)))) &
call abort
 
! Test arrays > rank 2
b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,&
18, 19/), (/3, 3, 2/))
b = cshift (b, 1)
if (any (b .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7, 12, 13, 11, 15,&
16, 14, 18, 19, 17/), (/3, 3, 2/)))) &
call abort
 
b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,&
18, 19/), (/3, 3, 2/))
b = cshift (b, reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)), 3)
if (any (b .ne. reshape ((/11, 2, 13, 4, 15, 6, 17, 8, 19, 1, 12, 3,&
14, 5, 16, 7, 18, 9/), (/3, 3, 2/)))) &
call abort
 
end program
/gfortran.fortran-torture/execute/random_init.f90
0,0 → 1,11
! pr 15149
! verify the random number generator is functional
program test_random
implicit none
real :: r(5) = 0.0
 
call random_number(r)
if (all (r .eq. 0)) call abort
end program
 
 
/gfortran.fortran-torture/execute/read_eof.f90
0,0 → 1,6
! PR 13919, segfault when file is empty
open(unit=8,status='scratch')
read(8,*,end=1)i
call abort
1 continue
end
/gfortran.fortran-torture/execute/transfer2.f90
0,0 → 1,19
program test_convert
 
implicit none
character(len=4) :: byte_string
character(len=1),dimension(4) :: byte_array
integer*4 :: value,value1,n,i
 
byte_string(1:1) = char(157)
byte_string(2:2) = char(127)
byte_string(3:3) = char(100)
byte_string(4:4) = char(0)
 
byte_array(1:4) = (/char(157),char(127),char(100),char(0)/)
 
value = transfer(byte_string(1:4),value)
value1 = transfer(byte_array(1:4),value1)
 
if (value .ne. value1) call abort()
end program test_convert
/gfortran.fortran-torture/execute/arithmeticif.f90
0,0 → 1,25
! Program to test the arithmetic if statement
function testif (a)
implicit none
integer a, b, testif
 
if (a) 1, 2, 3
b = 2
goto 4
1 b = -1
goto 4
2 b = 0
goto 4
3 b = 1
4 testif = b
end function
 
program testwrite
implicit none
integer i
integer testif
 
if (testif (-10) .ne. -1) call abort
if (testif (0) .ne. 0) call abort
if (testif (10) .ne. 1) call abort
end program
/gfortran.fortran-torture/execute/common_2.f90
0,0 → 1,20
! PR fortran/16336 -- the two common blocks used to clash
MODULE bar
INTEGER :: I
COMMON /X/I
contains
subroutine set_i()
i = 5
end subroutine set_i
END MODULE bar
 
USE bar
INTEGER :: J
COMMON /X/J
j = 1
i = 2
if (j.ne.i) call abort()
if (j.ne.2) call abort()
call set_i()
if (j.ne.5) call abort()
END
/gfortran.fortran-torture/execute/spec_abs.f90
0,0 → 1,12
!pr 14056
INTRINSIC IABS
INTEGER FF324
IVCOMP = FF324(IABS,-7)
IF (IVCOMP.NE.8) CALL ABORT
END
INTEGER FUNCTION FF324(NINT, IDON03)
FF324 = NINT(IDON03) + 1
! **** THE NAME NINT IS A DUMMY ARGUMENT
! AND NOT AN INTRINSIC FUNCTION REFERENCE *****
RETURN
END
/gfortran.fortran-torture/execute/intrinsic_leadz.f90
0,0 → 1,46
program test_intrinsic_leadz
implicit none
 
call test_leadz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
stop
 
contains
 
subroutine test_leadz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
integer(kind=1) :: z1, i1, e1
integer(kind=2) :: z2, i2, e2
integer(kind=4) :: z4, i4, e4
integer(kind=8) :: z8, i8, e8
 
if (leadz(0_1) /= 8) call abort()
if (leadz(0_2) /= 16) call abort()
if (leadz(0_4) /= 32) call abort()
if (leadz(0_8) /= 64) call abort()
 
if (leadz(1_1) /= 7) call abort()
if (leadz(1_2) /= 15) call abort()
if (leadz(1_4) /= 31) call abort()
if (leadz(1_8) /= 63) call abort()
 
if (leadz(8_1) /= 4) call abort()
if (leadz(8_2) /= 12) call abort()
if (leadz(8_4) /= 28) call abort()
if (leadz(8_8) /= 60) call abort()
 
if (leadz(z1) /= 8) call abort()
if (leadz(z2) /= 16) call abort()
if (leadz(z4) /= 32) call abort()
if (leadz(z8) /= 64) call abort()
 
if (leadz(i1) /= 7) call abort()
if (leadz(i2) /= 15) call abort()
if (leadz(i4) /= 31) call abort()
if (leadz(i8) /= 63) call abort()
 
if (leadz(e1) /= 4) call abort()
if (leadz(e2) /= 12) call abort()
if (leadz(e4) /= 28) call abort()
if (leadz(e8) /= 60) call abort()
end subroutine test_leadz
 
end program
/gfortran.fortran-torture/execute/entry_2.f90
0,0 → 1,51
! Test alternate entry points for functions when the result types
! of all entry points match
 
character*(*) function f1 (str, i, j)
character str*(*), e1*(*), e2*(*)
integer i, j
f1 = str (i:j)
return
entry e1 (str, i, j)
i = i + 1
entry e2 (str, i, j)
j = j - 1
e2 = str (i:j)
end function
 
character*5 function f3 ()
character e3*(*), e4*(*)
integer i
f3 = 'ABCDE'
return
entry e3 (i)
entry e4 (i)
if (i .gt. 0) then
e3 = 'abcde'
else
e4 = 'UVWXY'
endif
end function
 
program entrytest
character f1*16, e1*16, e2*16, str*16, ret*16
character f3*5, e3*5, e4*5
integer i, j
str = 'ABCDEFGHIJ'
i = 2
j = 6
ret = f1 (str, i, j)
if ((i .ne. 2) .or. (j .ne. 6)) call abort ()
if (ret .ne. 'BCDEF') call abort ()
ret = e1 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 5)) call abort ()
if (ret .ne. 'CDE') call abort ()
ret = e2 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 4)) call abort ()
if (ret .ne. 'CD') call abort ()
if (f3 () .ne. 'ABCDE') call abort ()
if (e3 (1) .ne. 'abcde') call abort ()
if (e4 (1) .ne. 'abcde') call abort ()
if (e3 (0) .ne. 'UVWXY') call abort ()
if (e4 (0) .ne. 'UVWXY') call abort ()
end program
/gfortran.fortran-torture/execute/der_point.f90
0,0 → 1,45
! Program to test DERIVED type with components point to the DERIVED
! type itself, and two DERIVED type with componets point to each
! other.
program nest_derived
type record
integer :: value
type(record), pointer :: rp
end type record
 
type record1
integer value
type(record2), pointer :: r1p
end type
 
type record2
integer value
type(record1), pointer :: r2p
end type
type(record), target :: e1, e2, e3
type(record1), target :: r1
type(record2), target :: r2
nullify(r1%r1p,r2%r2p,e1%rp,e2%rp,e3%rp)
 
r1%r1p => r2
r2%r2p => r1
e1%rp => e2
e2%rp => e3
 
r1%value = 11
r2%value = 22
 
e1%value = 33
e1%rp%value = 44
e1%rp%rp%value = 55
 
if (r1%r1p%value .ne. 22) call abort
if (r2%r2p%value .ne. 11) call abort
if (e1%value .ne. 33) call abort
if (e2%value .ne. 44) call abort
if (e3%value .ne. 55) call abort
if (r1%value .ne. 11) call abort
if (r2%value .ne. 22) call abort
 
end
/gfortran.fortran-torture/execute/entry_4.f90
0,0 → 1,64
! Test alternate entry points for functions when the result types
! of all entry points don't match
 
integer function f1 (a)
integer a, b
double precision e1
f1 = 15 + a
return
entry e1 (b)
e1 = 42 + b
end function
complex function f2 (a)
integer a
logical e2
entry e2 (a)
if (a .gt. 0) then
e2 = a .lt. 46
else
f2 = 45
endif
end function
function f3 (a) result (r)
integer a, b
real r
logical s
complex c
r = 15 + a
return
entry e3 (b) result (s)
s = b .eq. 42
return
entry g3 (b) result (c)
c = b + 11
end function
function f4 (a) result (r)
logical r
integer a, s
double precision t
entry e4 (a) result (s)
entry g4 (a) result (t)
r = a .lt. 0
if (a .eq. 0) s = 16 + a
if (a .gt. 0) t = 17 + a
end function
 
program entrytest
integer f1, e4
real f3
double precision e1, g4
logical e2, e3, f4
complex f2, g3
if (f1 (6) .ne. 21) call abort ()
if (e1 (7) .ne. 49) call abort ()
if (f2 (0) .ne. 45) call abort ()
if (.not. e2 (45)) call abort ()
if (e2 (46)) call abort ()
if (f3 (17) .ne. 32) call abort ()
if (.not. e3 (42)) call abort ()
if (e3 (41)) call abort ()
if (g3 (12) .ne. 23) call abort ()
if (.not. f4 (-5)) call abort ()
if (e4 (0) .ne. 16) call abort ()
if (g4 (2) .ne. 19) call abort ()
end
/gfortran.fortran-torture/execute/pr43390.f90
0,0 → 1,9
logical :: l1(4)
logical :: l2(4)
l1 = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./)
l2 = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./)
if (dot_product (l1, l2)) call abort ()
l2 = .TRUE.
if (.not.dot_product (l1, l2)) call abort ()
end
 
/gfortran.fortran-torture/execute/list_read_1.f90
0,0 → 1,54
! pr 14942, list directed io
program d
implicit none
integer i, j, m, n, nin, k
real x(3,4)
data x / 1,1,1,2,2,2,3,3,3,4,4,4 /
real y(3,4)
data y / 1,1,1,2,2,2,3,3,3,4,4,4 /
logical debug ! set me true to see the output
debug = .FALSE.
nin = 1
n = 4
open(unit = nin)
write(nin,*) n
do I = 1,3
write(nin,*)(x(i,j), j=1, n)
end do
m = 3
n = 4
write(nin,*) m,n
do I = 1,3
write(nin,*)(x(i,j), j=1, n)
enddo
close(nin)
! ok, the data file is written
open(unit = nin)
read(nin, fmt = *) n
if (debug ) write(*,'(A,I2)') 'n = ', n
do i = 1, 3
do K = 1,n
x(i,k) = -1
enddo
read(nin, fmt = *) (x(i,j), j=1, n)
if (debug) write(*, *) (x(i,j), j=1, n)
do K = 1,n
if (x(i,k).ne.y(i,k)) call abort
end do
end do
m = 0
n = 0
read(nin, fmt = *) m, n
if (debug) write(*,'(A,I2,2X,A,I2)') 'm = ', m, 'n = ', n
do i = 1, m
do K = 1,n
x(i,k) = -1
enddo
read(nin, fmt = *) (x(i,j), j=1, n)
if (debug) write(*, *) (x(i,j), j=1, n)
do K = 1,n
if (x(i,k).ne.y(i,k)) call abort
end do
end do
close(nin, status='delete')
end program d
/gfortran.fortran-torture/execute/intrinsic_sum.f90
0,0 → 1,47
! Program to test the FORALL construct
program testforall
implicit none
integer, dimension (3, 3) :: a
integer, dimension (3) :: b
logical, dimension (3, 3) :: m, tr
integer i
character(len=9) line
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));
 
tr = .true.
 
if (sum(a) .ne. 45) call abort
write (line, 9000) sum(a)
if (line .ne. ' 45 ') call abort
b = sum (a, 1)
if (b(1) .ne. 6) call abort
if (b(2) .ne. 15) call abort
if (b(3) .ne. 24) call abort
write (line, 9000) sum (a, 1)
if (line .ne. ' 6 15 24') call abort
 
m = .true.
m(1, 1) = .false.
m(2, 1) = .false.
 
if (sum (a, mask=m) .ne. 42) call abort
if (sum (a, mask=m .and. tr) .ne. 42) call abort
 
write(line, 9000) sum (a, mask=m)
if (line .ne. ' 42 ') call abort
 
b = sum (a, 2, m)
if (b(1) .ne. 11) call abort
if (b(2) .ne. 13) call abort
if (b(3) .ne. 18) call abort
 
b = sum (a, 2, m .and. tr)
if (b(1) .ne. 11) call abort
if (b(2) .ne. 13) call abort
if (b(3) .ne. 18) call abort
write (line, 9000) sum (a, 2, m)
if (line .ne. ' 11 13 18') call abort
 
9000 format(3I3)
end program
/gfortran.fortran-torture/execute/entry_6.f90
0,0 → 1,109
! Test alternate entry points for functions when the result types
! of all entry points match
 
function f1 (a)
integer, dimension (2, 2) :: a, b, f1, e1
f1 (:, :) = 15 + a (1, 1)
return
entry e1 (b)
e1 (:, :) = 42 + b (1, 1)
end function
function f2 ()
real, dimension (2, 2) :: f2, e2
entry e2 ()
e2 (:, :) = 45
end function
function f3 ()
double precision, dimension (2, 2) :: a, b, f3, e3
entry e3 ()
f3 (:, :) = 47
end function
function f4 (a) result (r)
double precision, dimension (2, 2) :: a, b, r, s
r (:, :) = 15 + a (1, 1)
return
entry e4 (b) result (s)
s (:, :) = 42 + b (1, 1)
end function
function f5 () result (r)
integer, dimension (2, 2) :: r, s
entry e5 () result (s)
r (:, :) = 45
end function
function f6 () result (r)
real, dimension (2, 2) :: r, s
entry e6 () result (s)
s (:, :) = 47
end function
 
program entrytest
interface
function f1 (a)
integer, dimension (2, 2) :: a, f1
end function
function e1 (b)
integer, dimension (2, 2) :: b, e1
end function
function f2 ()
real, dimension (2, 2) :: f2
end function
function e2 ()
real, dimension (2, 2) :: e2
end function
function f3 ()
double precision, dimension (2, 2) :: f3
end function
function e3 ()
double precision, dimension (2, 2) :: e3
end function
function f4 (a)
double precision, dimension (2, 2) :: a, f4
end function
function e4 (b)
double precision, dimension (2, 2) :: b, e4
end function
function f5 ()
integer, dimension (2, 2) :: f5
end function
function e5 ()
integer, dimension (2, 2) :: e5
end function
function f6 ()
real, dimension (2, 2) :: f6
end function
function e6 ()
real, dimension (2, 2) :: e6
end function
end interface
integer, dimension (2, 2) :: i, j
real, dimension (2, 2) :: r
double precision, dimension (2, 2) :: d, e
i (:, :) = 6
j = f1 (i)
if (any (j .ne. 21)) call abort ()
i (:, :) = 7
j = e1 (i)
j (:, :) = 49
if (any (j .ne. 49)) call abort ()
r = f2 ()
if (any (r .ne. 45)) call abort ()
r = e2 ()
if (any (r .ne. 45)) call abort ()
e = f3 ()
if (any (e .ne. 47)) call abort ()
e = e3 ()
if (any (e .ne. 47)) call abort ()
d (:, :) = 17
e = f4 (d)
if (any (e .ne. 32)) call abort ()
e = e4 (d)
if (any (e .ne. 59)) call abort ()
j = f5 ()
if (any (j .ne. 45)) call abort ()
j = e5 ()
if (any (j .ne. 45)) call abort ()
r = f6 ()
if (any (r .ne. 47)) call abort ()
r = e6 ()
if (any (r .ne. 47)) call abort ()
end
/gfortran.fortran-torture/execute/strarray_1.f90
0,0 → 1,13
subroutine foo(i)
character c
integer i
character(1),parameter :: hex_chars(0:15)=&
(/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/)
 
c = hex_chars(i)
if (c.ne.'3') call abort()
end
 
program strarray_1
call foo(3)
end
/gfortran.fortran-torture/execute/entry_8.f90
0,0 → 1,24
module entry_8_m
type t
integer i
real x (5)
end type t
end module entry_8_m
 
function f (i)
use entry_8_m
type (t) :: f,g
f % i = i
return
entry g (x)
g%x = x
end function f
 
use entry_8_m
type (t) :: f, g, res
 
res = f (42)
if (res%i /= 42) call abort ()
res = g (1.)
if (any (res%x /= 1.)) call abort ()
end
/gfortran.fortran-torture/execute/seq_io.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/slash_edit.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/strarray_3.f90
0,0 → 1,50
program strarray_3
character(len=5), dimension(2) :: c
c(1) = "Hello"
c(2) = "World"
 
call foo1(c)
call foo2(c, 2)
call foo3(c, 5)
call foo4(c, 5, 2)
call foo5(c(2:1:-1))
contains
subroutine foo1(a)
implicit none
character(len=5), dimension(2) :: a
 
if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort
end subroutine
 
subroutine foo2(a, m)
implicit none
integer m
character(len=5), dimension(m) :: a
 
if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort
end subroutine
 
subroutine foo3(a, n)
implicit none
integer n
character(len=n), dimension(:) :: a
 
if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort
end subroutine
 
subroutine foo4(a, n, m)
implicit none
integer n, m
character(len=n), dimension(m) :: a
 
if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort
end subroutine
 
subroutine foo5(a)
implicit none
character(len=2), dimension(5) :: a
 
if ((a(1) .ne. "Wo") .or. (a(3) .ne. "dH") .or. (a(5) .ne. "lo")) call abort
end subroutine
end program
/gfortran.fortran-torture/execute/bounds.f90
0,0 → 1,38
! Program to test the upper and lower bound intrinsics
program testbounds
implicit none
real, dimension(:, :), allocatable :: a
integer, dimension(5) :: j
integer i
 
! Check compile time simplification
if (lbound(j,1).ne.1 .or. ubound(j,1).ne.5) call abort ()
 
allocate (a(3:8, 6:7))
 
! With one parameter
j = 0;
j(3:4) = ubound(a)
if (j(3) .ne. 8) call abort
if (j(4) .ne. 7) call abort
 
! With two parameters, assigning to an array
j = lbound(a, 1)
if ((j(1) .ne. 3) .or. (j(5) .ne. 3)) call abort
 
! With a variable second parameter
i = 2
i = lbound(a, i)
if (i .ne. 6) call abort
 
call test(a)
contains
subroutine test (a)
real, dimension (1:, 1:) :: a
integer i
 
i = 2
if ((ubound(a, 1) .ne. 6) .or. (ubound(a, i) .ne. 2)) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/power.f90
0,0 → 1,75
! Program to test the power (**) operator
program testpow
implicit none
real(kind=4) r, s, two
real(kind=8) :: q
complex(kind=4) :: c, z
real, parameter :: del = 0.0001
integer i, j
 
i = 2
j = i ** 10
if (abs (j - 1024) .gt. del) call abort
j = i ** (-10)
if (abs (j - 0) .gt. del) call abort
j = i ** 0
if (abs (j - 1) .gt. del) call abort
i = 1
j = i ** 10
if (abs (j - 1) .gt. del) call abort
j = i ** (-10)
if (abs (j - 1) .gt. del) call abort
j = i ** 0
if (abs (j - 1) .gt. del) call abort
i = -1
j = i ** 10
if (abs (j - 1) .gt. del) call abort
j = i ** (-10)
if (abs (j - 1) .gt. del) call abort
j = i ** 0
if (abs (j - 1) .gt. del) call abort
j = i ** 11
if (abs (j - (-1)) .gt. del) call abort
j = i ** (-11)
if (abs (j - (-1)) .gt. del) call abort
 
c = (2.0, 3.0)
z = c ** 2
if (abs(z - (-5.0, 12.0)) .gt. del) call abort
z = c ** 7
if (abs(z - (6554.0, 4449.0)) .gt. del) call abort
 
two = 2.0
 
r = two ** 1
if (abs (r - 2.0) .gt. del) call abort
r = two ** 2
if (abs (r - 4.0) .gt. del) call abort
r = two ** 3
if (abs (r - 8.0) .gt. del) call abort
r = two ** 4
if (abs (r - 16.0) .gt. del) call abort
r = two ** 0
if (abs (r - 1.0) .gt. del) call abort
r = two ** (-1)
if (abs (r - 0.5) .gt. del) call abort
r = two ** (-2)
if (abs (r - 0.25) .gt. del) call abort
r = two ** (-4)
if (abs (r - 0.0625) .gt. del) call abort
s = 3.0
r = two ** s
if (abs (r - 8.0) .gt. del) call abort
s = -3.0
r = two ** s
if (abs (r - 0.125) .gt. del) call abort
i = 3
r = two ** i
if (abs (r - 8.0) .gt. del) call abort
i = -3
r = two ** i
if (abs (r - 0.125) .gt. del) call abort
c = (2.0, 3.0)
c = c ** two
if (abs(c - (-5.0, 12.0)) .gt. del) call abort
end program
/gfortran.fortran-torture/execute/unopened_unit_1.f90
0,0 → 1,14
! PR 14565
program unopened_unit_1
Integer I,J
Do I = 1,10
Write(99,*)I
End Do
Rewind(99)
Do I = 1,10
Read(99,*)J
If (J.ne.I) Call abort
End Do
Close(99, Status='Delete')
End program
 
/gfortran.fortran-torture/execute/forall_1.f90
0,0 → 1,61
! Program to test FORALL construct
program forall_1
 
call actual_variable ()
call negative_stride ()
call forall_index ()
 
contains
subroutine actual_variable ()
integer:: x = -1
integer a(3,4)
j = 100
! Actual variable 'x' and 'j' used as FORALL index
forall (x = 1:3, j = 1:4)
a (x,j) = j
end forall
if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
if ((x.ne.-1).or.(j.ne.100)) call abort
 
call actual_variable_2 (x, j, a)
end subroutine
 
subroutine actual_variable_2(x, j, a)
integer x,j,x1,j1
integer a(3,4), b(3,4)
 
! Actual variable 'x' and 'j' used as FORALL index.
forall (x=3:1:-1, j=4:1:-1)
a(x,j) = j
b(x,j) = j
end forall
 
if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
if (any (b.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
if ((x.ne.-1).or.(j.ne.100)) call abort
end subroutine
 
subroutine negative_stride ()
integer a(3,4)
integer x, j
 
! FORALL with negative stride
forall (x = 3:1:-1, j = 4:1:-1)
a(x,j) = j + x
end forall
if (any (a.ne.reshape ((/2,3,4,3,4,5,4,5,6,5,6,7/), (/3,4/)))) call abort
end subroutine
 
subroutine forall_index
integer a(32,32)
 
! FORALL with arbitrary number indexes
forall (i1=1:2,i2=1:2,i3=1:2,i4=1:2,i5=1:2,i6=1:2,i7=1:2,i8=1:2,i9=1:2,&
i10=1:2)
a(i1+2*i3+4*i5+8*i7+16*i9-30,i2+2*i4+4*i6+8*i8+16*i10-30) = 1
end forall
if ((a(5,5).ne.1).or. (a(32,32).ne.1)) call abort
end subroutine
 
end
/gfortran.fortran-torture/execute/execute.exp
0,0 → 1,106
# Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
 
# This file was written by Rob Savoye. (rob@cygnus.com)
# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com)
 
#
# These tests come from many different contributors.
#
 
if $tracelevel then {
strace $tracelevel
}
 
# load support procs
load_lib fortran-torture.exp
load_lib torture-options.exp
 
torture-init
set-torture-options [get-fortran-torture-options]
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f90]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F90]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f95]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F95]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f03]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F03]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f08]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F08]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture-execute $testcase
}
 
torture-finish
/gfortran.fortran-torture/execute/intrinsic_associated.f90
0,0 → 1,134
! Program to test the ASSOCIATED intrinsic.
program intrinsic_associated
call pointer_to_section ()
call associate_1 ()
call pointer_to_derived_1 ()
call associated_2 ()
end
 
subroutine pointer_to_section ()
integer, dimension(5, 5), target :: xy
integer, dimension(:, :), pointer :: window
data xy /25*0/
logical t
 
window => xy(2:4, 3:4)
window = 10
window (1, 1) = 0101
window (3, 2) = 4161
window (3, 1) = 4101
window (1, 2) = 0161
 
t = associated (window, xy(2:4, 3:4))
if (.not.t) call abort ()
! Check that none of the array got mangled
if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
.or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
if (any (xy(:, 1:2) .ne. 0)) call abort ()
if (any (xy(:, 5) .ne. 0)) call abort ()
if (any (xy (1, 3:4) .ne. 0)) call abort ()
if (any (xy (5, 3:4) .ne. 0)) call abort ()
if (xy(3, 3) .ne. 10) call abort ()
if (xy(3, 4) .ne. 10) call abort ()
if (any (xy(2:4, 3:4) .ne. window)) call abort ()
end
 
subroutine sub1 (a, ap)
integer, pointer :: ap(:, :)
integer, target :: a(10, 10)
 
ap => a
end
 
subroutine nullify_pp (a)
integer, pointer :: a(:, :)
 
if (.not. associated (a)) call abort ()
nullify (a)
end
 
subroutine associate_1 ()
integer, pointer :: a(:, :), b(:, :)
interface
subroutine nullify_pp (a)
integer, pointer :: a(:, :)
end subroutine nullify_pp
end interface
 
allocate (a(80, 80))
b => a
if (.not. associated(a)) call abort ()
if (.not. associated(b)) call abort ()
call nullify_pp (a)
if (associated (a)) call abort ()
if (.not. associated (b)) call abort ()
end
 
subroutine pointer_to_derived_1 ()
type record
integer :: value
type(record), pointer :: rp
end type record
 
type record1
integer value
type(record2), pointer :: r1p
end type
 
type record2
integer value
type(record1), pointer :: r2p
end type
 
type(record), target :: e1, e2, e3
type(record1), target :: r1
type(record2), target :: r2
 
nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
if (associated (r1%r1p)) call abort ()
if (associated (r2%r2p)) call abort ()
if (associated (e2%rp)) call abort ()
if (associated (e1%rp)) call abort ()
if (associated (e3%rp)) call abort ()
r1%r1p => r2
r2%r2p => r1
r1%value = 11
r2%value = 22
e1%rp => e2
e2%rp => e3
e1%value = 33
e1%rp%value = 44
e1%rp%rp%value = 55
if (.not. associated (r1%r1p)) call abort ()
if (.not. associated (r2%r2p)) call abort ()
if (.not. associated (e1%rp)) call abort ()
if (.not. associated (e2%rp)) call abort ()
if (associated (e3%rp)) call abort ()
if (r1%r1p%value .ne. 22) call abort ()
if (r2%r2p%value .ne. 11) call abort ()
if (e1%value .ne. 33) call abort ()
if (e2%value .ne. 44) call abort ()
if (e3%value .ne. 55) call abort ()
if (r1%value .ne. 11) call abort ()
if (r2%value .ne. 22) call abort ()
 
end
 
subroutine associated_2 ()
integer, pointer :: xp(:, :)
integer, target :: x(10, 10)
integer, target :: y(100, 100)
interface
subroutine sub1 (a, ap)
integer, pointer :: ap(:, :)
integer, target :: a(10, 1)
end
endinterface
 
xp => y
if (.not. associated (xp)) call abort ()
call sub1 (x, xp)
if (associated (xp, y)) call abort ()
if (.not. associated (xp, x)) call abort ()
end
 
/gfortran.fortran-torture/execute/forall_3.f90
0,0 → 1,37
! PR fortran/15080
! Really test forall with temporary
program evil_forall
implicit none
type t
logical valid
integer :: s
integer, dimension(:), pointer :: p
end type
type (t), dimension (5) :: v
integer i
 
allocate (v(1)%p(2))
allocate (v(2)%p(8))
v(3)%p => NULL()
allocate (v(4)%p(8))
allocate (v(5)%p(2))
 
v(:)%valid = (/.true., .true., .false., .true., .true./)
v(:)%s = (/1, 8, 999, 6, 2/)
v(1)%p(:) = (/9, 10/)
v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
v(5)%p(:) = (/11, 12/)
 
 
forall (i=1:5,v(i)%valid)
v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s)
end forall
 
if (any(v(1)%p(:) .ne. (/11, 10/))) call abort
if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort
if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort
if (any(v(5)%p(:) .ne. (/9, 10/))) call abort
 
! I should really free the memory I've allocated.
end program
/gfortran.fortran-torture/execute/forall_5.f90
0,0 → 1,28
! Program to test FORALL with pointer assignment inside it.
program forall_5
type element
integer, pointer, dimension(:)::p
end type
 
type (element) q(5)
integer, target, dimension(25)::t
 
n = 5
do i = 1,5
q(i)%p => t((i-1)*n + 1:i*n)
enddo
 
forall (i = 2:5)
q(i)%p => q(i-1)%p
end forall
 
do i = 1, 25
t(i) = i
enddo
 
if (any(q(1)%p .ne. (/1,2,3,4,5/))) call abort
if (any(q(2)%p .ne. (/1,2,3,4,5/))) call abort
if (any(q(3)%p .ne. (/6,7,8,9,10/))) call abort
if (any(q(4)%p .ne. (/11,12,13,14,15/))) call abort
if (any(q(5)%p .ne. (/16,17,18,19,20/))) call abort
end
/gfortran.fortran-torture/execute/forall_7.f90
0,0 → 1,88
! tests FORALL statements with a mask
program forall_7
real, dimension (5, 5, 5, 5) :: a, b, c, d
 
a (:, :, :, :) = 4
forall (i = 1:5)
a (i, i, 6 - i, i) = 7
end forall
forall (i = 1:5)
a (i, 6 - i, i, i) = 7
end forall
forall (i = 1:5)
a (6 - i, i, i, i) = 7
end forall
forall (i = 1:5:2)
a (1, 2, 3, i) = 0
end forall
 
b = a
c = a
d = a
 
forall (i = 1:5, j = 1:5, k = 1:5, ((a (i, j, k, i) .gt. 6) .or. (a (i, j, k, j) .gt. 6)))
forall (l = 1:5, a (1, 2, 3, l) .lt. 2)
a (i, j, k, l) = i - j + k - l + 0.5
end forall
end forall
 
forall (l = 1:5, b (1, 2, 3, l) .lt. 2)
forall (i = 1:5, j = 1:5, k = 1:5, ((b (i, j, k, i) .gt. 6) .or. (b (i, j, k, j) .gt. 6)))
b (i, j, k, l) = i - j + k - l + 0.5
end forall
end forall
 
forall (i = 1:5, j = 1:5, k = 1:5, ((c (i, j, k, i) .gt. 6) .or. (c (i, j, k, j) .gt. 6)))
forall (l = 1:5, c (1, 2, 3, l) .lt. 2)
c (i, j, k, l) = i - j + k - l + 0.5 + c (l, k, j, i)
end forall
end forall
 
forall (l = 1:5, d (1, 2, 3, l) .lt. 2)
forall (i = 1:5, j = 1:5, k = 1:5, ((d (i, j, k, i) .gt. 6) .or. (d (i, j, k, j) .gt. 6)))
d (i, j, k, l) = i - j + k - l + 0.5 + d (l, k, j, i)
end forall
end forall
 
do i = 1, 5
do j = 1, 5
do k = 1, 5
do l = 1, 5
r = 4
if ((i == j .and. k == 6 - i) .or. (i == k .and. j == 6 - i)) then
if (l /= 2 .and. l /= 4) then
r = 1
elseif (l == i) then
r = 7
end if
elseif (j == k .and. i == 6 - j) then
if (l /= 2 .and. l /= 4) then
r = 1
elseif (l == j) then
r = 7
end if
elseif (i == 1 .and. j == 2 .and. k == 3 .and. l /= 2 .and. l /= 4) then
r = 0
end if
s = r
if (r == 1) then
r = i - j + k - l + 0.5
if (((l == k .and. j == 6 - l) .or. (l == j .and. k == 6 - l)) .and. (i == l)) then
s = r + 7
elseif (k == j .and. l == 6 - k .and. i == k) then
s = r + 7
elseif (l /= 1 .or. k /= 2 .or. j /= 3 .or. i == 2 .or. i == 4) then
s = r + 4
else
s = r
end if
end if
if (a (i, j, k, l) /= r) call abort ()
if (c (i, j, k, l) /= s) call abort ()
end do
end do
end do
end do
 
if (any (a /= b .or. c /= d)) call abort ()
end
/gfortran.fortran-torture/execute/intrinsic_spacing.f90
0,0 → 1,35
!Program to test SPACING intrinsic function.
 
program test_spacing
call test_real4(3.0)
call test_real4(33.0)
call test_real4(-3.)
call test_real4(0.0)
call test_real8(0.0_8)
call test_real8(3.0_8)
call test_real8(33.0_8)
call test_real8(-33._8)
end
subroutine test_real4(orig)
real x,y,t,orig
integer p
x = orig
p = 24
y = 2.0 ** (exponent (x) - p)
t = tiny(x)
x = spacing(x)
if ((abs (x - y) .gt. abs(x * 1e-6)) &
.and. (abs (x - t) .gt. abs(x * 1e-6)))call abort
end
 
subroutine test_real8(orig)
real*8 x,y,t,orig
integer p
x = orig
p = 53
y = 2.0 ** (exponent (x) - p)
t = tiny (x)
x = spacing(x)
if ((abs (x - y) .gt. abs(x * 1e-6)) &
.and. (abs (x - t) .gt. abs(x * 1e-6)))call abort
end
/gfortran.fortran-torture/execute/string.f90
0,0 → 1,15
! Program to test string handling
program string
implicit none
character(len=5) :: a, b
character(len=20) :: c
 
a = 'Hello'
b = 'World'
c = a//b
 
if (c .ne. 'HelloWorld') call abort
if (c .eq. 'WorldHello') call abort
if (a//'World' .ne. 'HelloWorld') call abort
if (a .ge. b) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90
0,0 → 1,22
program intrinsic_mmloc_2
real a(-1:1), b(2:3), c(1:2)
integer, dimension(1):: i
real (kind = 8), dimension(-1:1) :: vc
 
a = 0
b = 0
c = 0
a(-1) = 1
b(2) = 1
c(1) = 1
 
if (maxloc (a, 1) .ne. 1) call abort()
if (maxloc (b, 1) .ne. 1) call abort()
if (maxloc (c, 1) .ne. 1) call abort()
 
 
! We were giving MINLOC and MAXLOC the wrong return type
vc = (/4.0d0, 2.50d1, 1.0d1/)
i = minloc (vc)
if (i(1) .ne. 1) call abort()
END PROGRAM
/gfortran.fortran-torture/execute/retarray_2.f90
0,0 → 1,20
! Procedure to test module procedures returning arrays.
! The array spec only gets applied to the result variable, not the function
! itself. As a result we missed it during resolution, and used the wrong
! calling convention (functions returning arrays must always have explicit
! interfaces).
module retarray_2
contains
function z(a) result (aout)
integer, dimension(4) :: aout,a
aout = a
end function z
end module retarray_2
 
program retarray
use retarray_2
integer, dimension(4) :: b, a=(/1,2,3,4/)
b = z(a)
if (any (b .ne. (/1, 2, 3, 4/))) call abort
end
 
/gfortran.fortran-torture/execute/plusconst_1.f90
0,0 → 1,15
! PR14005
! The GMP conversion routines object to a leading "+"
program plusconst_1
implicit none
real p
integer i
data p /+3.1415/
data i /+42/
real :: q = +1.234
integer :: j = +100
 
if ((p .ne. 3.1415) .or. (i .ne. 42) .or. (q .ne. 1.234) .or. (j .ne. 100)) &
call abort
end program
 
/gfortran.fortran-torture/execute/intrinsic_count.f90
0,0 → 1,34
! Program to test the COUNT intrinsic
program intrinsic_count
implicit none
logical(kind=4), dimension (3, 5) :: a
integer(kind=4), dimension (3) :: b
integer i
character(len=10) line
 
a = .false.
if (count(a) .ne. 0) call abort
a = .true.
if (count(a) .ne. 15) call abort
a(1, 1) = .false.
a(2, 2) = .false.
a(2, 5) = .false.
if (count(a) .ne. 12) call abort
write (line, 9000) count(a)
read (line, 9000) i
if (i .ne. 12) call abort
 
b(1:3) = count(a, 2);
if (b(1) .ne. 4) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 5) call abort
b = 0
write (line, 9000) count(a,2)
read (line, 9000) b
if (b(1) .ne. 4) call abort
if (b(2) .ne. 3) call abort
if (b(3) .ne. 5) call abort
 
9000 format(3I3)
 
end program
/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90
0,0 → 1,13
! Check zero sized arrays work correcly
! From PR12704
program intrinsic_mmloc_4
integer, allocatable, dimension(:) :: d
integer, allocatable, dimension(:,:) :: a
integer, dimension(2) :: b
 
allocate (d(0))
if (maxloc (d, 1) .ne. 0) call abort()
allocate (a(1, 0))
b = minloc (a)
if (any (b .ne. 0)) call abort()
end program
/gfortran.fortran-torture/execute/integer_select_1.f90
0,0 → 1,31
INTEGER :: I = 1
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
CALL abort
CASE (1)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
I = -3
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
CALL abort
CASE (1)
CONTINUE
CASE DEFAULT
CONTINUE
END SELECT
 
I = -5
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
CALL abort
CASE (-5)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
END
 
/gfortran.fortran-torture/execute/st_function_2.f90
0,0 → 1,21
! PR15620
! Check that evaluating a statement function doesn't affect the value of
! its dummy argument variables.
program st_function_2
integer fn, a, b
fn(a, b) = a + b
if (foo(1) .ne. 43) call abort
 
! Check that values aren't modified when avaluating the arguments.
a = 1
b = 5
if (fn (b + 2, a + 3) .ne. 11) call abort
contains
function foo (x)
integer z, y, foo, x
bar(z) = z*z
z = 42
t = bar(x)
foo = t + z
end function
end program
/gfortran.fortran-torture/execute/emptyif.f90
0,0 → 1,20
! Test empty if statements. We Used to fail this because we folded
! the if stmt before we finished building it.
program emptyif
implicit none
integer i
i=1
if(i .le. 0) then
else
i = 2
endif
if (i .ne. 2) call abort()
 
if (i .eq. 0) then
elseif (i .eq. 2) then
i = 3
end if
if (i .ne. 3) call abort()
end
 
/gfortran.fortran-torture/execute/der_init_2.f90
0,0 → 1,15
! PR 15314
! We were looking at the type of the initialization expression, not the type
! of the field.
program der_init_2
implicit none
type foo
integer :: a(3) = 42
integer :: b = 123
end type
 
type (foo) :: v
 
if ((v%b .ne. 123) .or. any (v%a .ne. 42)) call abort ();
end program
 
/gfortran.fortran-torture/execute/der_init_4.f90
0,0 → 1,15
! PR13930
! We were trying to assign a default initializer to dummy variables.
program der_init_4
type t
integer :: i = 42
end type
 
call foo(t(5))
contains
subroutine foo(a)
type (t), intent(in) :: a
 
if (a%i .ne. 5) call abort
end subroutine
end program
/gfortran.fortran-torture/execute/intrinsic_merge.f90
0,0 → 1,15
! Program to test the MERGE intrinsic
program intrinsic_merge
integer, dimension(3) :: a, b
integer i
 
a = (/-1, 2, 3/)
 
i = 5
if (merge (-1, 1, i .gt. 3) .ne. -1) call abort
i = 1
if (merge (-1, 1, i .ge. 3) .ne. 1) call abort
 
b = merge(a, 0, a .ge. 0)
if (any (b .ne. (/0, 2, 3/))) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_matmul.f90
0,0 → 1,32
! Program to test the MATMUL intrinsic
program intrinsic_matmul
implicit none
integer, dimension(2, 3) :: a
integer, dimension(3, 2) :: b
integer, dimension(2) :: x
integer, dimension(3) :: y
integer, dimension(2, 2) :: r
integer, dimension(3) :: v
real, dimension (2,2) :: aa
real, dimension (4,2) :: cc
 
a = reshape((/1, 2, 2, 3, 3, 4/), (/2, 3/))
b = reshape((/1, 2, 3, 3, 4, 5/), (/3, 2/))
x = (/1, 2/)
y = (/1, 2, 3/)
 
r = matmul(a, b)
if (any(r .ne. reshape((/14, 20, 26, 38/), (/2, 2/)))) call abort
 
v = matmul(x, a)
if (any(v .ne. (/5, 8, 11/))) call abort
 
v(1:2) = matmul(a, y)
if (any(v(1:2) .ne. (/14, 20/))) call abort
 
aa = reshape((/ 1.0, 1.0, 0.0, 1.0/), shape(aa))
cc = 42.
cc(1:2,1:2) = matmul(aa, transpose(aa))
if (any(cc(1:2,1:2) .ne. reshape((/ 1.0, 1.0, 1.0, 2.0 /), (/2,2/)))) call abort
if (any(cc(3:4,1:2) .ne. 42.)) call abort
end program
/gfortran.fortran-torture/execute/in-pack.f90
0,0 → 1,92
! Check in_pack and in_unpack for integer and comlex types, with
! alignment issues thrown in for good measure.
 
program main
implicit none
 
complex(kind=4) :: a4(5),b4(5),aa4(5),bb4(5)
real(kind=4) :: r4(100)
equivalence(a4(1),r4(1)),(b4(1),r4(12))
 
complex(kind=8) :: a8(5),b8(5),aa8(5),bb8(5)
real(kind=8) :: r8(100)
equivalence(a8(1),r8(1)),(b8(1),r8(12))
 
integer(kind=4) :: i4(5),ii4(5)
integer(kind=8) :: i8(5),ii8(5)
 
integer :: i
 
a4 = (/(cmplx(i,-i,kind=4),i=1,5)/)
b4 = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
call csub4(a4(5:1:-1),b4(5:1:-1),5)
aa4 = (/(cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
if (any(aa4 /= a4)) call abort
bb4 = (/(2*cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
if (any(bb4 /= b4)) call abort
 
a8 = (/(cmplx(i,-i,kind=8),i=1,5)/)
b8 = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
call csub8(a8(5:1:-1),b8(5:1:-1),5)
aa8 = (/(cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
if (any(aa8 /= a8)) call abort
bb8 = (/(2*cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
if (any(bb8 /= b8)) call abort
 
i4 = (/(i, i=1,5)/)
call isub4(i4(5:1:-1),5)
ii4 = (/(5-i+1,i=1,5)/)
if (any(ii4 /= i4)) call abort
 
i8 = (/(i,i=1,5)/)
call isub8(i8(5:1:-1),5)
ii8 = (/(5-i+1,i=1,5)/)
if (any(ii8 /= i8)) call abort
 
end program main
 
subroutine csub4(a,b,n)
implicit none
complex(kind=4), dimension(n) :: a,b
complex(kind=4), dimension(n) :: aa, bb
integer :: n, i
aa = (/(cmplx(n-i+1,i-n-1,kind=4),i=1,n)/)
if (any(aa /= a)) call abort
bb = (/(2*cmplx(n-i+1,i-n-1,kind=4),i=1,5)/)
if (any(bb /= b)) call abort
a = (/(cmplx(i,-i,kind=4),i=1,5)/)
b = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
end subroutine csub4
 
subroutine csub8(a,b,n)
implicit none
complex(kind=8), dimension(n) :: a,b
complex(kind=8), dimension(n) :: aa, bb
integer :: n, i
aa = (/(cmplx(n-i+1,i-n-1,kind=8),i=1,n)/)
if (any(aa /= a)) call abort
bb = (/(2*cmplx(n-i+1,i-n-1,kind=8),i=1,5)/)
if (any(bb /= b)) call abort
a = (/(cmplx(i,-i,kind=8),i=1,5)/)
b = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
end subroutine csub8
 
subroutine isub4(a,n)
implicit none
integer(kind=4), dimension(n) :: a
integer(kind=4), dimension(n) :: aa
integer :: n, i
aa = (/(n-i+1,i=1,n)/)
if (any(aa /= a)) call abort
a = (/(i,i=1,5)/)
end subroutine isub4
 
subroutine isub8(a,n)
implicit none
integer(kind=8), dimension(n) :: a
integer(kind=8), dimension(n) :: aa
integer :: n, i
aa = (/(n-i+1,i=1,n)/)
if (any(aa /= a)) call abort
a = (/(i,i=1,5)/)
end subroutine isub8
/gfortran.fortran-torture/execute/straret.f90
0,0 → 1,18
! Test assumed length character functions.
 
character*(*) function f()
f = "Hello"
end function
 
character*6 function g()
g = "World"
end function
 
program straret
character*6 f, g
character*12 v
 
v = f() // g()
if (v .ne. "Hello World ") call abort ()
end program
/gfortran.fortran-torture/execute/constructor.f90
0,0 → 1,29
! Program to test array constructors
program constructors
integer, dimension (4) :: a
integer, dimension (3, 2) :: b
integer i, j, k, l, m, n
 
a = (/1, (i,i=2,4)/)
do i = 1, 4
if (a(i) .ne. i) call abort
end do
 
b = reshape ((/0, 1, 2, 3, 4, 5/), (/3, 2/)) + 1
do i=1,3
if (b(i, 1) .ne. i) call abort
if (b(i, 2) .ne. i + 3) call abort
end do
 
k = 1
l = 2
m = 3
n = 4
! The remainder assumes constant constructors work ok.
a = (/n, m, l, k/)
if (any (a .ne. (/4, 3, 2, 1/))) call abort
a = (/((/i+10, 42/), i = k, l)/)
if (any (a .ne. (/11, 42, 12, 42/))) call abort
a = (/(I, I=k,l) , (J, J=m,n)/)
if (any (a .ne. (/1, 2, 3, 4/))) call abort
end program
/gfortran.fortran-torture/execute/nan_inf_fmt.x
0,0 → 1,6
if [istarget "spu-*-*"] {
# No Inf/NaN support on SPU.
return 1
}
add-ieee-options
return 0
/gfortran.fortran-torture/execute/where_1.f90
0,0 → 1,41
! Program to test WHERE inside FORALL
program where_1
integer :: A(5,5)
 
A(1,:) = (/1,0,0,0,0/)
A(2,:) = (/2,1,1,1,0/)
A(3,:) = (/1,2,2,0,2/)
A(4,:) = (/2,1,0,2,3/)
A(5,:) = (/1,0,0,0,0/)
 
! Where inside FORALL.
! WHERE masks must be evaluated before executing the assignments
forall (I=1:5)
where (A(I,:) .EQ. 0)
A(:,I) = I
elsewhere (A(I,:) >2)
A(I,:) = 6
endwhere
end forall
 
if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 3, 0, &
0, 1, 4, 2, 0, 0, 5, 6, 6, 5/), (/5, 5/)))) call abort
 
! Where inside DO
A(1,:) = (/1,0,0,0,0/)
A(2,:) = (/2,1,1,1,0/)
A(3,:) = (/1,2,2,0,2/)
A(4,:) = (/2,1,0,2,3/)
A(5,:) = (/1,0,0,0,0/)
 
do I=1,5
where (A(I,:) .EQ. 0)
A(:,I) = I
elsewhere (A(I,:) >2)
A(I,:) = 6
endwhere
enddo
 
if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 6, 0, &
0, 1, 0, 2, 0, 0, 0, 5, 5, 5/), (/5, 5/)))) call abort
end
/gfortran.fortran-torture/execute/st_function.f90
0,0 → 1,87
! Program to test STATEMENT function
program st_fuction
call simple_case
call with_function_call
call with_character_dummy
call with_derived_type_dummy
call with_pointer_dummy
call multiple_eval
 
contains
subroutine simple_case
integer st1, st2
integer c(10, 10)
st1 (i, j) = i + j
st2 (i, j) = c(i, j)
 
if (st1 (1, 2) .ne. 3) call abort
c = 3
if (st2 (1, 2) .ne. 3 .or. st2 (2, 3) .ne. 3) call abort
end subroutine
 
subroutine with_function_call
integer fun, st3
st3 (i, j) = fun (i) + fun (j)
 
if (st3 (fun (2), 4) .ne. 16) call abort
end subroutine
 
subroutine with_character_dummy
character (len=4) s1, s2, st4
character (len=10) st5, s0
st4 (i, j) = "0123456789"(i:j)
st5 (s1, s2) = s1 // s2
 
if (st4 (1, 4) .ne. "0123" ) call abort
if (st5 ("01", "02") .ne. "01 02 ") call abort ! { dg-warning "Character length of actual argument shorter" }
end subroutine
 
subroutine with_derived_type_dummy
type person
integer age
character (len=50) name
end type person
type (person) me, p, tom
type (person) st6
st6 (p) = p
 
me%age = 5
me%name = "Tom"
tom = st6 (me)
if (tom%age .ne. 5) call abort
if (tom%name .gt. "Tom") call abort
end subroutine
 
subroutine with_pointer_dummy
character(len=4), pointer:: p, p1
character(len=4), target:: i
character(len=6) a
a (p) = p // '10'
 
p1 => i
i = '1234'
if (a (p1) .ne. '123410') call abort
end subroutine
 
subroutine multiple_eval
integer st7, fun2, fun
 
st7(i) = i + fun(i)
 
if (st7(fun2(10)) .ne. 3) call abort
end subroutine
end
 
! This functon returns the argument passed on the previous call.
integer function fun2 (i)
integer i
integer, save :: val = 1
 
fun2 = val
val = i
end function
 
integer function fun (i)
integer i
fun = i * 2
end function
/gfortran.fortran-torture/execute/intrinsic_dim.f90
0,0 → 1,20
! Program to test the DIM intrinsic
program intrinsic_dim
implicit none
integer i, j
real(kind=4) :: r, s
real(kind=8) :: p, q
 
i = 1
j = 4
if (dim (i, j) .ne. 0) call abort
if (dim (j, i) .ne. 3) call abort
r = 1.0
s = 4.0
if (dim (r, s) .ne. 0.0) call abort
if (dim (s, r) .ne. 3.0) call abort
p = 1.0
q = 4.0
if (dim (p, q) .ne. 0.0) call abort
if (dim (q, p) .ne. 3.0) call abort
end program
/gfortran.fortran-torture/execute/data_3.f90
0,0 → 1,19
! Check initialization of character variables via the DATA statement
CHARACTER*4 a
CHARACTER*6 b
CHARACTER*2 c
CHARACTER*4 d(2)
CHARACTER*4 e
 
DATA a(1:2) /'aa'/
DATA a(3:4) /'b'/
DATA b(2:6), c /'AAA', '12345'/
DATA d /2*'1234'/
DATA e(4:4), e(1:3) /'45', '123A'/
 
IF (a.NE.'aab ') CALL abort()
IF (b.NE.' AAA ') CALL abort()
IF (c.NE.'12') CALL abort()
IF (d(1).NE.d(2) .OR. d(1).NE.'1234') CALL abort()
IF (e.NE.'1234') CALL abort()
END
/gfortran.fortran-torture/execute/where_3.f90
0,0 → 1,21
! Program to test WHERE on unknown size arrays
program where_3
integer A(10, 2)
 
A = 0
call sub(A)
 
contains
 
subroutine sub(B)
integer, dimension(:, :) :: B
 
B(1:5, 1) = 0
B(6:10, 1) = 5
where (B(:,1)>0)
B(:,1) = B(:,1) + 10
endwhere
if (any (B .ne. reshape ((/0, 0, 0, 0, 0, 15, 15, 15, 15, 15, &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0/), (/10, 2/)))) call abort
end subroutine
end program
/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90
0,0 → 1,87
!Program to test SET_EXPONENT intrinsic function.
 
program test_set_exponent
call test_real4()
call test_real8()
end
 
subroutine test_real4()
real*4 x,y
integer*4 i,n
equivalence(x, i)
 
n = -148
x = 1024.0
y = set_exponent (x, n)
if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()
 
n = 8
x = 1024.0
y = set_exponent (x, n)
if (exponent (y) .ne. n) call abort()
 
n = 128
i = 8388607
x = transfer (i, x) ! z'007fffff' Positive denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) call abort()
 
n = -148
x = -1024.0
y = set_exponent (x, n)
if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()
 
n = 8
x = -1024.0
y = set_exponent (x, n)
if (y .ne. -128.0) call abort()
if (exponent (y) .ne. n) call abort()
 
n = 128
i = -2139095041
x = transfer (i, x) ! z'807fffff' Negative denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) call abort()
 
end
 
subroutine test_real8()
implicit none
real*8 x, y
integer*8 i, n
equivalence(x, i)
 
n = -1073
x = 1024.0_8
y = set_exponent (x, n)
if ((y .ne. 0.0_8) .and. (exponent (y) .ne. n)) call abort()
 
n = 8
x = 1024.0_8
y = set_exponent (x, n)
if (y .ne. 128.0) call abort()
if (exponent (y) .ne. n) call abort()
 
n = 1024
i = 4503599627370495_8
x = transfer (i, x) !z'000fffffffffffff' Positive denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) call abort()
 
n = -1073
x = -1024.0
y = set_exponent (x, n)
if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()
 
n = 8
x = -1024.0
y = set_exponent (x, n)
if (y .ne. -128.0) call abort()
if (exponent (y) .ne. n) call abort()
 
n = 1024
i = -9218868437227405313_8
x = transfer (i, x)!z'800fffffffffffff' Negative denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) call abort()
end
/gfortran.fortran-torture/execute/test_slice.f90
0,0 → 1,17
! Program to test handling of reduced rank array sections. This uncovered
! bugs in simplify_shape and the scalarization of array sections.
program test_slice
implicit none
real (kind = 8), dimension(2, 2, 2) :: x
real (kind = 8) :: min, max
 
x = 1.0
if (minval(x(1, 1:2, 1:1)) .ne. 1.0) call abort ()
if (maxval(x(1, 1:2, 1:1)) .ne. 1.0) call abort ()
if (any (shape(x(1, 1:2, 1:1)) .ne. (/2, 1/))) call abort ()
 
if (any (shape(x(1, 1:2, 1)) .ne. (/2/))) call abort ()
if (any (shape(x(1:1, 1:2, 1:1)) .ne. (/1, 2, 1/))) call abort ()
 
end program test_slice
/gfortran.fortran-torture/execute/where_5.f90
0,0 → 1,13
! Tests WHERE satement with non-integer array in the mask expression
program where_5
integer, dimension(5) :: a
real(kind=8), dimension(5) :: b
 
a = (/1, 2, 3, 4, 5/)
b = (/1d0, 0d0, 1d0, 0d0, 1d0/)
where (b .ne. 0d0)
a(:) = a(:) + 10
endwhere
if (any (a .ne. (/11, 2, 13, 4, 15/))) call abort
end program
/gfortran.fortran-torture/execute/where_7.f90
0,0 → 1,53
! Really test where inside forall with temporary
program evil_where
implicit none
type t
logical valid
integer :: s
integer, dimension(:), pointer :: p
end type
type (t), dimension (5) :: v
integer i
 
allocate (v(1)%p(2))
allocate (v(2)%p(8))
v(3)%p => NULL()
allocate (v(4)%p(8))
allocate (v(5)%p(2))
 
v(:)%valid = (/.true., .true., .false., .true., .true./)
v(:)%s = (/1, 8, 999, 6, 2/)
v(1)%p(:) = (/9, 10/)
v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
v(5)%p(:) = (/11, 12/)
 
forall (i=1:5,v(i)%valid)
where (v(i)%p(1:v(i)%s).gt.4)
v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s)
end where
end forall
 
if (any(v(1)%p(:) .ne. (/11, 10/))) call abort
if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 17, 18, 19, 20/))) call abort
if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort
if (any(v(5)%p(:) .ne. (/9, 10/))) call abort
 
v(1)%p(:) = (/9, 10/)
v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/)
v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/)
v(5)%p(:) = (/11, 12/)
 
forall (i=1:5,v(i)%valid)
where (v(i)%p(1:v(i)%s).le.4)
v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s)
end where
end forall
 
if (any(v(1)%p(:) .ne. (/9, 10/))) call abort
if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 5, 6, 7, 8/))) call abort
if (any(v(4)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort
if (any(v(5)%p(:) .ne. (/11, 12/))) call abort
 
! I should really free the memory I've allocated.
end program
/gfortran.fortran-torture/execute/scalarize3.f90
0,0 → 1,8
program foo
integer, dimension(3, 2) :: a
 
a = reshape ((/1, 2, 3, 4, 5, 6/), (/3, 2/))
a = a(3:1:-1, 2:1:-1);
 
if (any (a .ne. reshape ((/6, 5, 4, 3, 2, 1/), (/3, 2/)))) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_len.f90
0,0 → 1,31
! Program to test the LEN intrinsic
program test
character(len=10) a
character(len=8) w
type person
character(len=10) name
integer age
end type person
type(person) Tom
integer n
a = w (n)
 
if ((a .ne. "01234567") .or. (n .ne. 8)) call abort
if (len(Tom%name) .ne. 10) call abort
call array_test()
end
 
function w(i)
character(len=8) w
integer i
w = "01234567"
i = len(w)
end
 
! This is the testcase from PR 15211 converted to a subroutine
subroutine array_test
implicit none
character(len=10) a(4)
if (len(a) .NE. 10) call abort()
end subroutine array_test
 
/gfortran.fortran-torture/execute/intrinsic_product.f90
0,0 → 1,47
! Program to test the PRODUCT intrinsic
program testproduct
implicit none
integer, dimension (3, 3) :: a
integer, dimension (3) :: b
logical, dimension (3, 3) :: m, tr
character(len=12) line
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));
 
b = product (a, 1)
 
tr = .true.
 
if (any(b .ne. (/6, 120, 504/))) call abort
 
write (line, 9000) product(a,1)
if (line .ne. ' 6 120 504') call abort
 
if (product (a) .ne. 362880) call abort
 
write (line, 9010) product(a)
if (line .ne. '362880') call abort
 
m = .true.
m(1, 1) = .false.
m(2, 1) = .false.
 
b = product (a, 2, m)
if (any(b .ne. (/28, 40, 162/))) call abort
 
b = product (a, 2, m .and. tr)
if (any(b .ne. (/28, 40, 162/))) call abort
 
write (line, 9000) product(a, 2, m)
if (line .ne. ' 28 40 162') call abort
 
if (product (a, mask=m) .ne. 181440) call abort
 
if (product (a, mask=m .and. tr) .ne. 181440) call abort
 
write (line, 9010) product(a, mask=m)
if (line .ne. '181440') call abort
 
9000 format (3I4)
9010 format (I6)
end program
/gfortran.fortran-torture/execute/intrinsic_present.f90
0,0 → 1,40
! Program to test the PRESENT intrinsic
program intrinsic_present
implicit none
integer a
integer, pointer :: b
integer, dimension(10) :: c
integer, pointer, dimension(:) :: d
if (testvar()) call abort ()
if (.not. testvar(a)) call abort ()
if (testptr()) call abort ()
if (.not. testptr(b)) call abort ()
if (testarray()) call abort ()
if (.not. testarray(c)) call abort ()
if (testparray()) call abort ()
if (.not. testparray(d)) call abort ()
contains
logical function testvar (p)
integer, optional :: p
testvar = present(p)
end function
 
logical function testptr (p)
integer, pointer, optional :: p
testptr = present(p)
end function
 
logical function testarray (p)
integer, dimension (10), optional :: p
testarray = present(p)
end function
 
logical function testparray (p)
integer, pointer, dimension(:), optional :: p
testparray = present(p)
end function
 
end program
 
/gfortran.fortran-torture/execute/ptr.f90
0,0 → 1,20
program ptr
implicit none
integer, pointer, dimension(:) :: a, b
integer, pointer :: p
integer, target :: i
 
allocate (a(1:6))
a = (/ 1, 2, 3, 4, 5, 6 /)
b => a
if (any (b .ne. (/ 1, 2, 3, 4, 5, 6 /))) call abort
b => a(1:6:2)
if (any (b .ne. (/ 1, 3, 5/))) call abort
p => i
i = 42
if (p .ne. 42) call abort
p => a(4)
if (p .ne. 4) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_set_exponent.x
0,0 → 1,6
if [istarget "spu-*-*"] {
# No denormal support on SPU.
return 1
}
add-ieee-options
return 0
/gfortran.fortran-torture/execute/strlen.f90
0,0 → 1,34
! Program to test the LEN and LEN_TRIM intrinsics.
subroutine test (c)
character(*) c
character(len(c)) d
 
d = c
if (len(d) .ne. 20) call abort
if (d .ne. "Longer Test String") call abort
c = "Hello World"
end subroutine
 
subroutine test2 (c)
character (*) c
character(len(c)) d
 
d = c
if (len(d) .ne. 6) call abort
if (d .ne. "Foobar") call abort
end subroutine
 
program strlen
implicit none
character(20) c
character(5) a, b
integer i
 
c = "Longer Test String"
call test (c)
 
if (len(c) .ne. 20) call abort
if (len_trim(c) .ne. 11) call abort
 
call test2 ("Foobar");
end program
/gfortran.fortran-torture/execute/arrayarg.f90
0,0 → 1,145
! Program to test arrays
! The program outputs a series of numbers.
! Two digit numbers beginning with 0, 1, 2 or 3 is a normal.
! Three digit numbers starting with 4 indicate an error.
! Using 1D arrays isn't a sufficient test, the first dimension is often
! handled specially.
 
! Fixed size parameter
subroutine f1 (a)
implicit none
integer, dimension (5, 8) :: a
 
if (a(1, 1) .ne. 42) call abort
 
if (a(5, 8) .ne. 43) call abort
end subroutine
 
 
program testprog
implicit none
integer, dimension(3:7, 4:11) :: a
a(:,:) = 0
a(3, 4) = 42
a(7, 11) = 43
call test(a)
contains
subroutine test (parm)
implicit none
! parameter
integer, dimension(2:, 3:) :: parm
! Known size arry
integer, dimension(5, 8) :: a
! Known size array with different bounds
integer, dimension(4:8, 3:10) :: b
! Unknown size arrays
integer, dimension(:, :), allocatable :: c, d, e
! Vectors
integer, dimension(5) :: v1
integer, dimension(10, 10) :: v2
integer n
external f1
 
! Same size
allocate (c(5,8))
! Same size, different bounds
allocate (d(11:15, 12:19))
! A larger array
allocate (e(15, 24))
a(:,:) = 0
b(:,:) = 0
c(:,:) = 0
d(:,:) = 0
a(1,1) = 42
b(4, 3) = 42
c(1,1) = 42
d(11,12) = 42
a(5, 8) = 43
b(8, 10) = 43
c(5, 8) = 43
d(15, 19) = 43
 
v2(:, :) = 0
do n=1,5
v1(n) = n
end do
 
v2 (3, 1::2) = v1 (5:1:-1)
v1 = v1 + 1
 
if (v1(1) .ne. 2) call abort
if (v2(3, 3) .ne. 4) call abort
 
! Passing whole arrays
call f1 (a)
call f1 (b)
call f1 (c)
call f2 (a)
call f2 (b)
call f2 (c)
! passing expressions
a(1,1) = 41
a(5,8) = 42
call f1(a+1)
call f2(a+1)
a(1,1) = 42
a(5,8) = 43
call f1 ((a + b) / 2)
call f2 ((a + b) / 2)
! Passing whole arrays as sections
call f1 (a(:,:))
call f1 (b(:,:))
call f1 (c(:,:))
call f2 (a(:,:))
call f2 (b(:,:))
call f2 (c(:,:))
! Passing sections
e(:,:) = 0
e(2, 3) = 42
e(6, 10) = 43
n = 3
call f1 (e(2:6, n:10))
call f2 (e(2:6, n:10))
! Vector subscripts
! v1= index plus one, v2(3, ::2) = reverse of index
e(:,:) = 0
e(2, 3) = 42
e(6, 10) = 43
call f1 (e(v1, n:10))
call f2 (e(v1, n:10))
! Double vector subscript
e(:,:) = 0
e(6, 3) = 42
e(2, 10) = 43
!These are not resolved properly
call f1 (e(v1(v2(3, ::2)), n:10))
call f2 (e(v1(v2(3, ::2)), n:10))
! non-contiguous sections
e(:,:) = 0
e(1, 1) = 42
e(13, 22) = 43
n = 3
call f1 (e(1:15:3, 1:24:3))
call f2 (e(::3, ::n))
! non-contiguous sections with bounds
e(:,:) = 0
e(3, 4) = 42
e(11, 18) = 43
n = 19
call f1 (e(3:11:2, 4:n:2))
call f2 (e(3:11:2, 4:n:2))
 
! Passing a dummy variable
call f1 (parm)
call f2 (parm)
end subroutine
! Assumed shape parameter
subroutine f2 (a)
integer, dimension (1:, 1:) :: a
 
if (a(1, 1) .ne. 42) call abort
 
if (a(5, 8) .ne. 43) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/data.f90
0,0 → 1,72
! Program to test data statement
program data
call sub1()
call sub2()
end
subroutine sub1()
integer i
type tmp
integer, dimension(4)::a
real :: r
end type
type tmp1
type (tmp) t1(4)
integer b
end type
type (tmp1) tmp2(2)
! Full array and scalar component initializer
data tmp2(2)%t1(2)%r, tmp2(1)%t1(3)%a, tmp2(1)%b/220,136,137,138,139,10/
data tmp2(2)%t1(4)%a,tmp2(2)%t1(3)%a/241,242,4*5,233,234/
! implied DO
data (tmp2(1)%t1(2)%a(i),i=4,1,-1)/124,123,122,121/
! array section
data tmp2(1)%t1(4)%a(4:1:-1)/144,143,142,141/
data tmp2(1)%t1(1)%a(1:4:2)/111,113/
! array element reference
data tmp2(2)%t1(2)%a(3), tmp2(2)%t1(2)%a(1)/223,221/
 
if (any(tmp2(1)%t1(1)%a .ne. (/111,0,113,0/))) call abort
if (tmp2(1)%t1(1)%r .ne. 0.0) call abort
if (tmp2(1)%b .ne. 10) call abort
 
if (any(tmp2(1)%t1(2)%a .ne. (/121,122,123,124/))) call abort
if (tmp2(1)%t1(2)%r .ne. 0.0) call abort
if (tmp2(1)%b .ne. 10) call abort
 
if (any(tmp2(1)%t1(3)%a .ne. (/136,137,138,139/))) call abort
if (tmp2(1)%t1(3)%r .ne. 0.0) call abort
if (tmp2(1)%b .ne. 10) call abort
 
if (any(tmp2(1)%t1(4)%a .ne. (/141,142,143,144/))) call abort
if (tmp2(1)%t1(4)%r .ne. 0.0) call abort
if (tmp2(1)%b .ne. 10) call abort
 
if (any(tmp2(2)%t1(1)%a .ne. (/0,0,0,0/))) call abort
if (tmp2(2)%t1(1)%r .ne. 0.0) call abort
if (tmp2(2)%b .ne. 0) call abort
 
if (any(tmp2(2)%t1(2)%a .ne. (/221,0,223,0/))) call abort
if (tmp2(2)%t1(2)%r .ne. 220.0) call abort
if (tmp2(2)%b .ne. 0) call abort
 
if (any(tmp2(2)%t1(3)%a .ne. (/5,5,233,234/))) call abort
if (tmp2(2)%t1(3)%r .ne. 0.0) call abort
if (tmp2(2)%b .ne. 0) call abort
 
if (any(tmp2(2)%t1(4)%a .ne. (/241,242,5,5/))) call abort
if (tmp2(2)%t1(4)%r .ne. 0.0) call abort
if (tmp2(2)%b .ne. 0) call abort
 
end
subroutine sub2()
integer a(4,4), b(10)
integer i,j,k
real r,t
data i,j,r,k,t,b(5),b(2),((a(i,j),i=1,4,1),j=4,1,-1)/1,2,3,4,5,5,2,&
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/
if ((i.ne.1) .and. (j.ne.2).and.(k.ne.4)) call abort
if ((r.ne.3.0).and.(t.ne.5.0)) call abort
if (any(b.ne.(/0,2,0,0,5,0,0,0,0,0/))) call abort
if (any(a.ne.reshape((/13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4/),(/4,4/)))) call abort
end
 
/gfortran.fortran-torture/execute/equiv_2.f90
0,0 → 1,46
subroutine test1
character*8 c
character*1 d, f
dimension d(2), f(2)
character*4 e
equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
end subroutine test1
subroutine test2
equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
character*8 c
character*1 d, f
dimension d(2), f(2)
character*4 e
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
end subroutine test2
subroutine test3
character*8 c
character*1 d, f
character*4 e
equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
dimension d(2), f(2)
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
end subroutine test3
subroutine test4
dimension d(2), f(2)
equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
character*8 c
character*1 d, f
character*4 e
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
end subroutine test4
program main
call test1
call test2
call test3
call test4
end program main
/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90
0,0 → 1,29
!Program to test RRSPACING intrinsic function.
 
program test_rrspacing
call test_real4(3.0)
call test_real4(33.0)
call test_real4(-3.0)
call test_real8(3.0_8)
call test_real8(33.0_8)
call test_real8(-33.0_8)
end
subroutine test_real4(orig)
real x,y,orig
integer p
x = orig
p = 24
y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p)
x = rrspacing(x)
if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end
 
subroutine test_real8(orig)
real*8 x,y,t,orig
integer p
x = orig
p = 53
y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p)
x = rrspacing(x)
if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end
/gfortran.fortran-torture/execute/where_11.f90
0,0 → 1,23
! Check whether conditional ELSEWHEREs work
! (without unconditional ELSEWHERE)
program where_11
integer :: a(5)
integer :: b(5)
 
a = (/1, 2, 3, 4, 5/)
b = (/0, 0, 0, 0, 0/)
where (a .eq. 1)
b = 3
elsewhere (a .eq. 2)
b = 1
elsewhere (a .eq. 3)
b = 4
elsewhere (a .eq. 4)
b = 1
elsewhere (a .eq. 5)
b = 5
endwhere
if (any (b .ne. (/3, 1, 4, 1, 5/))) &
call abort
end program
 
/gfortran.fortran-torture/execute/equiv_4.f90
0,0 → 1,54
subroutine test1
character*8 c
character*2 d, f
dimension d(2), f(2)
character*4 e
equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4))
equivalence (c(6:6), f(2)(:))
d(1)='AB'
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
end subroutine test1
subroutine test2
equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4))
equivalence (c(6:6), f(2)(1:))
character*8 c
character*2 d, f
dimension d(2), f(2)
character*4 e
d(1)='AB'
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
end subroutine test2
subroutine test3
character*8 c
character*2 d, f
character*4 e
equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4))
equivalence (c(6:6), f(2)(:1))
dimension d(2), f(2)
d(1)='AB'
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
end subroutine test3
subroutine test4
dimension d(2), f(2)
equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4))
equivalence (c(6:6), f(2)(1:2))
character*8 c
character*2 d, f
character*4 e
d(1)='AB'
c='abcdefgh'
if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
end subroutine test4
program main
call test1
call test2
call test3
call test4
end program main
/gfortran.fortran-torture/execute/adjustr.f90
0,0 → 1,46
! pr 15294 - [gfortran] ADJUSTR intrinsic accesses corrupted pointer
!
program test_adjustr
implicit none
integer test_cases
parameter (test_cases=13)
integer i
character(len=10) s1(test_cases), s2(test_cases)
s1(1)='A'
s2(1)=' A'
s1(2)='AB'
s2(2)=' AB'
s1(3)='ABC'
s2(3)=' ABC'
s1(4)='ABCD'
s2(4)=' ABCD'
s1(5)='ABCDE'
s2(5)=' ABCDE'
s1(6)='ABCDEF'
s2(6)=' ABCDEF'
s1(7)='ABCDEFG'
s2(7)=' ABCDEFG'
s1(8)='ABCDEFGH'
s2(8)=' ABCDEFGH'
s1(9)='ABCDEFGHI'
s2(9)=' ABCDEFGHI'
s1(10)='ABCDEFGHIJ'
s2(10)='ABCDEFGHIJ'
s1(11)=''
s2(11)=''
s1(12)=' '
s2(12)=' '
s1(13)=' '
s2(13)=' '
do I = 1,test_cases
print*,i
print*, 's1 = "', s1(i), '"'
print*, 's2 = "', s2(i), '"'
print*, 'adjustr(s1) = "', adjustr(s1(i)), '"'
if (adjustr(s1(i)).ne.s2(i)) then
print*,'fail'
call abort
endif
enddo
end program test_adjustr
/gfortran.fortran-torture/execute/intrinsic_dummy.f90
0,0 → 1,23
! Program to test passing intrinsic functions as actual arguments for
! dummy procedures.
subroutine test (proc)
implicit none
real proc
real a, b, c
 
a = 1.0
b = sin (a)
c = proc (a)
if (abs (b - c) .gt. 0.001) call abort
end subroutine
 
program dummy
implicit none
external test
intrinsic sin
call test (sin)
end program
 
/gfortran.fortran-torture/execute/where_13.f90
0,0 → 1,10
! Check empty WHERE and empty ELSEWHERE works
program where_13
integer :: a(5)
 
a = (/1, 2, 3, 4, 5/)
where (a .eq. 2)
elsewhere
endwhere
end program
 
/gfortran.fortran-torture/execute/alternate_return.f90
0,0 → 1,18
program alt_return
implicit none
call myproc (1, *10, 42)
20 continue
call abort ()
10 continue
call myproc(2, *20, 42)
call myproc(3, *20, 42)
contains
subroutine myproc(n, *, i)
integer n, i
if (i .ne. 42) call abort ()
if (n .eq. 1) return 1
if (n .eq. 2) return
end subroutine
end program alt_return
 
/gfortran.fortran-torture/execute/where_15.f90
0,0 → 1,15
! Check whether an empty WHERE works
program where_15
integer :: a(5)
integer :: b(5)
 
a = (/1, 2, 3, 4, 5/)
b = (/0, 0, 0, 0, 0/)
where (a .eq. 1)
elsewhere
b = 2
endwhere
if (any (b .ne. (/0, 2, 2, 2, 2/))) &
call abort
end program
 
/gfortran.fortran-torture/execute/pr23373-1.f90
0,0 → 1,15
program main
implicit none
real, dimension (:), pointer :: x
x => null ()
x => test (x)
if (.not. associated (x)) call abort
if (size (x) .ne. 10) call abort
contains
function test (p)
real, dimension (:), pointer :: p, test
if (associated (p)) call abort
allocate (test (10))
if (associated (p)) call abort
end function test
end program main
/gfortran.fortran-torture/execute/where17.f90
0,0 → 1,15
! Check to ensure only the first true clause in WHERE is
! executed.
program where_17
integer :: a(3)
 
a = (/1, 2, 3/)
where (a .eq. 1)
a = 2
elsewhere (a .le. 2)
a = 3
elsewhere (a .le. 3)
a = 4
endwhere
if (any (a .ne. (/2, 3, 4/))) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_nearest.f90
0,0 → 1,77
!Program to test NEAREST intrinsic function.
 
program test_nearest
real s, r, x, y, inf, max
integer i, infi, maxi
equivalence (s,i)
equivalence (inf,infi)
equivalence (max,maxi)
 
r = 2.0
s = 3.0
call test_n (s, r)
 
i = z'00800000'
call test_n (s, r)
 
i = z'007fffff'
call test_n (s, r)
 
i = z'00800100'
call test_n (s, r)
 
s = 0
x = nearest(s, r)
y = nearest(s, -r)
if (.not. (x .gt. s .and. y .lt. s )) call abort()
 
! ??? This is pretty sketchy, but passes on most targets.
infi = z'7f800000'
maxi = z'7f7fffff'
 
call test_up(max, inf)
call test_up(-inf, -max)
call test_down(inf, max)
call test_down(-max, -inf)
 
! ??? Here we require the F2003 IEEE_ARITHMETIC module to
! determine if denormals are supported. If they are, then
! nearest(0,1) is the minimum denormal. If they are not,
! then it's the minimum normalized number, TINY. This fails
! much more often than the infinity test above, so it's
! disabled for now.
 
! call test_up(0, min)
! call test_up(-min, 0)
! call test_down(0, -min)
! call test_down(min, 0)
end
 
subroutine test_up(s, e)
real s, e, x
 
x = nearest(s, 1.0)
if (x .ne. e) call abort()
end
 
subroutine test_down(s, e)
real s, e, x
 
x = nearest(s, -1.0)
if (x .ne. e) call abort()
end
 
subroutine test_n(s1, r)
real r, s1, x
 
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) call abort()
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) call abort()
 
s1 = -s1
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) call abort()
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) call abort()
end
/gfortran.fortran-torture/execute/enum_1.f90
0,0 → 1,28
! Program to test the default initialisation of enumerators
 
program main
implicit none
 
enum, bind (c)
enumerator :: red , yellow, blue
enumerator :: green
end enum
 
enum, bind (c)
enumerator :: a , b , c = 10
enumerator :: d
end enum
 
 
if (red /= 0 ) call abort
if (yellow /= 1) call abort
if (blue /= 2) call abort
if (green /= 3) call abort
 
if (a /= 0 ) call abort
if (b /= 1) call abort
if (c /= 10) call abort
if (d /= 11) call abort
 
end program main
/gfortran.fortran-torture/execute/where19.f90
0,0 → 1,23
! Check to ensure result is calculated from unmodified
! version of the right-hand-side in WHERE statements.
program where_19
integer :: a(4)
integer :: b(3)
integer :: c(3)
equivalence (a(1), b(1)), (a(2), c(1))
 
a = (/1, 2, 3, 4/)
where (b .gt. 1)
c = b
endwhere
if (any (a .ne. (/1, 2, 2, 3/))) &
call abort ()
 
a = (/1, 2, 3, 4/)
where (c .gt. 1)
b = c
endwhere
if (any (a .ne. (/2, 3, 4, 4/))) &
call abort ()
end program
 
/gfortran.fortran-torture/execute/intrinsic_mvbits.f90
0,0 → 1,16
! Test the MVBITS intrinsic subroutine
INTEGER*4 :: from, to, result
integer*8 :: from8, to8
 
DATA from / z'0003FFFC' /
DATA to / z'77760000' /
DATA result / z'7777FFFE' /
 
CALL mvbits(from, 2, 16, to, 1)
if (to /= result) CALL abort()
 
to8 = 0_8
from8 = b'1011'*2_8**32
call mvbits (from8, 33, 3, to8, 2)
if (to8 /= b'10100') call abort
end
/gfortran.fortran-torture/execute/enum_3.f90
0,0 → 1,57
! Program to test the initialisation range of enumerators
! and kind values check
 
program main
implicit none
 
enum, bind (c)
enumerator :: red , yellow =255 , blue
end enum
 
enum, bind (c)
enumerator :: r , y = 32767, b
end enum
 
enum, bind (c)
enumerator :: aa , bb = 65535, cc
end enum
 
enum, bind (c)
enumerator :: m , n = 2147483645, o
end enum
 
 
if (red /= 0 ) call abort
if (yellow /= 255) call abort
if (blue /= 256) call abort
if (r /= 0 ) call abort
if (y /= 32767) call abort
if (b /= 32768) call abort
 
if (kind (red) /= 4) call abort
if (kind (yellow) /= 4) call abort
if (kind (blue) /= 4) call abort
 
if (kind(r) /= 4 ) call abort
if (kind(y) /= 4) call abort
if (kind(b) /= 4) call abort
 
if (aa /= 0 ) call abort
if (bb /= 65535) call abort
if (cc /= 65536) call abort
 
if (kind (aa) /= 4 ) call abort
if (kind (bb) /= 4) call abort
if (kind (cc) /= 4) call abort
 
 
if (m /= 0 ) call abort
if (n /= 2147483645) call abort
if (o /= 2147483646) call abort
 
if (kind (m) /= 4 ) call abort
if (kind (n) /= 4) call abort
if (kind (o) /= 4) call abort
 
end program main
/gfortran.fortran-torture/execute/module_init_1.f90
0,0 → 1,9
! PR 13077: we used to fail when reading the module
module m1
real, dimension(4) :: a
data a(1:3:2) /2*1.0/
end module m1
use m1
if (a(1).NE.1.) call abort()
if (a(1).NE.a(3)) call abort()
end
/gfortran.fortran-torture/execute/iolength_1.f90
0,0 → 1,16
! Test that IOLENGTH works for dynamic arrays
program iolength_1
implicit none
! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
integer, parameter :: int32 = selected_int_kind(9)
integer(int32), allocatable :: a(:)
integer :: iol, alength
real :: r
call random_number(r)
alength = nint(r*20)
allocate(a(alength))
inquire (iolength = iol) a
if ( 4*alength /= iol) then
call abort
end if
end program iolength_1
/gfortran.fortran-torture/execute/hollerith.f90
0,0 → 1,9
! PR 14038- 'H' in hollerith causes mangling of string
program hollerith
IMPLICIT NONE
CHARACTER*4 LINE
100 FORMAT (4H12H4)
WRITE(LINE,100)
IF (LINE .NE. '12H4') call abort ()
end
 
/gfortran.fortran-torture/execute/intrinsic_dprod.f90
0,0 → 1,13
! Program to test DPROD intrinsic
program intrinsic_dprod
implicit none
real r, s, t
double precision dp
 
! 6d60 doesn't fit in a 4-byte real
r = 2e30
s = 4e30
dp = dprod (r, s)
if ((dp .gt. 8.001d60) .or. (dp .lt. 7.999d60)) call abort
end program
 
/gfortran.fortran-torture/execute/iolength_3.f90
0,0 → 1,15
! Test that IOLENGTH works for io list containing more than one entry
program iolength_3
implicit none
integer, parameter :: &
! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
int32 = selected_int_kind(9), &
! IEEE double precision, i.e. 8 bytes
dp = selected_real_kind(15, 307)
integer(int32) :: a, b, iol
real(dp) :: c
inquire (iolength = iol) a, b, c
if ( 16 /= iol) then
call abort
end if
end program iolength_3
/gfortran.fortran-torture/execute/read_null_string.f90
0,0 → 1,15
! pr 16080, segfault on reading an empty string
implicit none
integer t
character*20 temp_name
character*2 quotes
open(unit=7,status='SCRATCH')
quotes = '""""' ! "" in the file
write(7,*)1
write(7,'(A)')quotes
temp_name = 'hello' ! make sure the read overwrites it
rewind(7)
read(7, *) t
read(7, *) temp_name
if (temp_name.ne.'') call abort
end
/gfortran.fortran-torture/execute/args.f90
0,0 → 1,22
! Program to test procudure args
subroutine test (a, b)
integer, intent (IN) :: a
integer, intent (OUT) :: b
 
if (a .ne. 42) call abort
b = 43
end subroutine
 
program args
implicit none
external test
integer i, j
 
i = 42
j = 0
CALL test (i, j)
if (i .ne. 42) call abort
if (j .ne. 43) call abort
i = 41
CALL test (i + 1, j)
end program
/gfortran.fortran-torture/execute/mainsub.f90
0,0 → 1,17
! Program to test compilation of subroutines following the main program
program mainsub
implicit none
integer i
external test
 
i = 0
call test (i)
if (i .ne. 42) call abort
end program
 
subroutine test (p)
implicit none
integer p
 
p = 42
end subroutine
/gfortran.fortran-torture/execute/parameter_1.f90
0,0 → 1,12
! Program to test array parameter variables.
program parameter_1
implicit none
integer i
INTEGER, PARAMETER :: ii(10) = (/ (I,I=1,10) /)
REAL, PARAMETER :: rr(10) = ii
 
do i = 1, 10
if (ii(i) /= i) call abort()
if (rr(i) /= i) call abort()
end do
end program parameter_1
/gfortran.fortran-torture/execute/intrinsic_anyall.f90
0,0 → 1,41
! Program to test the ANY and ALL intrinsics
program anyall
implicit none
logical, dimension(3, 3) :: a
logical, dimension(3) :: b
character(len=10) line
 
a = .false.
if (any(a)) call abort
a(1, 1) = .true.
a(2, 3) = .true.
if (.not. any(a)) call abort
b = any(a, 1)
if (.not. b(1)) call abort
if (b(2)) call abort
if (.not. b(3)) call abort
b = .false.
write (line, 9000) any(a,1)
read (line, 9000) b
if (.not. b(1)) call abort
if (b(2)) call abort
if (.not. b(3)) call abort
 
a = .true.
if (.not. all(a)) call abort
a(1, 1) = .false.
a(2, 3) = .false.
if (all(a)) call abort
b = all(a, 1)
if (b(1)) call abort
if (.not. b(2)) call abort
if (b(3)) call abort
b = .false.
write (line, 9000) all(a,1)
read (line, 9000) b
if (b(1)) call abort
if (.not. b(2)) call abort
if (b(3)) call abort
 
9000 format (9L1)
end program
/gfortran.fortran-torture/execute/unopened_unit_1.x
0,0 → 1,7
load_lib target-supports.exp
 
if { ! [check_effective_target_fd_truncate] } {
return 1
}
 
return 0
/gfortran.fortran-torture/execute/t_edit.f90
0,0 → 1,11
!pr 14897 T edit descriptor broken
implicit none
character*80 line
WRITE(line,'(T5,A,T10,A,T15,A)')'AA','BB','CC'
if (line.ne.' AA BB CC ') call abort
WRITE(line,'(5HAAAAA,TL4,4HABCD)')
if (line.ne.'AABCD') call abort
END
 
 
 
/gfortran.fortran-torture/execute/intrinsic_minmax.f90
0,0 → 1,37
! Program to test min and max intrinsics
program intrinsic_minmax
implicit none
integer i, j, k, m
real r, s, t, u
 
i = 1
j = -2
k = 3
m = 4
if (min (i, k) .ne. 1) call abort
if (min (i, j, k, m) .ne. -2) call abort
if (max (i, k) .ne. 3) call abort
if (max (i, j, k, m) .ne. 4) call abort
if (max (i+1, j) .ne. 2) call abort
 
r = 1
s = -2
t = 3
u = 4
if (min (r, t) .ne. 1) call abort
if (min (r, s, t, u) .ne. -2) call abort
if (max (r, t) .ne. 3) call abort
if (max (r, s, t, u) .ne. 4) call abort
 
if (max (4d0, r) .ne. 4d0) call abort
if (amax0 (i, j) .ne. 1.0) call abort
if (min1 (r, s) .ne. -2) call abort
 
! Test simplify.
if (min (1, -2, 3, 4) .ne. -2) call abort
if (max (1, -2, 3, 4) .ne. 4) call abort
if (amax0 (1, -2) .ne. 1.0) call abort
if (min1 (1., -2.) .ne. -2) call abort
 
end program
 
/gfortran.fortran-torture/execute/date_time_1.f90
0,0 → 1,26
! Check the DATE_AND_TIME intrinsic.
! Call teh intrinsic with a variety of arguments, but does not check the
! returned values.
CHARACTER(8) :: d, d1
CHARACTER(10) :: t, t1
CHARACTER(5) :: z, z1
INTEGER :: v(8), v1(8)
 
CALL DATE_AND_TIME
 
CALL DATE_AND_TIME(DATE=d)
CALL DATE_AND_TIME(TIME=t)
CALL DATE_AND_TIME(ZONE=z)
 
CALL DATE_AND_TIME(VALUES=v)
 
CALL DATE_AND_TIME(DATE=d, TIME=t)
CALL DATE_AND_TIME(DATE=d, VALUES=v)
CALL DATE_AND_TIME(TIME=t, ZONE=z)
 
CALL DATE_AND_TIME(DATE=d, TIME=t, ZONE=z)
CALL DATE_AND_TIME(TIME=t, ZONE=z, VALUES=v)
 
CALL DATE_AND_TIME(DATE=d, TIME=t, ZONE=z, VALUES=v)
 
END
/gfortran.fortran-torture/execute/where20.f90
0,0 → 1,54
! Test the dependency checking in simple where. This
! did not work and was fixed as part of the patch for
! pr24519.
!
program where_20
integer :: a(4)
integer :: b(3)
integer :: c(3)
integer :: d(3) = (/1, 2, 3/)
equivalence (a(1), b(1)), (a(2), c(1))
 
! This classic case worked before the patch.
a = (/1, 2, 3, 4/)
where (b .gt. 1) a(2:4) = a(1:3)
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
! This is the original manifestation of the problem
! and is repeated in where_19.f90.
a = (/1, 2, 3, 4/)
where (b .gt. 1)
c = b
endwhere
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
! Mask to.destination dependency.
a = (/1, 2, 3, 4/)
where (b .gt. 1)
c = d
endwhere
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
! Source to.destination dependency.
a = (/1, 2, 3, 4/)
where (d .gt. 1)
c = b
endwhere
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
! Check the simple where.
a = (/1, 2, 3, 4/)
where (b .gt. 1) c = b
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
! This was OK before the patch.
a = (/1, 2, 3, 4/)
where (b .gt. 1)
where (d .gt. 1)
c = b
end where
endwhere
if (any(a .ne. (/1,2,2,3/))) call abort ()
 
end program
 
/gfortran.fortran-torture/execute/nan_inf_fmt.f90
0,0 → 1,88
!pr 12839- F2003 formatting of Inf /Nan
! Modified for PR47434
implicit none
character*40 l
character*12 fmt
real zero, pos_inf, neg_inf, nan
zero = 0.0
 
! need a better way of generating these floating point
! exceptional constants.
 
pos_inf = 1.0/zero
neg_inf = -1.0/zero
nan = zero/zero
 
! check a field width = 0
fmt = '(F0.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'Inf') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.'-Inf') call abort
write(l,fmt=fmt)nan
if (l.ne.'NaN') call abort
 
! check a field width < 3
fmt = '(F2.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'**') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.'**') call abort
write(l,fmt=fmt)nan
if (l.ne.'**') call abort
 
! check a field width = 3
fmt = '(F3.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'Inf') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.'***') call abort
write(l,fmt=fmt)nan
if (l.ne.'NaN') call abort
 
! check a field width > 3
fmt = '(F4.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Inf') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.'-Inf') call abort
write(l,fmt=fmt)nan
if (l.ne.' NaN') call abort
 
! check a field width = 7
fmt = '(F7.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Inf') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.' -Inf') call abort
write(l,fmt=fmt)nan
if (l.ne.' NaN') call abort
 
! check a field width = 8
fmt = '(F8.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'Infinity') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.' -Inf') call abort
write(l,fmt=fmt)nan
if (l.ne.' NaN') call abort
 
! check a field width = 9
fmt = '(F9.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Infinity') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.'-Infinity') call abort
write(l,fmt=fmt)nan
if (l.ne.' NaN') call abort
 
! check a field width = 14
fmt = '(F14.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Infinity') call abort
write(l,fmt=fmt)neg_inf
if (l.ne.' -Infinity') call abort
write(l,fmt=fmt)nan
if (l.ne.' NaN') call abort
end
 
/gfortran.fortran-torture/execute/save_2.f90
0,0 → 1,23
! PR fortran/18518
program main
call foo
call bar
call foo
end program main
 
subroutine foo
integer i,g,h
data i/0/
equivalence (g,h)
save g
if (i == 0) then
i = 1
h = 12345
end if
if (h .ne. 12345) call abort
end subroutine foo
 
subroutine bar
integer a(10)
a = 34
end subroutine bar
/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.x
0,0 → 1,2
add-ieee-options
return 0
/gfortran.fortran-torture/execute/cmplx.f90
0,0 → 1,48
! Test complex munbers
program testcmplx
implicit none
complex(kind=4) c, d
complex(kind=8) z
real(kind=4) x, y
real(kind=8) q
 
! cmplx intrinsic
x = 3
y = 4
c = cmplx(x,y)
if (c .ne. (3.0, 4.0)) call abort
x = 4
y = 3
z = cmplx(x, y, 8)
if (z .ne. (4.0, 3.0)) call abort
z = c
if (z .ne. (3.0, 4.0)) call abort
 
! dcmplx intrinsic
x = 3
y = 4
z = dcmplx (x, y)
if (z .ne. (3.0, 4.0)) call abort
 
! conjucates and aimag
c = (1.0, 2.0)
c = conjg (c)
x = aimag (c)
if (abs (c - (1.0, -2.0)) .gt. 0.001) call abort
if (x .ne. -2.0) call abort
z = (2.0, 1.0)
z = conjg (z)
q = aimag (z)
if (z .ne. (2.0, -1.0)) call abort
if (q .ne. -1.0) call abort
 
! addition, subtraction and multiplication
c = (1, 3)
d = (5, 2)
if (c + d .ne. ( 6, 5)) call abort
if (c - d .ne. (-4, 1)) call abort
if (c * d .ne. (-1, 17)) call abort
 
! test for constant folding
if ((35.,-10.)**0.NE.(1.,0.)) call abort
end program
/gfortran.fortran-torture/execute/intrinsic_eoshift.f90
0,0 → 1,102
! Program to test the eoshift intrinsic
program intrinsic_eoshift
integer, dimension(3, 3) :: a
integer, dimension(3, 3, 2) :: b
integer, dimension(3) :: bo, sh
 
! Scalar shift and scalar bound.
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, 1, 99, 1)
if (any (a .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, 9999, 99, 1)
if (any (a .ne. 99)) call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, -2, dim = 2)
if (any (a .ne. reshape ((/0, 0, 0, 0, 0, 0, 1, 2, 3/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, -9999, 99, 1)
if (any (a .ne. 99)) call abort
 
! Array shift and scalar bound.
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/1, 0, -1/), 99, 1)
if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 99, 7, 8/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/9999, 0, -9999/), 99, 1)
if (any (a .ne. reshape ((/99, 99, 99, 4, 5, 6, 99, 99, 99/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/2, -2, 0/), dim = 2)
if (any (a .ne. reshape ((/7, 0, 3, 0, 0, 6, 0, 2, 9/), (/3, 3/)))) &
call abort
 
! Scalar shift and array bound.
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, 1, (/99, -1, 42/), 1)
if (any (a .ne. reshape ((/2, 3, 99, 5, 6, -1, 8, 9, 42/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, 9999, (/99, -1, 42/), 1)
if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), &
(/3, 3/)))) call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, -9999, (/99, -1, 42/), 1)
if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), &
(/3, 3/)))) call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, -2, (/99, -1, 42/), 2)
if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
bo = (/99, -1, 42/)
a = eoshift (a, -2, bo, 2)
if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) &
call abort
 
! Array shift and array bound.
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/1, 0, -1/), (/99, -1, 42/), 1)
if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 42, 7, 8/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/2, -2, 0/), (/99, -1, 42/), 2)
if (any (a .ne. reshape ((/7, -1, 3, 99, -1, 6, 99, 2, 9/), (/3, 3/)))) &
call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
sh = (/ 3, -1, -3 /)
bo = (/-999, -99, -9 /)
a = eoshift(a, shift=sh, boundary=bo)
if (any (a .ne. reshape ((/ -999, -999, -999, -99, 4, 5, -9, -9, -9 /), &
shape(a)))) call abort
 
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, (/9999, -9999, 0/), (/99, -1, 42/), 2)
if (any (a .ne. reshape ((/99, -1, 3, 99, -1, 6, 99, -1, 9/), (/3, 3/)))) &
call abort
 
! Test arrays > rank 2
b(:, :, 1) = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
b(:, :, 2) = 10 + reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
b = eoshift (b, 1, 99, 1)
if (any (b(:, :, 1) .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) &
call abort
if (any (b(:, :, 2) .ne. reshape ((/12, 13, 99, 15, 16, 99, 18, 19, 99/), (/3, 3/)))) &
call abort
 
! TODO: Test array sections
end program
/gfortran.fortran-torture/execute/initializer.f90
0,0 → 1,26
! Program to test static variable initialization
! returns the parameter from the previous invocation, or 42 on the first call.
function test (parm)
implicit none
integer test, parm
integer :: val = 42
 
test = val
val = parm
end function
 
program intializer
implicit none
integer test
character(11) :: c = "Hello World"
character(15) :: d = "Teststring"
integer, dimension(3) :: a = 1
 
if (any (a .ne. 1)) call abort
if (test(11) .ne. 42) call abort
! The second call should return
if (test(0) .ne. 11) call abort
 
if (c .ne. "Hello World") call abort
if (d .ne. "Teststring") call abort
end program
/gfortran.fortran-torture/execute/contained_3.f90
0,0 → 1,22
! Program to test contained functions calling their siblings.
! This is tricky because we don't find the declaration for the sibling
! function until after the caller has been parsed.
program contained_3
call test
contains
subroutine test
if (sub(3) .ne. 6) call abort
end subroutine
integer function sub(i)
integer i
if (i .gt. 1) then
sub = sub2(i) * i
else
sub = 1
end if
end function
integer function sub2(i)
integer i
sub2 = sub(i - 1)
end function
end program
/gfortran.fortran-torture/execute/dep_fails.f90
0,0 → 1,50
! This gives incorrect results when compiled with
! the intel and pgf90 compilers
Program Strange
 
Implicit None
 
Type Link
Integer, Dimension(2) :: Next
End Type Link
 
Integer, Parameter :: N = 2
Integer, dimension (2, 4) :: results
Integer :: i, j
 
Type(Link), Dimension(:,:), Pointer :: Perm
Integer, Dimension(2) :: Current
 
Allocate (Perm(N,N))
 
! Print*, 'Spanned by indices'
Do i = 1, N**2
Perm(mod(i-1,N)+1, (i-1)/N+1)%Next = (/ Mod(i,N) + 1, Mod(i/N+1,N)+1/)
! Write(*,100) mod(i-1,N)+1, (i-1)/N+1, Perm(mod(i-1,N)+1, (i-1)/N+1)%Next
! Expected output:
! Spanned by indices
! 1 1---> 2 2
! 2 1---> 1 1
! 1 2---> 2 1
! 2 2---> 1 2
End Do
 
! Print*, 'Spanned as a cycle'
Current = (/1,1/)
Do i = 1, n**2
results (:, i) = Perm(Current(1), Current(2))%Next
! Write(*,100) Current, Perm(Current(1), Current(2))%Next
! Expected output:
! 1 1---> 2 2
! 2 2---> 1 2
! 1 2---> 2 1
! 2 1---> 1 1
Current = Perm(Current(1), Current(2))%Next
End Do
 
if (any(results .ne. reshape ((/2,2,1,2,2,1,1,1/), (/2, 4/)))) call abort
 
! 100 Format( 2I3, '--->', 2I3)
DeAllocate (Perm)
 
End Program Strange
/gfortran.fortran-torture/execute/pr19269-1.f90
0,0 → 1,16
program main
call test (reshape ((/ 'a', 'b', 'c', 'd' /), (/ 2, 2 /)))
contains
subroutine test (a)
character (len = *), dimension (:, :) :: a
 
if (size (a, 1) .ne. 2) call abort
if (size (a, 2) .ne. 2) call abort
if (len (a) .ne. 1) call abort
 
if (a (1, 1) .ne. 'a') call abort
if (a (2, 1) .ne. 'b') call abort
if (a (1, 2) .ne. 'c') call abort
if (a (2, 2) .ne. 'd') call abort
end subroutine test
end program main
/gfortran.fortran-torture/execute/integer_select.f90
0,0 → 1,71
PROGRAM Test_INTEGER_select
 
! Every wrong branch leads to destruction.
 
INTEGER, PARAMETER :: maxI = HUGE (maxI)
INTEGER, PARAMETER :: minI = -1 * maxI
INTEGER :: I = 0
 
SELECT CASE (I)
CASE (:-1)
CALL abort
CASE (1:)
CALL abort
CASE DEFAULT
CONTINUE
END SELECT
 
SELECT CASE (I)
CASE (3,2,1)
CALL abort
CASE (0)
CONTINUE
CASE DEFAULT
call abort
END SELECT
 
! Not aborted by here, so it worked
! See about weird corner cases
 
I = maxI
 
SELECT CASE (I)
CASE (:-1)
CALL abort
CASE (1:)
CONTINUE
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (I)
CASE (3,2,1,:0)
CALL abort
CASE (maxI)
CONTINUE
CASE DEFAULT
call abort
END SELECT
 
I = minI
 
SELECT CASE (I)
CASE (:-1)
CONTINUE
CASE (1:)
CALL abort
CASE DEFAULT
CALL abort
END SELECT
 
SELECT CASE (I)
CASE (3:,2,1,0)
CALL abort
CASE (minI)
CONTINUE
CASE DEFAULT
call abort
END SELECT
 
END
 
/gfortran.fortran-torture/execute/f2_edit_1.f90
0,0 → 1,10
! check F2.x edit descriptors
! PR 14746
CHARACTER*15 LINE
RCON21 = 9.
RCON22 = .9
WRITE(LINE,'(F2.0,1H,,F2.1)')RCON21,RCON22
READ(LINE,'(F2.0,1X,F2.1)')XRCON21,XRCON22
IF (RCON21.NE.XRCON21) CALL ABORT
IF (RCON22.NE.XRCON22) CALL ABORT
END
/gfortran.fortran-torture/execute/inquire_2.f90
0,0 → 1,7
! PR 14837
INTEGER UNIT
OPEN(FILE='CSEQ', UNIT=23)
INQUIRE(FILE='CSEQ',NUMBER=UNIT)
IF (UNIT.NE.23) CALL ABORT
CLOSE(UNIT, STATUS='DELETE')
END
/gfortran.fortran-torture/execute/inquire_4.f90
0,0 → 1,21
! pr 14904
! inquire lastrec not correct when two records written
! with one write statement
OPEN(UNIT=10,ACCESS='DIRECT',FORM='FORMATTED',RECL=120)
100 FORMAT(I4)
WRITE(UNIT=10,REC=1,FMT=100)1
INQUIRE(UNIT=10,NEXTREC=J)
IF (J.NE.2) THEN
! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 2'
CALL ABORT
ENDIF
200 FORMAT(I4,/,I4)
WRITE(UNIT=10,REC=2,FMT=200)2,3
INQUIRE(UNIT=10,NEXTREC=J)
IF (J.NE.4) THEN
! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 4'
CALL ABORT
ENDIF
CLOSE(UNIT=10,STATUS='DELETE')
END
 
/gfortran.fortran-torture/execute/mystery_proc.f90
0,0 → 1,23
! Program to test dummy procedures
subroutine bar()
end subroutine
 
subroutine foo2(p)
external p
 
call p()
end subroutine
 
subroutine foo(p)
external p
! We never actually discover if this is a function or a subroutine
call foo2(p)
end subroutine
 
program intrinsic_minmax
implicit none
external bar
 
call foo(bar)
end program
 
/gfortran.fortran-torture/execute/pr40021.f
0,0 → 1,40
C Derived from lapack
PROGRAM test
DOUBLE PRECISION DA
INTEGER I, N
DOUBLE PRECISION DX(9),DY(9)
 
EXTERNAL DAXPY
N=5
DA=1.0
DATA DX/-2, -1, -3, -4, 1, 2, 10, 15, 14/
DATA DY/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/
CALL DAXPY (N,DA,DX,DY)
DO 10 I = 1, N
if (DX(I).ne.DY(I)) call abort
10 CONTINUE
STOP
END
 
SUBROUTINE DAXPY(N,DA,DX,DY)
DOUBLE PRECISION DA
INTEGER N
DOUBLE PRECISION DX(*),DY(*)
INTEGER I,IX,IY,M,MP1
INTRINSIC MOD
IF (N.LE.0) RETURN
20 M = MOD(N,4)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DY(I) = DY(I) + DA*DX(I)
30 CONTINUE
IF (N.LT.4) RETURN
40 MP1 = M + 1
DO 50 I = MP1,N,4
DY(I) = DY(I) + DA*DX(I)
DY(I+1) = DY(I+1) + DA*DX(I+1)
DY(I+2) = DY(I+2) + DA*DX(I+2)
DY(I+3) = DY(I+3) + DA*DX(I+3)
50 CONTINUE
RETURN
END
/gfortran.fortran-torture/execute/der_io.f90
0,0 → 1,67
! Program to test IO of derived types
program derived_io
character(400) :: buf1, buf2, buf3
 
type xyz_type
integer :: x
character(11) :: y
logical :: z
end type xyz_type
 
type abcdef_type
integer :: a
logical :: b
type (xyz_type) :: c
integer :: d
real(4) :: e
character(11) :: f
end type abcdef_type
 
type (xyz_type), dimension(2) :: xyz
type (abcdef_type) abcdef
 
xyz(1)%x = 11111
xyz(1)%y = "hello world"
xyz(1)%z = .true.
xyz(2)%x = 0
xyz(2)%y = "go away"
xyz(2)%z = .false.
 
abcdef%a = 0
abcdef%b = .true.
abcdef%c%x = 111
abcdef%c%y = "bzz booo"
abcdef%c%z = .false.
abcdef%d = 3
abcdef%e = 4.0
abcdef%f = "kawabanga"
 
write (buf1, *), xyz(1)%x, xyz(1)%y, xyz(1)%z
! Use function call to ensure it is only evaluated once
write (buf2, *), xyz(bar())
if (buf1.ne.buf2) call abort
 
write (buf1, *), abcdef
write (buf2, *), abcdef%a, abcdef%b, abcdef%c, abcdef%d, abcdef%e, abcdef%f
write (buf3, *), abcdef%a, abcdef%b, abcdef%c%x, abcdef%c%y, &
abcdef%c%z, abcdef%d, abcdef%e, abcdef%f
if (buf1.ne.buf2) call abort
if (buf1.ne.buf3) call abort
 
call foo(xyz(1))
 
contains
 
subroutine foo(t)
type (xyz_type) t
write (buf1, *), t%x, t%y, t%z
write (buf2, *), t
if (buf1.ne.buf2) call abort
end subroutine foo
 
integer function bar()
integer, save :: i = 1
bar = i
i = i + 1
end function
end
/gfortran.fortran-torture/execute/direct_io.f90
0,0 → 1,21
! demonstrates basic direct access using variables for REC
! pr14872
OPEN(UNIT=10,ACCESS='DIRECT',RECL=128)
DO I = 1,10
WRITE(10,REC=I,ERR=10)I
ENDDO
CLOSE(10)
OPEN(UNIT=10,ACCESS='DIRECT',RECL=128)
DO I = 1,10
READ(10,REC=I,ERR=10)J
IF (J.NE.I) THEN
! PRINT*,' READ ',J,' EXPECTED ',I
CALL ABORT
ENDIF
ENDDO
CLOSE(10,STATUS='DELETE')
STOP
10 CONTINUE
! PRINT*,' ERR= RETURN FROM READ OR WRITE'
CALL ABORT
END
/gfortran.fortran-torture/execute/random_2.f90
0,0 → 1,24
! Check that the real(4) and real(8) random number generators return the same
! sequence of values.
program random_4
integer, dimension(:), allocatable :: seed
real(kind=4), dimension(10) :: r4
real(kind=8), dimension(10) :: r8
real, parameter :: delta = 0.0001
integer n
 
call random_seed (size=n)
allocate (seed(n))
call random_seed (get=seed)
! Test both array valued and scalar routines.
call random_number(r4)
call random_number (r4(10))
 
! Reset the seed and get the real(8) values.
call random_seed (put=seed)
call random_number(r8)
call random_number (r8(10))
 
if (any ((r4 - r8) .gt. delta)) call abort
end program
 
/gfortran.fortran-torture/execute/entry_11.f90
0,0 → 1,16
! PR fortran/23663
function i (n)
i = n
i = max (i, 6)
return
entry j (n)
j = n
j = max (j, 3)
end
 
program entrytest
if (i (8).ne.8) call abort
if (i (4).ne.6) call abort
if (j (0).ne.3) call abort
if (j (7).ne.7) call abort
end
/gfortran.fortran-torture/execute/nullarg.f90
0,0 → 1,13
! This is the testcase from PR 12841. We used to report a type/rank mismatch
! when passing NULL() as an argument to a function.
MODULE T
PUBLIC :: A
CONTAINS
SUBROUTINE A(B)
REAL, POINTER :: B
IF (ASSOCIATED(B)) CALL ABORT()
END SUBROUTINE A
END MODULE T
USE T
CALL A(NULL())
END
/gfortran.fortran-torture/execute/transfer1.f90
0,0 → 1,10
program chop
integer ix, iy
real x, y
x = 1.
y = x
ix = transfer(x,ix)
iy = transfer(y,iy)
print '(2z20.8)', ix, iy
if (ix /= iy) call abort
end program chop
/gfortran.fortran-torture/execute/module_interface.f90
0,0 → 1,39
! We were incorrectly mangling procedures in interfaces in modules
 
module module_interface
interface
subroutine foo ()
end subroutine foo
end interface
contains
subroutine cs
end subroutine
 
subroutine cproc
interface
subroutine bar ()
end subroutine
end interface
call bar ()
call foo ()
call cs ()
end subroutine
end module
 
subroutine foo ()
end subroutine
 
subroutine bar ()
end subroutine
 
program module_interface_proc
use module_interface
interface
subroutine bar ()
end subroutine
end interface
 
call cproc ()
call foo ()
call bar ()
end program
/gfortran.fortran-torture/execute/initialization_1.f90
0,0 → 1,10
! PR 15963 -- checks character comparison in initialization expressions
character(8), parameter :: a(5) = (/ "H", "E", "L", "L", "O" /)
call x(a)
contains
subroutine x(a)
character(8), intent(in) :: a(:)
integer :: b(count(a < 'F'))
if (size(b) /= 1) call abort()
end subroutine x
end
/gfortran.fortran-torture/execute/strcmp.f90
0,0 → 1,16
program test
implicit none
character(len=20) :: foo
 
foo="hello"
 
if (llt(foo, "hello")) call abort
if (.not. lle(foo, "hello")) call abort
if (lgt("hello", foo)) call abort
if (.not. lge("hello", foo)) call abort
 
if (.not. llt(foo, "world")) call abort
if (.not. lle(foo, "world")) call abort
if (lgt(foo, "world")) call abort
if (lge(foo, "world")) call abort
end
/gfortran.fortran-torture/execute/der_type.f90
0,0 → 1,45
! Program to test derived types
program der_type
implicit none
type t1
integer, dimension (4, 5) :: a
integer :: s
end type
type my_type
character(20) :: c
type (t1), dimension (4, 3) :: ca
type (t1) :: r
end type
 
type init_type
integer :: i = 13
integer :: j = 14
end type
 
type (my_type) :: var
type (init_type) :: def_init
type (init_type) :: is_init = init_type (10, 11)
integer i;
 
if ((def_init%i .ne. 13) .or. (def_init%j .ne. 14)) call abort
if ((is_init%i .ne. 10) .or. (is_init%j .ne. 11)) call abort
! Passing a component as a parameter tests getting the addr of a component
call test_call(def_init%i)
var%c = "Hello World"
if (var%c .ne. "Hello World") call abort
var%r%a(:, :) = 0
var%ca(:, :)%s = 0
var%r%a(1, 1) = 42
var%r%a(4, 5) = 43
var%ca(:, :)%s = var%r%a(:, 1:5:2)
if (var%ca(1, 1)%s .ne. 42) call abort
if (var%ca(4, 3)%s .ne. 43) call abort
contains
subroutine test_call (p)
integer p
 
if (p .ne. 13) call abort
end subroutine
end program
 
/gfortran.fortran-torture/execute/pr32140.f90
0,0 → 1,16
MODULE TEST
CONTAINS
PURE FUNCTION s2a_3(s1,s2,s3) RESULT(a)
CHARACTER(LEN=*), INTENT(IN) :: s1, s2, s3
CHARACTER(LEN=4), DIMENSION(3) :: a
 
a(1)=s1; a(2)=s2; a(3)=s3
END FUNCTION
END MODULE
 
USE TEST
character(len=12) :: line
write(line,'(3A4)') s2a_3("a","bb","ccc")
IF (line.NE."a bb ccc") CALL ABORT()
END
 
/gfortran.fortran-torture/execute/slash_edit.f90
0,0 → 1,14
! pr 14762 - '/' not working in format
INTEGER N(5)
DATA N/1,2,3,4,5/
OPEN(UNIT=7)
100 FORMAT(I4)
WRITE(7,100)N
CLOSE(7)
OPEN(7)
200 FORMAT(I4,///I4)
READ(7,200)I,J
CLOSE(7, STATUS='DELETE')
IF (I.NE.1) CALL ABORT
IF (J.NE.4) CALL ABORT
END
/gfortran.fortran-torture/execute/seq_io.f90
0,0 → 1,81
! pr 15472
! sequential access files
!
! this test verifies the most basic sequential unformatted I/O
! write 3 records of various sizes
! then read them back
! and compare with what was written
!
implicit none
integer size
parameter(size=100)
logical debug
data debug /.FALSE./
! set debug to true for help in debugging failures.
integer m(2)
integer n
real*4 r(size)
integer i
m(1) = Z'11111111'
m(2) = Z'22222222'
n = Z'33333333'
do i = 1,size
r(i) = i
end do
write(9)m ! an array of 2
write(9)n ! an integer
write(9)r ! an array of reals
! zero all the results so we can compare after they are read back
do i = 1,size
r(i) = 0
end do
m(1) = 0
m(2) = 0
n = 0
 
rewind(9)
read(9)m
read(9)n
read(9)r
!
! check results
if (m(1).ne.Z'11111111') then
if (debug) then
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
else
call abort
endif
endif
 
if (m(2).ne.Z'22222222') then
if (debug) then
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
else
call abort
endif
endif
 
if (n.ne.Z'33333333') then
if (debug) then
print '(A,Z8)','n incorrect. n = ',n
else
call abort
endif
endif
 
do i = 1,size
if (int(r(i)).ne.i) then
if (debug) then
print*,'element ',i,' was ',r(i),' should be ',i
else
call abort
endif
endif
end do
! use hexdump to look at the file "fort.9"
if (debug) then
close(9)
else
close(9,status='DELETE')
endif
end
/gfortran.fortran-torture/execute/intrinsic_integer.f90
0,0 → 1,18
! Program to test the real->integer conversion routines.
program intrinsic_integer
implicit none
 
call test (0.0, (/0, 0, 0, 0/))
call test (0.3, (/0, 1, 0, 0/))
call test (0.7, (/0, 1, 0, 1/))
call test (-0.3, (/-1, 0, 0, 0/))
call test (-0.7, (/-1, 0, 0, -1/))
contains
subroutine test(val, res)
real :: val
integer, dimension(4) :: res
 
if ((floor(val) .ne. res(1)) .or. (ceiling(val) .ne. res(2)) &
.or. (int(val) .ne. res(3)) .or. (nint(val) .ne. res(4))) call abort
end subroutine
end program
/gfortran.fortran-torture/execute/character_passing.f90
0,0 → 1,22
! PR middle-end/20030
! we were messing up the access in LSAME for
! the character arguments.
program foo
character*1 a1, a2, b
logical LSAME, x
a1='A'
a2='A'
b='B'
x = LSAME(a1,a2)
if ( .not. x ) then
call abort ();
endif
end
 
logical function LSAME( CA, CB )
character CA, CB
integer INTA, INTB
INTA = ICHAR( CA )
INTB = ICHAR( CB )
LSAME = INTA.EQ.INTB
end
/gfortran.fortran-torture/execute/entry_1.f90
0,0 → 1,74
! Test alternate entry points for functions when the result types
! of all entry points match
 
function f1 (a)
integer a, b, f1, e1
f1 = 15 + a
return
entry e1 (b)
e1 = 42 + b
end function
function f2 ()
real f2, e2
entry e2 ()
e2 = 45
end function
function f3 ()
double precision a, b, f3, e3
entry e3 ()
f3 = 47
end function
function f4 (a) result (r)
double precision a, b, r, s
r = 15 + a
return
entry e4 (b) result (s)
s = 42 + b
end function
function f5 () result (r)
integer r, s
entry e5 () result (s)
r = 45
end function
function f6 () result (r)
real r, s
entry e6 () result (s)
s = 47
end function
function f7 ()
entry e7 ()
e7 = 163
end function
function f8 () result (r)
entry e8 ()
e8 = 115
end function
function f9 ()
entry e9 () result (r)
r = 119
end function
 
program entrytest
integer f1, e1, f5, e5
real f2, e2, f6, e6, f7, e7, f8, e8, f9, e9
double precision f3, e3, f4, e4, d
if (f1 (6) .ne. 21) call abort ()
if (e1 (7) .ne. 49) call abort ()
if (f2 () .ne. 45) call abort ()
if (e2 () .ne. 45) call abort ()
if (f3 () .ne. 47) call abort ()
if (e3 () .ne. 47) call abort ()
d = 17
if (f4 (d) .ne. 32) call abort ()
if (e4 (d) .ne. 59) call abort ()
if (f5 () .ne. 45) call abort ()
if (e5 () .ne. 45) call abort ()
if (f6 () .ne. 47) call abort ()
if (e6 () .ne. 47) call abort ()
if (f7 () .ne. 163) call abort ()
if (e7 () .ne. 163) call abort ()
if (f8 () .ne. 115) call abort ()
if (e8 () .ne. 115) call abort ()
if (f9 () .ne. 119) call abort ()
if (e9 () .ne. 119) call abort ()
end
/gfortran.fortran-torture/compile/module_expr.f90
0,0 → 1,18
! This uncovered a bug in the reading/writing of expressions.
module module_expr_1
integer a
end module
 
module module_expr_2
use module_expr_1
contains
 
subroutine myproc (p)
integer, dimension (a) :: p
end subroutine
end module
 
program module_expr
use module_expr_1
use module_expr_2
end program
/gfortran.fortran-torture/compile/stoppause.f90
0,0 → 1,10
! Program to check the STOP and PAUSE intrinsics
program stoppause
 
pause
pause 1
pause 'Hello world'
stop
stop 42
stop 'Go away'
end program
/gfortran.fortran-torture/compile/pr41654.f90
0,0 → 1,15
SUBROUTINE SCANBUFR (LBUFRIGNOREERROR, LBOPRPRO, LLSPLIT)
LOGICAL :: LBUFRIGNOREERROR, LBOPRPRO, LLSPLIT
INTEGER :: IBOTYP, IBSTYP
IF ((IBOTYP.eq.0).AND.(IBSTYP.eq.1)) GO TO 251
IF ((IBOTYP.eq.0).AND.(IBSTYP.eq.3)) GO TO 251
IF(LBUFRIGNOREERROR) THEN
goto 360
ENDIF
251 CONTINUE
IF(LBOPRPRO.AND.LLSPLIT) THEN
CALL OBSCREEN
ENDIF
360 CONTINUE
END SUBROUTINE SCANBUFR
 
/gfortran.fortran-torture/compile/pr33276.f90
0,0 → 1,27
! PR fortran/33276
! this used to crash due to an uninitialized variable in expand_iterator.
 
module foo
type buffer_type
integer(kind=kind(1)) :: item_end
character(256) :: string
end type
type textfile_type
type(buffer_type) :: buffer
end type
contains
function rest_of_line(self) result(res)
type(textfile_type) :: self
intent(inout) :: self
character(128) :: res
res = self%buffer%string(self%buffer%item_end+1: )
end function
 
subroutine read_intvec_ptr(v)
integer(kind=kind(1)), dimension(:), pointer :: v
integer(kind=kind(1)) :: dim,f,l,i
 
if (dim>0) then; v = (/ (i, i=f,l) /)
end if
end subroutine
end
/gfortran.fortran-torture/compile/fnresvar.f90
0,0 → 1,5
! Explicit function rsult variables
function fnresvar() result (r)
integer r
r = 0
end function
/gfortran.fortran-torture/compile/pr42781.f90
0,0 → 1,59
! ICE with gfortran 4.5 at -O1:
!gfcbug98.f90: In function ‘convert_cof’:
!gfcbug98.f90:36:0: internal compiler error: in pt_solutions_same_restrict_base,
!at tree-ssa-structalias.c:5072
module foo
implicit none
type t_time
integer :: secs = 0
end type t_time
contains
elemental function time_cyyyymmddhh (cyyyymmddhh) result (time)
type (t_time) :: time
character(len=10),intent(in) :: cyyyymmddhh
end function time_cyyyymmddhh
 
function nf90_open(path, mode, ncid)
character(len = *), intent(in) :: path
integer, intent(in) :: mode
integer, intent(out) :: ncid
integer :: nf90_open
end function nf90_open
end module foo
!==============================================================================
module gfcbug98
use foo
implicit none
 
type t_fileinfo
character(len=10) :: atime = ' '
end type t_fileinfo
 
type t_body
real :: bg(10)
end type t_body
contains
subroutine convert_cof (ifile)
character(len=*) ,intent(in) :: ifile
 
character(len=5) :: version
type(t_fileinfo) :: gattr
type(t_time) :: atime
type(t_body),allocatable :: tmp_dat(:)
real ,allocatable :: BDA(:, :, :)
 
call open_input
call convert_data
contains
subroutine open_input
integer :: i,j
version = ''
j = nf90_open(ifile, 1, i)
end subroutine open_input
!--------------------------------------------------------------------------
subroutine convert_data
BDA(1,:,1) = tmp_dat(1)% bg(:)
atime = time_cyyyymmddhh (gattr% atime)
end subroutine convert_data
end subroutine convert_cof
end module gfcbug98
/gfortran.fortran-torture/compile/complex_1.f90
0,0 → 1,5
program test_gfortran2
Complex(8) :: g, zh
Real(8) :: g_q
g = zh - zh/cmplx(0.0_8,-g_q)
end
/gfortran.fortran-torture/compile/write.f90
0,0 → 1,5
! Program to test simple IO
program testwrite
write (*) 1
write (*) "Hello World"
end program
/gfortran.fortran-torture/compile/pr45738.f90
0,0 → 1,11
PROGRAM TestInfinite
integer(8) :: bit_pattern_NegInf_i8 = -4503599627370496_8
 
integer(8) :: i
real(8) :: r
 
r = transfer(bit_pattern_NegInf_i8_p,r)
i = transfer(r,i)
 
END PROGRAM TestInfinite
 
/gfortran.fortran-torture/compile/module_common.f90
0,0 → 1,10
! We were incorrectly trying to create a variable for the common block itself,
! in addition to the variables it contains.
module FOO
implicit none
integer I
common /C/I
contains
subroutine BAR
end subroutine BAR
end module FOO
/gfortran.fortran-torture/compile/io_end.f90
0,0 → 1,9
! Check we can cope with end labels in IO statements
program m
implicit none
integer i
do while (.true.)
read(*, *, end = 1) i
end do
1 continue
end program m
/gfortran.fortran-torture/compile/empty_interface_1.f90
0,0 → 1,4
! Program to test empty interfaces PR15051
INTERFACE leer
END INTERFACE
END
/gfortran.fortran-torture/compile/named_args.f90
0,0 → 1,6
! This caused problems because we created a symbol for P while
! trying to parse the argument list as a substring reference.
program named_args
implicit none
integer, parameter :: realdp = selected_real_kind(p=8,r=30)
end program
/gfortran.fortran-torture/compile/arrayio.f90
0,0 → 1,12
! Program to test array IO. Should print the numbers 1-20 in order
program arrayio
implicit none
integer, dimension(5, 4) :: a
integer i, j
 
do j=1,4
a(:, j) = (/ (i + (j - 1) * 5, i=1,5) /)
end do
 
write (*) a
end program
/gfortran.fortran-torture/compile/pr24136.f
0,0 → 1,43
subroutine electra(ro,t,ye,ee,pe,se
a ,eer,eet,per,pet,ser,set,keyps)
implicit real*8 (a-h,o-z)
common /nunu/ nu,dnudr,dnudb,eta,detadnu,nup
data facen,facpr,facs,rg /2.037300d+24,1.358200d+24,1.686304d-10
1,8.314339d+07/
data a1,a2,a3,a4 /2.059815d-03,-7.027778d-03
1,4.219747d-02,-1.132427d+00/
beta=facs*t
b32=b12*beta
u=(f62/f52)**2
dudnu=2.0d0*u*(df62/f62-df52/f52)
x=beta*u
f=1.0d0+x*(2.5d0+x*(2.0d0+0.5d0*x))
df=2.5d0+x*(4.0d0+1.5d0*x)
dfdb=u*df
fi32=f32+(f-1.0d0)*f52/u
dfidnu=dfidu*dudnu+df32+(f-1.0d0)*df52/u
dfidb=dfdb*f52/u
dfidbet=dfidb+dfidnu*dnudb
gs=sqrt(g)
dg=0.75d0*gs
dgdb=u*dg
dgdu=beta*dg
gi32=f32+(g-1.0d0)*f52/u
dgidu=(u*dgdu-g+1.0d0)*f52/us
dgidnu=dgidu*dudnu+df32+(g-1.0d0)*df52/u
dgidb=dgdb*f52/u
dgidbet=dgidb+dgidnu*dnudb
dgidroe=dgidnu*dnudr
em=facen*b52*fi32
demdbet=facen*b32*(2.5d0*fi32+beta*dfidbet)
dpmdbet=facpr*b32*(2.5d0*gi32+beta*dgidbet)
demdroe=facen*b52*dfidroe
dpmdroe=facpr*b52*dgidroe
call divine(nup,fp12,dfp12,s12)
s42=2.0d0
call divine(nup,fp42,dfp42,s42)
eer=(ye*(demdroe+depdroe)-(em+ep)/ro)/ro
eet=facs*(demdbet+depdbet)/ro
per=ye*(dpmdroe+dppdroe)
pet=facs*(dpmdbet+dppdbet)
end
/gfortran.fortran-torture/compile/logical-1.f90
0,0 → 1,8
! PR fortran/33500
 
subroutine whatever()
logical(kind=1) :: l1, l2, l3
if ((l1 .and. l2) .neqv. l3) then
l1 = .true.
endif
end
/gfortran.fortran-torture/compile/logical-2.f90
0,0 → 1,10
! Check for operand type validity after gimplification
 
subroutine whatever()
logical(kind=1) :: l1
logical(kind=2) :: l2
logical(kind=4) :: l3
if ((l1 .and. l2) .neqv. l3) then
l1 = .true.
endif
end
/gfortran.fortran-torture/compile/implicit.f90
0,0 → 1,13
implicit integer(a), logical(b-c), real(d-y), integer(z)
a = 1_4
b = .true.
c = b
d = 1.0e2
y = d
z = a
end
! test prompted by PR 16161
! we used to match "character (c)" wrongly in the below, confusing the parser
subroutine b
implicit character (c)
end
/gfortran.fortran-torture/compile/emptyif-1.f90
0,0 → 1,10
program emptyif
 
implicit none
integer i,K(4)
 
if (K(i)==0) then
! do absolutely nothing
end if
 
end program
/gfortran.fortran-torture/compile/pr40413.f90
0,0 → 1,46
module state_matrices
 
implicit none
private
 
public :: state_matrix_copy
public :: state_matrix_t
public :: matrix_element_t
 
type :: matrix_element_t
private
integer, dimension(:), allocatable :: f
end type matrix_element_t
 
type :: state_matrix_t
private
type(matrix_element_t), dimension(:), allocatable :: me
end type state_matrix_t
 
type :: polarization_t
logical :: polarized = .false.
integer :: spin_type = 0
integer :: multiplicity = 0
type(state_matrix_t) :: state
end type polarization_t
 
contains
 
function polarization_copy (pol_in) result (pol)
type(polarization_t) :: pol
type(polarization_t), intent(in) :: pol_in
!!! type(state_matrix_t) :: state_dummy
pol%polarized = pol_in%polarized
pol%spin_type = pol_in%spin_type
pol%multiplicity = pol_in%multiplicity
!!! state_dummy = state_matrix_copy (pol_in%state)
!!! pol%state = state_dummy
pol%state = state_matrix_copy (pol_in%state)
end function polarization_copy
 
function state_matrix_copy (state_in) result (state)
type(state_matrix_t) :: state
type(state_matrix_t), intent(in), target :: state_in
end function state_matrix_copy
 
end module state_matrices
/gfortran.fortran-torture/compile/forall-1.f90
0,0 → 1,7
integer i, a(1)
logical(kind=8) s(1)
 
s = .true.
a = 42
forall (i=1:1, .not. s(1)) a(i) = 0
end
/gfortran.fortran-torture/compile/emptyif.f90
0,0 → 1,42
! Program to test empty IF statements
program emptyif
implicit none
logical c
logical d
 
if (c) then
c = .true.
end if
if (c) then
else
c = .true.
end if
 
if (c) then
c = .true.
else
end if
 
if (c) then
c = .true.
elseif (d) then
c = .true.
else
end if
 
if (c) then
c = .true.
elseif (d) then
else
c = .true.
end if
 
if (c) then
elseif (d) then
c = .true.
else
c = .true.
end if
 
end program
/gfortran.fortran-torture/compile/pr36078.f90
0,0 → 1,22
subroutine foo(func,p,eval)
real(kind=kind(1.0d0)), dimension(3,0:4,0:4,0:4) :: p
logical(kind=kind(.true.)), dimension(5,5,5) :: eval
interface
subroutine func(values,pt)
real(kind=kind(1.0d0)), dimension(:), intent(out) :: values
real(kind=kind(1.0d0)), dimension(:,:), intent(in) :: pt
end subroutine
end interface
real(kind=kind(1.0d0)), dimension(125,3) :: pt
integer(kind=kind(1)) :: n_pt
 
n_pt = 1
pt(1:n_pt,:) = &
reshape( &
pack( &
transpose(reshape(p,(/3,125/))), &
spread(reshape(eval,(/125/)),dim=2,ncopies=3)), &
(/n_pt,3/))
 
end subroutine
end
/gfortran.fortran-torture/compile/data_1.f90
0,0 → 1,11
! this tests the fix for PR 13826
TYPE a
REAL x
END TYPE
TYPE(a) :: y
DATA y /a(1.)/ ! used to give an error about non-PARAMETER
END
! this tests the fix for PR 13940
SUBROUTINE a
DATA i /z'f95f95'/
END
/gfortran.fortran-torture/compile/inline_1.f90
0,0 → 1,17
program gfcbug43
call try_fit (1)
call try_fit (1)
contains
subroutine try_fit (k)
call fit (1, debug=.true.)
end subroutine try_fit
subroutine fit (k, debug)
logical, intent(in), optional :: debug
do j = 1, 2
maxerr1 = funk (r ,x1 , x1)
end do
if (debug) then
print *, "help"
end if
end subroutine fit
end program gfcbug43
/gfortran.fortran-torture/compile/20080806-1.f90
0,0 → 1,24
MODULE M1
IMPLICIT NONE
TYPE mmm
COMPLEX(KIND=8), DIMENSION(:,:), POINTER :: data
END TYPE mmm
 
CONTAINS
 
SUBROUTINE S(ma,mb,mc)
TYPE(mmm), POINTER :: ma,mb,mc
COMPLEX(KIND=8), DIMENSION(:, :), &
POINTER :: a, b, c
INTEGER :: i,j
a=>ma%data
b=>mb%data
c=>mc%data
DO i=1,size(a,1)
DO j=1,size(a,2)
c(i,j)=a(i,j)*b(i,j)
ENDDO
ENDDO
END SUBROUTINE
 
END MODULE M1
/gfortran.fortran-torture/compile/pr40421.f90
0,0 → 1,15
subroutine pr40421 (j, q, r)
double precision :: q(1,1), r(1,1,3)
save
integer :: i, j, m, n
double precision :: s, t, u
do i=1,2
do m=1,j
do n=1,1
s=q(n,m)*r(n,m,1)
t=q(n,m)*r(n,m,2)
u=q(n,m)*r(n,m,3)
end do
end do
end do
end
/gfortran.fortran-torture/compile/pr37236.f
0,0 → 1,82
C
SUBROUTINE FFTRC (A,N,X,IWK,WK)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N,IWK(1)
REAL*8 A(N),WK(1)
COMPLEX*16 X(1)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ND2P1,ND2,I,MTWO,M,IMAX,ND4,NP2,K,NMK,J
REAL*8 RPI,ZERO,ONE,HALF,THETA,TP,G(2),B(2),Z(2),AI,
1 AR
COMPLEX*16 XIMAG,ALPH,BETA,GAM,S1,ZD
EQUIVALENCE (GAM,G(1)),(ALPH,B(1)),(Z(1),AR),(Z(2),AI),
1 (ZD,Z(1))
DATA ZERO/0.0D0/,HALF/0.5D0/,ONE/1.0D0/,IMAX/24/
DATA RPI/3.141592653589793D0/
C FIRST EXECUTABLE STATEMENT
IF (N .NE. 2) GO TO 5
C N EQUAL TO 2
ZD = DCMPLX(A(1),A(2))
THETA = AR
TP = AI
X(2) = DCMPLX(THETA-TP,ZERO)
X(1) = DCMPLX(THETA+TP,ZERO)
GO TO 9005
5 CONTINUE
C N GREATER THAN 2
ND2 = N/2
ND2P1 = ND2+1
C MOVE A TO X
J = 1
DO 6 I=1,ND2
X(I) = DCMPLX(A(J),A(J+1))
J = J+2
6 CONTINUE
C COMPUTE THE CENTER COEFFICIENT
GAM = DCMPLX(ZERO,ZERO)
DO 10 I=1,ND2
GAM = GAM + X(I)
10 CONTINUE
TP = G(1)-G(2)
GAM = DCMPLX(TP,ZERO)
C DETERMINE THE SMALLEST M SUCH THAT
C N IS LESS THAN OR EQUAL TO 2**M
MTWO = 2
M = 1
DO 15 I=1,IMAX
IF (ND2 .LE. MTWO) GO TO 20
MTWO = MTWO+MTWO
M = M+1
15 CONTINUE
20 IF (ND2 .EQ. MTWO) GO TO 25
C N IS NOT A POWER OF TWO, CALL FFTCC
CALL FFTCC (X,ND2,IWK,WK)
GO TO 30
C N IS A POWER OF TWO, CALL FFT2C
25 CALL FFT2C (X,M,IWK)
30 ALPH = X(1)
X(1) = B(1) + B(2)
ND4 = (ND2+1)/2
IF (ND4 .LT. 2) GO TO 40
NP2 = ND2 + 2
THETA = RPI/ND2
TP = THETA
XIMAG = DCMPLX(ZERO,ONE)
C DECOMPOSE THE COMPLEX VECTOR X
C INTO THE COMPONENTS OF THE TRANSFORM
C OF THE INPUT DATA.
DO 35 K = 2,ND4
NMK = NP2 - K
S1 = DCONJG(X(NMK))
ALPH = X(K) + S1
BETA = XIMAG*(S1-X(K))
S1 = DCMPLX(DCOS(THETA),DSIN(THETA))
X(K) = (ALPH+BETA*S1)*HALF
X(NMK) = DCONJG(ALPH-BETA*S1)*HALF
THETA = THETA + TP
35 CONTINUE
40 CONTINUE
X(ND2P1) = GAM
9005 RETURN
END
 
/gfortran.fortran-torture/compile/pr32583.f
0,0 → 1,40
subroutine detune(iv,ekk,ep,beta,dtu,dtup,dfac)
implicit real*8 (a-h,o-z)
parameter(npart=64,nmac=1)
parameter(nele=700,nblo=300,nper=16,
&nelb=100,nblz=20000,nzfz=300000,mmul=11)
parameter(nran=280000,ncom=100,mran=500,mpa=6,nrco=5,nema=15)
parameter(mcor=10)
parameter(npos=20000,nlya=10000,ninv=1000,nplo=20000)
parameter(nmon1=600,ncor1=600)
parameter(pieni=1d-17)
parameter(zero=0.0d0,half=0.5d0,one=1.0d0)
parameter(two=2.0d0,three=3.0d0,four=4.0d0)
dimension dfac(10),dtu(2,5),ep(2),beta(2),dtup(2,5,0:4,0:4)
save
pi=four*atan(one)
iv2=2*iv
iv3=iv+1
vtu1=-ekk*(half**iv2)*dfac(iv2)/pi
dtu1=zero
dtu2=zero
do 10 iv4=1,iv3
iv5=iv4-1
iv6=iv-iv5
vor=one
if(mod(iv6,2).ne.0) vor=-one
vtu2=vor/(dfac(iv5+1)**2)/(dfac(iv6+1)**2)*(beta(1)**iv5)* (beta
+ (2)**iv6)
if(iv5.ne.0) then
dtu1=dtu1+vtu2*iv5*(ep(1)**(iv5-1))*(ep(2)**iv6)
dtup(1,iv,iv5-1,iv6)=dtup(1,iv,iv5-1,iv6)+vtu2*iv5*vtu1
endif
if(iv6.ne.0) then
dtu2=dtu2+vtu2*iv6*(ep(1)**iv5)*(ep(2)**(iv6-1))
dtup(2,iv,iv5,iv6-1)=dtup(2,iv,iv5,iv6-1)+vtu2*iv6*vtu1
endif
10 continue
dtu(1,iv)=dtu(1,iv)+vtu1*dtu1
dtu(2,iv)=dtu(2,iv)+vtu1*dtu2
return
end
/gfortran.fortran-torture/compile/pr30147.f90
0,0 → 1,14
MODULE input_cp2k_motion
IMPLICIT NONE
interface
SUBROUTINE keyword_create(variants)
CHARACTER(len=*), DIMENSION(:), &
INTENT(in) :: variants
end subroutine
end interface
CONTAINS
SUBROUTINE create_neb_section()
CALL keyword_create(variants=(/"K"/))
END SUBROUTINE create_neb_section
END MODULE input_cp2k_motion
 
/gfortran.fortran-torture/compile/convert.f90
0,0 → 1,37
! Program to test conversion. Does not actualy test the generated code
program convert
implicit none
integer(kind=4) i
integer(kind=8) m
real(kind=4) r
real(kind=8) q
complex(kind=4) c
complex(kind=8) z
 
! each of these should generate a single intrinsic conversion expression
i = int(i)
i = int(m)
i = int(r)
i = int(q)
i = int(c)
i = int(z)
m = int(i, kind=8)
m = int(m, kind=8)
m = int(r, kind=8)
m = int(q, kind=8)
m = int(c, kind=8)
m = int(z, kind=8)
r = real(i)
r = real(m)
r = real(r)
r = real(q)
r = real(c)
r = real(z, kind=4)
q = real(i, kind=8)
q = real(m, kind=8)
q = real(r, kind=8)
q = real(q, kind=8)
q = real(c, kind=8)
! Note real(<complex>) returns the type kind of the argument.
q = real(z)
end program
/gfortran.fortran-torture/compile/named_args_2.f90
0,0 → 1,8
! this is the reduced testcase from pr13372
! we wrongly add a symbol "P" to the module
! Currently (2004/06/09) a workaround is in place
! PR 15481 tracks any steps towards a real fix.
module typeSizes
implicit none
integer, parameter :: FourByteReal = selected_real_kind(P = 6, R = 37)
end module typeSizes
/gfortran.fortran-torture/compile/enum_1.f90
0,0 → 1,46
! Program to test parsing of ENUM in different program units
 
program main
implicit none
interface
subroutine sub1
end subroutine sub1
end interface
integer :: i = 55
 
enum , bind (c)
enumerator :: a , b=5
enumerator c, d
end enum
 
call sub
call sub1
i = fun()
 
contains
 
subroutine sub
enum, bind(c)
enumerator :: p = b, q = 10 + 50
enumerator r, s
end enum
end subroutine sub
 
function fun()
integer :: fun
enum, bind (c)
enumerator :: red, yellow = 23
enumerator :: blue
enumerator :: green
end enum
fun = 1
end function fun
end program main
 
subroutine sub1
implicit none
enum, bind(c)
enumerator x , y
enumerator :: z = 100
end enum
end subroutine sub1
/gfortran.fortran-torture/compile/compile.exp
0,0 → 1,102
# Expect driver script for GCC Regression Tests
# Copyright (C) 2003, 2007, 2008 Free Software Foundation
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
 
# These tests come from many different contributors.
 
if $tracelevel then {
strace $tracelevel
}
 
# load support procs
load_lib fortran-torture.exp
load_lib torture-options.exp
 
torture-init
set-torture-options [get-fortran-torture-options]
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f90]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F90]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f95]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F95]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f03]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F03]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f08]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F08]] {
if ![runtest_file_p $runtests $testcase] then {
continue
}
fortran-torture $testcase
}
 
torture-finish
/gfortran.fortran-torture/compile/pr39937.f
0,0 → 1,28
SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
DOUBLE PRECISION X( 2, 2 )
CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ ZERO, X, 2, SCALE, XNORM, IERR )
CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
DO 90 J = KI - 2, 1, -1
IF( J.GT.JNXT )
$ GO TO 90
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
END IF
END IF
CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ XNORM, IERR )
CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
END IF
90 CONTINUE
END
/gfortran.fortran-torture/compile/pr26806.f90
0,0 → 1,11
module solv_cap
integer, private, save :: Ng1=0, Ng2=0
contains
subroutine FourirG(G)
real, intent(in out), dimension(0:,0:) :: G
complex, allocatable, dimension(:,:) :: t
allocate( t(0:2*Ng1-1,0:2*Ng2-1) )
t(0:Ng1,0:Ng2-1) = G(:,0:Ng2-1) ! Fill one quadrant (one extra row)
t(0:Ng1,Ng2:2*Ng2-1) = G(:,Ng2:1:-1) ! This quadrant using symmetry
end subroutine FourirG
end module solv_cap
/gfortran.fortran-torture/compile/pr45634.f90
0,0 → 1,5
SUBROUTINE RCRDRD (VTYP)
CHARACTER(4), INTENT(OUT) :: VTYP
CHARACTER(1), SAVE :: DBL = "D"
VTYP = DBL
END
/gfortran.fortran-torture/compile/implicit_1.f90
0,0 → 1,32
! Test implicit character declarations.
! This requires some coordination between the typespec and variable name range
! matchers to get it right.
module implicit_1
integer, parameter :: x = 10
integer, parameter :: y = 6
integer, parameter :: z = selected_int_kind(4)
end module
subroutine foo(n)
use implicit_1
! Test various combinations with and without character length
! and type kind specifiers
implicit character(len=5) (a)
implicit character(n) (b)
implicit character*6 (c-d)
implicit character (e)
implicit character(x-y) (f)
implicit integer(z) (g)
implicit character (z)
 
a1 = 'Hello'
b1 = 'world'
c1 = 'wibble'
d1 = 'hmmm'
e1 = 'n'
f1 = 'test'
g1 = 1
x1 = 1.0
y1 = 2.0
z1 = 'A'
end
 
/gfortran.fortran-torture/compile/mloc.f90
0,0 → 1,8
! from PR 14928
! we used to not accept the two argument variant of MINLOC and MAXLOC when
! the MASK keyword was omitted.
real b(10)
integer c(1)
c = minloc(b,b<0)
c = maxloc(b,b>0)
end
/gfortran.fortran-torture/compile/name_clash.f90
0,0 → 1,9
! This is the testcase from PR13249.
! the two different entities named AN_EXAMPLE shouldn't conflict
MODULE MOD
INTEGER FOO
END
PROGRAM MAIN
USE MOD
COMMON /FOO/ BAR
END
/gfortran.fortran-torture/compile/implicit_2.f90
0,0 → 1,6
! PR 13372 -- we incorrectly added a symbol for p, which broke implicit typing
module t
implicit none
integer, parameter :: F = selected_real_kind(P = 6, R = 37)
end module t
 
/gfortran.fortran-torture/compile/noncontinuation_1.f
0,0 → 1,3
! verifies that 0 in column six doesn't start a continuation line
!234567890
0 END
/gfortran.fortran-torture/compile/pr45598.f90
0,0 → 1,13
program main
implicit none
character(len=10) :: digit_string = '123456789'
character :: digit_arr(10)
call copy(digit_string, digit_arr)
print '(1x, a1)',digit_arr(1:9)
contains
subroutine copy(in, out)
character, dimension(10) :: in, out
out(1:10) = in(1:10)
end subroutine copy
end program main
 
/gfortran.fortran-torture/compile/parameter_1.f90
0,0 → 1,7
! legal
integer, parameter :: j = huge(j)
integer i
 
if (j /= huge(i)) call abort
end
 
/gfortran.fortran-torture/compile/parameter_2.f90
0,0 → 1,23
! Program to test initialization expressions involving subobjects
program parameter_2
implicit none
type :: SS
integer :: I
integer :: J
end type SS
type :: TT
integer :: N
type (SS), dimension(2) :: o
end type
type (SS), parameter :: s = SS (1, 2)
type (TT), parameter :: t = TT(42, (/ SS(3, 4), SS(8, 9) /))
 
integer, parameter :: a(2) = (/5, 10/)
integer, parameter :: d1 = s%i
integer, parameter :: d2 = a(2)
integer, parameter :: d4 = t%o(2)%j
 
integer q1, q2, q3, q4
common /c1/q1(d1), q2(d2), q3(a(1)), q4(d4) ! legal
end
/gfortran.fortran-torture/compile/parameter_3.f90
0,0 → 1,4
program tst
write (6,"(a,es15.8)") "2.0**(-0.0) = ",2.0**(-0.0)
end program tst
 
/gfortran.fortran-torture/compile/strparm_1.f90
0,0 → 1,6
! Check known length string parameters
subroutine test (s)
character(len=80) :: s
 
s = "Hello World"
end subroutine
/gfortran.fortran-torture/compile/actual.f90
0,0 → 1,38
module modull
 
contains
 
function fun( a )
real, intent(in) :: a
real :: fun
fun = a
end function fun
 
end module modull
 
 
 
program t5
 
use modull
 
real :: a, b
 
b = foo( fun, a )
 
contains
 
function foo( f, a )
real, intent(in) :: a
interface
function f( x )
real, intent(in) :: x
real :: f
end function f
end interface
real :: foo
 
foo = f( a )
end function foo
 
end program t5
/gfortran.fortran-torture/compile/pr49721-1.f
0,0 → 1,9
PARAMETER( LM=7 )
PARAMETER( NM=2+2**LM, NV=NM**3 )
PARAMETER( NR = (8*(NM**3+NM**2+5*NM-23+7*LM))/7 )
COMMON /X/ U, V, R, A
REAL*8 U(NR),V(NV),R(NR),A(0:3)
DO 20 IT=1,NIT
CALL RESID(U,V,R,N,A)
20 CONTINUE
END
/gfortran.fortran-torture/compile/ambig.f90
0,0 → 1,26
MODULE TYPESP
TYPE DMT
REAL(KIND(1.D0)), POINTER :: ASPK(:)
END TYPE DMT
END MODULE TYPESP
 
MODULE TCNST
Integer, Parameter :: DIM_TEMP_BUFFER=10000
Real(Kind(1.d0)), Parameter :: COLROW_=0.33,PERCENT=0.7
end MODULE TCNST
 
 
Subroutine DOWORK(A)
Use TYPESP
Use TCNST
Type(DMT), intent (inout) :: A
Real(Kind(1.d0)),Pointer :: ASPK(:)
Integer :: ISIZE, IDIM
 
ISIZE=DIM_TEMP_BUFFER
Allocate(ASPK(ISIZE),STAT=INFO)
IDIM = MIN(ISIZE,SIZE(A%ASPK))
ASPK(1:IDIM) = A%ASPK(1:IDIM)
Return
End Subroutine DOWORK
/gfortran.fortran-torture/compile/dummyfn.f90
0,0 → 1,13
! Program to test array valued dummy functions
SUBROUTINE dummyfn(deriv)
implicit none
INTERFACE
FUNCTION deriv()
REAL :: deriv(4)
END FUNCTION deriv
END INTERFACE
 
REAL :: dx(4)
 
dx = deriv()
END SUBROUTINE
/gfortran.fortran-torture/compile/pr32417.f90
0,0 → 1,15
! PR tree-opt/32417
! this used to crash while running IV-opts
! aff_combination_add_elt was not ready to handle pointers correctly
 
SUBROUTINE ONEINTS()
COMMON /INFOA / NAT,NUM
DIMENSION TINT(NUM*NUM,NAT,3,3,3),TINTM(NUM,NUM,NAT,3,3,3)
 
CALL TINTS(IC)
DO ID=1,3
DO IC=1,NAT
TINTM(J,I,IC,IAN,INU,ID) = TINT((I-1)*NUM+J,IC,IAN,INU,ID)
ENDDO
ENDDO
END
/gfortran.fortran-torture/compile/nested.f90
0,0 → 1,23
! Program to test the nested functions
program intrinsic_pack
integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/)
integer, dimension(3, 3) :: a
integer, dimension(6) :: b
 
a = reshape (val, (/3, 3/))
b = 0
b(1:6:3) = pack (a, a .ne. 0);
if (any (b(1:6:3) .ne. (/9, 7/))) call abort
b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/));
if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort
 
contains
subroutine tests_with_temp
! A few tests which involve a temporary
if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort
if (any (pack(a, .true.) .ne. val)) call abort
if (size(pack (a, .false.)) .ne. 0) call abort
if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort
 
end subroutine tests_with_temp
end program
/gfortran.fortran-torture/compile/do_1.f90
0,0 → 1,28
! test various forms of the DO statement
! inspired by PR14066
LOGICAL L
DO i=1,10
END DO
DO 10 i=1,20
DO 20,j=1,10,2
20 CONTINUE
10 END DO
L = .TRUE.
DO WHILE(L)
L = .FALSE.
END DO
DO 50 WHILE(.NOT.L)
L = .TRUE.
50 CONTINUE
DO
DO 30
DO 40
40 CONTINUE
30 END DO
END DO
outer: DO i=1,20
inner: DO,j=i,30
IF (j.EQ.2*i) CYCLE outer
END DO inner
END DO outer
END
/gfortran.fortran-torture/compile/transfer-1.f90
0,0 → 1,22
! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
integer(1), parameter :: zero = 0
LOGICAL, PARAMETER :: bigend = IACHAR(TRANSFER(1,"a")) == zero
LOGICAL :: bigendian
call foo ()
contains
subroutine foo ()
integer :: chr, ans
if (bigend) then
ans = 1
else
ans = 0
end if
chr = IACHAR(TRANSFER(1,"a"))
bigendian = chr == 0_4
if (bigendian) then
ans = 1
else
ans = 0
end if
end subroutine foo
end
/gfortran.fortran-torture/compile/module_result.f90
0,0 → 1,9
! Result variables in module procedures
module module_result
implicit none
contains
function test () result (res)
integer res
res = 0
end function
end module
/gfortran.fortran-torture/compile/contained_1.f90
0,0 → 1,15
! Obscure failure that disappeared when the parameter was removed.
! Works OK now.
module mymod
implicit none
contains
subroutine test(i)
implicit none
integer i
end subroutine
end module mymod
 
program error
use mymod
end program
 
/gfortran.fortran-torture/compile/allocate.f90
0,0 → 1,26
! Snippet to test various allocate statements
 
program test_allocate
implicit none
type t
integer i
real r
end type
type pt
integer, pointer :: p
end type
integer, allocatable, dimension(:, :) :: a
type (t), pointer, dimension(:) :: b
type (pt), pointer :: c
integer, pointer:: p
integer n
 
n = 10
allocate (a(1:10, 4))
allocate (a(5:n, n:14))
allocate (a(6, 8))
allocate (b(n))
allocate (c)
allocate (c%p)
allocate (p)
end program
/gfortran.fortran-torture/compile/contained_2.f90
0,0 → 1,11
! Arrays declared in parent but used in the child.
program error
implicit none
integer, dimension (10) :: a
contains
subroutine test()
implicit none
a(1) = 0
end subroutine
end program
 
/gfortran.fortran-torture/compile/contained_3.f90
0,0 → 1,12
! Program to check using parent variables in more than one contained function
program contained_3
implicit none
integer var
contains
subroutine one
var = 1
end subroutine
subroutine two
var = 2
end subroutine
end program
/gfortran.fortran-torture/compile/bergervoet2.f90
0,0 → 1,5
function testi() result(res)
integer :: res
res = 0
end function testi
 
/gfortran.fortran-torture/compile/contained_4.f90
0,0 → 1,35
! Check contained functions with the same name.
module contained_4
 
contains
 
subroutine foo1()
call bar()
contains
subroutine bar()
end subroutine bar
end subroutine foo1
 
subroutine foo2()
call bar()
contains
subroutine bar()
end subroutine bar
end subroutine foo2
 
end module contained_4
 
subroutine foo1()
call bar()
contains
subroutine bar()
end subroutine bar
end subroutine
 
subroutine foo2()
call bar()
contains
subroutine bar()
end subroutine bar
end subroutine foo2
 
/gfortran.fortran-torture/compile/vrp_1.f90
0,0 → 1,17
SUBROUTINE STONUM(STRVAR,LENGTH)
CHARACTER STRVAR*(*) , CHK
LOGICAL MEND , NMARK , MMARK , EMARK
NMARK = .FALSE.
MMARK = .FALSE.
DO WHILE ( .NOT.MEND )
IF ( CHK.GE.'0' .AND. CHK.LE.'9' ) THEN
IF ( CHK.EQ.'E' ) THEN
NMARK = .TRUE.
ELSEIF ( .NOT.MMARK .AND. CHK.EQ.'*' .AND. .NOT.NMARK ) &
& THEN
MMARK = .TRUE.
ENDIF
ENDIF
ENDDO
END
 
/gfortran.fortran-torture/compile/contained_5.f90
0,0 → 1,10
! Function returning an array continaed in a module. Caused problems 'cos
! we tried to add the dummy return vars to the parent scope.
 
Module contained_5
contains
FUNCTION test ()
REAL, DIMENSION (1) :: test
test(1)=0.0
END FUNCTION
end module
/gfortran.fortran-torture/compile/empty.f90 --- gfortran.fortran-torture/compile/pr40421.f (nonexistent) +++ gfortran.fortran-torture/compile/pr40421.f (revision 695) @@ -0,0 +1,18 @@ + SUBROUTINE VROT2(N,DIS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER(ZERO=0.0D+00) + COMMON /SYMSPD/ PTR(3,144) + DIMENSION DIS(3,2),TMP(3,2) + DO I = 1,3 + TMP1 = ZERO + DO J = 1,3 + TMP1 = TMP1 + PTR(I,N+J) + END DO + TMP(I,1) = TMP1 + END DO + DO I = 1,3 + DIS(I,1) = TMP(I,1) + END DO + RETURN + END +
/gfortran.fortran-torture/compile/shape_reshape.f90
0,0 → 1,8
! This checks that the shape of the SHAPE intrinsic is known.
PROGRAM shape_reshape
INTEGER, ALLOCATABLE :: I(:,:)
ALLOCATE(I(2,2))
I = RESHAPE((/1,2,3,4/),SHAPE=SHAPE(I))
DEALLOCATE(I)
END PROGRAM
 
/gfortran.fortran-torture/compile/module_proc.f90
0,0 → 1,14
! Check module procedures with arguments
module module_proc
contains
subroutine s(p)
integer p
end subroutine
end module
 
program test
use module_proc
integer i
call s(i)
end program
 
/gfortran.fortran-torture/compile/pr32663.f
0,0 → 1,147
SUBROUTINE DIMOID(DEN,RLMO,SSQU,STRI,ATMU,IATM,IWHI,MAPT,INAT,
* IATB,L1,L2,M1,M2,NATS,NOSI,NCAT,NSWE)
C
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
DIMENSION RLMO(L1,L1),SSQU(L1,L1),STRI(L2),ATMU(NATS),DEN(M2)
DIMENSION IATM(NATS,M1),IWHI(M1+NATS),MAPT(M1),INAT(M1+NATS)
DIMENSION IATB(NATS,M1)
C
PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, MXAO=2047)
C
LOGICAL GOPARR,DSKWRK,MASWRK
C
COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
* ZAN(MXATM),C(3,MXATM)
COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(400)
COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
* CF(MXGTOT),CG(MXGTOT),
* KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),
* KNG(MXSH),KLOC(MXSH),KMIN(MXSH),
* KMAX(MXSH),NSHELL
COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
* MOOUTA(MXAO),MOOUTB(MXAO)
COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
C
C
DO 920 II=1,M1
INAT(II) = 0
920 CONTINUE
C
 
DO 900 IO = NOUTA+1,NUMLOC
IZ = IO - NOUTA
DO 895 II=NST,NEND
ATMU(II) = 0.0D+00
IATM(II,IZ) = 0
895 CONTINUE
IFUNC = 0
DO 890 ISHELL = 1,NSHELL
IAT = KATOM(ISHELL)
IST = KMIN(ISHELL)
IEN = KMAX(ISHELL)
DO 880 INO = IST,IEN
IFUNC = IFUNC + 1
IF (IAT.LT.NST.OR.IAT.GT.NEND) GOTO 880
ZINT = 0.0D+00
DO 870 II = 1,L1
ZINT = ZINT + RLMO(II,IO)*SSQU(II,IFUNC)
870 CONTINUE
ATMU(IAT) = ATMU(IAT) + RLMO(IFUNC,IO)*ZINT
880 CONTINUE
890 CONTINUE
IF (MASWRK) WRITE(IW,9010) IZ,(ATMU(II),II=NST,NEND)
900 CONTINUE
C
NOSI = 0
DO 700 II=1,M1
NO=0
DO 720 JJ=1,NAT
NO = NO + 1
720 CONTINUE
740 CONTINUE
IF (NO.GT.1.OR.NO.EQ.0) THEN
NOSI = NOSI + 1
IWHI(NOSI) = II
ENDIF
IF (MASWRK)
* WRITE(IW,9030) II,(IATM(J,II),A(IATM(J,II)),J=1,NO)
700 CONTINUE
C
IF (MASWRK) THEN
WRITE(IW,9035) NOSI
IF (NOSI.GT.0) THEN
WRITE(IW,9040) (IWHI(I),I=1,NOSI)
WRITE(IW,9040)
ELSE
WRITE(IW,9040)
ENDIF
ENDIF
C
CALL DCOPY(L1*L1,RLMO,1,SSQU,1)
CALL DCOPY(M2,DEN,1,STRI,1)
C
IP2 = NOUTA
IS2 = M1+NOUTA-NOSI
DO 695 II=1,NAT
INAT(II) = 0
695 CONTINUE
C
DO 690 IAT=1,NAT
DO 680 IORB=1,M1
IP1 = IORB + NOUTA
IF (IATM(1,IORB).NE.IAT) GOTO 680
IF (IATM(2,IORB).NE.0) GOTO 680
INAT(IAT) = INAT(IAT) + 1
IP2 = IP2 + 1
CALL DCOPY(L1,SSQU(1,IP1),1,RLMO(1,IP2),1)
CALL ICOPY(NAT,IATM(1,IORB),1,IATB(1,IP2-NOUTA),1)
MAPT(IORB) = IP2-NOUTA
680 CONTINUE
DO 670 IORB=1,NOSI
IS1 = IWHI(IORB) + NOUTA
IF (IAT.EQ.NAT.AND.IATM(1,IWHI(IORB)).EQ.0) GOTO 675
IF (IATM(1,IWHI(IORB)).NE.IAT) GOTO 670
675 CONTINUE
IS2 = IS2 + 1
MAPT(IWHI(IORB)) = IS2-NOUTA
670 CONTINUE
690 CONTINUE
C
NSWE = 0
NCAT = 0
LASP = 1
NLAST = 0
DO 620 II=1,NAT
NSWE = NSWE + (IWHI(II)*(IWHI(II)-1))/2
NCAT = NCAT + 1
INAT(NCAT) = LASP + NLAST
LASP = INAT(NCAT)
NLAST = IWHI(II)
IWHI(NCAT) = II
620 CONTINUE
C
DO 610 II=1,NOSI
NCAT = NCAT + 1
INAT(NCAT) = LASP + NLAST
LASP = INAT(NCAT)
NLAST = 1
IWHI(NCAT) = 0
610 CONTINUE
C
RETURN
C
8000 FORMAT(/1X,'** MULLIKEN ATOMIC POPULATIONS FOR EACH NON-FROZEN ',
* 'LOCALIZED ORBITAL **')
9000 FORMAT(/3X,'ATOM',2X,100(I2,1X,A4))
9005 FORMAT(1X,'LMO')
9010 FORMAT(1X,I3,3X,100F7.3)
9015 FORMAT(/1X,'** ATOMIC POPULATIONS GREATER THAN ',F4.2,
* ' ARE CONSIDERED MAJOR **')
9020 FORMAT(/2X,'LMO',3X,'MAJOR CONTRIBUTIONS FROM ATOM(S)')
9030 FORMAT(2X,I3,2X,100(I2,1X,A2,2X))
9035 FORMAT(/1X,'NO OF LMOS INVOLVING MORE THAN ONE ATOM =',I3)
9040 FORMAT(1X,'THESE ARE LMOS :',100I3)
C
END
/gfortran.fortran-torture/compile/defined_type_1.f90
0,0 → 1,10
!This used to ICE as we chose the wrong type for the
! temporary to hold type%var
! fortran/18157
program testcase_fold
type :: struct
real :: var ! its julian sec
end type struct
type(struct), dimension(:), pointer :: mystruct
mystruct(:)%var = mystruct(:)%var
END Program testcase_fold
/gfortran.fortran-torture/compile/gen_interf.f90
0,0 → 1,19
! Program to test generic interfaces.
program gen_interf
implicit none
interface gen
function ifn (a)
integer :: a, ifn
end function
end interface
interface gsub
subroutine igsub (a)
integer a
end subroutine
end interface
integer i
 
call gsub (i)
i = gen(i)
end program
/gfortran.fortran-torture/compile/defined_type_2.f90
0,0 → 1,17
!This used to ICE as we chose the wrong type for the
! temporary to hold type%x
! fortran/18157
MODULE bug
IMPLICIT NONE
TYPE :: my_type
REAL :: x
END TYPE
TYPE (my_type), DIMENSION(3) :: t
CONTAINS
SUBROUTINE foo
INTEGER, DIMENSION(8) :: c(3)
t(c)%x = t(c)%x
RETURN
END SUBROUTINE foo
END MODULE bug
/gfortran.fortran-torture/compile/inquiry_1.f90
0,0 → 1,8
! Check that inquiry functions are allowed as specification expressions.
subroutine inquiry(x1)
implicit none
real, dimension(1:), intent(out) :: x1
real, dimension(1:size(x1)) :: x3
x3 = 0
x1 = x3
end subroutine
/gfortran.fortran-torture/compile/defined_type_3.f90
0,0 → 1,10
!This used to ICE as we chose the wrong type for the
! temporary to hold type%var
! fortran/18157
program testcase_fold
type :: struct
real :: var ! its julian sec
end type struct
type(struct), dimension(:), pointer :: mystruct
mystruct(1:2)%var = mystruct(2:3)%var
END Program testcase_fold
/gfortran.fortran-torture/ChangeLog.g95
0,0 → 1,106
2003-07-24 Lifang Zeng <zlf605@hotmail.com>
 
* execute/where_3.f90: Modified.
* execute/where_6.f90: New testcase.
 
2003-07-09 Chun HUang <compiler@sohu.com>
 
* execute/intrinsic_scan.f90: Test the SCAN intrinsic.
* execute/intrinsic_verify.f90: Test the VERIFY intrinsic.
 
2003-07-02 Paul Brook <paul@nowt.org>
 
* execite/initializer.f90: Test arrays with scalar initializer.
 
2003-06-02 Kejia Zhao <kejia_zh@yahoo.com.cn>
 
* execute/intrinsic_associated.f90: New testcase.
* execute/intrinsic_associated_2.f90: New testcase.
 
2003-06-01 Paul Brook <paul@nowt.org>
 
* execute/power.f90: Check complex ** real.
 
2003-05-20 Paul Brook <paul@nowt.org>
 
* execute/forall_1.f90: Avoid many to one assignment.
 
2003-05-20 Canqun Yang <canqun@yahoo.com.cn>
 
* execute/forall_1.f90: Replace logical operator 'and' with 'or'.
 
2003-05-19 Lifang Zeng <zlf605@hotmail.com>
 
* execute/forall_1.f90: FORALL with negative stride, FORALL has
arbitrary number of indexes, and actual variables used as FORALL
indexes.
 
2003-05-07 Kejia Zhao <kejia_zh@yahoo.com.cn>
 
* execute/der_point.f90: DERIVED type with components point to the
DERIVED type itself, and two DERIVED type with components point to
each other.
 
2003-03-16 Paul Brook <paul@nowt.org>
 
* execute/arrayarg.f90: Assumed shape dummy arrays aren't legal when
using an implicit interface.
* execute/arraysave.f90: Ditto.
* execute/bounds.f90: Ditto.
* lib/f95-torture.exp (TORTURE_OPTIONS): Check f77 arrays.
 
2003-03-15 Paul Brook <paul@nowt.org>
 
* execute/elemental.f90: Test expressions inside elemental functions.
 
2003-03-14 Paul Brook <paul@nowt.org>
 
* lib/f95-torture.exp (TORTURE_OPTIONS): Check different array
repacking strategies.
 
2003-02-15 Paul Brook <paul@nowt.org>
 
* execute/der_init.f90: Add tests for non-constant constructors.
 
2003-02-08 Paul Brook <paul@nowt.org>
 
* execute/constructor.f90: Additional tests for non-constant
constructors with unexpanded implicit do loops.
 
2003-02-06 Paul Brook <paul@nowt.org>
 
* execute/der_type.f90: Add extra tests for initializers and passing
components as arguments.
 
2003-02-01 Paul Brook <paul@nowr.org>
 
* execute/elemental.f90: Test intrinsic elemental conversion
routines.
 
2003-01-28 Paul Brook <paul@nowt.org>
 
* compile/mystery_proc.f90: New testcase.
 
2003-01-27 Paul Brook <paul@nowt.org>
 
* execute/intrinsic_minmax.f90: Add a couple more variations.
 
2003-01-26 Paul Brook <paul@nowt.org>
 
* execute/contained.f90: New testcase.
* execute/intrinsic_present.f90: New testcase.
 
2003-01-22 Steven Bosscher <s.bosscher@student.tudelft.nl>
 
* compile/bergervoet2.f90, compile/ambig.f90,
compile/actual.f90, execute/integer_select.f90:
New testcases.
* execute/function_module_1.f90: Fix syntax error.
* execute/retarray.f90: Fix another syntax error.
 
Copyright (C) 2003 Free Software Foundation, Inc.
 
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
notice and this notice are preserved.

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.