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/gfortran.fortran-torture
- from Rev 685 to Rev 695
- ↔ Reverse comparison
Rev 685 → Rev 695
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
|
/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 |
|
/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 |
|
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/execute/intrinsic_nearest.x
0,0 → 1,6
if [istarget "spu-*-*"] { |
# No Inf/NaN support on SPU. |
return 1 |
} |
add-ieee-options |
return 0 |
/execute/list_read_1.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/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 |
/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 |
/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 |
/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 |
/execute/read_null_string.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/execute/intrinsic_spacing.x
0,0 → 1,2
add-ieee-options |
return 0 |
/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 |
/execute/backspace.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
|
/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 |
/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 |
/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 |
|
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/execute/seq_io.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/execute/slash_edit.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/execute/intrinsic_set_exponent.x
0,0 → 1,6
if [istarget "spu-*-*"] { |
# No denormal support on SPU. |
return 1 |
} |
add-ieee-options |
return 0 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/execute/unopened_unit_1.x
0,0 → 1,7
load_lib target-supports.exp |
|
if { ! [check_effective_target_fd_truncate] } { |
return 1 |
} |
|
return 0 |
/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 |
|
|
|
/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 |
|
/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 |
/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 |
|
/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 |
|
/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 |
/execute/intrinsic_fraction_exponent.x
0,0 → 1,2
add-ieee-options |
return 0 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/compile/fnresvar.f90
0,0 → 1,5
! Explicit function rsult variables |
function fnresvar() result (r) |
integer r |
r = 0 |
end function |
/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 |
/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 |
/compile/write.f90
0,0 → 1,5
! Program to test simple IO |
program testwrite |
write (*) 1 |
write (*) "Hello World" |
end program |
/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 |
|
/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 |
/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 |
/compile/empty_interface_1.f90
0,0 → 1,4
! Program to test empty interfaces PR15051 |
INTERFACE leer |
END INTERFACE |
END |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/compile/pr45634.f90
0,0 → 1,5
SUBROUTINE RCRDRD (VTYP) |
CHARACTER(4), INTENT(OUT) :: VTYP |
CHARACTER(1), SAVE :: DBL = "D" |
VTYP = DBL |
END |
/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 |
|
/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 |
/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 |
/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 |
|
/compile/noncontinuation_1.f
0,0 → 1,3
! verifies that 0 in column six doesn't start a continuation line |
!234567890 |
0 END |
/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 |
|
/compile/parameter_1.f90
0,0 → 1,7
! legal |
integer, parameter :: j = huge(j) |
integer i |
|
if (j /= huge(i)) call abort |
end |
|
/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 |
/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 |
|
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
|
/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 |
/compile/bergervoet2.f90
0,0 → 1,5
function testi() result(res) |
integer :: res |
res = 0 |
end function testi |
|
/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 |
|
/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 |
|
/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 |
/compile/empty.f90
--- compile/pr40421.f (nonexistent)
+++ 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
+
/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 |
|
/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 |
|
/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 |
/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 |
/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 |
/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 |
|
/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 |
/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 |
/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. |