This is an archive of the discontinued LLVM Phabricator instance.

Differential D146481

Add tests from gfortran test suite [Patch 6 of 6]
AbandonedPublic

Authored by tarunprabhu on Mar 20 2023, 5:33 PM.

Details

Reviewers
kiranchandramohan
sscalpone
rovka
awarzynski
klausler
PeteSteinfeld
AlexisPerry
Summary

Add Fortran tests from GCC's test suite. This is the sixth of six patches that add the test files. A separate patch adds the build files. All the patches will be committed together.

  1. https://reviews.llvm.org/D146475
  2. https://reviews.llvm.org/D146477
  3. https://reviews.llvm.org/D146478
  4. https://reviews.llvm.org/D146479
  5. https://reviews.llvm.org/D146480
  6. https://reviews.llvm.org/D146481 (this patch)

A discourse post discussing this is here

Diff Detail

Event Timeline

tarunprabhu created this revision.Mar 20 2023, 5:33 PM
tarunprabhu created this object with visibility "No One".
Herald added a project: Restricted Project. · View Herald TranscriptMar 20 2023, 5:33 PM
tarunprabhu requested review of this revision.Mar 20 2023, 5:33 PM
tarunprabhu edited the summary of this revision. (Show Details)
tarunprabhu mentioned this in D146480: Add tests from gfortran test suite [Patch 5 of 6].
tarunprabhu mentioned this in D146479: Add tests from gfortran test suite [Patch 4 of 6].
tarunprabhu mentioned this in D146478: Add tests from gfortran test suite [Patch 3 of 6].
tarunprabhu mentioned this in D146477: Add tests from gfortran test suite [Patch 2 of 6].Mar 20 2023, 5:35 PM
tarunprabhu mentioned this in D146475: Add tests from gfortran test-suite [Patch 1 of 6].
tarunprabhu edited the summary of this revision. (Show Details)Mar 20 2023, 6:24 PM
tarunprabhu set the repository for this revision to rT test-suite.
tarunprabhu changed the visibility from "No One" to "Public (No Login Required)".
tarunprabhu added a subscriber: flang-commits.
Herald added subscribers: • pcwang-thead, arphaman. · View Herald TranscriptMar 20 2023, 6:24 PM
tarunprabhu edited the summary of this revision. (Show Details)Mar 20 2023, 6:31 PM
tarunprabhu mentioned this in D146485: Add tests from gfortran test suite [build files].
tarunprabhu added reviewers: kiranchandramohan, sscalpone, rovka, awarzynski, klausler, PeteSteinfeld, AlexisPerry.Mar 20 2023, 6:37 PM
tarunprabhu abandoned this revision.Mar 31 2023, 8:04 AM

Based on discussions here, the test files will be committed after the patch containing the build and license files.

Revision Contents

PathSize
Fortran/
gfortran/
torture/
106 lines
compile/
24 lines
38 lines
26 lines
26 lines
12 lines
5 lines
39 lines
5 lines
15 lines
11 lines
12 lines
35 lines
10 lines
37 lines
11 lines
10 lines
17 lines
10 lines
28 lines
13 lines
4 lines
10 lines
42 lines
46 lines
5 lines
7 lines
19 lines
13 lines
32 lines
6 lines
17 lines
8 lines
9 lines
8 lines
10 lines
8 lines
10 lines
18 lines
14 lines
9 lines
9 lines
6 lines
8 lines
23 lines
3 lines
7 lines
23 lines
4 lines
43 lines
11 lines
14 lines
15 lines
40 lines
147 lines
27 lines
22 lines
82 lines
46 lines
18 lines
15 lines
15 lines
59 lines
13 lines
5 lines
11 lines
9 lines
13 lines
20 lines
23 lines
7 lines
18 lines
22 lines
10 lines
23 lines
17 lines
16 lines
39 lines
30 lines
22 lines
8 lines
28 lines
24 lines
15 lines
8 lines
10 lines
6 lines
22 lines
17 lines
5 lines
execute/
17 lines
46 lines
38 lines
18 lines
22 lines
25 lines
145 lines
21 lines
24 lines
39 lines
14 lines
7 lines
38 lines
22 lines
12 lines
48 lines
53 lines
20 lines
24 lines
10 lines
29 lines
16 lines
28 lines
22 lines
78 lines
72 lines
17 lines
19 lines
6 lines
26 lines
50 lines
32 lines
15 lines
12 lines
15 lines
16 lines
67 lines
45 lines
45 lines
21 lines
32 lines
14 lines
20 lines
74 lines
13 lines
16 lines
51 lines
40 lines
64 lines
51 lines
109 lines
106 lines
24 lines
24 lines
28 lines
29 lines
57 lines
19 lines
15 lines
46 lines
13 lines
54 lines
225 lines
94 lines
43 lines
10 lines
17 lines
61 lines
20 lines
37 lines
27 lines
28 lines
25 lines
88 lines
36 lines
30 lines
9 lines
92 lines
10 lines
26 lines
9 lines
7 lines
14 lines
21 lines
32 lines
71 lines
31 lines
11 lines
33 lines
9 lines
55 lines
41 lines
134 lines
36 lines
32 lines
34 lines
43 lines
20 lines
25 lines
13 lines
23 lines
102 lines
84 lines
2 lines
15 lines
18 lines
46 lines
31 lines
32 lines
15 lines
37 lines
117 lines
22 lines
40 lines
13 lines
45 lines
67 lines
16 lines
76 lines
6 lines
24 lines
40 lines
47 lines
29 lines
29 lines
87 lines
2 lines
22 lines
35 lines
31 lines
37 lines
35 lines
2 lines
17 lines
62 lines
47 lines
46 lines
24 lines
23 lines
21 lines
16 lines
24 lines
15 lines
54 lines
7 lines
55 lines
17 lines
100 lines
9 lines
39 lines
29 lines
23 lines
88 lines
2 lines
9 lines
13 lines
6 lines
21 lines
12 lines
7 lines
15 lines
15 lines
75 lines
16 lines
15 lines
15 lines
16 lines
61 lines
40 lines
9 lines
31 lines
33 lines
29 lines
20 lines
33 lines
24 lines
11 lines
6 lines
15 lines
7 lines
45 lines
20 lines
29 lines
23 lines
23 lines
24 lines
8 lines
17 lines
81 lines
7 lines
14 lines
7 lines
12 lines
311 lines
87 lines
23 lines
21 lines
30 lines
18 lines
13 lines
14 lines
50 lines
39 lines
16 lines
28 lines
15 lines
34 lines
25 lines
11 lines
17 lines
10 lines
19 lines
14 lines
7 lines
67 lines
15 lines
26 lines
23 lines
54 lines
9 lines
41 lines
23 lines
23 lines
9 lines
10 lines
15 lines
15 lines
39 lines
22 lines
21 lines
13 lines
13 lines
23 lines
53 lines
28 lines
14 lines
23 lines

Diff 506799

Fortran/gfortran/torture/ChangeLog.g95

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.

Fortran/gfortran/torture/compile/20080806-1.f90

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

Fortran/gfortran/torture/compile/actual.f90

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

Fortran/gfortran/torture/compile/allocate.f90

! 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

Fortran/gfortran/torture/compile/ambig.f90

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

Fortran/gfortran/torture/compile/arrayio.f90

! 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

Fortran/gfortran/torture/compile/bergervoet2.f90

function testi() result(res)
integer :: res
res = 0
end function testi

Fortran/gfortran/torture/compile/compile.exp

# Expect driver script for GCC Regression Tests
# Copyright (C) 2003-2023 Free Software Foundation, Inc.
#
# 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/*.\[fF\]{,90,95,03,08} ]] {
# 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
}
torture-finish

Fortran/gfortran/torture/compile/complex_1.f90

program test_gfortran2
Complex(8) :: g, zh
Real(8) :: g_q
g = zh - zh/cmplx(0.0_8,-g_q)
end

Fortran/gfortran/torture/compile/contained_1.f90

! 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

Fortran/gfortran/torture/compile/contained_2.f90

! 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

Fortran/gfortran/torture/compile/contained_3.f90

! 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

Fortran/gfortran/torture/compile/contained_4.f90

! 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

Fortran/gfortran/torture/compile/contained_5.f90

! 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

Fortran/gfortran/torture/compile/convert.f90

! 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

Fortran/gfortran/torture/compile/data_1.f90

! 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

Fortran/gfortran/torture/compile/defined_type_1.f90

!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

Fortran/gfortran/torture/compile/defined_type_2.f90

!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

Fortran/gfortran/torture/compile/defined_type_3.f90

!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

Fortran/gfortran/torture/compile/do_1.f90

! 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

Fortran/gfortran/torture/compile/dummyfn.f90

! 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

Fortran/gfortran/torture/compile/empty_interface_1.f90

! Program to test empty interfaces PR15051
INTERFACE leer
END INTERFACE
END

Fortran/gfortran/torture/compile/emptyif-1.f90

program emptyif
implicit none
integer i,K(4)
if (K(i)==0) then
! do absolutely nothing
end if
end program

Fortran/gfortran/torture/compile/emptyif.f90

! 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

Fortran/gfortran/torture/compile/enum_1.f90

! 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

Fortran/gfortran/torture/compile/fnresvar.f90

! Explicit function rsult variables
function fnresvar() result (r)
integer r
r = 0
end function

Fortran/gfortran/torture/compile/forall-1.f90

integer i, a(1)
logical(kind=8) s(1)
s = .true.
a = 42
forall (i=1:1, .not. s(1)) a(i) = 0
end

Fortran/gfortran/torture/compile/gen_interf.f90

! 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

Fortran/gfortran/torture/compile/implicit.f90

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

Fortran/gfortran/torture/compile/implicit_1.f90

! 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

Fortran/gfortran/torture/compile/implicit_2.f90

! 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

Fortran/gfortran/torture/compile/inline_1.f90

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

Fortran/gfortran/torture/compile/inquiry_1.f90

! 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

Fortran/gfortran/torture/compile/io_end.f90

! 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

Fortran/gfortran/torture/compile/logical-1.f90

! PR fortran/33500
subroutine whatever()
logical(kind=1) :: l1, l2, l3
if ((l1 .and. l2) .neqv. l3) then
l1 = .true.
endif
end

Fortran/gfortran/torture/compile/logical-2.f90

! 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

Fortran/gfortran/torture/compile/mloc.f90

! 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

Fortran/gfortran/torture/compile/module_common.f90

! 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

Fortran/gfortran/torture/compile/module_expr.f90

! 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

Fortran/gfortran/torture/compile/module_proc.f90

! 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

Fortran/gfortran/torture/compile/module_result.f90

! Result variables in module procedures
module module_result
implicit none
contains
function test () result (res)
integer res
res = 0
end function
end module

Fortran/gfortran/torture/compile/name_clash.f90

! 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

Fortran/gfortran/torture/compile/named_args.f90

! 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

Fortran/gfortran/torture/compile/named_args_2.f90

! 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

Fortran/gfortran/torture/compile/nested.f90

! 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/))) STOP 1
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/))) STOP 2
contains
subroutine tests_with_temp
! A few tests which involve a temporary
if (any (pack(a, a.ne.0) .ne. (/9, 7/))) STOP 3
if (any (pack(a, .true.) .ne. val)) STOP 4
if (size(pack (a, .false.)) .ne. 0) STOP 5
if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) STOP 6
end subroutine tests_with_temp
end program

Fortran/gfortran/torture/compile/noncontinuation_1.f

! verifies that 0 in column six doesn't start a continuation line
!234567890
0 END

Fortran/gfortran/torture/compile/parameter_1.f90

! legal
integer, parameter :: j = huge(j)
integer i
if (j /= huge(i)) STOP 1
end

Fortran/gfortran/torture/compile/parameter_2.f90

! 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

Fortran/gfortran/torture/compile/parameter_3.f90

program tst
write (6,"(a,es15.8)") "2.0**(-0.0) = ",2.0**(-0.0)
end program tst

Fortran/gfortran/torture/compile/pr24136.f

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

Fortran/gfortran/torture/compile/pr26806.f90

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

Fortran/gfortran/torture/compile/pr30147.f90

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

Fortran/gfortran/torture/compile/pr32417.f90

! 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

Fortran/gfortran/torture/compile/pr32583.f

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

Fortran/gfortran/torture/compile/pr32663.f

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

Fortran/gfortran/torture/compile/pr33276.f90

! 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

Fortran/gfortran/torture/compile/pr36078.f90

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

Fortran/gfortran/torture/compile/pr37236.f

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

Fortran/gfortran/torture/compile/pr40413.f90

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

Fortran/gfortran/torture/compile/pr40421.f

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

Fortran/gfortran/torture/compile/pr40421.f90

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

Fortran/gfortran/torture/compile/pr41654.f90

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

Fortran/gfortran/torture/compile/pr42781.f90

! 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

Fortran/gfortran/torture/compile/pr45598.f90

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

Fortran/gfortran/torture/compile/pr45634.f90

SUBROUTINE RCRDRD (VTYP)
CHARACTER(4), INTENT(OUT) :: VTYP
CHARACTER(1), SAVE :: DBL = "D"
VTYP = DBL
END

Fortran/gfortran/torture/compile/pr45738.f90

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

Fortran/gfortran/torture/compile/pr49721-1.f

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

Fortran/gfortran/torture/compile/pr57517.f90

SUBROUTINE cal_helicity (uh, ph, phb, wavg, ims, ime, its, ite)
INTEGER, INTENT( IN ) :: ims, ime, its, ite
REAL, DIMENSION( ims:ime), INTENT( IN ) :: ph, phb, wavg
REAL, DIMENSION( ims:ime), INTENT( INOUT ) :: uh
INTEGER :: i
REAL :: zu
DO i = its, ite
zu = (ph(i ) + phb(i)) + (ph(i-1) + phb(i-1))
IF (wavg(i) .GT. 0) THEN
uh(i) = uh(i) + zu
ENDIF
END DO
END SUBROUTINE cal_helicity

Fortran/gfortran/torture/compile/pr65758.f90

SUBROUTINE USER_MESSAGE (MESSAGE)
CHARACTER MSGL*1
CHARACTER, INTENT(IN) :: MESSAGE*(*)
CHARACTER(21) :: LEADER(4)
CHARACTER(132) :: MSG_TEXT*132
LOGICAL, SAVE :: FIRST
100 IR = MIN (LM, IL+INDEX(MESSAGE(MIN(LM,IL+1):LM)//MSGL,MSGL))
IF (FIRST) THEN
IF (INDEX(MESSAGE(IL:IR),'WARN') .NE. 0) THEN
K = 2
ELSE IF (INDEX(MESSAGE(IL:IR),'INFORM') .NE. 0) THEN
K = 3
GO TO 100
ENDIF
ELSE
IF (MESSAGE(IR:IR) .EQ. MSGL) THEN
MSG_TEXT = LEADER(K)//MESSAGE(IL+1:IR-1)
ENDIF
ENDIF
END

Fortran/gfortran/torture/compile/pr66251-2.f90

subroutine mv(m,nc,irp,ja,val,x,ldx,y,ldy,acc)
use iso_fortran_env
implicit none
integer, parameter :: ipk_ = int32
integer, parameter :: spk_ = real32
complex(spk_), parameter :: czero=(0.0_spk_,0.0_spk_)
integer(ipk_), intent(in) :: m,ldx,ldy,nc,irp(*),ja(*)
complex(spk_), intent(in) :: x(ldx,*),val(*)
complex(spk_), intent(inout) :: y(ldy,*)
complex(spk_), intent(inout) :: acc(*)
integer(ipk_) :: i,j,k, ir, jc
do i=1,m
acc(1:nc) = czero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = -acc(1:nc)
end do
end subroutine mv

Fortran/gfortran/torture/compile/pr66251.f90

SUBROUTINE dbcsr_data_convert (n)
COMPLEX(KIND=4), DIMENSION(:), POINTER :: s_data_c
COMPLEX(KIND=8), DIMENSION(:), POINTER :: t_data_z
t_data_z(1:n) = CMPLX(s_data_c(1:n), KIND=8)
CALL foo()
END SUBROUTINE dbcsr_data_convert

Fortran/gfortran/torture/compile/pr66352.f90

! { dg-additional-options "-fprofile-generate" }
SUBROUTINE matmul_test ( ntim,len)
INTEGER, PARAMETER :: dp=8
REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc
INTEGER :: siz,len, ntim
DO i = 5, siz, 2
len = 2**i + 1
ALLOCATE ( ma ( len, len ), STAT = ierr )
IF ( ierr /= 0 ) EXIT
ALLOCATE ( mb ( len, len ), STAT = ierr )
IF ( ierr /= 0 ) EXIT
ALLOCATE ( mc ( len, len ), STAT = ierr )
IF ( ierr /= 0 ) EXIT
DO j = 1, ntim
mc = MATMUL ( ma, mb )
END DO
END DO
END SUBROUTINE matmul_test

Fortran/gfortran/torture/compile/pr68639.f90

SUBROUTINE makeCoulE0(natorb,Coul)
INTEGER, PARAMETER :: dp=8
REAL(KIND=dp), PARAMETER :: fourpi=432.42, oorootpi=13413.3142
INTEGER :: natorb
REAL(KIND=dp), DIMENSION(45, 45), &
INTENT(OUT) :: Coul
INTEGER :: gpt, imA, imB, k1, k2, k3, &
k4, lp, mp, np
REAL(KIND=dp) :: alpha, d2f(3,3), &
d4f(3,3,3,3), f, ff, w
REAL(KIND=dp), DIMENSION(3, 45) :: M1A
REAL(KIND=dp), DIMENSION(45) :: M0A
DO imA=1, (natorb*(natorb+1))/2
DO imB=1, (natorb*(natorb+1))/2
w= M0A(imA)*M0A(imB)
DO k1=1,3
w=w+ M1A(k1,imA)*M1A(k1,imB)
ENDDO
Coul(imA,imB)=Coul(imA,imB)-4.0_dp*alpha**3*oorootpi*w/3.0_dp
ENDDO
ENDDO
END SUBROUTINE makeCoulE0

Fortran/gfortran/torture/compile/pr70960.f90

SUBROUTINE calbrec(a,ai,error)
REAL(KIND=8) :: a(3,3), ai(3,3)
DO i = 1, 3
il = 1
IF (i==1) il = 2
DO j = 1, 3
ai(j,i) = (-1.0_8)**(i+j)*det*(a(il,jl)*a(iu,ju)-a(il,ju)*a(iu,jl))
END DO
END DO
END SUBROUTINE calbrec

Fortran/gfortran/torture/compile/pr76490.f90

program membug
call bug1()
end program membug
subroutine unknown(x1,y1,ibig)
write(*,*)x1,y1,ibig
end subroutine unknown
subroutine bug1()
real arrayq(3000)
isize=0
ibig=-1
x2=0
10 continue
isize=isize+1
arrayq(isize)=x2
15 continue
call unknown(x1,y1,ibig)
if(ibig.eq.1)then
goto 10
elseif(ibig.eq.2)then
isize=max(1,isize-1)
goto 15
endif
end subroutine bug1

Fortran/gfortran/torture/compile/pr77798.f90

subroutine foo(self,value)
integer(kind=kind(1)), dimension(:) :: self
integer(kind=kind(1)), intent(in) :: value
integer(kind=kind(1)) :: x,y,sign
intent(inout) :: self
integer(kind=kind(1)) :: len,i
len = size(self)
do i = 1,len
x = self(i)
if (x==0.0d0) cycle
y = abs(x)
sign = x/y
self(i) = sign*min(value,y)
end do
end subroutine

Fortran/gfortran/torture/compile/pr80158.f

SUBROUTINE DRPAUL(SMAT,TMAT,EPS,EPT,SIJ,TIJ,WRK,VEC,ARRAY,FMO,
* XMKVIR,TMJ,XMI,YMI,ZMI,ZQQ,L1,L1EF,LNA,LNA2,
* NAEF,L2,NLOC,NVIR,PROVEC,FOCKMA,MXBF,MXMO2)
DIMENSION CMO(L1,L1),TLOC(LNA,LNA),SMJ(L1,NAEF),XMK(L1,LNA)
DO I = 1,LNA
DO J = 1,LNA
IF (I.LE.NOUT) TLOC(I,J) = ZERO
IF (J.LE.NOUT) TLOC(I,J) = ZERO
END DO
DO NA=1,NOC
IF ( ABS(E(NI)-E(NA)) .GE.TOL) THEN
END IF
END DO
END DO
END

Fortran/gfortran/torture/compile/pr80464.f90

subroutine bla(a,bar,lb,ne,nt,v,b)
character*8 lb
integer bar(20),foo(8,5)
real*8 a(3,*),x(3,8),v(0:3,*)
if(lb(4:4).eq.'3') then
n=8
elseif(lb(4:5).eq.'10') then
n=10
ns=6
m=4
endif
call blub(id)
do
if(id.eq.0) exit
if(lb(4:4).eq.'6') then
m=1
endif
if((n.eq.20).or.(n.eq.8)) then
if(b.eq.0) then
do i=1,ns
do j=1,3
x(j,i)=a(j,bar(foo(i,ig)))
enddo
enddo
else
do i=1,ns
do j=1,3
x(j,i)=a(j,bar(foo(i,ig)))+v(j,bar(foo(i,ig)))
enddo
enddo
endif
endif
do i=1,m
if(lb(4:5).eq.'1E') then
call blab(x)
endif
enddo
enddo
end subroutine bla

Fortran/gfortran/torture/compile/pr83189.f90

Module radin_mod
INTEGER, PARAMETER :: DP = selected_real_kind(14,200)
Contains
Subroutine SPLIFT (X,Y,YP,YPP,N,IERR,ISX,A1,B1,AN,BN)
Integer, Intent(in) :: N,ISX
Real(dp), Intent(in) :: X(N),Y(N),A1,B1,AN,BN
Real(dp), Intent(out) :: YP(N),YPP(N)
Real(dp), Allocatable, Dimension(:,:) :: W
NM1 = N-1
NM2 = N-2
If (ISX.Gt.0) GO TO 40
Do I=2,N
If (X(I)-X(I-1) .Le. 0) Then
IERR = 3
Return
Endif
End Do
Allocate(W(N,3))
40 YPP(1) = 4*B1
DOLD = (Y(2)-Y(1))/W(2,2)
Do I=2,NM2
DNEW = (Y(I+1) - Y(I))/W(I+1,2)
YPP(I) = 6*(DNEW - DOLD)
YP(I) = DOLD
DOLD = DNEW
End Do
Return
End Subroutine SPLIFT
End Module radin_mod

Fortran/gfortran/torture/compile/pr85863.f

! { dg-do compile }
! { dg-additional-options "-ffast-math -ftree-vectorize" }
SUBROUTINE SOBOOK(MHSO,HSOMAX,MS)
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
COMPLEX*16 HSOT,HSO1(2)
PARAMETER (ZERO=0.0D+00,TWO=2.0D+00)
DIMENSION SOL1(3,2),SOL2(3)
CALL FOO(SOL1,SOL2)
SQRT2=SQRT(TWO)
DO IH=1,MHSO
IF(MS.EQ.0) THEN
HSO1(IH) = DCMPLX(ZERO,-SOL1(3,IH))
HSOT = DCMPLX(ZERO,-SOL2(3))
ELSE
HSO1(IH) = DCMPLX(-SOL1(2,IH),SOL1(1,IH))/SQRT2
HSOT = DCMPLX(-SOL2(2),SOL2(1))/SQRT2
ENDIF
ENDDO
HSOT=HSOT+HSO1(1)
HSOMAX=MAX(HSOMAX,ABS(HSOT))
RETURN
END

Fortran/gfortran/torture/compile/pr85878.f90

! PR middle-end/85878
program pr85878
real :: a
complex :: c = (2.0, 3.0)
print *, c
print *, transfer (a, c)
end

Fortran/gfortran/torture/compile/pr88304-2.f90

! PR fortran/88304
module pr88304
implicit none
integer :: p
contains
function foo (x, y, z, w)
integer, intent(in) :: x, y
character(*), optional, intent(out) :: z
integer, optional, intent(out) :: w
integer :: foo
foo = 1
end function foo
subroutine bar ()
integer :: s
s = baz (1)
contains
function baz (u)
integer, intent(in) :: u
integer :: baz
integer :: q
integer :: r (10)
r = 0
baz = 1
q = foo (p, r(u), w = baz)
end function baz
end subroutine bar
end module pr88304

Fortran/gfortran/torture/compile/pr88304.f90

! PR fortran/88304
module pr88304
implicit none
type t
integer :: b = -1
end type t
contains
subroutine f1 (x, y)
integer, intent(out) :: x, y
x = 5
y = 6
end subroutine f1
subroutine f2 ()
type(t) :: x
integer :: y
call f3
if (x%b .ne. 5 .or. y .ne. 6) stop 1
contains
subroutine f3
call f1 (x%b, y)
end subroutine f3
end subroutine f2
end module pr88304

Fortran/gfortran/torture/compile/pr89324.f90

module a
contains
pure function myotherlen()
myotherlen = 99
end
subroutine b
characterx
block
character(myotherlen()) c
c = "abc"
x = c
end block
end
end

Fortran/gfortran/torture/compile/shape_reshape.f90

! 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

Fortran/gfortran/torture/compile/stoppause.f90

! Program to check the STOP and PAUSE intrinsics
program stoppause
pause
pause 1
pause 'Hello world'
stop
stop 42
stop 'Go away'
end program

Fortran/gfortran/torture/compile/strparm_1.f90

! Check known length string parameters
subroutine test (s)
character(len=80) :: s
s = "Hello World"
end subroutine

Fortran/gfortran/torture/compile/transfer-1.f90

! 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

Fortran/gfortran/torture/compile/vrp_1.f90

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

Fortran/gfortran/torture/compile/write.f90

! Program to test simple IO
program testwrite
write (*,*) 1
write (*,*) "Hello World"
end program

Fortran/gfortran/torture/execute/a_edit_1.f90

! 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
STOP 1
endif
read(C,'(A)')D
if (D.NE.'ABCD') then
! print*,D
STOP 2
endif
end

Fortran/gfortran/torture/execute/adjustr.f90

! 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'
STOP 1
endif
enddo
end program test_adjustr

Fortran/gfortran/torture/execute/allocate.f90

! 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)) STOP 1
else
if (.not. allocated (p)) STOP 2
end if
if (allocated (q)) STOP 3
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)) STOP 4
end subroutine
end program

Fortran/gfortran/torture/execute/alternate_return.f90

program alt_return
implicit none
call myproc (1, *10, 42)
20 continue
STOP 1
10 continue
call myproc(2, *20, 42)
call myproc(3, *20, 42)
contains
subroutine myproc(n, *, i)
integer n, i
if (i .ne. 42) STOP 2
if (n .eq. 1) return 1
if (n .eq. 2) return
end subroutine
end program alt_return

Fortran/gfortran/torture/execute/args.f90

! Program to test procudure args
subroutine test (a, b)
integer, intent (IN) :: a
integer, intent (OUT) :: b
if (a .ne. 42) STOP 1
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) STOP 2
if (j .ne. 43) STOP 3
i = 41
CALL test (i + 1, j)
end program

Fortran/gfortran/torture/execute/arithmeticif.f90

! 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) STOP 1
if (testif (0) .ne. 0) STOP 2
if (testif (10) .ne. 1) STOP 3
end program

Fortran/gfortran/torture/execute/arrayarg.f90

! 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) STOP 1
if (a(5, 8) .ne. 43) STOP 2
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) STOP 3
if (v2(3, 3) .ne. 4) STOP 4
! 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) STOP 5
if (a(5, 8) .ne. 43) STOP 6
end subroutine
end program

Fortran/gfortran/torture/execute/arrayarg2.f90

! 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/))) STOP 1
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

Fortran/gfortran/torture/execute/arraysave.f90

! 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/))) STOP 1
if (a(1, 1) .ne. 42) STOP 2
if (a(6, 5) .ne. 43) STOP 3
end subroutine
end program

Fortran/gfortran/torture/execute/assumed_size.f90

! 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/)))) &
STOP 1
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) STOP 1
a(1, 1) = 1
call test1(a(1:2, :), (/1, 2, 4, 5, 7, 8/))
if (a(1,1) .ne. 0) STOP 2
a(1, 1) = 1
call test1(a(3:1:-1, :), (/3, 2, 1, 6, 5, 4/))
if (a(3,1) .ne. 0) STOP 3
a(3, 1) = 3
call test1(a(:, 2:3), (/4, 5, 6, 7, 8, 9/))
if (a(1, 2) .ne. 0) STOP 4
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)) STOP 2
p(1) = 0
end subroutine
end program

Fortran/gfortran/torture/execute/backspace.f90

! 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') STOP 1
close(10,STATUS='DELETE')
end

Fortran/gfortran/torture/execute/backspace.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/bounds.f90

! 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) STOP 1
allocate (a(3:8, 6:7))
! With one parameter
j = 0;
j(3:4) = ubound(a)
if (j(3) .ne. 8) STOP 1
if (j(4) .ne. 7) STOP 2
! With two parameters, assigning to an array
j = lbound(a, 1)
if ((j(1) .ne. 3) .or. (j(5) .ne. 3)) STOP 3
! With a variable second parameter
i = 2
i = lbound(a, i)
if (i .ne. 6) STOP 4
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)) STOP 5
end subroutine
end program

Fortran/gfortran/torture/execute/character_passing.f90

! 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
STOP 1;
endif
end
logical function LSAME( CA, CB )
character CA, CB
integer INTA, INTB
INTA = ICHAR( CA )
INTB = ICHAR( CB )
LSAME = INTA.EQ.INTB
end

Fortran/gfortran/torture/execute/character_select_1.f90

CHARACTER(LEN=6) :: C = "STEVEN"
SELECT CASE (C)
CASE ("AAA":"EEE")
STOP 1
CASE ("R":"T")
CONTINUE
CASE DEFAULT
STOP 2
END SELECT
END

Fortran/gfortran/torture/execute/cmplx.f90

! 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)) STOP 1
x = 4
y = 3
z = cmplx(x, y, 8)
if (z .ne. (4.0, 3.0)) STOP 2
z = c
if (z .ne. (3.0, 4.0)) STOP 3
! dcmplx intrinsic
x = 3
y = 4
z = dcmplx (x, y)
if (z .ne. (3.0, 4.0)) STOP 4
! conjucates and aimag
c = (1.0, 2.0)
c = conjg (c)
x = aimag (c)
if (abs (c - (1.0, -2.0)) .gt. 0.001) STOP 5
if (x .ne. -2.0) STOP 6
z = (2.0, 1.0)
z = conjg (z)
q = aimag (z)
if (z .ne. (2.0, -1.0)) STOP 7
if (q .ne. -1.0) STOP 8
! addition, subtraction and multiplication
c = (1, 3)
d = (5, 2)
if (c + d .ne. ( 6, 5)) STOP 9
if (c - d .ne. (-4, 1)) STOP 10
if (c * d .ne. (-1, 17)) STOP 11
! test for constant folding
if ((35.,-10.)**0.NE.(1.,0.)) STOP 12
end program

Fortran/gfortran/torture/execute/common.f90

! 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/))) STOP 1
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/))) STOP 2
if (any (b .ne. (/100,100,100,100,100/))) STOP 3
if (any (c .ne. (/200,200,200,200,200/))) STOP 4
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/))) STOP 5
if (any (x .ne. (/200,200,200,300,300,300,300,400/))) STOP 6
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/))) STOP 7
end subroutine

Fortran/gfortran/torture/execute/common_2.f90

! 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) STOP 1
if (j.ne.2) STOP 2
call set_i()
if (j.ne.5) STOP 3
END

Fortran/gfortran/torture/execute/common_init_1.f90

! 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)) STOP 1
if (c .ne. "Hello World ") STOP 2
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

Fortran/gfortran/torture/execute/common_size.f90

! 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)) STOP 1
end

Fortran/gfortran/torture/execute/constructor.f90

! 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) STOP 1
end do
b = reshape ((/0, 1, 2, 3, 4, 5/), (/3, 2/)) + 1
do i=1,3
if (b(i, 1) .ne. i) STOP 2
if (b(i, 2) .ne. i + 3) STOP 3
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/))) STOP 4
a = (/((/i+10, 42/), i = k, l)/)
if (any (a .ne. (/11, 42, 12, 42/))) STOP 5
a = (/(I, I=k,l) , (J, J=m,n)/)
if (any (a .ne. (/1, 2, 3, 4/))) STOP 6
end program

Fortran/gfortran/torture/execute/contained.f90

program contained
implicit none
integer i
i = 0;
call testproc (40)
if (i .ne. 42) STOP 1
contains
subroutine testproc (p)
implicit none
integer p
if (p .ne. 40) STOP 2
i = p + 2
end subroutine
end program

Fortran/gfortran/torture/execute/contained2.f90

! Program to check resolution of symbols with the same name
program contained2
implicit none
integer var1
var1 = 42
if (f1() .ne. 1) STOP 1
call f2()
if (var1 .ne. 42) STOP 2
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) STOP 3
end subroutine
end program

Fortran/gfortran/torture/execute/contained_3.f90

! 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) STOP 1
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

Fortran/gfortran/torture/execute/csqrt_1.f90

! 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) STOP 1
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

Fortran/gfortran/torture/execute/data.f90

! 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/))) STOP 1
if (tmp2(1)%t1(1)%r .ne. 0.0) STOP 2
if (tmp2(1)%b .ne. 10) STOP 3
if (any(tmp2(1)%t1(2)%a .ne. (/121,122,123,124/))) STOP 4
if (tmp2(1)%t1(2)%r .ne. 0.0) STOP 5
if (tmp2(1)%b .ne. 10) STOP 6
if (any(tmp2(1)%t1(3)%a .ne. (/136,137,138,139/))) STOP 7
if (tmp2(1)%t1(3)%r .ne. 0.0) STOP 8
if (tmp2(1)%b .ne. 10) STOP 9
if (any(tmp2(1)%t1(4)%a .ne. (/141,142,143,144/))) STOP 10
if (tmp2(1)%t1(4)%r .ne. 0.0) STOP 11
if (tmp2(1)%b .ne. 10) STOP 12
if (any(tmp2(2)%t1(1)%a .ne. (/0,0,0,0/))) STOP 13
if (tmp2(2)%t1(1)%r .ne. 0.0) STOP 14
if (tmp2(2)%b .ne. 0) STOP 15
if (any(tmp2(2)%t1(2)%a .ne. (/221,0,223,0/))) STOP 16
if (tmp2(2)%t1(2)%r .ne. 220.0) STOP 17
if (tmp2(2)%b .ne. 0) STOP 18
if (any(tmp2(2)%t1(3)%a .ne. (/5,5,233,234/))) STOP 19
if (tmp2(2)%t1(3)%r .ne. 0.0) STOP 20
if (tmp2(2)%b .ne. 0) STOP 21
if (any(tmp2(2)%t1(4)%a .ne. (/241,242,5,5/))) STOP 22
if (tmp2(2)%t1(4)%r .ne. 0.0) STOP 23
if (tmp2(2)%b .ne. 0) STOP 24
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)) STOP 25
if ((r.ne.3.0).and.(t.ne.5.0)) STOP 26
if (any(b.ne.(/0,2,0,0,5,0,0,0,0,0/))) STOP 27
if (any(a.ne.reshape((/13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4/),(/4,4/)))) STOP 28
end

Fortran/gfortran/torture/execute/data_2.f90

! 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/))) STOP 1
if (any (b%i .ne. (/4, 5, 6/))) STOP 2
if ((any (c(1, :) .ne. (/7, 8/))) &
.or. (any (c(2,:) .ne. (/9, 10/)))) STOP 3
end program

Fortran/gfortran/torture/execute/data_3.f90

! 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 ') STOP 1
IF (b.NE.' AAA ') STOP 2
IF (c.NE.'12') STOP 3
IF (d(1).NE.d(2) .OR. d(1).NE.'1234') STOP 4
IF (e.NE.'1234') STOP 5
END

Fortran/gfortran/torture/execute/data_4.f90

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)) STOP 1
END

Fortran/gfortran/torture/execute/date_time_1.f90

! 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

Fortran/gfortran/torture/execute/dep_fails.f90

! 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/)))) STOP 1
! 100 Format( 2I3, '--->', 2I3)
DeAllocate (Perm)
End Program Strange

Fortran/gfortran/torture/execute/der_init.f90

! 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) STOP 1
if (var2%j .ne. 4) STOP 2
var2 = t(6, 5)
if (var2%i .ne. 6 .or. var2%j .ne. 5) STOP 3
if ((var3(1)%j .ne. 4) .or. (var3(2)%j .ne. 4)) STOP 4
if ((var4(1)%i .ne. 7) .or. (var4(2)%i .ne. 8) &
.or. (var4(1)%j .ne. 9) .or. (var4(2)%j .ne. 6)) STOP 5
! Non-constant constructor
n = 1
m = 5
var2 = t(n, n + m)
if (var2%i .ne. 1 .or. var2%j .ne. 6) STOP 6
end program

Fortran/gfortran/torture/execute/der_init_2.f90

! 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)) STOP 1;
end program

Fortran/gfortran/torture/execute/der_init_3.f90

! 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) STOP 1
if (b%x.ne.123) STOP 2
end

Fortran/gfortran/torture/execute/der_init_4.f90

! 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) STOP 1
end subroutine
end program

Fortran/gfortran/torture/execute/der_init_5.f90

! 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)) STOP 1
if (associated(p%b)) STOP 2
! if (associated(p%c)) STOP 3
if (associated(p%d)) STOP 4
end

Fortran/gfortran/torture/execute/der_io.f90

! 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) STOP 1
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) STOP 2
if (buf1.ne.buf3) STOP 3
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) STOP 4
end subroutine foo
integer function bar()
integer, save :: i = 1
bar = i
i = i + 1
end function
end

Fortran/gfortran/torture/execute/der_point.f90

! 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) STOP 1
if (r2%r2p%value .ne. 11) STOP 2
if (e1%value .ne. 33) STOP 3
if (e2%value .ne. 44) STOP 4
if (e3%value .ne. 55) STOP 5
if (r1%value .ne. 11) STOP 6
if (r2%value .ne. 22) STOP 7
end

Fortran/gfortran/torture/execute/der_type.f90

! 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)) STOP 1
if ((is_init%i .ne. 10) .or. (is_init%j .ne. 11)) STOP 2
! 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") STOP 3
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) STOP 4
if (var%ca(4, 3)%s .ne. 43) STOP 5
contains
subroutine test_call (p)
integer p
if (p .ne. 13) STOP 6
end subroutine
end program

Fortran/gfortran/torture/execute/direct_io.f90

! 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
STOP 1
ENDIF
ENDDO
CLOSE(10,STATUS='DELETE')
STOP
10 CONTINUE
! PRINT*,' ERR= RETURN FROM READ OR WRITE'
STOP 2
END

Fortran/gfortran/torture/execute/elemental.f90

! 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/)))) STOP 1
a = e_fn (a(:, 4:1:-1), 1 + b)
if (any (a .ne. reshape ((/7, 7, 5, 3, 3, -1, 1, -5/), (/2, 4/)))) STOP 2
! This tests intrinsic elemental conversion functions.
c = 2 * a(1, 1)
if (any (c .ne. 14)) STOP 3
! 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)) STOP 4
! Check expressions involving constants
a = e_fn (b + 1, 1)
if (any (a .ne. 0)) STOP 5
contains
elemental integer(kind=4) function e_fn (p, q)
integer, intent(in) :: p, q
e_fn = p - q
end function
end program

Fortran/gfortran/torture/execute/empty_format.f90

! 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
STOP 1
ENDIF
END

Fortran/gfortran/torture/execute/emptyif.f90

! 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) STOP 1
if (i .eq. 0) then
elseif (i .eq. 2) then
i = 3
end if
if (i .ne. 3) STOP 2
end

Fortran/gfortran/torture/execute/entry_1.f90

! 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) STOP 1
if (e1 (7) .ne. 49) STOP 2
if (f2 () .ne. 45) STOP 3
if (e2 () .ne. 45) STOP 4
if (f3 () .ne. 47) STOP 5
if (e3 () .ne. 47) STOP 6
d = 17
if (f4 (d) .ne. 32) STOP 7
if (e4 (d) .ne. 59) STOP 8
if (f5 () .ne. 45) STOP 9
if (e5 () .ne. 45) STOP 10
if (f6 () .ne. 47) STOP 11
if (e6 () .ne. 47) STOP 12
if (f7 () .ne. 163) STOP 13
if (e7 () .ne. 163) STOP 14
if (f8 () .ne. 115) STOP 15
if (e8 () .ne. 115) STOP 16
if (f9 () .ne. 119) STOP 17
if (e9 () .ne. 119) STOP 18
end

Fortran/gfortran/torture/execute/entry_10.f90

function foo ()
foo = 4
foo = foo / 2
return
entry bar ()
bar = 9
bar = bar / 3
end
program entrytest
if (foo () .ne. 2) STOP 1
if (bar () .ne. 3) STOP 2
end

Fortran/gfortran/torture/execute/entry_11.f90

! 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) STOP 1
if (i (4).ne.6) STOP 2
if (j (0).ne.3) STOP 3
if (j (7).ne.7) STOP 4
end

Fortran/gfortran/torture/execute/entry_2.f90

! 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)) STOP 1
if (ret .ne. 'BCDEF') STOP 2
ret = e1 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 5)) STOP 3
if (ret .ne. 'CDE') STOP 4
ret = e2 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 4)) STOP 5
if (ret .ne. 'CD') STOP 6
if (f3 () .ne. 'ABCDE') STOP 7
if (e3 (1) .ne. 'abcde') STOP 8
if (e4 (1) .ne. 'abcde') STOP 9
if (e3 (0) .ne. 'UVWXY') STOP 10
if (e4 (0) .ne. 'UVWXY') STOP 11
end program

Fortran/gfortran/torture/execute/entry_3.f90

subroutine f1 (n, *, i)
integer n, i
if (i .ne. 42) STOP 1
entry e1 (n, *)
if (n .eq. 1) return 1
if (n .eq. 2) return
return
entry e2 (n, i, *, *, *)
if (i .ne. 46) STOP 2
if (n .ge. 4) return
return n
entry e3 (n, i)
if ((i .ne. 48) .or. (n .ne. 61)) STOP 3
end subroutine
program alt_return
implicit none
call f1 (1, *10, 42)
20 continue
STOP 4
10 continue
call f1 (2, *20, 42)
call f1 (3, *20, 42)
call e1 (2, *20)
call e1 (1, *30)
STOP 5
30 continue
call e2 (1, 46, *40, *20, *20)
STOP 6
40 continue
call e2 (2, 46, *20, *50, *20)
STOP 7
50 continue
call e2 (3, 46, *20, *20, *60)
STOP 8
60 continue
call e2 (4, 46, *20, *20, *20)
call e3 (61, 48)
end program

Fortran/gfortran/torture/execute/entry_4.f90

! 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) STOP 1
if (e1 (7) .ne. 49) STOP 2
if (f2 (0) .ne. 45) STOP 3
if (.not. e2 (45)) STOP 4
if (e2 (46)) STOP 5
if (f3 (17) .ne. 32) STOP 6
if (.not. e3 (42)) STOP 7
if (e3 (41)) STOP 8
if (g3 (12) .ne. 23) STOP 9
if (.not. f4 (-5)) STOP 10
if (e4 (0) .ne. 16) STOP 11
if (g4 (2) .ne. 19) STOP 12
end

Fortran/gfortran/torture/execute/entry_5.f90

! 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)) STOP 1
if (ret .ne. 'BCDEF') STOP 2
ret = e1 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 5)) STOP 3
if (ret .ne. 'CDE') STOP 4
ret = e2 (str, i, j)
if ((i .ne. 3) .or. (j .ne. 4)) STOP 5
if (ret .ne. 'CD') STOP 6
if (f3 () .ne. 'ABCDE') STOP 7
if (e3 (1) .ne. 'abcde') STOP 8
if (e4 (1) .ne. 'abcde') STOP 9
if (e3 (0) .ne. 'UVWXY') STOP 10
if (e4 (0) .ne. 'UVWXY') STOP 11
end program

Fortran/gfortran/torture/execute/entry_6.f90

! 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)) STOP 1
i (:, :) = 7
j = e1 (i)
j (:, :) = 49
if (any (j .ne. 49)) STOP 2
r = f2 ()
if (any (r .ne. 45)) STOP 3
r = e2 ()
if (any (r .ne. 45)) STOP 4
e = f3 ()
if (any (e .ne. 47)) STOP 5
e = e3 ()
if (any (e .ne. 47)) STOP 6
d (:, :) = 17
e = f4 (d)
if (any (e .ne. 32)) STOP 7
e = e4 (d)
if (any (e .ne. 59)) STOP 8
j = f5 ()
if (any (j .ne. 45)) STOP 9
j = e5 ()
if (any (j .ne. 45)) STOP 10
r = f6 ()
if (any (r .ne. 47)) STOP 11
r = e6 ()
if (any (r .ne. 47)) STOP 12
end

Fortran/gfortran/torture/execute/entry_7.f90

! 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) STOP 1
if (e1 (7) .ne. 49) STOP 2
if (f2 () .ne. 45) STOP 3
if (e2 () .ne. 45) STOP 4
if (f3 () .ne. 47) STOP 5
if (e3 () .ne. 47) STOP 6
d = 17
if (f4 (d) .ne. 32) STOP 7
if (e4 (d) .ne. 59) STOP 8
if (f5 () .ne. 45) STOP 9
if (e5 () .ne. 45) STOP 10
if (f6 () .ne. 47) STOP 11
if (e6 () .ne. 47) STOP 12
end

Fortran/gfortran/torture/execute/entry_8.f90

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) STOP 1
res = g (1.)
if (any (res%x /= 1.)) STOP 2
end

Fortran/gfortran/torture/execute/entry_9.f90

! 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) STOP 1
if (e1 () .ne. 42) STOP 2
if (f2 () .ne. 45) STOP 3
if (e2 () .ne. 45) STOP 4
end

Fortran/gfortran/torture/execute/enum_1.f90

! 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 ) STOP 1
if (yellow /= 1) STOP 2
if (blue /= 2) STOP 3
if (green /= 3) STOP 4
if (a /= 0 ) STOP 5
if (b /= 1) STOP 6
if (c /= 10) STOP 7
if (d /= 11) STOP 8
end program main

Fortran/gfortran/torture/execute/enum_2.f90

! 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 ) STOP 1
if (yellow /= (red + 1)) STOP 2
if (blue /= (yellow + 1)) STOP 3
if (green /= (blue + 1)) STOP 4
if (sun /= -10 ) STOP 5
if (mon /= (sun + 1)) STOP 6
if (tue /= (mon + 1)) STOP 7
if (wed /= 10) STOP 8
if (sat /= (wed+1)) STOP 9
end program main

Fortran/gfortran/torture/execute/enum_3.f90

! 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 ) STOP 1
if (yellow /= 255) STOP 2
if (blue /= 256) STOP 3
if (r /= 0 ) STOP 4
if (y /= 32767) STOP 5
if (b /= 32768) STOP 6
if (kind (red) /= 4) STOP 7
if (kind (yellow) /= 4) STOP 8
if (kind (blue) /= 4) STOP 9
if (kind(r) /= 4 ) STOP 10
if (kind(y) /= 4) STOP 11
if (kind(b) /= 4) STOP 12
if (aa /= 0 ) STOP 13
if (bb /= 65535) STOP 14
if (cc /= 65536) STOP 15
if (kind (aa) /= 4 ) STOP 16
if (kind (bb) /= 4) STOP 17
if (kind (cc) /= 4) STOP 18
if (m /= 0 ) STOP 19
if (n /= 2147483645) STOP 20
if (o /= 2147483646) STOP 21
if (kind (m) /= 4 ) STOP 22
if (kind (n) /= 4) STOP 23
if (kind (o) /= 4) STOP 24
end program main

Fortran/gfortran/torture/execute/enum_4.f90

! 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 ) STOP 1
if (yellow /= 1) STOP 2
if (blue /= 2) STOP 3
if (green /= 3) STOP 4
end program main

Fortran/gfortran/torture/execute/equiv_1.f90

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)) STOP 1
if ((i .ne. 4) .or. (j .ne. 4) .or. (k .ne. 4) .or. (l .ne. 4)) &
STOP 2
end program

Fortran/gfortran/torture/execute/equiv_2.f90

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') STOP 1
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') STOP 2
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') STOP 3
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') STOP 4
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') STOP 5
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') STOP 6
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') STOP 7
if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') STOP 8
end subroutine test4
program main
call test1
call test2
call test3
call test4
end program main

Fortran/gfortran/torture/execute/equiv_3.f90

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') STOP 1
end subroutine test1
program main
call test1
end program main

Fortran/gfortran/torture/execute/equiv_4.f90

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') STOP 1
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') STOP 2
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') STOP 3
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') STOP 4
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') STOP 5
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') STOP 6
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') STOP 7
if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') STOP 8
end subroutine test4
program main
call test1
call test2
call test3
call test4
end program main

Fortran/gfortran/torture/execute/equiv_5.f

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

Fortran/gfortran/torture/execute/equiv_init_1.f90

! 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") STOP 1
if (ys(1).ne."abcdefghij") STOP 2
if (ys(10).ne."abcdefghij") STOP 3
end
subroutine test0
integer :: x = 123
integer :: y
equivalence (x,y)
if (y.ne.123) STOP 4
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) STOP 5
if (z.ne.3) STOP 6
if (a(1).ne.1) STOP 7
if (a(3).ne.3) STOP 8
end
subroutine test2
integer :: x
integer :: z
integer :: a(3) = 123
equivalence (a(1), x)
equivalence (a(3), z)
if (x.ne.123) STOP 9
if (z.ne.123) STOP 10
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) STOP 11
!!$ if (y.ne.2) STOP 12
if (z.ne.3) STOP 13
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) STOP 14
if (b(2).ne.3) STOP 15
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) STOP 16
!!$ if (b(2).ne.3) STOP 17
!!$ print *, "Passed test5"
!!$end
program main
call test0s
call test0
call test1
call test2
call test3
call test4
!!$ call test5
end

Fortran/gfortran/torture/execute/execute.exp

# Copyright (C) 2003-2023 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/*.\[fF\]{,90,95,03,08} ]] {
# 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
}
torture-finish

Fortran/gfortran/torture/execute/f2_edit_1.f90

! 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) STOP 1
IF (RCON22.NE.XRCON22) STOP 2
END

Fortran/gfortran/torture/execute/forall.f90

! 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) STOP 1
if (b(2) .ne. 15) STOP 2
if (b(3) .ne. 24) STOP 3
end program

Fortran/gfortran/torture/execute/forall_1.f90

! 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/)))) STOP 1
if ((x.ne.-1).or.(j.ne.100)) STOP 2
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/)))) STOP 3
if (any (b.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) STOP 4
if ((x.ne.-1).or.(j.ne.100)) STOP 5
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/)))) STOP 6
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)) STOP 7
end subroutine
end

Fortran/gfortran/torture/execute/forall_2.f90

!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/)))) STOP 1
end

Fortran/gfortran/torture/execute/forall_3.f90

! 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/))) STOP 1
if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) STOP 2
if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) STOP 3
if (any(v(5)%p(:) .ne. (/9, 10/))) STOP 4
! I should really free the memory I've allocated.
end program

Fortran/gfortran/torture/execute/forall_4.f90

! 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/)))) STOP 1
if (any (a(:,:,2) .ne. a(:,:,1) + 16)) STOP 2
end

Fortran/gfortran/torture/execute/forall_5.f90

! Program to test FORALL with pointer assignment inside it.
program forall_5
type element
integer, pointer, dimension(:)::p
end type
type (element) :: q(5), r(5)
integer, target, dimension(25)::t
n = 5
do i = 1,5
r(i)%p => t((i-1)*n + 1:i*n)
enddo
forall (i = 2:5)
q(i)%p => r(i-1)%p
end forall
do i = 1, 25
t(i) = i
enddo
if (any(r(1)%p .ne. (/1,2,3,4,5/))) STOP 1
if (any(q(2)%p .ne. (/1,2,3,4,5/))) STOP 2
if (any(q(3)%p .ne. (/6,7,8,9,10/))) STOP 3
if (any(q(4)%p .ne. (/11,12,13,14,15/))) STOP 4
if (any(q(5)%p .ne. (/16,17,18,19,20/))) STOP 5
end

Fortran/gfortran/torture/execute/forall_6.f90

! 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)) STOP 1
end do
end

Fortran/gfortran/torture/execute/forall_7.f90

! 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) STOP 1
if (c (i, j, k, l) /= s) STOP 2
end do
end do
end do
end do
if (any (a /= b .or. c /= d)) STOP 3
end

Fortran/gfortran/torture/execute/function_module_1.f90

! 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) STOP 1
end

Fortran/gfortran/torture/execute/getarg_1.f90

! 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) STOP 1
if (args.eq.'') STOP 2
I = 1
CALL GETARG(I,ARGS)
if (args.ne.'') STOP 3
I = -1
CALL GETARG(I,ARGS)
if (args.ne.'') STOP 4
! Assume we won't have been called with more that 4 args.
I = 4
CALL GETARG(I,ARGS)
if (args.ne.'') STOP 5
I = 1000
CALL GETARG(I,ARGS)
if (args.ne.'') STOP 6
end

Fortran/gfortran/torture/execute/hollerith.f90

! 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') STOP 1
end

Fortran/gfortran/torture/execute/in-pack.f90

! 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)) STOP 1
bb4 = (/(2*cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
if (any(bb4 /= b4)) STOP 2
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)) STOP 3
bb8 = (/(2*cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
if (any(bb8 /= b8)) STOP 4
i4 = (/(i, i=1,5)/)
call isub4(i4(5:1:-1),5)
ii4 = (/(5-i+1,i=1,5)/)
if (any(ii4 /= i4)) STOP 5
i8 = (/(i,i=1,5)/)
call isub8(i8(5:1:-1),5)
ii8 = (/(5-i+1,i=1,5)/)
if (any(ii8 /= i8)) STOP 6
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)) STOP 7
bb = (/(2*cmplx(n-i+1,i-n-1,kind=4),i=1,5)/)
if (any(bb /= b)) STOP 8
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)) STOP 9
bb = (/(2*cmplx(n-i+1,i-n-1,kind=8),i=1,5)/)
if (any(bb /= b)) STOP 10
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)) STOP 11
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)) STOP 12
a = (/(i,i=1,5)/)
end subroutine isub8

Fortran/gfortran/torture/execute/initialization_1.f90

! 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) STOP 1
end subroutine x
end

Fortran/gfortran/torture/execute/initializer.f90

! 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)) STOP 1
if (test(11) .ne. 42) STOP 2
! The second call should return
if (test(0) .ne. 11) STOP 3
if (c .ne. "Hello World") STOP 4
if (d .ne. "Teststring") STOP 5
end program

Fortran/gfortran/torture/execute/inquire_1.f90

! PR 14831
CHARACTER*4 BLANK
CHARACTER*10 ACCESS
OPEN(UNIT=9,ACCESS='SEQUENTIAL')
INQUIRE(UNIT=9,ACCESS=ACCESS,BLANK=BLANK)
IF(BLANK.NE.'NULL') STOP 1
IF(ACCESS.NE.'SEQUENTIAL') STOP 2
CLOSE(UNIT=9,STATUS='DELETE')
END

Fortran/gfortran/torture/execute/inquire_2.f90

! PR 14837
INTEGER UNIT
OPEN(FILE='CSEQ', UNIT=23)
INQUIRE(FILE='CSEQ',NUMBER=UNIT)
IF (UNIT.NE.23) STOP 1
CLOSE(UNIT, STATUS='DELETE')
END

Fortran/gfortran/torture/execute/inquire_3.f90

! 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) STOP 1
READ(UNIT=9,REC=1) MVI
INQUIRE(UNIT=9,NEXTREC=NREC)
IF (NREC.NE.2) STOP 2
! PRINT*,NREC
CLOSE(UNIT=9,STATUS='DELETE')
END

Fortran/gfortran/torture/execute/inquire_4.f90

! 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'
STOP 1
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'
STOP 2
ENDIF
CLOSE(UNIT=10,STATUS='DELETE')
END

Fortran/gfortran/torture/execute/inquire_5.f90

! 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) STOP 1
inquire (file = 'inquire_5.txt', number = unit4, exist = exist4)
if (unit4 .ne. 78 .or. .not. exist4) STOP 2
inquire (file = 'inquire_5.txt', number = unit2, exist = exist2)
if (unit2 .ne. 78 .or. .not. exist2) STOP 3
inquire (file = 'inquire_5.txt', number = unit1, exist = exist1)
if (unit1 .ne. 78 .or. .not. exist1) STOP 4
del = 'delete'
close (unit = 78, status = del)
end

Fortran/gfortran/torture/execute/integer_select.f90

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)
STOP 1
CASE (1:)
STOP 2
CASE DEFAULT
CONTINUE
END SELECT
SELECT CASE (I)
CASE (3,2,1)
STOP 3
CASE (0)
CONTINUE
CASE DEFAULT
STOP 4
END SELECT
! Not aborted by here, so it worked
! See about weird corner cases
I = maxI
SELECT CASE (I)
CASE (:-1)
STOP 5
CASE (1:)
CONTINUE
CASE DEFAULT
STOP 6
END SELECT
SELECT CASE (I)
CASE (3,2,1,:0)
STOP 7
CASE (maxI)
CONTINUE
CASE DEFAULT
STOP 8
END SELECT
I = minI
SELECT CASE (I)
CASE (:-1)
CONTINUE
CASE (1:)
STOP 9
CASE DEFAULT
STOP 10
END SELECT
SELECT CASE (I)
CASE (3:,2,1,0)
STOP 11
CASE (minI)
CONTINUE
CASE DEFAULT
STOP 12
END SELECT
END

Fortran/gfortran/torture/execute/integer_select_1.f90

INTEGER :: I = 1
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
STOP 1
CASE (1)
CONTINUE
CASE DEFAULT
STOP 2
END SELECT
I = -3
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
STOP 3
CASE (1)
CONTINUE
CASE DEFAULT
CONTINUE
END SELECT
I = -5
SELECT CASE (I)
CASE (-3:-5) ! Can never be matched
STOP 4
CASE (-5)
CONTINUE
CASE DEFAULT
STOP 5
END SELECT
END

Fortran/gfortran/torture/execute/internal_write.f90

! 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
STOP 1
ENDIF
END

Fortran/gfortran/torture/execute/intrinsic_abs.f90

! 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) STOP 1
i = -43
i = abs(i)
if (i .ne. 43) STOP 2
r = 42.0
r = abs(r)
if (r .ne. 42.0) STOP 3
r = -43.0
r = abs(r)
if (r .ne. 43.0) STOP 4
q = 42.0_8
q = abs(q)
if (q .ne. 42.0_8) STOP 5
q = -43.0_8
q = abs(q)
if (q .ne. 43.0_8) STOP 6
z = (3, 4)
r = abs(z)
if (r .ne. 5) STOP 7
end program

Fortran/gfortran/torture/execute/intrinsic_achar.f90

! Program to test the ACHAR and IACHAR intrinsics
program intrinsic_achar
integer i
i = 32
if (achar(i) .ne. " ") STOP 1
i = iachar("A")
if ((i .ne. 65) .or. char(i) .ne. "A") STOP 2
end program

Fortran/gfortran/torture/execute/intrinsic_aint_anint.f90

! 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)) STOP 1
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)) STOP 2
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

Fortran/gfortran/torture/execute/intrinsic_anyall.f90

! 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)) STOP 1
a(1, 1) = .true.
a(2, 3) = .true.
if (.not. any(a)) STOP 2
b = any(a, 1)
if (.not. b(1)) STOP 3
if (b(2)) STOP 4
if (.not. b(3)) STOP 5
b = .false.
write (line, 9000) any(a,1)
read (line, 9000) b
if (.not. b(1)) STOP 6
if (b(2)) STOP 7
if (.not. b(3)) STOP 8
a = .true.
if (.not. all(a)) STOP 9
a(1, 1) = .false.
a(2, 3) = .false.
if (all(a)) STOP 10
b = all(a, 1)
if (b(1)) STOP 11
if (.not. b(2)) STOP 12
if (b(3)) STOP 13
b = .false.
write (line, 9000) all(a,1)
read (line, 9000) b
if (b(1)) STOP 14
if (.not. b(2)) STOP 15
if (b(3)) STOP 16
9000 format (9L1)
end program

Fortran/gfortran/torture/execute/intrinsic_associated.f90

! 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) STOP 1
! 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)) STOP 2
if (any (xy(:, 1:2) .ne. 0)) STOP 3
if (any (xy(:, 5) .ne. 0)) STOP 4
if (any (xy (1, 3:4) .ne. 0)) STOP 5
if (any (xy (5, 3:4) .ne. 0)) STOP 6
if (xy(3, 3) .ne. 10) STOP 7
if (xy(3, 4) .ne. 10) STOP 8
if (any (xy(2:4, 3:4) .ne. window)) STOP 9
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)) STOP 10
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)) STOP 11
if (.not. associated(b)) STOP 12
call nullify_pp (a)
if (associated (a)) STOP 13
if (.not. associated (b)) STOP 14
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)) STOP 15
if (associated (r2%r2p)) STOP 16
if (associated (e2%rp)) STOP 17
if (associated (e1%rp)) STOP 18
if (associated (e3%rp)) STOP 19
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)) STOP 20
if (.not. associated (r2%r2p)) STOP 21
if (.not. associated (e1%rp)) STOP 22
if (.not. associated (e2%rp)) STOP 23
if (associated (e3%rp)) STOP 24
if (r1%r1p%value .ne. 22) STOP 25
if (r2%r2p%value .ne. 11) STOP 26
if (e1%value .ne. 33) STOP 27
if (e2%value .ne. 44) STOP 28
if (e3%value .ne. 55) STOP 29
if (r1%value .ne. 11) STOP 30
if (r2%value .ne. 22) STOP 31
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, 10)
end
endinterface
xp => y
if (.not. associated (xp)) STOP 32
call sub1 (x, xp)
if (associated (xp, y)) STOP 33
if (.not. associated (xp, x)) STOP 34
end

Fortran/gfortran/torture/execute/intrinsic_associated_2.f90

! 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)) STOP 1
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) STOP 2
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)) STOP 3
end

Fortran/gfortran/torture/execute/intrinsic_bitops.f90

! 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)) STOP 1
if (btest (i, o+2)) STOP 2
if (iand (i, j) .ne. 2) STOP 3
if (ibclr (j, o+1) .ne. 1) STOP 4
if (ibclr (j, o+2) .ne. 3) STOP 5
if (ibits (k, o+1, o+2) .ne. 2) STOP 6
if (ibset (j, o+1) .ne. 3) STOP 7
if (ibset (j, o+2) .ne. 7) STOP 8
if (ieor (i, j) .ne. 1) STOP 9
if (ior (i, j) .ne. 3) STOP 10
if (ishft (k, o+2) .ne. 48) STOP 11
if (ishft (k, o-3) .ne. 1) STOP 12
if (ishft (k, o) .ne. 12) STOP 13
if (ishftc (k, o+30) .ne. 3) STOP 14
if (ishftc (k, o-30) .ne. 48) STOP 15
if (ishftc (k, o+1, o+3) .ne. 9) STOP 16
if (not (i) .ne. -3) STOP 17
if (ishftc (a, 1, bit_size(a)) .ne. 10) STOP 18
if (ishftc (1, 1, 32) .ne. 2) STOP 19
end program

Fortran/gfortran/torture/execute/intrinsic_count.f90

! 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) STOP 1
a = .true.
if (count(a) .ne. 15) STOP 2
a(1, 1) = .false.
a(2, 2) = .false.
a(2, 5) = .false.
if (count(a) .ne. 12) STOP 3
write (line, 9000) count(a)
read (line, 9000) i
if (i .ne. 12) STOP 4
b(1:3) = count(a, 2);
if (b(1) .ne. 4) STOP 5
if (b(2) .ne. 3) STOP 6
if (b(3) .ne. 5) STOP 7
b = 0
write (line, 9000) count(a,2)
read (line, 9000) b
if (b(1) .ne. 4) STOP 8
if (b(2) .ne. 3) STOP 9
if (b(3) .ne. 5) STOP 10
9000 format(3I3)
end program

Fortran/gfortran/torture/execute/intrinsic_cshift.f90

! 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/)))) &
STOP 1
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/)))) &
STOP 2
! 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/)))) &
STOP 3
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/)))) &
STOP 4
! 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/)))) &
STOP 5
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/)))) &
STOP 6
end program

Fortran/gfortran/torture/execute/intrinsic_dim.f90

! 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) STOP 1
if (dim (j, i) .ne. 3) STOP 2
r = 1.0
s = 4.0
if (dim (r, s) .ne. 0.0) STOP 3
if (dim (s, r) .ne. 3.0) STOP 4
p = 1.0
q = 4.0
if (dim (p, q) .ne. 0.0) STOP 5
if (dim (q, p) .ne. 3.0) STOP 6
end program

Fortran/gfortran/torture/execute/intrinsic_dotprod.f90

! 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) STOP 1
r = dot_product(a, c)
if (abs(r - 32.0) .gt. 0.001) STOP 2
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) STOP 3
end program

Fortran/gfortran/torture/execute/intrinsic_dprod.f90

! 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)) STOP 1
end program

Fortran/gfortran/torture/execute/intrinsic_dummy.f90

! 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) STOP 1
end subroutine
program dummy
implicit none
external test
intrinsic sin
call test (sin)
end program

Fortran/gfortran/torture/execute/intrinsic_eoshift.f90

! 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/)))) &
STOP 1
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, 9999, 99, 1)
if (any (a .ne. 99)) STOP 2
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/)))) &
STOP 3
a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
a = eoshift (a, -9999, 99, 1)
if (any (a .ne. 99)) STOP 4
! 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/)))) &
STOP 5
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/)))) &
STOP 6
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/)))) &
STOP 7
! 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/)))) &
STOP 8
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/)))) STOP 9
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/)))) STOP 10
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/)))) &
STOP 11
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/)))) &
STOP 12
! 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/)))) &
STOP 13
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/)))) &
STOP 14
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)))) STOP 15
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/)))) &
STOP 16
! 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/)))) &
STOP 17
if (any (b(:, :, 2) .ne. reshape ((/12, 13, 99, 15, 16, 99, 18, 19, 99/), (/3, 3/)))) &
STOP 18
! TODO: Test array sections
end program

Fortran/gfortran/torture/execute/intrinsic_fraction_exponent.f90

!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 = int(o'00000000001')
call test_4(x)
i = int(o'00010000000')
call test_4(x)
i = int(o'17700000000')
call test_4(x)
i = int(o'00004000001')
call test_4(x)
i = int(o'17737777777')
call test_4(x)
i = int(o'10000000000')
call test_4(x)
i = int(o'0000010000')
call test_4(x)
y = 0.5
call test_8(y)
y = 0.
call test_8(y)
j = int(o'00000000001',8)
call test_8(y)
y = 0.2938735877D-38
call test_8(y)
y = -1.469369D-39
call test_8(y)
y = real(z'7fe00000',8)
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)))) STOP 1
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)))) STOP 2
end

Fortran/gfortran/torture/execute/intrinsic_fraction_exponent.x

add-ieee-options
return 0

Fortran/gfortran/torture/execute/intrinsic_index.f90

! Program to test the INDEX intrinsic
program test
character(len=10) a
integer w
if (index("FORTRAN", "R") .ne. 3) STOP 1
if (index("FORTRAN", "R", .TRUE.) .ne. 5) STOP 2
if (w ("FORTRAN") .ne. 3) STOP 3
end
function w(str)
character(len=7) str
integer w
w = index(str, "R")
end

Fortran/gfortran/torture/execute/intrinsic_integer.f90

! 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))) STOP 1
end subroutine
end program

Fortran/gfortran/torture/execute/intrinsic_leadz.f90

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) STOP 1
if (leadz(0_2) /= 16) STOP 2
if (leadz(0_4) /= 32) STOP 3
if (leadz(0_8) /= 64) STOP 4
if (leadz(1_1) /= 7) STOP 5
if (leadz(1_2) /= 15) STOP 6
if (leadz(1_4) /= 31) STOP 7
if (leadz(1_8) /= 63) STOP 8
if (leadz(8_1) /= 4) STOP 9
if (leadz(8_2) /= 12) STOP 10
if (leadz(8_4) /= 28) STOP 11
if (leadz(8_8) /= 60) STOP 12
if (leadz(z1) /= 8) STOP 13
if (leadz(z2) /= 16) STOP 14
if (leadz(z4) /= 32) STOP 15
if (leadz(z8) /= 64) STOP 16
if (leadz(i1) /= 7) STOP 17
if (leadz(i2) /= 15) STOP 18
if (leadz(i4) /= 31) STOP 19
if (leadz(i8) /= 63) STOP 20
if (leadz(e1) /= 4) STOP 21
if (leadz(e2) /= 12) STOP 22
if (leadz(e4) /= 28) STOP 23
if (leadz(e8) /= 60) STOP 24
end subroutine test_leadz
end program

Fortran/gfortran/torture/execute/intrinsic_len.f90

! 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)) STOP 1
if (len(Tom%name) .ne. 10) STOP 2
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) STOP 1
end subroutine array_test

Fortran/gfortran/torture/execute/intrinsic_matmul.f90

! 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/)))) STOP 1
v = matmul(x, a)
if (any(v .ne. (/5, 8, 11/))) STOP 2
v(1:2) = matmul(a, y)
if (any(v(1:2) .ne. (/14, 20/))) STOP 3
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/)))) STOP 4
if (any(cc(3:4,1:2) .ne. 42.)) STOP 5
end program

Fortran/gfortran/torture/execute/intrinsic_merge.f90

! 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) STOP 1
i = 1
if (merge (-1, 1, i .ge. 3) .ne. 1) STOP 2
b = merge(a, 0, a .ge. 0)
if (any (b .ne. (/0, 2, 3/))) STOP 3
end program

Fortran/gfortran/torture/execute/intrinsic_minmax.f90

! 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) STOP 1
if (min (i, j, k, m) .ne. -2) STOP 2
if (max (i, k) .ne. 3) STOP 3
if (max (i, j, k, m) .ne. 4) STOP 4
if (max (i+1, j) .ne. 2) STOP 5
r = 1
s = -2
t = 3
u = 4
if (min (r, t) .ne. 1) STOP 6
if (min (r, s, t, u) .ne. -2) STOP 7
if (max (r, t) .ne. 3) STOP 8
if (max (r, s, t, u) .ne. 4) STOP 9
if (max (4d0, r) .ne. 4d0) STOP 10
if (amax0 (i, j) .ne. 1.0) STOP 11
if (min1 (r, s) .ne. -2) STOP 12
! Test simplify.
if (min (1, -2, 3, 4) .ne. -2) STOP 13
if (max (1, -2, 3, 4) .ne. 4) STOP 14
if (amax0 (1, -2) .ne. 1.0) STOP 15
if (min1 (1., -2.) .ne. -2) STOP 16
end program

Fortran/gfortran/torture/execute/intrinsic_mmloc.f90

! 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) STOP 1
if (b(2) .ne. 2) STOP 2
if (b(3) .ne. 3) STOP 3
b = -1
write (line, 9000) minloc(a,1)
read (line, 9000) b
if (b(1) .ne. 1) STOP 4
if (b(2) .ne. 2) STOP 5
if (b(3) .ne. 3) STOP 6
m = .true.
m(1, 1) = .false.
m(1, 2) = .false.
b = minloc (a, 1, m)
if (b(1) .ne. 2) STOP 7
if (b(2) .ne. 2) STOP 8
if (b(3) .ne. 3) STOP 9
b = minloc (a, 1, m .and. tr)
if (b(1) .ne. 2) STOP 10
if (b(2) .ne. 2) STOP 11
if (b(3) .ne. 3) STOP 12
b = -1
write (line, 9000) minloc(a, 1, m)
read (line, 9000) b
if (b(1) .ne. 2) STOP 13
if (b(2) .ne. 2) STOP 14
if (b(3) .ne. 3) STOP 15
b(1:2) = minloc(a)
if (b(1) .ne. 1) STOP 16
if (b(2) .ne. 1) STOP 17
b = -1
write (line, 9000) minloc(a)
read (line, 9000) b
if (b(1) .ne. 1) STOP 18
if (b(2) .ne. 1) STOP 19
if (b(3) .ne. 0) STOP 20
b(1:2) = minloc(a, mask=m)
if (b(1) .ne. 2) STOP 21
if (b(2) .ne. 1) STOP 22
b(1:2) = minloc(a, mask=m .and. tr)
if (b(1) .ne. 2) STOP 23
if (b(2) .ne. 1) STOP 24
b = -1
write (line, 9000) minloc(a, mask=m)
read (line, 9000) b
if (b(1) .ne. 2) STOP 25
if (b(2) .ne. 1) STOP 26
if (b(3) .ne. 0) STOP 27
b = maxloc (a, 1)
if (b(1) .ne. 3) STOP 28
if (b(2) .ne. 3) STOP 29
if (b(3) .ne. 1) STOP 30
b = -1
write (line, 9000) maxloc(a, 1)
read (line, 9000) b
if (b(1) .ne. 3) STOP 31
if (b(2) .ne. 3) STOP 32
if (b(3) .ne. 1) STOP 33
m = .true.
m(1, 2) = .false.
m(1, 3) = .false.
b = maxloc (a, 1, m)
if (b(1) .ne. 3) STOP 34
if (b(2) .ne. 3) STOP 35
if (b(3) .ne. 2) STOP 36
b = maxloc (a, 1, m .and. tr)
if (b(1) .ne. 3) STOP 37
if (b(2) .ne. 3) STOP 38
if (b(3) .ne. 2) STOP 39
b = -1
write (line, 9000) maxloc(a, 1, m)
read (line, 9000) b
if (b(1) .ne. 3) STOP 40
if (b(2) .ne. 3) STOP 41
if (b(3) .ne. 2) STOP 42
b(1:2) = maxloc(a)
if (b(1) .ne. 1) STOP 43
if (b(2) .ne. 3) STOP 44
b = -1
write (line, 9000) maxloc(a)
read (line, 9000) b
if (b(1) .ne. 1) STOP 45
if (b(2) .ne. 3) STOP 46
b(1:2) = maxloc(a, mask=m)
if (b(1) .ne. 2) STOP 47
if (b(2) .ne. 3) STOP 48
b(1:2) = maxloc(a, mask=m .and. tr)
if (b(1) .ne. 2) STOP 49
if (b(2) .ne. 3) STOP 50
b = -1
write (line, 9000) maxloc(a, mask=m)
read (line, 9000) b
if (b(1) .ne. 2) STOP 51
if (b(2) .ne. 3) STOP 52
if (b(3) .ne. 0) STOP 53
9000 format (3I3)
end program

Fortran/gfortran/torture/execute/intrinsic_mmloc_2.f90

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) STOP 1
if (maxloc (b, 1) .ne. 1) STOP 2
if (maxloc (c, 1) .ne. 1) STOP 3
! 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) STOP 4
END PROGRAM

Fortran/gfortran/torture/execute/intrinsic_mmloc_3.f90

! 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) STOP 1
d = huge (d)
if (minloc (d, 1) .ne. 1) STOP 2
d = -huge (d)
if (maxloc (d, 1, k) .ne. 1) STOP 3
d = huge (d)
if (minloc (d, 1, k) .ne. 1) STOP 4
a = -huge (a)
d = maxloc (a)
if (any (d .ne. 1)) STOP 5
a = huge (a)
d = minloc (a)
if (any (d .ne. 1)) STOP 6
a = -huge (a)
d = maxloc (a, l)
if (any (d .ne. 1)) STOP 7
a = huge (a)
d = minloc (a, l)
if (any (d .ne. 1)) STOP 8
end program

Fortran/gfortran/torture/execute/intrinsic_mmloc_4.f90

! 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) STOP 1
allocate (a(1, 0))
b = minloc (a)
if (any (b .ne. 0)) STOP 2
end program

Fortran/gfortran/torture/execute/intrinsic_mmval.f90

! 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/))) STOP 1
write (line, 9000) minval (a, 1)
if (line .ne. ' 1 4 7') STOP 2
m = .true.
m(1, 1) = .false.
m(1, 2) = .false.
b = minval (a, 1, m)
if (any(b .ne. (/2, 4, 7/))) STOP 3
b = minval (a, 1, m .and. tr)
if (any(b .ne. (/2, 4, 7/))) STOP 4
write (line, 9000) minval(a, 1, m)
if (line .ne. ' 2 4 7') STOP 5
b = maxval (a, 1)
if (any(b .ne. (/3, 6, 9/))) STOP 6
write (line, 9000) maxval (a, 1)
if (line .ne. ' 3 6 9') STOP 7
m = .true.
m(1, 2) = .false.
m(1, 3) = .false.
b = maxval (a, 1, m)
if (any(b .ne. (/3, 6, 8/))) STOP 8
b = maxval (a, 1, m .and. tr)
if (any(b .ne. (/3, 6, 8/))) STOP 9
write (line, 9000) maxval(a, 1, m)
if (line .ne. ' 3 6 8') STOP 10
9000 format(3I3)
end program

Fortran/gfortran/torture/execute/intrinsic_mod_ulo.f90

! 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))) STOP 1
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))) STOP 2
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))) STOP 3
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

Fortran/gfortran/torture/execute/intrinsic_mvbits.f90

! 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) STOP 1
to8 = 0_8
from8 = int(b'1011',8)*2_8**32
call mvbits (from8, 33, 3, to8, 2)
if (to8 /= int(b'10100',8)) STOP 1
end

Fortran/gfortran/torture/execute/intrinsic_nearest.f90

!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 = int(z'00800000')
call test_n (s, r)
i = int(z'007fffff')
call test_n (s, r)
i = int(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 )) STOP 1
infi = int(z'7f800000')
maxi = int(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) STOP 2
end
subroutine test_down(s, e)
real s, e, x
x = nearest(s, -1.0)
if (x .ne. e) STOP 3
end
subroutine test_n(s1, r)
real r, s1, x
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) STOP 4
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) STOP 5
s1 = -s1
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) STOP 6
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) STOP 7
end

Fortran/gfortran/torture/execute/intrinsic_nearest.x

if [istarget "powerpc-ibm-aix*"] {
# z'7f7fffff' value not preserved by lfs instruction.
return 1
}
add-ieee-options
return 0

Fortran/gfortran/torture/execute/intrinsic_pack.f90

! 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/))) STOP 1
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/))) STOP 2
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/))) STOP 3
if (any (pack(a, .true.) .ne. val)) STOP 4
if (size(pack (a, .false.)) .ne. 0) STOP 5
if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) STOP 6
end subroutine tests_with_temp
end program

Fortran/gfortran/torture/execute/intrinsic_present.f90

! 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()) STOP 1
if (.not. testvar(a)) STOP 2
if (testptr()) STOP 3
if (.not. testptr(b)) STOP 4
if (testarray()) STOP 5
if (.not. testarray(c)) STOP 6
if (testparray()) STOP 7
if (.not. testparray(d)) STOP 8
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

Fortran/gfortran/torture/execute/intrinsic_product.f90

! 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/))) STOP 1
write (line, 9000) product(a,1)
if (line .ne. ' 6 120 504') STOP 2
if (product (a) .ne. 362880) STOP 3
write (line, 9010) product(a)
if (line .ne. '362880') STOP 4
m = .true.
m(1, 1) = .false.
m(2, 1) = .false.
b = product (a, 2, m)
if (any(b .ne. (/28, 40, 162/))) STOP 5
b = product (a, 2, m .and. tr)
if (any(b .ne. (/28, 40, 162/))) STOP 6
write (line, 9000) product(a, 2, m)
if (line .ne. ' 28 40 162') STOP 7
if (product (a, mask=m) .ne. 181440) STOP 8
if (product (a, mask=m .and. tr) .ne. 181440) STOP 9
write (line, 9010) product(a, mask=m)
if (line .ne. '181440') STOP 10
9000 format (3I4)
9010 format (I6)
end program

Fortran/gfortran/torture/execute/intrinsic_rrspacing.f90

!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)) STOP 1
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)) STOP 2
end

Fortran/gfortran/torture/execute/intrinsic_scale.f90

!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)) STOP 1
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)) STOP 2
end

Fortran/gfortran/torture/execute/intrinsic_set_exponent.f90

!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)) STOP 1
n = 8
x = 1024.0
y = set_exponent (x, n)
if (exponent (y) .ne. n) STOP 2
n = 128
i = 8388607
x = transfer (i, x) ! z'007fffff' Positive denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) STOP 3
n = -148
x = -1024.0
y = set_exponent (x, n)
if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) STOP 4
n = 8
x = -1024.0
y = set_exponent (x, n)
if (y .ne. -128.0) STOP 5
if (exponent (y) .ne. n) STOP 6
n = 128
i = -2139095041
x = transfer (i, x) ! z'807fffff' Negative denormalized floating-point.
y = set_exponent (x, n)
if (exponent (y) .ne. n) STOP 7
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)) STOP 8
n = 8
x = 1024.0_8
y = set_exponent (x, n)
if (y .ne. 128.0) STOP 9
if (exponent (y) .ne. n) STOP 10
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) STOP 11
n = -1073
x = -1024.0
y = set_exponent (x, n)
if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) STOP 12
n = 8
x = -1024.0
y = set_exponent (x, n)
if (y .ne. -128.0) STOP 13
if (exponent (y) .ne. n) STOP 14
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) STOP 15
end

Fortran/gfortran/torture/execute/intrinsic_set_exponent.x

add-ieee-options
return 0

Fortran/gfortran/torture/execute/intrinsic_shape.f90

! 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 /))) STOP 1
call test(a)
contains
subroutine test (a)
real, dimension (1:, 1:) :: a
if (any (shape (a) .ne. (/ 6, 2 /))) STOP 2
end subroutine
end program

Fortran/gfortran/torture/execute/intrinsic_si_kind.f90

! 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) STOP 1
t = huge (i2)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 2) STOP 2
t = huge (i4)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 4) STOP 3
t = huge (i8)
t = log10 (t)
res = selected_int_kind (int (t))
if (res .ne. 8) STOP 4
i4 = huge (i4)
res = selected_int_kind (i4)
if (res .ne. (-1)) STOP 5
end program

Fortran/gfortran/torture/execute/intrinsic_sign.f90

! 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) STOP 1
i = 4
j = -5
if (sign (i, j) .ne. -4) STOP 2
i = -6
j = 7
if (sign (i, j) .ne. 6) STOP 3
i = -8
j = -9
if (sign (i, j) .ne. -8) STOP 4
r = 1
s = 2
if (sign (r, s) .ne. 1) STOP 5
r = 1
s = -2
if (sign (r, s) .ne. -1) STOP 6
s = 0
if (sign (r, s) .ne. 1) STOP 7
! Will fail on machines which cannot represent negative zero.
s = -s ! Negative zero
if (sign (r, s) .ne. -1) STOP 8
end program

Fortran/gfortran/torture/execute/intrinsic_size.f90

! 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) STOP 1
allocate (a(3:8, 5:7))
! With one parameter
if (size(a) .ne. 18) STOP 2
! With two parameters, assigning to an array
j = size(a, 1)
if (any (j .ne. (/6, 6, 6, 6, 6/))) STOP 3
! With a variable second parameter
i = 2
i = size(a, i)
if (i .ne. 3) STOP 4
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)) STOP 5
if (size (a) .ne. 18 ) STOP 6
end subroutine
end program

Fortran/gfortran/torture/execute/intrinsic_spacing.f90

!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)))STOP 1
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)))STOP 2
end

Fortran/gfortran/torture/execute/intrinsic_spacing.x

add-ieee-options
return 0

Fortran/gfortran/torture/execute/intrinsic_spread.f90

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/)))) &
STOP 1
write(line1, 9000) b
write(line2, 9000) spread (a, 1, 2)
if (line1 /= line2) STOP 2
write(line3, 9000) spread (a, 1, 2) + 0
if (line1 /= line3) STOP 3
9000 format(12I3)
end program

Fortran/gfortran/torture/execute/intrinsic_sr_kind.f90

! 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) STOP 1
res = selected_real_kind (r = i8)
if (res .ne. 8) STOP 2
! 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) STOP 3
res = selected_real_kind (p = precision (r4))
if (res .ne. 4) STOP 4
res = selected_real_kind (p = precision (r4), r = i4)
if (res .ne. 4) STOP 5
res = selected_real_kind (p = precision (r4), r = i8)
if (res .ne. 8) STOP 6
! res = selected_real_kind (p = precision (r4), r = i8 + 1)
! if (res .ne. -2) STOP 7
res = selected_real_kind (p = precision (r8))
if (res .ne. 8) STOP 8
res = selected_real_kind (p = precision (r8), r = i4)
if (res .ne. 8) STOP 9
res = selected_real_kind (p = precision (r8), r = i8)
if (res .ne. 8) STOP 10
! res = selected_real_kind (p = precision (r8), r = i8 + 1)
! if (res .ne. -2) STOP 11
! res = selected_real_kind (p = (precision (r8) + 1))
! if (res .ne. -1) STOP 12
! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
! if (res .ne. -1) STOP 13
! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
! if (res .ne. -1) STOP 14
! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
! if (res .ne. -3) STOP 15
end

Fortran/gfortran/torture/execute/intrinsic_sum.f90

! 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) STOP 1
write (line, 9000) sum(a)
if (line .ne. ' 45 ') STOP 2
b = sum (a, 1)
if (b(1) .ne. 6) STOP 3
if (b(2) .ne. 15) STOP 4
if (b(3) .ne. 24) STOP 5
write (line, 9000) sum (a, 1)
if (line .ne. ' 6 15 24') STOP 6
m = .true.
m(1, 1) = .false.
m(2, 1) = .false.
if (sum (a, mask=m) .ne. 42) STOP 7
if (sum (a, mask=m .and. tr) .ne. 42) STOP 8
write(line, 9000) sum (a, mask=m)
if (line .ne. ' 42 ') STOP 9
b = sum (a, 2, m)
if (b(1) .ne. 11) STOP 10
if (b(2) .ne. 13) STOP 11
if (b(3) .ne. 18) STOP 12
b = sum (a, 2, m .and. tr)
if (b(1) .ne. 11) STOP 13
if (b(2) .ne. 13) STOP 14
if (b(3) .ne. 18) STOP 15
write (line, 9000) sum (a, 2, m)
if (line .ne. ' 11 13 18') STOP 16
9000 format(3I3)
end program

Fortran/gfortran/torture/execute/intrinsic_trailz.f90

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) STOP 1
if (trailz(0_2) /= 16) STOP 2
if (trailz(0_4) /= 32) STOP 3
if (trailz(0_8) /= 64) STOP 4
if (trailz(1_1) /= 0) STOP 5
if (trailz(1_2) /= 0) STOP 6
if (trailz(1_4) /= 0) STOP 7
if (trailz(1_8) /= 0) STOP 8
if (trailz(8_1) /= 3) STOP 9
if (trailz(8_2) /= 3) STOP 10
if (trailz(8_4) /= 3) STOP 11
if (trailz(8_8) /= 3) STOP 12
if (trailz(z1) /= 8) STOP 13
if (trailz(z2) /= 16) STOP 14
if (trailz(z4) /= 32) STOP 15
if (trailz(z8) /= 64) STOP 16
if (trailz(i1) /= 0) STOP 17
if (trailz(i2) /= 0) STOP 18
if (trailz(i4) /= 0) STOP 19
if (trailz(i8) /= 0) STOP 20
if (trailz(e1) /= 3) STOP 21
if (trailz(e2) /= 3) STOP 22
if (trailz(e4) /= 3) STOP 23
if (trailz(e8) /= 3) STOP 24
end subroutine test_trailz
end program

Fortran/gfortran/torture/execute/intrinsic_transpose.f90

! 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/)))) &
STOP 1
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/)))) &
STOP 1;
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/)))) &
STOP 2;
end program

Fortran/gfortran/torture/execute/intrinsic_trim.f90

! 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")) STOP 1
a=' '
b=trim(a)
if (b .gt. "") STOP 2
b='12'
a=repeat(b,0)
if (a .gt. "") STOP 3
a=repeat(b,2)
if (a .ne. "12 12 ") STOP 4
end
function work(i,a)
integer i
character(len=i) a
character(len=4) work
work = trim(a)
end

Fortran/gfortran/torture/execute/intrinsic_unpack.f90

! 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/)))) &
STOP 1
write (line1,'(10I4)') b
write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a)
if (line1 .ne. line2) STOP 2
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/)))) &
STOP 3
end program

Fortran/gfortran/torture/execute/iolength_1.f90

! 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
STOP 1
end if
end program iolength_1

Fortran/gfortran/torture/execute/iolength_2.f90

! 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
STOP 1
end if
end program iolength_2

Fortran/gfortran/torture/execute/iolength_3.f90

! 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
STOP 1
end if
end program iolength_3

Fortran/gfortran/torture/execute/list_read_1.f90

! 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)) STOP 1
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)) STOP 2
end do
end do
close(nin, status='delete')
end program d

Fortran/gfortran/torture/execute/list_read_1.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/logical_select_1.f90

LOGICAL :: L = .FALSE.
SELECT CASE (L)
CASE (.TRUE.)
STOP 1
CASE (.FALSE.)
CONTINUE
CASE DEFAULT
STOP 2
END SELECT
SELECT CASE (L)
CASE (.TRUE., .FALSE.)
CONTINUE
CASE DEFAULT
STOP 3
END SELECT
SELECT CASE (L)
CASE (.FALSE.)
CONTINUE
CASE DEFAULT
STOP 4
END SELECT
SELECT CASE (L)
CASE (.NOT. .TRUE.)
CONTINUE
CASE DEFAULT
STOP 5
END SELECT
SELECT CASE (.NOT. L)
CASE (.TRUE.)
CONTINUE
CASE DEFAULT
STOP 6
END SELECT
SELECT CASE (Truth_or_Dare() .OR. L)
CASE (.TRUE.)
CONTINUE
CASE DEFAULT
STOP 7
END SELECT
CONTAINS
FUNCTION Truth_or_Dare ()
LOGICAL Truth_or_Dare
Truth_or_Dare = .TRUE.
END FUNCTION
END

Fortran/gfortran/torture/execute/mainsub.f90

! 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) STOP 1
end program
subroutine test (p)
implicit none
integer p
p = 42
end subroutine

Fortran/gfortran/torture/execute/math.f90

! 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) STOP 1
if (abs (real (val8, kind=4) - known) .gt. 0.001) STOP 2
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) STOP 3
if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) STOP 4
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

Fortran/gfortran/torture/execute/module_init_1.f90

! 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.) STOP 1
if (a(1).NE.a(3)) STOP 2
end

Fortran/gfortran/torture/execute/module_interface.f90

! 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

Fortran/gfortran/torture/execute/module_interface_2.f90

! 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) STOP 1
end subroutine
end module
subroutine myfoo (i)
integer i
if (i .ne. 42) STOP 2
end subroutine
program test
use module_interface_2
call foo (42)
call foo (1.0)
end program

Fortran/gfortran/torture/execute/mystery_proc.f90

! 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

Fortran/gfortran/torture/execute/nan_inf_fmt.f90

!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') STOP 1
write(l,fmt=fmt)neg_inf
if (l.ne.'-Inf') STOP 2
write(l,fmt=fmt)nan
if (l.ne.'NaN') STOP 3
! check a field width < 3
fmt = '(F2.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'**') STOP 4
write(l,fmt=fmt)neg_inf
if (l.ne.'**') STOP 5
write(l,fmt=fmt)nan
if (l.ne.'**') STOP 6
! check a field width = 3
fmt = '(F3.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'Inf') STOP 7
write(l,fmt=fmt)neg_inf
if (l.ne.'***') STOP 8
write(l,fmt=fmt)nan
if (l.ne.'NaN') STOP 9
! check a field width > 3
fmt = '(F4.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Inf') STOP 10
write(l,fmt=fmt)neg_inf
if (l.ne.'-Inf') STOP 11
write(l,fmt=fmt)nan
if (l.ne.' NaN') STOP 12
! check a field width = 7
fmt = '(F7.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Inf') STOP 13
write(l,fmt=fmt)neg_inf
if (l.ne.' -Inf') STOP 14
write(l,fmt=fmt)nan
if (l.ne.' NaN') STOP 15
! check a field width = 8
fmt = '(F8.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.'Infinity') STOP 16
write(l,fmt=fmt)neg_inf
if (l.ne.' -Inf') STOP 17
write(l,fmt=fmt)nan
if (l.ne.' NaN') STOP 18
! check a field width = 9
fmt = '(F9.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Infinity') STOP 19
write(l,fmt=fmt)neg_inf
if (l.ne.'-Infinity') STOP 20
write(l,fmt=fmt)nan
if (l.ne.' NaN') STOP 21
! check a field width = 14
fmt = '(F14.0)'
write(l,fmt=fmt)pos_inf
if (l.ne.' Infinity') STOP 22
write(l,fmt=fmt)neg_inf
if (l.ne.' -Infinity') STOP 23
write(l,fmt=fmt)nan
if (l.ne.' NaN') STOP 24
end

Fortran/gfortran/torture/execute/nan_inf_fmt.x

add-ieee-options
return 0

Fortran/gfortran/torture/execute/nestcons.f90

! 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/))) STOP 1
end

Fortran/gfortran/torture/execute/nullarg.f90

! 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)) STOP 1
END SUBROUTINE A
END MODULE T
USE T
CALL A(NULL())
END

Fortran/gfortran/torture/execute/open_replace.f90

! 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

Fortran/gfortran/torture/execute/optstring_1.f90

! 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") STOP 1
else
if (b .ne. "Hello World") STOP 2
if (c .ne. 42) STOP 3
end if
end subroutine
end program

Fortran/gfortran/torture/execute/parameter_1.f90

! 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) STOP 1
if (rr(i) /= i) STOP 2
end do
end program parameter_1

Fortran/gfortran/torture/execute/parameter_2.f90

module m
parameter (p = -1.) ! negative numbers used to get output incorrectly
end module m
use m
if (p .ne. -1.) STOP 1
end

Fortran/gfortran/torture/execute/partparm.f90

! Program to test
subroutine test (p)
integer, dimension (3) :: p
if (any (p .ne. (/ 2, 4, 6/))) STOP 1
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

Fortran/gfortran/torture/execute/plusconst_1.f90

! 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)) &
STOP 1
end program

Fortran/gfortran/torture/execute/power.f90

! 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) STOP 1
j = i ** (-10)
if (abs (j - 0) .gt. del) STOP 2
j = i ** 0
if (abs (j - 1) .gt. del) STOP 3
i = 1
j = i ** 10
if (abs (j - 1) .gt. del) STOP 4
j = i ** (-10)
if (abs (j - 1) .gt. del) STOP 5
j = i ** 0
if (abs (j - 1) .gt. del) STOP 6
i = -1
j = i ** 10
if (abs (j - 1) .gt. del) STOP 7
j = i ** (-10)
if (abs (j - 1) .gt. del) STOP 8
j = i ** 0
if (abs (j - 1) .gt. del) STOP 9
j = i ** 11
if (abs (j - (-1)) .gt. del) STOP 10
j = i ** (-11)
if (abs (j - (-1)) .gt. del) STOP 11
c = (2.0, 3.0)
z = c ** 2
if (abs(z - (-5.0, 12.0)) .gt. del) STOP 12
z = c ** 7
if (abs(z - (6554.0, 4449.0)) .gt. del) STOP 13
two = 2.0
r = two ** 1
if (abs (r - 2.0) .gt. del) STOP 14
r = two ** 2
if (abs (r - 4.0) .gt. del) STOP 15
r = two ** 3
if (abs (r - 8.0) .gt. del) STOP 16
r = two ** 4
if (abs (r - 16.0) .gt. del) STOP 17
r = two ** 0
if (abs (r - 1.0) .gt. del) STOP 18
r = two ** (-1)
if (abs (r - 0.5) .gt. del) STOP 19
r = two ** (-2)
if (abs (r - 0.25) .gt. del) STOP 20
r = two ** (-4)
if (abs (r - 0.0625) .gt. del) STOP 21
s = 3.0
r = two ** s
if (abs (r - 8.0) .gt. del) STOP 22
s = -3.0
r = two ** s
if (abs (r - 0.125) .gt. del) STOP 23
i = 3
r = two ** i
if (abs (r - 8.0) .gt. del) STOP 24
i = -3
r = two ** i
if (abs (r - 0.125) .gt. del) STOP 25
c = (2.0, 3.0)
c = c ** two
if (abs(c - (-5.0, 12.0)) .gt. del) STOP 26
end program

Fortran/gfortran/torture/execute/pr19269-1.f90

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) STOP 1
if (size (a, 2) .ne. 2) STOP 2
if (len (a) .ne. 1) STOP 3
if (a (1, 1) .ne. 'a') STOP 4
if (a (2, 1) .ne. 'b') STOP 5
if (a (1, 2) .ne. 'c') STOP 6
if (a (2, 2) .ne. 'd') STOP 7
end subroutine test
end program main

Fortran/gfortran/torture/execute/pr23373-1.f90

program main
implicit none
real, dimension (:), pointer :: x
x => null ()
x => test (x)
if (.not. associated (x)) STOP 1
if (size (x) .ne. 10) STOP 2
contains
function test (p)
real, dimension (:), pointer :: p, test
if (associated (p)) STOP 3
allocate (test (10))
if (associated (p)) STOP 4
end function test
end program main

Fortran/gfortran/torture/execute/pr23373-2.f90

program main
implicit none
real, dimension (:), pointer :: x
x => null ()
x => test ()
if (.not. associated (x)) STOP 1
if (size (x) .ne. 10) STOP 2
contains
function test()
real, dimension (:), pointer :: test
if (associated (x)) STOP 3
allocate (test (10))
if (associated (x)) STOP 4
end function test
end program main

Fortran/gfortran/torture/execute/pr32140.f90

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") STOP 1
END

Fortran/gfortran/torture/execute/pr32604.f90

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

Fortran/gfortran/torture/execute/pr40021.f

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)) STOP 1
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

Fortran/gfortran/torture/execute/pr43390.f90

logical :: l1(4)
logical :: l2(4)
l1 = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./)
l2 = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./)
if (dot_product (l1, l2)) STOP 1
l2 = .TRUE.
if (.not.dot_product (l1, l2)) STOP 2
end

Fortran/gfortran/torture/execute/pr54767.f90

SUBROUTINE XXX (IL, IU)
implicit none
integer, INTENT(IN) :: IL, IU
integer :: NXX (14) = (/ 0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14 /)
integer :: ivvv, ia, ja, iaii
logical :: qop
QOP=.FALSE.
DO IA=IL,IU
JA=NXX(IA)
IF (.NOT. QOP .and. JA.GT.0) THEN
IAII=IA
QOP=.TRUE.
ENDIF
IF (QOP) THEN
ivvv=IA-IAII+1 ! mis-compiled
ENDIF
ENDDO
IF (ivvv.NE.2) THEN
STOP 1
ENDIF
END subroutine
program p
implicit none
CALL XXX (1, 3)
end

Fortran/gfortran/torture/execute/pr57396.f90

module testmod
implicit none
contains
subroutine foo(n)
integer, intent(in) :: n
real :: r(0:n,-n:n), a(0:n,-n:n), dj
integer :: k, j
! initialize with some dummy values
do j = -n, n
a(:, j) = j
r(:,j) = j + 1
end do
! here be dragons
do k = 0, n
dj = r(k, k - 2) * a(k, k - 2)
r(k,k) = a(k, k - 1) * dj
enddo
if (r(0,0) .ne. -2.) STOP 1
end subroutine
end module
program test
use testmod
implicit none
call foo(5)
end program

Fortran/gfortran/torture/execute/procarg.f90

! Pogram to test
subroutine myp (a)
implicit none
integer a
if (a .ne. 42) STOP 1
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

Fortran/gfortran/torture/execute/ptr.f90

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 /))) STOP 1
b => a(1:6:2)
if (any (b .ne. (/ 1, 3, 5/))) STOP 2
p => i
i = 42
if (p .ne. 42) STOP 3
p => a(4)
if (p .ne. 4) STOP 4
end program

Fortran/gfortran/torture/execute/random_1.f90

! 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)) STOP 1
! Get the last 5 numbers again.
call random_seed (put=seed)
call random_number (b(6:10))
if (any (a .ne. b)) STOP 2
end program

Fortran/gfortran/torture/execute/random_2.f90

! 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)) STOP 1
end program

Fortran/gfortran/torture/execute/random_init.f90

! 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)) STOP 1
end program

Fortran/gfortran/torture/execute/read_eof.f90

! PR 13919, segfault when file is empty
open(unit=8,status='scratch')
read(8,*,end=1)i
STOP 1
1 continue
end

Fortran/gfortran/torture/execute/read_null_string.f90

! 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.'') STOP 1
end

Fortran/gfortran/torture/execute/read_null_string.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/retarray.f90

! 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) STOP 1
if (a(6,5) .ne. 43) STOP 2
a = 0
a(1:6:2, 2:5) = test2()
if (a(1,2) .ne. 42) STOP 3
if (a(5,5) .ne. 43) STOP 4
a = 1
! This requires a temporary
a = test(6, 5) - a
if (a(1,1) .ne. 41) STOP 5
if (a(6,5) .ne. 42) STOP 6
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

Fortran/gfortran/torture/execute/retarray_2.f90

! 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/))) STOP 1
end

Fortran/gfortran/torture/execute/save_1.f90

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) STOP 1
if (s .ne. 'This is a test string') STOP 2
end if
end subroutine foo
subroutine bar (s)
character*42 s
if (s .ne. '0123456789012345678901234567890123456') STOP 3
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

Fortran/gfortran/torture/execute/save_2.f90

! 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) STOP 1
end subroutine foo
subroutine bar
integer a(10)
a = 34
end subroutine bar

Fortran/gfortran/torture/execute/scalarize.f90

! 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)) STOP 1
if (b(4, n) .ne. (6 - n)) STOP 2
end do
end program

Fortran/gfortran/torture/execute/scalarize2.f90

! 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)) STOP 1
if (b(4, n) .ne. (6 - n)) STOP 2
end do
end program

Fortran/gfortran/torture/execute/scalarize3.f90

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/)))) STOP 1
end program

Fortran/gfortran/torture/execute/select_1.f90

! 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) STOP 1
end

Fortran/gfortran/torture/execute/seq_io.f90

! 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) = int(Z'11111111')
m(2) = int(Z'22222222')
n = int(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. int(Z'11111111')) then
if (debug) then
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
else
STOP 1
endif
endif
if (m(2).ne. int(Z'22222222')) then
if (debug) then
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
else
STOP 2
endif
endif
if (n.ne. int(Z'33333333')) then
if (debug) then
print '(A,Z8)','n incorrect. n = ',n
else
STOP 3
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
STOP 4
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

Fortran/gfortran/torture/execute/seq_io.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/slash_edit.f90

! 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) STOP 1
IF (J.NE.4) STOP 2
END

Fortran/gfortran/torture/execute/slash_edit.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/spec_abs.f90

!pr 14056
INTRINSIC IABS
INTEGER FF324
IVCOMP = FF324(IABS,-7)
IF (IVCOMP.NE.8) STOP 1
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

Fortran/gfortran/torture/execute/specifics.f90

! 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)) STOP 1
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)) STOP 2
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)) STOP 3
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)) STOP 4
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)) STOP 5
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)) STOP 6
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)) STOP 7
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)) STOP 8
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) STOP 9
end subroutine
subroutine test_nint(fn,val,res)
integer fn, res
real val
if (res .ne. fn(val)) STOP 10
end subroutine
subroutine test_idnint(fn,val,res)
integer fn, res
double precision val
if (res .ne. fn(val)) STOP 11
end subroutine
subroutine test_idim(fn,val1,val2,res)
integer fn, res, val1, val2
if (res .ne. fn(val1,val2)) STOP 12
end subroutine
subroutine test_iabs(fn,val,res)
integer fn, res, val
if (res .ne. fn(val)) STOP 13
end subroutine
subroutine test_len(fn,val,res)
integer fn, res
character(len=*) val
if (res .ne. fn(val)) STOP 14
end subroutine
subroutine test_index(fn,val1,val2,res)
integer fn, res
character(len=*) val1, val2
if (fn(val1,val2) .ne. res) STOP 15
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

Fortran/gfortran/torture/execute/st_function.f90

! 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) STOP 1
c = 3
if (st2 (1, 2) .ne. 3 .or. st2 (2, 3) .ne. 3) STOP 2
end subroutine
subroutine with_function_call
integer fun, st3
st3 (i, j) = fun (i) + fun (j)
if (st3 (fun (2), 4) .ne. 16) STOP 3
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" ) STOP 4
if (st5 ("01", "02") .ne. "01 02 ") STOP 5! { 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) STOP 6
if (tom%name .gt. "Tom") STOP 7
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') STOP 8
end subroutine
subroutine multiple_eval
integer st7, fun2, fun
st7(i) = i + fun(i)
if (st7(fun2(10)) .ne. 3) STOP 9
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

Fortran/gfortran/torture/execute/st_function_1.f90

! 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))) STOP 1
end subroutine
end program

Fortran/gfortran/torture/execute/st_function_2.f90

! 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) STOP 1
! Check that values aren't modified when avaluating the arguments.
a = 1
b = 5
if (fn (b + 2, a + 3) .ne. 11) STOP 2
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

Fortran/gfortran/torture/execute/stack_varsize.f90

! 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)) STOP 1
if ((m .ne. 10).or.(n(256,4) .ne. 20).or.(k(1,1024) .ne. 30)) STOP 2
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) STOP 3
a (1) = 0
end subroutine
end

Fortran/gfortran/torture/execute/straret.f90

! 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 ") STOP 1
end program

Fortran/gfortran/torture/execute/strarray_1.f90

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') STOP 1
end
program strarray_1
call foo(3)
end

Fortran/gfortran/torture/execute/strarray_2.f90

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') STOP 1
end

Fortran/gfortran/torture/execute/strarray_3.f90

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")) STOP 1
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")) STOP 2
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")) STOP 3
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")) STOP 4
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")) STOP 5
end subroutine
end program

Fortran/gfortran/torture/execute/strarray_4.f90

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")) STOP 1
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")) STOP 2
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")) STOP 3
end subroutine
end program

Fortran/gfortran/torture/execute/strcmp.f90

program test
implicit none
character(len=20) :: foo
foo="hello"
if (llt(foo, "hello")) STOP 1
if (.not. lle(foo, "hello")) STOP 2
if (lgt("hello", foo)) STOP 3
if (.not. lge("hello", foo)) STOP 4
if (.not. llt(foo, "world")) STOP 5
if (.not. lle(foo, "world")) STOP 6
if (lgt(foo, "world")) STOP 7
if (lge(foo, "world")) STOP 8
end

Fortran/gfortran/torture/execute/strcommon_1.f90

! PR14081 character variables in common blocks.
subroutine test1
implicit none
common /block/ c
character(len=12) :: c
if (c .ne. "Hello World") STOP 1
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")) STOP 2
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

Fortran/gfortran/torture/execute/string.f90

! 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') STOP 1
if (c .eq. 'WorldHello') STOP 2
if (a//'World' .ne. 'HelloWorld') STOP 3
if (a .ge. b) STOP 4
end program

Fortran/gfortran/torture/execute/strlen.f90

! 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) STOP 1
if (d .ne. "Longer Test String") STOP 2
c = "Hello World"
end subroutine
subroutine test2 (c)
character (*) c
character(len(c)) d
d = c
if (len(d) .ne. 6) STOP 3
if (d .ne. "Foobar") STOP 4
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) STOP 5
if (len_trim(c) .ne. 11) STOP 6
call test2 ("Foobar");
end program

Fortran/gfortran/torture/execute/strret.f90

! 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") STOP 1
s = "Hello " // test ()
if (s .ne. test2 () //" World") STOP 2
end

Fortran/gfortran/torture/execute/t_edit.f90

!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 ') STOP 1
WRITE(line,'(5HAAAAA,TL4,4HABCD)')
if (line.ne.'AABCD') STOP 2
END

Fortran/gfortran/torture/execute/test_slice.f90

! 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) STOP 1
if (maxval(x(1, 1:2, 1:1)) .ne. 1.0) STOP 2
if (any (shape(x(1, 1:2, 1:1)) .ne. (/2, 1/))) STOP 3
if (any (shape(x(1, 1:2, 1)) .ne. (/2/))) STOP 4
if (any (shape(x(1:1, 1:2, 1:1)) .ne. (/1, 2, 1/))) STOP 5
end program test_slice

Fortran/gfortran/torture/execute/transfer1.f90

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) STOP 1
end program chop

Fortran/gfortran/torture/execute/transfer2.f90

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) STOP 1
end program test_convert

Fortran/gfortran/torture/execute/unopened_unit_1.f90

! 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) STOP 1
End Do
Close(99, Status='Delete')
End program

Fortran/gfortran/torture/execute/unopened_unit_1.x

load_lib target-supports.exp
if { ! [check_effective_target_fd_truncate] } {
return 1
}
return 0

Fortran/gfortran/torture/execute/userop.f90

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) STOP 1
c = .false.
if (.not. (b * c)) STOP 2
if (c * b) STOP 3
b = .false.
if (b * c) STOP 4
i = 0
b = i
if (b) STOP 5
i = 2
b = i
if (.not. b) STOP 6
j = 3
if ((i .foo. j) .ne. 5) STOP 7
end program

Fortran/gfortran/torture/execute/where17.f90

! 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/))) STOP 1
end program

Fortran/gfortran/torture/execute/where18.f90

! 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/))) &
STOP 1
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/))) &
STOP 2
end program

Fortran/gfortran/torture/execute/where19.f90

! 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/))) &
STOP 1
a = (/1, 2, 3, 4/)
where (c .gt. 1)
b = c
endwhere
if (any (a .ne. (/2, 3, 4, 4/))) &
STOP 2
end program

Fortran/gfortran/torture/execute/where20.f90

! 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/))) STOP 1
! 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/))) STOP 2
! Mask to.destination dependency.
a = (/1, 2, 3, 4/)
where (b .gt. 1)
c = d
endwhere
if (any(a .ne. (/1,2,2,3/))) STOP 3
! Source to.destination dependency.
a = (/1, 2, 3, 4/)
where (d .gt. 1)
c = b
endwhere
if (any(a .ne. (/1,2,2,3/))) STOP 4
! Check the simple where.
a = (/1, 2, 3, 4/)
where (b .gt. 1) c = b
if (any(a .ne. (/1,2,2,3/))) STOP 5
! 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/))) STOP 6
end program

Fortran/gfortran/torture/execute/where21.f90

! { 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)) STOP 1
end program a

Fortran/gfortran/torture/execute/where_1.f90

! 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/)))) STOP 1
! 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/)))) STOP 2
end

Fortran/gfortran/torture/execute/where_10.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_11.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_12.f90

! Check empty WHEREs work
program where_12
integer :: a(5)
a = (/1, 2, 3, 4, 5/)
where (a .eq. 1)
endwhere
end program

Fortran/gfortran/torture/execute/where_13.f90

! 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

Fortran/gfortran/torture/execute/where_14.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_15.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_16.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_2.f90

! 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/))) &
STOP 1
end program

Fortran/gfortran/torture/execute/where_3.f90

! 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/)))) STOP 1
end subroutine
end program

Fortran/gfortran/torture/execute/where_4.f90

! 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/))) STOP 1
end program

Fortran/gfortran/torture/execute/where_5.f90

! 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/))) STOP 1
end program

Fortran/gfortran/torture/execute/where_6.f90

! 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/)))) STOP 1
end

Fortran/gfortran/torture/execute/where_7.f90

! 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/))) STOP 1
if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 17, 18, 19, 20/))) STOP 2
if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) STOP 3
if (any(v(5)%p(:) .ne. (/9, 10/))) STOP 4
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/))) STOP 5
if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 5, 6, 7, 8/))) STOP 6
if (any(v(4)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) STOP 7
if (any(v(5)%p(:) .ne. (/11, 12/))) STOP 8
! I should really free the memory I've allocated.
end program

Fortran/gfortran/torture/execute/where_8.f90

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/))) STOP 1
if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 21, 21, 21, 21/))) STOP 2
if (any(v(4)%p(:) .ne. (/21, 21, 21, 21, 21, 21, 19, 20/))) STOP 3
if (any(v(5)%p(:) .ne. (/21, 21, 0, 0, 0, 0, 0, 0/))) STOP 4
end program

Fortran/gfortran/torture/execute/write_a_1.f90

! 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") STOP 1
! string < format
write(s,'(A2)') "hello world"
if (s.ne."he") STOP 2
! string > format
write(s,'(A18)') "hello world"
if (s.ne." hello world") STOP 3
end

Fortran/gfortran/torture/execute/write_logical.f90

! 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') STOP 1
b = ''
write (b, '(L1)') false
if (b(1:1) .ne. 'F') STOP 2
b = ''
write(b, '(L4)') true
if (b(1:4) .ne. ' T') STOP 3
b = ''
write(b, '(L4)') false
if (b(1:4) .ne. ' F') STOP 4
end