Skip to content

R
riscv-gcc-1
Commit 649067c3 by Toon Moene Committed by Toon Moene
Options

g77.dg: Removed. 

2004-07-17  Toon Moene  <toon@moene.indiv.nluug.nl>

	* g77.dg: Removed.
	* g77.f-torture: Ditto.

From-SVN: r84865
parent 320e32f6
Showing with 5 additions and 11047 deletions
gcc/testsuite/ChangeLog
2004-07-17 Toon Moene <toon@moene.indiv.nluug.nl>
* g77.dg: Removed.
* g77.f-torture: Ditto.
2004-07-17 Joseph S. Myers <jsm@polyomino.org.uk> 2004-07-17 Joseph S. Myers <jsm@polyomino.org.uk>
* gcc.dg/Wparentheses-2.c, gcc.dg/Wparentheses-3.c, * gcc.dg/Wparentheses-2.c, gcc.dg/Wparentheses-3.c,
......
gcc/testsuite/g77.dg/12632.f deleted 100644 → 0
C { dg-do compile }
C { dg-options "-fbounds-check" }
INTEGER I(1)
I(2) = 0 ! { dg-error "out of defined range" "out of defined range" }
END
gcc/testsuite/g77.dg/20010216-1.f deleted 100644 → 0
C Test for bug in reg-stack handling conditional moves.
C Reported by Tim Prince <tprince@computer.org>
C
C { dg-do run { target "i[6789]86-*-*" } }
C { dg-options "-ffast-math -march=pentiumpro" }
double precision function foo(x, y)
implicit none
double precision x, y
double precision a, b, c, d
if (x /= y) then
if (x * y >= 0) then
a = abs(x)
b = abs(y)
c = max(a, b)
d = min(a, b)
foo = 1 - d/c
else
foo = 1
end if
else
foo = 0
end if
end
program test
implicit none
integer ntests
parameter (ntests=7)
double precision tolerance
parameter (tolerance=1.0D-6)
C Each column is a pair of values to feed to foo,
C and its expected return value.
double precision a(ntests) /1, -23, -1, 1, 9, 10, -9/
double precision b(ntests) /1, -23, 12, -12, 10, 9, -10/
double precision x(ntests) /0, 0, 1, 1, 0.1, 0.1, 0.1/
double precision foo
double precision result
integer i
do i = 1, ntests
result = foo(a(i), b(i))
if (abs(result - x(i)) > tolerance) then
print *, i, a(i), b(i), x(i), result
call abort
end if
end do
end
gcc/testsuite/g77.dg/7388.f deleted 100644 → 0
C { dg-do run }
C { dg-options "-fbounds-check" }
character*25 buff(0:10)
character*80 line
integer i, m1, m2
i = 1
m1 = 1
m2 = 7
buff(i) = 'tcase0a'
write(line,*) buff(i)(m1:m2)
if (line .ne. ' tcase0a') call abort
end
gcc/testsuite/g77.dg/bprob/bprob.exp deleted 100644 → 0
# Copyright (C) 2001, 2002 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 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Test the functionality of programs compiled with profile-directed block
# ordering using -fprofile-arcs followed by -fbranch-probabilities.
load_lib target-supports.exp
# Some targets don't have any implementation of __bb_init_func or are
# missing other needed machinery.
if { ![check_profiling_available "-fprofile-arcs"] } {
return
}
# The procedures in profopt.exp need these parameters.
set tool g77
set profile_option -fprofile-arcs
set feedback_option -fbranch-probabilities
set prof_ext gcda
set perf_ext tim
# Override the list defined in profopt.exp.
set PROFOPT_OPTIONS [list \
{ -g } \
{ -O0 } \
{ -O1 } \
{ -O2 } \
{ -O3 } \
{ -O3 -g } \
{ -Os } ]
if $tracelevel then {
strace $tracelevel
}
# Load support procs.
load_lib profopt.exp
foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $src] then {
continue
}
profopt-execute $src
}
gcc/testsuite/g77.dg/bprob/g77-bprob-1.f deleted 100644 → 0
C Test profile-directed block ordering with various Fortran 77 constructs
C to catch basic regressions in the functionality.
program bprob1
implicit none
integer i,j,k,n
integer result
integer lpall, ieall, gtall
integer lpval, ieval, gtval
lpval = lpall()
ieval = ieall()
gtval = gtall()
if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
call abort
end if
end
C Pass a value through a function to thwart optimization.
integer function foo(i)
implicit none
integer i
foo = i
end
C Test various flavors of GOTO and compare results against expected values.
integer function gtall()
implicit none
integer gt1, gt2, gt3, gt4, gt5
integer gtval
gtall = 1
gtval = 0
gtval = gtval + gt1(0)
gtval = gtval + gt1(1)
if (gtval .ne. 3) then
print *,"gtall part 1: ", gtval, 3
gtall = 0
end if
gtval = 0
gtval = gtval + gt2(3)
gtval = gtval + gt2(30)
if (gtval .ne. 12) then
print *,"gtall part 2: ", gtval, 12
gtall = 0
end if
gtval = 0
gtval = gtval + gt3(0)
gtval = gtval + gt3(3)
if (gtval .ne. 48) then
print *,"gtall part 3: ", gtval, 48
gtall = 0
end if
gtval = 0
gtval = gtval + gt4(1)
gtval = gtval + gt4(2)
gtval = gtval + gt4(3)
if (gtval .ne. 14) then
print *,"gtall part 4: ", gtval, 14
gtall = 0
end if
gtval = 0
gtval = gtval + gt5(0)
gtval = gtval + gt5(-1)
gtval = gtval + gt5(5)
if (gtval .ne. 14) then
print *,"gtall part 5: ", gtval, 14
gtall = 0
end if
end
C Test simple GOTO.
integer function gt1(f)
implicit none
integer f
if (f .ne. 0) goto 100
gt1 = 1
goto 101
100 gt1 = 2
101 continue
end
C Test simple GOTO again, this time out of a DO loop.
integer function gt2(f)
implicit none
integer f
integer i
do i=1,10
if (i .eq. f) goto 100
end do
gt2 = 4
goto 101
100 gt2 = 8
101 continue
end
C Test computed GOTO.
integer function gt3(i)
implicit none
integer i
gt3 = 8
goto (101, 102, 103, 104), i
goto 105
101 gt3 = 1024
goto 105
102 gt3 = 2048
goto 105
103 gt3 = 16
goto 105
104 gt3 = 4096
goto 105
105 gt3 = gt3 * 2
end
C Test assigned GOTO.
integer function gt4(i)
implicit none
integer i
integer label
assign 101 to label
if (i .eq. 2) assign 102 to label
if (i .eq. 3) assign 103 to label
goto label, (101, 102, 103)
101 gt4 = 1
goto 104
102 gt4 = 2
goto 104
103 gt4 = 4
104 gt4 = gt4 * 2
end
C Test arithmetic IF (bundled with the GOTO variants).
integer function gt5(i)
implicit none
integer i
gt5 = 1
if (i) 101, 102, 103
101 gt5 = 2
goto 104
102 gt5 = 4
goto 104
103 gt5 = 8
104 continue
end
C Run all of the loop tests and check results against expected values.
integer function lpall()
implicit none
integer loop1, loop2
integer loopval
lpall = 1
loopval = 0
loopval = loopval + loop1(1,0)
loopval = loopval + loop1(1,2)
loopval = loopval + loop1(1,7)
if (loopval .ne. 12) then
print *,"lpall part 1: ", loopval, 12
lpall = 0
end if
loopval = 0
loopval = loopval + loop2(1,0,0,0)
loopval = loopval + loop2(1,1,0,0)
loopval = loopval + loop2(1,1,3,0)
loopval = loopval + loop2(1,1,3,1)
loopval = loopval + loop2(1,3,1,5)
loopval = loopval + loop2(1,3,7,3)
if (loopval .ne. 87) then
print *,"lpall part 2: ", loopval, 87
lpall = 0
end if
end
C Test a simple DO loop.
integer function loop1(r,n)
implicit none
integer r,n,i
loop1 = r
do i=1,n
loop1 = loop1 + 1
end do
end
C Test nested DO loops.
integer function loop2(r, l, m, n)
implicit none
integer r,l,m,n
integer i,j,k
loop2 = r
do i=1,l
do j=1,m
do k=1,n
loop2 = loop2 + 1
end do
end do
end do
end
C Test various combinations of IF-THEN-ELSE and check results against
C expected values.
integer function ieall()
implicit none
integer ie1, ie2, ie3
integer ieval
ieall = 1
ieval = 0
ieval = ieval + ie1(0,2)
ieval = ieval + ie1(0,0)
ieval = ieval + ie1(1,2)
ieval = ieval + ie1(10,2)
ieval = ieval + ie1(11,11)
if (ieval .ne. 31) then
print *,"ieall part 1: ", ieval, 31
ieall = 0
end if
ieval = 0
ieval = ieval + ie2(0)
ieval = ieval + ie2(2)
ieval = ieval + ie2(2)
ieval = ieval + ie2(2)
ieval = ieval + ie2(3)
ieval = ieval + ie2(3)
if (ieval .ne. 23) then
print *,"ieall part 2: ", ieval, 23
ieall = 0
end if
ieval = 0
ieval = ieval + ie3(11,19)
ieval = ieval + ie3(25,27)
ieval = ieval + ie3(11,22)
ieval = ieval + ie3(11,10)
ieval = ieval + ie3(21,32)
ieval = ieval + ie3(21,20)
ieval = ieval + ie3(1,2)
ieval = ieval + ie3(32,31)
ieval = ieval + ie3(3,0)
ieval = ieval + ie3(0,47)
ieval = ieval + ie3(65,65)
if (ieval .ne. 246) then
print *,"ieall part 3: ", ieval, 246
ieall = 0
end if
end
C Test IF-THEN-ELSE.
integer function ie1(i,j)
implicit none
integer i,j
integer foo
ie1 = 0
if (i .ne. 0) then
if (j .ne. 0) then
ie1 = foo(4)
else
ie1 = foo(1024)
end if
else
if (j .ne. 0) then
ie1 = foo(1)
else
ie1 = foo(2)
end if
end if
if (i .gt. j) then
ie1 = foo(ie1*2)
end if
if (i .gt. 10) then
if (j .gt. 10) then
ie1 = foo(ie1*4)
end if
end if
end
C Test a series of simple IF-THEN statements.
integer function ie2(i)
implicit none
integer i
integer foo
ie2 = 0
if (i .eq. 0) then
ie2 = foo(1)
end if
if (i .eq. 1) then
ie2 = foo(1024)
end if
if (i .eq. 2) then
ie2 = foo(2)
end if
if (i .eq. 3) then
ie2 = foo(8)
end if
if (i .eq. 4) then
ie2 = foo(2048)
end if
end
C Test nested IF statements and IF with compound expressions.
integer function ie3(i,j)
implicit none
integer i,j
integer foo
ie3 = 1
if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then
ie3 = foo(16)
end if
if (i .gt. 20) then
if (j .gt. i) then
if (j .lt. 30) then
ie3 = foo(32)
end if
end if
end if
if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then
ie3 = foo(64)
end if
end
gcc/testsuite/g77.dg/dg.exp deleted 100644 → 0
# Copyright (C) 1997 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 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# GCC testsuite that uses the `dg.exp' driver.
# Load support procs.
load_lib g77-dg.exp
# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
set DEFAULT_FFLAGS " -pedantic-errors"
}
# Initialize `dg'.
dg-init
# Main loop.
g77-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.f]] \
$DEFAULT_FFLAGS
# All done.
dg-finish
gcc/testsuite/g77.dg/f77-edit-apostrophe-out.f deleted 100644 → 0
C Test Fortran 77 apostrophe edit descriptor
C (ANSI X3.9-1978 Section 13.5.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
10 format('abcde')
20 format('and an apostrophe -''-')
30 format('''a leading apostrophe')
40 format('a trailing apostrophe''')
50 format('''and all of the above -''-''')
write(*,10) ! { dg-output "abcde(\n|\r\n|\r)" }
write(*,20) ! { dg-output "and an apostrophe -'-(\n|\r\n|\r)" }
write(*,30) ! { dg-output "'a leading apostrophe(\n|\r\n|\r)" }
write(*,40) ! { dg-output "a trailing apostrophe'(\n|\r\n|\r)" }
write(*,50) ! { dg-output "'and all of the above -'-'(\n|\r\n|\r)" }
C { dg-output "\$" }
end
gcc/testsuite/g77.dg/f77-edit-colon-out.f deleted 100644 → 0
C Test Fortran 77 colon edit descriptor
C (ANSI X3.9-1978 Section 13.5.5)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
write(*,'((3(I1:)))') (I,I=1,5)
end
gcc/testsuite/g77.dg/f77-edit-h-out.f deleted 100644 → 0
C Test Fortran 77 H edit descriptor
C (ANSI X3.9-1978 Section 13.5.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
10 format(1H1)
20 format(6H 6)
write(*,10) ! { dg-output "1(\n|\r\n|\r)" }
write(*,20) ! { dg-output " 6(\n|\r\n|\r)" }
write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\n|\r\n|\r)" }
C { dg-output "\$" }
end
gcc/testsuite/g77.dg/f77-edit-i-in.f deleted 100644 → 0
C Test Fortran 77 I edit descriptor for input
C (ANSI X3.9-1978 Section 13.5.9.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
integer i,j
character*10 buf
write(buf,'(A)') '1 -1'
read(buf,'(I1)') i
if ( i.ne.1 ) call abort()
read(buf,'(X,I1)') i
if ( i.ne.0 ) call abort()
read(buf,'(X,I1,X,I2)') i,j
if ( i.ne.0 .and. j.ne.-1 ) call abort()
end
gcc/testsuite/g77.dg/f77-edit-i-out.f deleted 100644 → 0
C Test Fortran 77 I edit descriptor for output
C (ANSI X3.9-1978 Section 13.5.9.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
write(*,'(I1)') 1 ! { dg-output "1(\n|\r\n|\r)" }
write(*,'(I1)') -1 ! { dg-output "\\*(\n|\r\n|\r)" }
write(*,'(I2)') 2 ! { dg-output " 2(\n|\r\n|\r)" }
write(*,'(I2)') -2 ! { dg-output "-2(\n|\r\n|\r)" }
write(*,'(I3)') 3 ! { dg-output " 3(\n|\r\n|\r)" }
write(*,'(I3)') -3 ! { dg-output " -3(\n|\r\n|\r)" }
write(*,'(I2.0)') 0 ! { dg-output " (\n|\r\n|\r)" }
write(*,'(I1.1)') 4 ! { dg-output "4(\n|\r\n|\r)" }
write(*,'(I1.1)') -4 ! { dg-output "\\*(\n|\r\n|\r)" }
write(*,'(I2.1)') 5 ! { dg-output " 5(\n|\r\n|\r)" }
write(*,'(I2.1)') -5 ! { dg-output "-5(\n|\r\n|\r)" }
write(*,'(I2.2)') 6 ! { dg-output "06(\n|\r\n|\r)" }
write(*,'(I2.2)') -6 ! { dg-output "\\*\\*(\n|\r\n|\r)" }
write(*,'(I3.2)') 7 ! { dg-output " 07(\n|\r\n|\r)" }
write(*,'(I3.2)') -7 ! { dg-output "-07(\n|\r\n|\r)" }
end
gcc/testsuite/g77.dg/f77-edit-s-out.f deleted 100644 → 0
C Test Fortran 77 S, SS and SP edit descriptors
C (ANSI X3.9-1978 Section 13.5.6)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
10 format(SP,I3,1X,SS,I3)
20 format(SP,I3,1X,SS,I3,SP,I3)
30 format(SP,I3,1X,SS,I3,S,I3)
40 format(SP,I3)
50 format(SP,I2)
write(*,10) 10, 20 ! { dg-output "\\+10 20(\n|\r\n|\r)" }
write(*,20) 10, 20, 30 ! { dg-output "\\+10 20\\+30(\n|\r\n|\r)" }
write(*,30) 10, 20, 30 ! { dg-output "\\+10 20 30(\n|\r\n|\r)" }
write(*,40) 0 ! { dg-output " \\+0(\n|\r\n|\r)" }
C 15.5.9 - Note 5: When SP editing is in effect, the plus sign is not optional
write(*,50) 11 ! { dg-output "\\*\\*(\n|\r\n|\r)" }
C { dg-output "\$" }
end
gcc/testsuite/g77.dg/f77-edit-slash-out.f deleted 100644 → 0
C Test Fortran 77 colon slash descriptor
C (ANSI X3.9-1978 Section 13.5.4)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
write(*,'(3(I1)/2(I1))') (I,I=1,5)
end
gcc/testsuite/g77.dg/f77-edit-t-in.f deleted 100644 → 0
C Test Fortran 77 T edit descriptor for input
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
integer i,j
real a,b,c,d,e
character*32 in
in = '1234 8'
read(in,'(T3,I1)') i
if ( i.ne.3 ) call abort()
read(in,'(5X,TL4,I2)') i
if ( i.ne.23 ) call abort()
read(in,'(3X,I1,TR3,I1)') i,j
if ( i.ne.4 ) call abort()
if ( j.ne.8 ) call abort()
in = ' 1.5 -12.62 348.75 1.0E-6'
100 format(F6.0,TL6,I4,1X,I1,8X,I5,F3.0,T10,F5.0,T17,F6.0,TR2,F6.0)
read(in,100) a,i,j,k,b,c,d,e
if ( abs(a-1.5).gt.1.0e-5 ) call abort()
if ( i.ne.1 ) call abort()
if ( j.ne.5 ) call abort()
if ( k.ne.348 ) call abort()
if ( abs(b-0.75).gt.1.0e-5 ) call abort()
if ( abs(c-12.62).gt.1.0e-5 ) call abort()
if ( abs(d-348.75).gt.1.0e-4 ) call abort()
if ( abs(e-1.0e-6).gt.1.0e-11 ) call abort()
end
gcc/testsuite/g77.dg/f77-edit-t-out.f deleted 100644 → 0
C Test Fortran 77 T edit descriptor
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
write(*,'(I4,T8,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
write(*,'(I4,TR3,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
write(*,'(I4,5X,TL2,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
C ( dg-output "\$" }
end
gcc/testsuite/g77.dg/f77-edit-x-out.f deleted 100644 → 0
C Test Fortran 77 X descriptor
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
C Section 13.5.3 explains why there are no trailing blanks
write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
C { dg-output "\$" }
end
gcc/testsuite/g77.dg/fbackslash.f deleted 100644 → 0
C Test compiler flags: -fbackslash
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fbackslash" }
if ( len('A\nB') .ne. 3 ) call abort
end
gcc/testsuite/g77.dg/fcase-preserve.f deleted 100644 → 0
C Test compiler flags: -fcase-preserve
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fcase-preserve" }
i = 3
I = 4
if ( i .ne. 3 ) call abort
end
gcc/testsuite/g77.dg/ff90-1.f deleted 100644 → 0
C Test compiler flags: -ff90
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C Read the g77 manual entry on CMPAMBIG
C
C { dg-do run }
C { dg-options "-ff90" }
double complex z
z = (2.0d0,1.0d0)
call s(real(z))
end
subroutine s(x)
double precision x
if ( abs(x-2.0d0) .gt. 1.0e-5 ) call abort
end
gcc/testsuite/g77.dg/ffixed-form-1.f deleted 100644 → 0
! Test compiler flags: -ffixed-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffixed-form" }
end
gcc/testsuite/g77.dg/ffixed-form-2.f deleted 100644 → 0
! PR fortran/10843
! Origin: Brad Davis <bdavis9659@comcast.net>
!
! { dg-do compile }
! { dg-options "-ffixed-form" }
GO TO 3
GOTO 3
3 CONTINUE
GOTO = 55
GO TO = 55
END
gcc/testsuite/g77.dg/ffixed-line-length-0.f deleted 100644 → 0
C Test compiler flags: -ffixed-line-length-0
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-0" }
C The next line has length 257
en d
gcc/testsuite/g77.dg/ffixed-line-length-132.f deleted 100644 → 0
C Test compiler flags: -ffixed-line-length-132
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-132" }
c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012
en d*
gcc/testsuite/g77.dg/ffixed-line-length-7.f deleted 100644 → 0
C Test compiler flags: -ffixed-line-length-7
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-7" }
e*
$n*
$d*
gcc/testsuite/g77.dg/ffixed-line-length-72.f deleted 100644 → 0
C Test compiler flags: -ffixed-line-length-72
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-72" }
c2345678901234567890123456789012345678901234567890123456789012345678901234567890
en d*
gcc/testsuite/g77.dg/ffixed-line-length-none.f deleted 100644 → 0
C Test compiler flags: -ffixed-line-length-none
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-none" }
C The next line has length 257
en d
gcc/testsuite/g77.dg/ffree-form-1.f deleted 100644 → 0
! Test compiler flags: -ffree-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
end
gcc/testsuite/g77.dg/ffree-form-2.f deleted 100644 → 0
! PR fortran/10843
! Origin: Brad Davis <bdavis9659@comcast.net>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
GO TO 3
GOTO 3
3 CONTINUE
GOTO = 55
END
gcc/testsuite/g77.dg/ffree-form-3.f deleted 100644 → 0
! Test acceptance of keywords in free format
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
integer i, j
i = 1
if ( i .eq. 1 ) then
go = 2
endif
if ( i .eq. 3 ) then
i = 4
end if
do i = 1, 3
j = i
end do
do j = 1, 3
i = j
enddo
end
gcc/testsuite/g77.dg/fno-backslash.f deleted 100644 → 0
C Test compiler flags: -fno-backslash
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-backslash" }
if ( len('A\nB') .ne. 4 ) call abort
end
gcc/testsuite/g77.dg/fno-f90-1.f deleted 100644 → 0
C Test compiler flags: -fno-f90
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C Read the g77 manual entry on CMPAMBIG
C
C { dg-do run }
C { dg-options "-fno-f90 -fugly-complex" }
double complex z
z = (2.0d0,1.0d0)
call s(real(z))
end
subroutine s(x)
real x
if ( abs(x-2.0) .gt. 1.0e-5 ) call abort
end
gcc/testsuite/g77.dg/fno-fixed-form-1.f deleted 100644 → 0
! Test compiler flags: -fno-fixed-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-fno-fixed-form" }
end
gcc/testsuite/g77.dg/fno-onetrip.f deleted 100644 → 0
C Test compiler flags: -fno-onetrip
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-onetrip -w" }
do i = 1, 0
call abort
end do
end
gcc/testsuite/g77.dg/fno-typeless-boz.f deleted 100644 → 0
C Test compiler flags: -fno-typeless-boz
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-typeless-boz" }
equivalence (i,r)
r = Z'ABCD1234'
j = Z'ABCD1234'
if ( j .eq. i ) call abort
end
gcc/testsuite/g77.dg/fno-underscoring.f deleted 100644 → 0
C Test compiler flags: -fno-underscoring
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-fno-underscoring" }
call aaabbbccc
end
C { dg-final { scan-assembler-not "aaabbbccc_" } }
gcc/testsuite/g77.dg/fno-vxt-1.f deleted 100644 → 0
C Test compiler flags: -fno-vxt
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-vxt" }
i = 0
!1
if ( i .ne. 0 ) call exit
call abort
END
gcc/testsuite/g77.dg/fonetrip.f deleted 100644 → 0
C Test compiler flags: -fonetrip
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fonetrip -w" }
do i = 1, 0
call exit
end do
call abort
end
gcc/testsuite/g77.dg/ftypeless-boz.f deleted 100644 → 0
C Test compiler flags: -ftypeless-boz
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-ftypeless-boz" }
equivalence (i,r)
r = Z'ABCD1234'
j = Z'ABCD1234'
if ( j .ne. i ) call abort
end
gcc/testsuite/g77.dg/fugly-assumed.f deleted 100644 → 0
C Test compiler flags: -fugly-assumed
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-fugly-assumed" }
function f(i)
integer i(1)
f = i(1)+i(2)
end
gcc/testsuite/g77.dg/funderscoring.f deleted 100644 → 0
C Test compiler flags: -funderscoring
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-funderscoring" }
call aaabbbccc
end
C { dg-final { scan-assembler "aaabbbccc_" } }
gcc/testsuite/g77.dg/fvxt-1.f deleted 100644 → 0
C Test compiler flags: -fvxt
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fvxt" }
i = 0
!1
if ( i .eq. 0 ) call exit
call abort
END
gcc/testsuite/g77.dg/gcov/gcov-1.f deleted 100644 → 0
C { dg-options "-fprofile-arcs -ftest-coverage" }
C { dg-do run { target native } }
C
C Test gcov reports for line counts and branch and call return percentages
C for various Fortran 77 constructs to catch basic regressions in the
C functionality.
program gcov1
implicit none
integer i,j,k,n
integer result
integer lpall, ieall, gtall
integer lpval, ieval, gtval
! returns(100)
lpval = lpall() ! count(1)
! returns(100)
ieval = ieall() ! count(1)
! returns(100)
gtval = gtall() ! count(1)
! returns(end)
if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
call abort
end if
end
C Pass a value through a function to thwart optimization.
integer function foo(i)
implicit none
integer i
foo = i ! count(18)
end
C Test various flavors of GOTO and compare results against expected values.
integer function gtall()
implicit none
integer gt1, gt2, gt3, gt4, gt5
integer gtval
gtall = 1 ! count(1)
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt1(0) ! count(1)
! returns(100)
gtval = gtval + gt1(1) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 3) then ! count(1)
! branch(end)
print *,"gtall part 1: ", gtval, 3
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt2(9) ! count(1)
! returns(100)
gtval = gtval + gt2(20) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 12) then ! count(1)
! branch(end)
print *,"gtall part 2: ", gtval, 12
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt3(0) ! count(1)
! returns(100)
gtval = gtval + gt3(3) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 48) then ! count(1)
! branch(end)
! branch(end)
print *,"gtall part 3: ", gtval, 48
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt4(1) ! count(1)
! returns(100)
gtval = gtval + gt4(2) ! count(1)
! returns(100)
gtval = gtval + gt4(3) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 14) then ! count(1)
! branch(end)
print *,"gtall part 4: ", gtval, 14
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt5(0) ! count(1)
! returns(100)
gtval = gtval + gt5(-1) ! count(1)
! returns(100)
gtval = gtval + gt5(5) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 14) then ! count(1)
! branch(end)
print *,"gtall part 5: ", gtval, 14
gtall = 0
end if
end
C Test simple GOTO.
integer function gt1(f)
implicit none
integer f
! branch(50)
if (f .ne. 0) goto 100 ! count(2)
! branch(end)
gt1 = 1 ! count(1)
goto 101 ! count(1)
100 gt1 = 2 ! count(1)
101 continue ! count(2)
end
C Test simple GOTO again, this time out of a DO loop.
integer function gt2(f)
implicit none
integer f
integer i
! branch(95)
do i=1,10
! branch(end)
if (i .eq. f) goto 100 ! count(19)
end do
gt2 = 4 ! count(1)
goto 101 ! count(1)
100 gt2 = 8 ! count(1)
101 continue ! count(2)
end
C Test computed GOTO.
integer function gt3(i)
implicit none
integer i
goto (101, 102, 103, 104), i ! count(2)
gt3 = 8 ! count(1)
goto 105 ! count(1)
101 gt3 = 1024
goto 105
102 gt3 = 2048
goto 105
103 gt3 = 16 ! count(1)
goto 105 ! count(1)
104 gt3 = 4096
goto 105
105 gt3 = gt3 * 2 ! count(2)
end
C Test assigned GOTO.
integer function gt4(i)
implicit none
integer i
integer label
assign 101 to label ! count(3)
if (i .eq. 2) assign 102 to label ! count(3)
if (i .eq. 3) assign 103 to label ! count(3)
goto label, (101, 102, 103) ! count(3)
101 gt4 = 1 ! count(1)
goto 104 ! count(1)
102 gt4 = 2 ! count(1)
goto 104 ! count(1)
103 gt4 = 4 ! count(1)
104 gt4 = gt4 * 2 ! count(3)
end
C Test arithmetic IF (bundled with the GOTO variants).
integer function gt5(i)
implicit none
integer i
gt5 = 1 ! count(3)
! branch(67 50)
if (i) 101, 102, 103 ! count(3)
! branch(end)
101 gt5 = 2 ! count(1)
goto 104 ! count(1)
102 gt5 = 4 ! count(1)
goto 104 ! count(1)
103 gt5 = 8 ! count(1)
104 continue ! count(3)
end
C Run all of the loop tests and check results against expected values.
integer function lpall()
implicit none
integer loop1, loop2
integer loopval
lpall = 1 ! count(1)
loopval = 0 ! count(1)
! returns(100)
loopval = loopval + loop1(1,0) ! count(1)
! returns(100)
loopval = loopval + loop1(1,2) ! count(1)
! returns(100)
loopval = loopval + loop1(1,7) ! count(1)
! returns(end)
if (loopval .ne. 12) then ! count(1)
print *,"lpall part 1: ", loopval, 12
lpall = 0
end if
loopval = 0 ! count(1)
! returns(100)
loopval = loopval + loop2(1,0,0,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,0,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,3,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,3,1) ! count(1)
! returns(100)
loopval = loopval + loop2(1,3,1,5) ! count(1)
! returns(100)
loopval = loopval + loop2(1,3,7,3) ! count(1)
! returns(end)
if (loopval .ne. 87) then ! count(1)
print *,"lpall part 2: ", loopval, 87
lpall = 0
end if
end
C Test a simple DO loop.
integer function loop1(r,n)
implicit none
integer r,n,i
loop1 = r ! count(3)
! branch(75)
do i=1,n
! branch(end)
loop1 = loop1 + 1 ! count(9)
end do
end
C Test nested DO loops.
integer function loop2(r, l, m, n)
implicit none
integer r,l,m,n
integer i,j,k
loop2 = r ! count(6)
! branch(60)
do i=1,l
! branch(77)
do j=1,m
! branch(73)
do k=1,n
! branch(end)
loop2 = loop2 + 1 ! count(81)
end do
end do
end do
end
C Test various combinations of IF-THEN-ELSE and check results against
C expected values.
integer function ieall()
implicit none
integer ie1, ie2, ie3
integer ieval
ieall = 1 ! count(1)
ieval = 0 ! count(1)
ieval = ieval + ie1(0,2) ! count(1)
ieval = ieval + ie1(0,0) ! count(1)
ieval = ieval + ie1(1,2) ! count(1)
ieval = ieval + ie1(10,2) ! count(1)
ieval = ieval + ie1(11,11) ! count(1)
if (ieval .ne. 31) then ! count(1)
print *,"ieall part 1: ", ieval, 31
ieall = 0
end if
ieval = 0
ieval = ieval + ie2(0) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(3) ! count(1)
ieval = ieval + ie2(3) ! count(1)
if (ieval .ne. 23) then ! count(1)
print *,"ieall part 2: ", ieval, 23
ieall = 0
end if
ieval = 0
ieval = ieval + ie3(11,19) ! count(1)
ieval = ieval + ie3(25,27) ! count(1)
ieval = ieval + ie3(11,22) ! count(1)
ieval = ieval + ie3(11,10) ! count(1)
ieval = ieval + ie3(21,32) ! count(1)
ieval = ieval + ie3(21,20) ! count(1)
ieval = ieval + ie3(1,2) ! count(1)
ieval = ieval + ie3(32,31) ! count(1)
ieval = ieval + ie3(3,0) ! count(1)
ieval = ieval + ie3(0,47) ! count(1)
ieval = ieval + ie3(65,65) ! count(1)
if (ieval .ne. 246) then ! count(1)
print *,"ieall part 3: ", ieval, 246
ieall = 0
end if
end
C Test IF-THEN-ELSE.
integer function ie1(i,j)
implicit none
integer i,j
integer foo
ie1 = 0 ! count(5)
! branch(40)
if (i .ne. 0) then ! count(5)
! branch(0)
if (j .ne. 0) then ! count(3)
! branch(end)
ie1 = foo(4) ! count(3)
else
ie1 = foo(1024)
end if
else
! branch(50)
if (j .ne. 0) then ! count(2)
! branch(end)
ie1 = foo(1) ! count(1)
else
ie1 = foo(2) ! count(1)
end if
end if
! branch(80)
if (i .gt. j) then ! count(5)
! branch(end)
ie1 = foo(ie1*2)
end if
! branch(80)
if (i .gt. 10) then ! count(5)
! branch(0)
if (j .gt. 10) then ! count(1)
! branch(end)
ie1 = foo(ie1*4) ! count(1)
end if
end if
end
C Test a series of simple IF-THEN statements.
integer function ie2(i)
implicit none
integer i
integer foo
ie2 = 0 ! count(6)
! branch(83)
if (i .eq. 0) then ! count(6)
! branch(end)
ie2 = foo(1) ! count(1)
end if
! branch(100)
if (i .eq. 1) then ! count(6)
! branch(end)
ie2 = foo(1024)
end if
! branch(50)
if (i .eq. 2) then ! count(6)
! branch(end)
ie2 = foo(2) ! count(3)
end if
! branch(67)
if (i .eq. 3) then ! count(6)
! branch(end)
ie2 = foo(8) ! count(2)
end if
! branch(100)
if (i .eq. 4) then ! count(6)
! branch(end)
ie2 = foo(2048)
end if
end
C Test nested IF statements and IF with compound expressions.
integer function ie3(i,j)
implicit none
integer i,j
integer foo
ie3 = 1 ! count(11)
! branch(27 50 75)
if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then ! count(11)
! branch(end)
ie3 = foo(16) ! count(1)
end if
! branch(55)
if (i .gt. 20) then ! count(11)
! branch(60)
if (j .gt. i) then ! count(5)
! branch(50)
if (j .lt. 30) then ! count(2)
! branch(end)
ie3 = foo(32) ! count(1)
end if
end if
end if
! branch(9 10 11)
if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then ! count(11)
! branch(end)
ie3 = foo(64) ! count(3)
end if
end
C
C { dg-final { run-gcov branches calls { -b gcov-1.f } } }
gcc/testsuite/g77.dg/gcov/gcov.exp deleted 100644 → 0
# Copyright (C) 1997, 2001 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 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Gcov test driver.
# Load support procs.
load_lib g77-dg.exp
load_lib gcov.exp
global G77_UNDER_TEST
# For now find gcov in the same directory as $G77_UNDER_TEST.
if { ![is_remote host] && [string match "*/*" [lindex $G77_UNDER_TEST 0]] } {
set GCOV [file dirname [lindex $G77_UNDER_TEST 0]]/gcov
} else {
set GCOV gcov
}
# Initialize harness.
dg-init
# Delete old .da files.
set files [glob -nocomplain gcov-*.da];
if { $files != "" } {
eval "remote_file build delete $files";
}
# Main loop.
dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/gcov-*.f]] "" ""
dg-finish
gcc/testsuite/g77.dg/pr3743-1.f deleted 100644 → 0
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
integer i
i = bit_size(i)
end
gcc/testsuite/g77.dg/pr3743-2.f deleted 100644 → 0
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
C { dg-options "-fcase-preserve -fintrin-case-upper" }
integer i
i = BIT_SIZE(i)
end
gcc/testsuite/g77.dg/pr3743-3.f deleted 100644 → 0
c Test case for PR fortran/3743
c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
c
c { dg-do link }
c { dg-options "-fcase-preserve -fintrin-case-lower" }
integer i
i = bit_size(i)
end
gcc/testsuite/g77.dg/pr3743-4.f deleted 100644 → 0
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
C { dg-options "-fcase-preserve -fintrin-case-initcap" }
integer i
i = Bit_Size(i)
end
gcc/testsuite/g77.dg/pr5473.f deleted 100644 → 0
program pr5473
c Derived from g77.f-torture/execute/intrinsic-unix-bessel.f
c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
c { dg-do compile }
real x, a
double precision dx, da
integer*8 m
x = 2.0
dx = x
m = 2
a = BESJN(m,x) ! { dg-error "incorrect type" "incorrect type" }
a = BESYN(m,x) ! { dg-error "incorrect type" "incorrect type" }
da = DBESJN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
da = DBESYN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
end
gcc/testsuite/g77.dg/pr9258.f deleted 100644 → 0
C Test case for PR/9258
C Origin: kmccarty@princeton.edu
C
C { dg-do compile }
SUBROUTINE FOO (B)
10 CALL BAR (A)
ASSIGN 20 TO M
IF (100.LT.A) GOTO 10
GOTO 40
C
20 IF (B.LT.ABS(A)) GOTO 10
ASSIGN 30 TO M
GOTO 40
C
30 ASSIGN 10 TO M
40 GOTO M,(10,20,30)
END
gcc/testsuite/g77.dg/strlen0.f deleted 100644 → 0
C Substring range checking test program, to check behavior with respect
C to X3J3/90.4 paragraph 5.7.1.
C
C Patches relax substring checking for subscript expressions in order to
C simplify coding (elimination of length checks for strings passed as
C parameters) and to avoid contradictory behavior of subscripted substring
C expressions with respect to unsubscripted string expressions.
C
C Key part of 5.7.1 interpretation comes down to statement that in the
C substring expression,
C v ( e1 : e2 )
C 1 <= e1 <= e2 <= len to be valid, yet the expression
C v ( : )
C is equivalent to
C v(1:len(v))
C
C meaning that any statement that reads
C str = v // 'tail'
C (where v is a string passed as a parameter) would require coding as
C if (len(v) .gt. 0) then
C str = v // 'tail'
C else
C str = 'tail'
C endif
C to comply with the standard specification. Under the stricter
C interpretation, functions strcat and strlat would be incorrect as
C written for null values of str1 and/or str2.
C
C This code compiles and runs without error on
C SunOS 4.1.3 f77 (-C option)
C SUNWspro SPARCcompiler 4.2 f77 (-C option)
C (and with proposed patches, gcc-2.9.2 -fbounds-check except for test 6,
C which is a genuine, deliberate error - comment out to make further
C tests)
C
C { dg-do run }
C { dg-options "-fbounds-check" }
C
C G. Helffrich/Tokyo Inst. Technology Jul 24 2001
character str*8,strres*16,strfun*16,strcat*16,strlat*16
str='Hi there'
C Test 1 - (current+patched) two char substring result
strres=strfun(str,1,2)
write(*,*) 'strres is ',strres
C Test 2 - (current+patched) null string result
strres=strfun(str,5,4)
write(*,*) 'strres is ',strres
C Test 3 - (current+patched) null string result
strres=strfun(str,8,7)
write(*,*) 'strres is ',strres
C Test 4 - (current) error; (patched) null string result
strres=strfun(str,9,8)
write(*,*) 'strres is ',strres
C Test 5 - (current) error; (patched) null string result
strres=strfun(str,1,0)
write(*,*) 'strres is ',strres
C Test 6 - (current+patched) error
C strres=strfun(str,20,20)
C write(*,*) 'strres is ',strres
C Test 7 - (current+patched) str result
strres=strcat(str,'')
write(*,*) 'strres is ',strres
C Test 8 - (current) error; (patched) str result
strres=strlat('',str)
write(*,*) 'strres is ',strres
end
character*(*) function strfun(str,i,j)
character str*(*)
strfun = str(i:j)
end
character*(*) function strcat(str1,str2)
character str1*(*), str2*(*)
strcat = str1 // str2
end
character*(*) function strlat(str1,str2)
character str1*(*), str2*(*)
strlat = str1(1:len(str1)) // str2(1:len(str2))
end
gcc/testsuite/g77.f-torture/compile/12002.f deleted 100644 → 0
C PR middle-end/12002
COMPLEX TE1
TE1=-2.
TE1=TE1+TE1
END
gcc/testsuite/g77.f-torture/compile/13060.f deleted 100644 → 0
subroutine geo2()
implicit none
integer ms,n,ne(2)
ne(1) = 1
ne(2) = 2
ms = 1
call call_me(ne(1)*ne(1))
n = ne(ms)
end
gcc/testsuite/g77.f-torture/compile/19990218-0.f deleted 100644 → 0
program test
double precision a,b,c
data a,b/1.0d-46,1.0d0/
c=fun(a,b)
print*,'in main: fun=',c
end
double precision function fun(a,b)
double precision a,b
print*,'in sub: a,b=',a,b
fun=a*b
print*,'in sub: fun=',fun
return
end
gcc/testsuite/g77.f-torture/compile/19990305-0.f deleted 100644 → 0
* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST)
* From: Denes Molnar <molnard@phys.columbia.edu>
* To: fortran@gnu.org
* Subject: f771 gets fatal signal 6
* Content-Type: TEXT/PLAIN; charset=US-ASCII
* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f
*
* Hi,
*
*
* Comiling object from the source code below WORKS FINE with
* 'g77 -o hwuci2 -c hwuci2.F'
* but FAILS with fatal signal 6
* 'g77 -o hwuci2 -O -c hwuci2.F'
*
* Any explanations?
*
* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1).
*
*
* Denes Molnar
*
* %%%%%%%%%%%%%%%%%%%%%%%%%
* %the source:
* %%%%%%%%%%%%%%%%%%%%%%%%%
*
CDECK ID>, HWUCI2.
*CMZ :- -23/08/94 13.22.29 by Mike Seymour
*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
FUNCTION HWUCI2(A,B,Y0)
C-----------------------------------------------------------------------
C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
C-----------------------------------------------------------------------
IMPLICIT NONE
DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
EXTERNAL HWULI2
COMMON/SMALL/EPSI
PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
IF(B.EQ.ZERO)THEN
HWUCI2=CMPLX(ZERO,ZERO)
ELSE
Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
Y2=ONE-Y1
Z1=Y0/(Y0-Y1)
Z2=(Y0-ONE)/(Y0-Y1)
Z3=Y0/(Y0-Y2)
Z4=(Y0-ONE)/(Y0-Y2)
HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
ENDIF
RETURN
END
*
* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
gcc/testsuite/g77.f-torture/compile/19990419-0.f deleted 100644 → 0
* Test case Toon submitted, cut down to expose the one bug.
* Belongs in compile/.
SUBROUTINE INIERS1
IMPLICIT LOGICAL(L)
COMMON/COMIOD/ NHIERS1, LERS1
inquire(nhiers1, exist=lers1)
END
gcc/testsuite/g77.f-torture/compile/19990502-0.f deleted 100644 → 0
* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
* Precedence: bulk
* Sender: owner-egcs-bugs@egcs.cygnus.com
* From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de>
* Subject: egcs g77 19990524pre Internal compiler error in `print_operand'
* To: egcs-bugs@egcs.cygnus.com
* Date: Mon, 31 May 1999 11:46:52 +0200 (CET)
* Content-Type: text/plain; charset=US-ASCII
* X-UIDL: 9a00095a5fe4d774b7223de071157374
*
* Hi,
*
* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524
* on an i686-pc-linux-gnu. The program below gives an internal compiler error.
*
*
* Script started on Mon May 31 11:30:01 1999
* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f
* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515)
* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs
* gcc version gcc-2.95 19990524 (prerelease)
* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s
* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease).
* GNU Fortran Front End version 0.5.24-19990515
* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405
* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'.
* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for details.
* lx{g010}:/tmp>cat e3.f
SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 )
DOUBLE PRECISION SMALL2, TOL2
DOUBLE PRECISION EE( * ), QQ( * )
INTEGER ICONV, N, OFF
DOUBLE PRECISION QEMAX, XINF
EXTERNAL DLASQ3
INTRINSIC MAX, SQRT
XINF = 0.0D0
ICONV = 0
IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
END IF
IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
$ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN
QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
END IF
IF( N.EQ.0 ) THEN
IF( OFF.EQ.0 ) THEN
RETURN
ELSE
XINF =0.0D0
END IF
ELSE IF( N.EQ.2 ) THEN
END IF
CALL DLASQ3(ICONV)
END
* lx{g010}:/tmp>exit
*
* Script done on Mon May 31 11:30:23 1999
*
* Best regards,
*
* Norbert.
* --
* Norbert Conrad phone: ++49 641 9913021
* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de
* Heinrich-Buff-Ring 44
* 35392 Giessen
* Germany
gcc/testsuite/g77.f-torture/compile/19990502-1.f deleted 100644 → 0
SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY)
INTEGER*2 IGAMS(2,NADC)
in = 1
do while (in.le.nadc.and.IGAMS(2,in).le.in)
enddo
END
gcc/testsuite/g77.f-torture/compile/19990525-0.f deleted 100644 → 0
* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
* Precedence: bulk
* Sender: owner-egcs-bugs@egcs.cygnus.com
* From: "Bjorn R. Bjornsson" <brb@halo.hi.is>
* Subject: g77 char expr. as arg to subroutine bug
* To: egcs-bugs@egcs.cygnus.com
* Date: Tue, 25 May 1999 14:45:56 +0000 (GMT)
* Content-Type: text/plain; charset=US-ASCII
* X-UIDL: 06000c94269ed6dfe826493e52a818b9
*
* The following bug is in all snapshots starting
* from April 18. I have only tested this on Alpha linux,
* and with FFECOM_FASTER_ARRAY_REFS set to 1.
*
* Run the following through g77:
*
subroutine a
character*2 string1
character*2 string2
character*4 string3
string1 = 's1'
string2 = 's2'
c
c the next 2 lines are ok.
string3 = (string1 // string2)
call b(string1//string2)
c
c this line gives gcc/f/com.c:10660: failed assertion `hook'
call b((string1//string2))
end
*
* the output from:
*
* /usr/local/egcs-19990418/bin/g77 --verbose -c D.f
*
* is:
*
* on egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (from FSF-g77 version 0.5.24-19990418)
* Reading specs from /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/specs
* gcc version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental)
* /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/f771 D.f -quiet -dumpbase D.f -version -fversion -o /tmp/ccNpaaaa.s
* GNU F77 version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (alphaev56-unknown-linux-gnu) compiled by GNU C version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental).
* GNU Fortran Front End version 0.5.24-19990418
* ../../../egcs-19990418/gcc/f/com.c:10351: failed assertion `hook'
* g77: Internal compiler error: program f771 got fatal signal 6
*
* Yours,
*
* Bjorn R. Bjornsson
* brb@halo.hi.is
gcc/testsuite/g77.f-torture/compile/19990826-1.f deleted 100644 → 0
* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST)
* From: Jonathan Ravens <ravens@whio.gns.cri.nz>
* To: gcc-bugs@gcc.gnu.org
* Subject: g77 bug report
* X-UIDL: a0bf5ecc21487cde48d9104983ab04d6
! This fortran source will not compile - if the penultimate elseif block is 0
! included then the message appears :
!
! /usr/src/egcs//gcc-2.95.1/gcc/f/stw.c:308: failed assertion `b->uses_ > 0'
! g77: Internal compiler error: program f771 got fatal signal 6
!
! The command was : g77 -c <prog.f>
!
! The OS is Red Hat 6, and the output from uname -a is
! Linux grfw1452.gns.cri.nz 2.2.5-15 #1 Mon Apr 19 23:00:46 EDT 1999 i686 unknown
!
! The configure script I used was
! /usr/src/egcs/gcc/gcc-2.95.1/configure --enable-languages=f77 i585-unknown-linux
!
! I was installing 2.95 because under EGCS 2.1.1 none of my code was working
! with optimisation turned on, and there were still bugs with no optimisation
! (all of which code works fine under g77 0.5.21 and Sun/IBM/Dec/HP fortrans).
!
! The version of g77 is :
!
!g77 version 2.95.1 19990816 (release) (from FSF-g77 version 0.5.25 19990816 (release))
program main
if (i.eq.1) then
call abc(1)
else if (i.eq. 1) then
call abc( 1)
else if (i.eq. 2) then
call abc( 2)
else if (i.eq. 3) then
call abc( 3)
else if (i.eq. 4) then
call abc( 4)
else if (i.eq. 5) then
call abc( 5)
else if (i.eq. 6) then
call abc( 6)
else if (i.eq. 7) then
call abc( 7)
else if (i.eq. 8) then
call abc( 8)
else if (i.eq. 9) then
call abc( 9)
else if (i.eq. 10) then
call abc( 10)
else if (i.eq. 11) then
call abc( 11)
else if (i.eq. 12) then
call abc( 12)
else if (i.eq. 13) then
call abc( 13)
else if (i.eq. 14) then
call abc( 14)
else if (i.eq. 15) then
call abc( 15)
else if (i.eq. 16) then
call abc( 16)
else if (i.eq. 17) then
call abc( 17)
else if (i.eq. 18) then
call abc( 18)
else if (i.eq. 19) then
call abc( 19)
else if (i.eq. 20) then
call abc( 20)
else if (i.eq. 21) then
call abc( 21)
else if (i.eq. 22) then
call abc( 22)
else if (i.eq. 23) then
call abc( 23)
else if (i.eq. 24) then
call abc( 24)
else if (i.eq. 25) then
call abc( 25)
else if (i.eq. 26) then
call abc( 26)
else if (i.eq. 27) then
call abc( 27)
else if (i.eq. 28) then
call abc( 28)
else if (i.eq. 29) then
call abc( 29)
else if (i.eq. 30) then
call abc( 30)
else if (i.eq. 31) then
call abc( 31)
else if (i.eq. 32) then
call abc( 32)
else if (i.eq. 33) then
call abc( 33)
else if (i.eq. 34) then
call abc( 34)
else if (i.eq. 35) then
call abc( 35)
else if (i.eq. 36) then
call abc( 36)
else if (i.eq. 37) then
call abc( 37)
else if (i.eq. 38) then
call abc( 38)
else if (i.eq. 39) then
call abc( 39)
else if (i.eq. 40) then
call abc( 40)
else if (i.eq. 41) then
call abc( 41)
else if (i.eq. 42) then
call abc( 42)
else if (i.eq. 43) then
call abc( 43)
else if (i.eq. 44) then
call abc( 44)
else if (i.eq. 45) then
call abc( 45)
else if (i.eq. 46) then
call abc( 46)
else if (i.eq. 47) then
call abc( 47)
else if (i.eq. 48) then
call abc( 48)
else if (i.eq. 49) then
call abc( 49)
else if (i.eq. 50) then
call abc( 50)
else if (i.eq. 51) then
call abc( 51)
else if (i.eq. 52) then
call abc( 52)
else if (i.eq. 53) then
call abc( 53)
else if (i.eq. 54) then
call abc( 54)
else if (i.eq. 55) then
call abc( 55)
else if (i.eq. 56) then
call abc( 56)
else if (i.eq. 57) then
call abc( 57)
else if (i.eq. 58) then
call abc( 58)
else if (i.eq. 59) then
call abc( 59)
else if (i.eq. 60) then
call abc( 60)
else if (i.eq. 61) then
call abc( 61)
else if (i.eq. 62) then
call abc( 62)
else if (i.eq. 63) then
call abc( 63)
else if (i.eq. 64) then
call abc( 64)
else if (i.eq. 65) then
call abc( 65)
else if (i.eq. 66) then
call abc( 66)
else if (i.eq. 67) then
call abc( 67)
else if (i.eq. 68) then
call abc( 68)
else if (i.eq. 69) then
call abc( 69)
else if (i.eq. 70) then
call abc( 70)
else if (i.eq. 71) then
call abc( 71)
else if (i.eq. 72) then
call abc( 72)
else if (i.eq. 73) then
call abc( 73)
else if (i.eq. 74) then
call abc( 74)
else if (i.eq. 75) then
call abc( 75)
else if (i.eq. 76) then
call abc( 76)
else if (i.eq. 77) then
call abc( 77)
else if (i.eq. 78) then
call abc( 78)
else if (i.eq. 79) then
call abc( 79)
else if (i.eq. 80) then
call abc( 80)
else if (i.eq. 81) then
call abc( 81)
else if (i.eq. 82) then
call abc( 82)
else if (i.eq. 83) then
call abc( 83)
else if (i.eq. 84) then
call abc( 84)
else if (i.eq. 85) then
call abc( 85)
else if (i.eq. 86) then
call abc( 86)
else if (i.eq. 87) then
call abc( 87)
else if (i.eq. 88) then
call abc( 88)
else if (i.eq. 89) then
call abc( 89)
else if (i.eq. 90) then
call abc( 90)
else if (i.eq. 91) then
call abc( 91)
else if (i.eq. 92) then
call abc( 92)
else if (i.eq. 93) then
call abc( 93)
else if (i.eq. 94) then
call abc( 94)
else if (i.eq. 95) then
call abc( 95)
else if (i.eq. 96) then
call abc( 96)
else if (i.eq. 97) then
call abc( 97)
else if (i.eq. 98) then
call abc( 98)
else if (i.eq. 99) then
call abc( 99)
else if (i.eq. 100) then
call abc( 100)
else if (i.eq. 101) then
call abc( 101)
else if (i.eq. 102) then
call abc( 102)
else if (i.eq. 103) then
call abc( 103)
else if (i.eq. 104) then
call abc( 104)
else if (i.eq. 105) then
call abc( 105)
else if (i.eq. 106) then
call abc( 106)
else if (i.eq. 107) then
call abc( 107)
else if (i.eq. 108) then
call abc( 108)
else if (i.eq. 109) then
call abc( 109)
else if (i.eq. 110) then
call abc( 110)
else if (i.eq. 111) then
call abc( 111)
else if (i.eq. 112) then
call abc( 112)
else if (i.eq. 113) then
call abc( 113)
else if (i.eq. 114) then
call abc( 114)
else if (i.eq. 115) then
call abc( 115)
else if (i.eq. 116) then
call abc( 116)
else if (i.eq. 117) then
call abc( 117)
else if (i.eq. 118) then
call abc( 118)
else if (i.eq. 119) then
call abc( 119)
else if (i.eq. 120) then
call abc( 120)
else if (i.eq. 121) then
call abc( 121)
else if (i.eq. 122) then
call abc( 122)
else if (i.eq. 123) then
call abc( 123)
else if (i.eq. 124) then
call abc( 124)
else if (i.eq. 125) then !< Miscompiles if present
call abc( 125) !<
c else if (i.eq. 126) then
c call abc( 126)
endif
end
gcc/testsuite/g77.f-torture/compile/19990826-3.f deleted 100644 → 0
* Date: Thu, 19 Aug 1999 10:02:32 +0200
* From: Frederic Devernay <devernay@istar.fr>
* Organization: ISTAR
* X-Accept-Language: French, fr, en
* To: gcc-bugs@gcc.gnu.org
* Subject: g77 2.95 bug (Internal compiler error in `final_scan_insn')
* X-UIDL: 08443f5c374ffa382a05573281482f4f
* Here's a bug that happens only when I compile with -O (disappears with
* -O2)
* > g77 -v --save-temps -O -c pcapop.f
* g77 version 2.95 19990728 (release) (from FSF-g77 version 0.5.25
* 19990728 (release))
* Reading specs from
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/specs
* gcc version 2.95 19990728 (release)
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/f771 pcapop.f -quiet
* -dumpbase pcapop.f -O -version -fversion -o pcapop.s
* GNU F77 version 2.95 19990728 (release) (sparc-sun-solaris2.6) compiled
* by GNU C version 2.95 19990728 (release).
* GNU Fortran Front End version 0.5.25 19990728 (release)
* pcapop.f: In subroutine `pcapop':
* pcapop.f:291: Internal compiler error in `final_scan_insn', at
* final.c:2920
* Please submit a full bug report.
* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for instructions.
C* PCAPOP
SUBROUTINE PCAPOP(M1,M2,L1,L2,NMEM,N1,N2,IB,IBB,K3,TF,TS,TC,TTO)
DIMENSION NVA(6),C(6),I(6)
C
C CALCUL DES PARAMETRES OPTIMAUX N1 N2 IB IBB
C
TACC=.035
TTRANS=.000004
RAD=.000001
RMI=.000001
RMU=.0000015
RDI=.000003
RTE=.000003
REQ=.000005
VY1=3*RTE+RDI+8*REQ+3*(RAD+RMI+RMU)
VY2=REQ+2*RAD
AR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ))
C VARIATION DE L1,L2,
C
TTOTOP=1.E+10
N1CO=0
N2CO=0
IBCO=0
IBBCO=0
K3CO=0
TESOP=0.
TCOP=0.
TFOP=0.
INUN=7
INDE=7
IF(M1.LT.128)INUN=6
IF(M1.LT.64)INUN=5
IF(M1.LT.32)INUN=4
IF(M2.LT.128)INDE=6
IF(M2.LT.64)INDE=5
IF(M2.LT.32)INDE=4
DO 3 NUN =3,INUN
DO 3 NDE=3,INDE
N10=2**NUN
N20=2**NDE
NDIF=(N10-N20)
NDIF=IABS(NDIF)
C POUR AVOIR CES RESULTATS FAIRE TOURNER LE PROGRAMME VEFFT1
TCFFTU=0.
IF(N10.EQ.128.AND.N20.EQ.128)TCFFTU=3.35
IF(N10.EQ.64.AND.N20.EQ.64)TCFFTU=.70
IF(N10.EQ.32.AND.N20.EQ.32)TCFFTU=.138
IF(N10.EQ.16.AND.N20.EQ.16)TCFFTU=.0332
IF(N10.EQ.8.AND.N20.EQ.8)TCFFTU=.00688
IF(NDIF.EQ.64)TCFFTU=1.566
IF(NDIF.EQ.96)TCFFTU=.709
IF(NDIF.EQ.112)TCFFTU=.349
IF(NDIF.EQ.120)TCFFTU=.160
IF(NDIF.EQ.32)TCFFTU=.315
IF(NDIF.EQ.48)TCFFTU=.154
IF(NDIF.EQ.56)TCFFTU=.07
IF(NDIF.EQ.16)TCFFTU=.067
IF(NDIF.EQ.24)TCFFTU=.030
IF(NDIF.EQ.8)TCFFTU=.016
N30=N10-L1+1
N40=N20-L2+1
WW=VY1+N30*VY2
NDOU=2*N10*N20
IF((N10.LT.L1).OR.(N20.LT.L2)) GOTO 3
NB=NMEM-NDOU-N20*(L1-1)
NVC=2*N10*(N20-1)+M1
IF(NB.LT.(NVC)) GOTO 3
CALL VALENT(M1,N30,K1)
CALL VALENT(M2,N40,K2)
IS=K1/2
IF((2*IS).NE.K1)K1=K1+1
TFF=TCFFTU*K1*K2
CALL VALENT(M2,N40,JOFI)
IF(NB.GE.(K1*N20*N30+2*N20*(L1-1))) GOTO 4
TIOOP=1.E+10
IC=1
18 IB1=2*IC
MAX=(NB-2*N20*(L1-1))/(N20*N30)
IN=MAX/2
IF(MAX.NE.2*IN) MAX=MAX-1
K3=K1/IB1
IBB1=K1-K3*IB1
IOFI=M1/(IB1*N30)
IRZ=0
IF(IOFI*IB1*N30.EQ.M1) GOTO1234
IRZ=1
IOFI=IOFI+1
IF(IBB1.EQ.0) GOTO 1234
IF(M1.EQ.((IOFI-1)*IB1*N30+IBB1*N30)) GOTO 1233
IRZ=2
GOTO 1234
1233 IRZ=3
1234 IBX1=IBB1
IF(IBX1.EQ.0)IBX1=IB1
AR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1-(IOFI-1)*IB1*N30)*2*(REQ+RAD))
%+M2*(3*(REQ+RMU+RAD)+4*RMI+(M1-(IOFI-1)*IB1*N30)*(2*RAD+REQ)
%+(IOFI-1)*IB1*N30*(2*RMI+REQ+RAD))
AR5=(JOFI-1)*(N20-L2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU)+REQ)
%*IOFI+(M2-(JOFI-1)*N40+L2-2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU
%)+REQ)*IOFI
WQ=((IOFI-1)*IB1+IBX1)*JOFI*WW
AT1=N20*WQ
AT2=N40*WQ
QW=JOFI*(VY1+VY2*IB1*N30)
AT3=IOFI*N40*QW
AT4=(IOFI-1)*N40*QW
AT5=JOFI*((IOFI-1)*N40*(IB1/IBX1)*(VY1+IBX1*N30*VY2)
%+N40*((IB1/IBX1)*(IOFI-1)+1)*(VY1+IBX1*N30*VY2))
AT6=JOFI*((IOFI-1)*N40*(IB1/2)*(VY1+2*N30*VY2)+N40*(
%IB1*(IOFI-1)/2+IBX1/2)*(VY1+2*N30*VY2))
T1=JOFI*N20*(L1-1)*REQ
T2=M1*(L2-1)*REQ
T3=JOFI*N20*IBX1*N30*(RAD+REQ)
T4=JOFI*((IOFI-1)*IB1*N30*N20*(2*RMI+REQ)+IBX1*N30*N20*(2*RMI+R
%EQ))
T5=JOFI*((IOFI-1)*IB1/2+IBX1/2)*N20*N30*(2*RAD+REQ)
T6=2*JOFI*(((IOFI-1)*IB1+IBX1)*N20)*((5*(RMI+RMU)+4*RAD
%)+(L1-1)*(2*RAD+REQ)+N30*(2*RAD+REQ))
T7=JOFI*2*((IOFI-1)*IB1+IBX1)*(L1-1)*(2*RAD+REQ)
T8=JOFI*N10*N20*((IOFI-1)*IB1/2+IBX1/2)*(3*REQ+9*RAD+4*RMU+RMI)
T9=N10*N20*JOFI*((IOFI-1)*IB1/2+IBX1/2)*(REQ+RMI)+M1*M2*(REQ+R
%DI+2*RAD)
T10=JOFI*((IOFI-1)*IB1/2+IBX1/2)*2*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
POI=JOFI
IF(POI.LE.2)POI=2
TNRAN=(N40+(POI-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMI+RMU+RAD
%+REQ+N30*(2*RAD+2*REQ)*(IB1*(IOFI-1)+IBX1))
IF(TNRAN.LT.0.)TNRAN=0.
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10+TNRAN
NVA(1)=N40
NVA(2)=N40
NVA(3)=N20
NVA(4)=N20
NVA(5)=M2-(JOFI-1)*N40
NVA(6)=NVA(5)
C(1)=FLOAT(IB1*N30)/FLOAT(M1)
C(2)=FLOAT(M1-(IOFI-1)*IB1*N30)/FLOAT(M1)
C(3)=C(1)
C(4)=C(2)
C(5)=C(1)
C(6)=C(2)
K=1
P1=FLOAT(NB)/FLOAT(M1)
10 IP1=P1
I(K)=1
IF(IP1.GE.NVA(K)) GOTO 7
P2=P1
IP2=P2
8 P2=P2-FLOAT(IP2)*C(K)
IP2=P2
IF(IP2.EQ.0) GOTO 3
IP1=IP1+IP2
I(K)=I(K)+1
IF(IP1.GE.NVA(K))GOTO 7
GOTO 8
7 IF(K.EQ.6) GOTO 11
K=K+1
GOTO 10
11 IP1=0
IP2=0
IP3=0
POFI=JOFI
IF(POFI.LE.2)POFI=2
TIOL=(I(2)+(IOFI-1)*I(1)+(POFI-2)*(IOFI-1)*I(3)+(POFI-
%2)*I(4)+(IOFI-1)*I(5)+I(6))*TACC+(IOFI*M1*N40+(POFI-2)*IOFI*
%M1*N20+(M2-(JOFI-1)*N40+L2-1)*M1*IOFI)*TTRANS
IF(IBB1.EQ.0) GOTO 33
IF(IB1.EQ.IBB1) GOTO 33
IF(IBB1.EQ.2)GOTO 34
IP3=1
INL=NMEM/((IOFI-1)*IB1*N30+IBB1*N30)
55 IF(INL.GT.N40)INL=N40
GOTO 35
33 IF(IB1.GT.2) GOTO 36
IF((M1-(IOFI-1)*IB1*N30).GE.N30) GOTO 36
34 IP1=1
INL=NMEM/(2*M1-(IOFI-1)*IB1*N30)
GOTO 55
36 IP2=1
INL=NMEM/(IOFI*IB1*N30)
IF(INL.GT.N40)INL=N40
35 CALL VALENT(N40,INL,KN1)
CALL VALENT(M2-(JOFI-1)*N40,INL,KN2)
CALL VALENT(INL*IBB1,IB1,KN3)
CALL VALENT((N40-(KN1-1)*INL)*IBB1,IB1,KN4)
IF((IP1+IP2+IP3).NE.1) CALL ERMESF(14)
TIO1=0.
IF(IP3.EQ.1)TIO1=N30*M2*TTRANS*(IB1*(IOFI-1)+IBB1)
IF(IP1.EQ.1)TIO1=M1*M2*TTRANS
IF(IP2.EQ.1) TIO1=(IB1*N30*M2*IOFI*TTRANS)
TTIO=2.*TIO1+(KN1*IOFI*(JOFI-1)+KN2*IOFI+(KN1-1)*(
%JOFI-1)+IOFI*(JOFI-1)+KN2-1.+IOFI+(KN1*(JOFI-1)+KN2))*TACC
%+M1*M2*TTRANS+TIOL
IF((IP1.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
IF((IP1.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT4+AR1
IF((IP2.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
IF((IP2.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT3+AR2
IFOIS=IB1/IBX1
IF((IP3.EQ.1).AND.(IFOIS*IBX1.EQ.IB1))TCPU=TCPU+AT1+AT2+AT5+AR2
IF((IP3.EQ.1).AND.(IFOIS*IBX1.NE.IB1))TCPU=TCPU+AT1+AT2+AT6+AR2
IF((IP1.EQ.1).AND.(IRZ.EQ.1))TCPU=TCPU+AR5
IF((IP1.EQ.1).AND.(IRZ.EQ.2))TCPU=TCPU+AR5
TTIOG=TTIO+TCPU
IF(TTIOG.LE.0.) GOTO 99
IF(TTIOG.GE.TIOOP) GOTO 99
IBOP=IB1
IBBOP=IBB1
K3OP=K3
TIOOP=TTIOG
TIOOP1=TTIO
TIOOP2=TCPU
99 IF(IB1.GE.MAX)GOTO17
IC=IC+1
GOTO 18
4 T1=JOFI*N20*(L1-1)*REQ
T2=M1*(L2-1)*REQ
T3=JOFI*N20*N30*(RAD+REQ)*K1
T4=JOFI*(K1*N30*N20*(2*RMI+REQ))
T5=JOFI*N20*N30*(2*RAD+REQ)*K1/2
T6=2*JOFI*(K1*N20)*((5*RMI+RMU)+4*RAD+(L1-1)*(2*RAD+REQ)+N30*2*
%RAD+REQ)
T7=JOFI*2*K1*(L1-1)*(2*RAD+REQ)
T9=JOFI*N10*N20*K1*(REQ+RMI)/2+M1*M2*(REQ+RDI+2*RAD)
T8=JOFI*N10*N20*K1*(3*REQ+9*RAD+4*RMU+RMI)/2
T10=JOFI*K1*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
PIO=JOFI
IF(PIO.LE.2)PIO=2
TNR=(N40+(PIO-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMU+RMI+RAD+REQ+
%N30*(2*RAD+2*REQ)*K1)
IF(TNR.LE.0.)TNR=0.
BT1=JOFI*N20*WW*K1
BT2=JOFI*N40*WW*K1
BT3=JOFI*N40*(VY1+K1*N30*VY2)
BR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1*2*(REQ+RAD)))+M2*(3*(
$REQ+RAD+RMU)+4*(RMI)+M1*(2*(RAD)+REQ))
BR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ))
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10
TCPU=TCPU+TNR+BT1+BT2
LIOF=M1/(N30)
IRZ=0
IF(LIOF*N30.EQ.M1) GOTO 2344
IRZ=1
2344 IF(IRZ.EQ.0)TCPU=TCPU+BT3
IF(IRZ.NE.0)TCPU=TCPU+BT3+BR2
TIOOP=2.*FLOAT(M1)*FLOAT(M2)*TTRANS+2.*FLOAT(K2)*TACC+TCPU
IBOP=1
IBBOP=0
K3OP=1
TIOOP2=TCPU
TIOOP1=TIOOP-TCPU
17 TTOT=TIOOP+TFF
IF(TTOT.LE.0.) GOTO 3
IF(TTOT.GE.TTOTOP)GOTO3
N1CO=N10
N2CO=N20
IBCO=IBOP
IBBCO=IBBOP
K3CO=K3OP
TTOTOP=TTOT
TESOP=TIOOP1
TCOP=TIOOP2
TFOP=TFF
3 CONTINUE
C
N1=N1CO
N2=N2CO
TTO=TTOTOP
IB=IBCO
IBB=IBBCO
K3=K3CO
TC=TCOP
TS=TESOP
TF=TFOP
TT=TCOP+TFOP
TWER=TTO-TT
IF(N1.EQ.0.OR.N2.EQ.0) CALL OUTSTR(0,'PAS DE PLACE MEMOIRE SUFFISA
$NTE POUR UNE MISE EN OEUVRE PAR BLOCS$')
IF(IB.NE.1)RETURN
IHJ=(M1/(N1-L1+1))
IF(IHJ*(N1-L1+1).NE.M1)IHJ=IHJ+1
IHJ1=IHJ/2
IF(IHJ1*2.NE.IHJ)GOTO7778
IB=IHJ
IBB=0
RETURN
7778 IB=IHJ+1
IBB=0
RETURN
END
gcc/testsuite/g77.f-torture/compile/19990905-0.f deleted 100644 → 0
* =foo0.f in Burley's g77 test suite.
subroutine sub(a)
common /info/ iarray(1000)
equivalence (m,iarray(100)), (n,iarray(200))
real a(m,n)
a(1,1) = a(2,2)
end
gcc/testsuite/g77.f-torture/compile/19990905-2.f deleted 100644 → 0
* =watson11.f in Burley's g77 test suite.
* Probably originally submitted by Ian Watson.
* Too small to worry about copyright issues, IMO, since it
* doesn't do anything substantive.
SUBROUTINE OUTDNS(A,B,LCONV)
IMPLICIT REAL*8(A-H,O-Z),INTEGER*4(I-N)
COMMON/ARRAYS/Z(64,8),AB(30,30),PAIRS(9,9),T(9,9),TEMP(9,9),C1(3),
> C2(3),AA(30),BB(30)
EQUIVALENCE (X1,C1(1)),(Y1,C1(2)),(Z1,C1(3))
EQUIVALENCE (X2,C2(1)),(Y2,C2(2)),(Z2,C2(3))
COMMON /CONTRL/
> SHIFT,CONV,SCION,DIVERG,
> IOPT,KCNDO,KINDO,KMINDO,I2EINT,KOHNO,KSLATE,
> N,NG,NUMAT,NSEK,NELECS,NIT,OCCA,OCCB,NOLDAT,NOLDFN
INTEGER*4 OCCA,OCCB
DIMENSION W(N),A(N,N),B(N,N)
DIMENSION BUF(100)
occb=5
ENTRY INDNS (A,B)
40 READ(IREAD) BUF
STOP
END
gcc/testsuite/g77.f-torture/compile/20000412-1.f deleted 100644 → 0
subroutine aap(k)
equivalence (i,r)
i = k
print*,r
end
gcc/testsuite/g77.f-torture/compile/20000511-1.f deleted 100644 → 0
subroutine saxpy(n,sa,sx,incx,sy,incy)
C
C constant times a vector plus a vector.
C uses unrolled loop for increments equal to one.
C jack dongarra, linpack, 3/11/78.
C modified 12/3/93, array(1) declarations changed to array(*)
C
real sx(*),sy(*),sa
integer i,incx,incy,ix,iy,m,mp1,n
C
C -ffast-math ICE provoked by this conditional
if(sa /= 0.0)then
C
C code for both increments equal to 1
C
do i= 1,n
sy(i)= sy(i)+sa*sx(i)
enddo
endif
return
end
gcc/testsuite/g77.f-torture/compile/20000511-2.f deleted 100644 → 0
subroutine sgbcon(norm,n,kl,ku,ab,ldab,ipiv,anorm,rcond,work,iwork
&,info)
C
C -- LAPACK routine (version 3.0) --
C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C Courant Institute, Argonne National Lab, and Rice University
C September 30, 1994
C
C .. Scalar Arguments ..
character norm
integer info,kl,ku,ldab,n
real anorm,rcond
C ..
C .. Array Arguments ..
integer ipiv(n),iwork(n)
real ab(ldab,n),work(n)
C ..
C
C Purpose
C =======
C demonstrate g77 bug at -O -funroll-loops
C =====================================================================
C
C .. Parameters ..
real one,zero
parameter(one= 1.0e+0,zero= 0.0e+0)
C ..
C .. Local Scalars ..
logical lnoti,onenrm
character normin
integer ix,j,jp,kase,kase1,kd,lm
real ainvnm,scale,smlnum,t
C ..
C .. External Functions ..
logical lsame
integer isamax
real sdot,slamch
externallsame,isamax,sdot,slamch
C ..
C .. External Subroutines ..
externalsaxpy,slacon,slatbs,srscl,xerbla
C ..
C .. Executable Statements ..
C
C Multiply by inv(L).
C
do j= 1,n-1
C the following min() intrinsic provokes this bug
lm= min(kl,n-j)
jp= ipiv(j)
t= work(jp)
if(jp.ne.j)then
C but only when combined with this if block
work(jp)= work(j)
work(j)= t
endif
C and this subroutine call
call saxpy(lm,-t,ab(kd+1,j),1,work(j+1),1)
enddo
return
end
gcc/testsuite/g77.f-torture/compile/20000518.f deleted 100644 → 0
SUBROUTINE SORG2R( K, A, N, LDA )
* ICE in `verify_wide_reg_1', at flow.c:2605 at -O2
* g77 version 2.96 20000515 (experimental) on i686-pc-linux-gnu
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 18 May 2000
INTEGER I, K, LDA, N
REAL A( LDA, * )
DO I = K, 1, -1
IF( I.LT.N ) A( I, I ) = 1.0
A( I, I ) = 1.0
END DO
RETURN
END
gcc/testsuite/g77.f-torture/compile/20000601-1.f deleted 100644 → 0
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB )
* PR fortran/275
* ICE in `change_address', at emit-rtl.c:1589 with -O1 and above
* g77 version 2.96 20000530 (experimental) on mips-sgi-irix6.5/-mabi=64
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 1 June 2000
INTEGER KL, KU, LDAB, M
REAL AB( LDAB, * )
INTEGER J, JB, JJ, JP, KV, KM
REAL WORK13(65,64), WORK31(65,64)
KV = KU + KL
DO J = 1, M
JB = MIN( 1, M-J+1 )
DO JJ = J, J + JB - 1
KM = MIN( KL, M-JJ )
JP = KM+1
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
END DO
END DO
RETURN
END
gcc/testsuite/g77.f-torture/compile/20000601-2.f deleted 100644 → 0
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB )
* Slightly modified version of 20000601-1.f that still ICES with
* CVS 20010118 g77 on mips-sgi-irix6.5/-mabi=64.
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 18 January 2001
INTEGER KL, KU, LDAB, M
REAL AB( LDAB, * )
INTEGER J, JB, JJ, JP, KV, KM, F
REAL WORK13(65,64), WORK31(65,64)
KV = KU + KL
DO J = 1, M
JB = MIN( 1, M-J+1 )
DO JJ = J, J + JB - 1
KM = MIN( KL, M-JJ )
JP = F( KM+1, AB( KV+1, JJ ) )
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
END DO
END DO
RETURN
END
gcc/testsuite/g77.f-torture/compile/20000629-1.f deleted 100644 → 0
SUBROUTINE MIST(N, BETA)
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER IA, IQ, M1
DIMENSION BETA(N)
DO 80 IQ=1,M1
IF (BETA(IQ).EQ.0.0D0) GO TO 120
80 CONTINUE
120 IF (IQ.NE.1) GO TO 160
160 M1 = IA(IQ)
RETURN
END
gcc/testsuite/g77.f-torture/compile/20000630-2.f deleted 100644 → 0
SUBROUTINE CHOUT(CHR,ICNT)
C ICE: failed assertion `expr != NULL'
C Reduced version of GNATS PR fortran/329 from trond.bo@dnmi.no
INTEGER CHR(ICNT)
CHARACTER*255 BUF
BUF(1:1)=CHAR(CHR(1))
CALL FPUTC(1,BUF(1:1))
RETURN
END
gcc/testsuite/g77.f-torture/compile/20010115.f deleted 100644 → 0
* GNATS PR Fortran/1636
PRINT 42, 'HELLO'
42 FORMAT(A)
CALL WORLD
END
SUBROUTINE WORLD
PRINT 42, 'WORLD'
42 FORMAT(A)
END
gcc/testsuite/g77.f-torture/compile/20010321-1.f deleted 100644 → 0
# 1 "20010321-1.f"
SUBROUTINE TWOEXP
# 1 "include/implicit.h" 1 3
IMPLICIT DOUBLE PRECISION (A-H)
# 3 "20010321-1.f" 2 3
LOGICAL ANTI
ANTI = .FALSE.
END
gcc/testsuite/g77.f-torture/compile/20010426.f deleted 100644 → 0
function f(c)
implicit none
real*8 c, f
f = sqrt(c)
return
end
gcc/testsuite/g77.f-torture/compile/20010519-1.f deleted 100644 → 0
CHARMM Element source/dimb/nmdimb.src 1.1
C.##IF DIMB
SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR,
1 PARDDV,DDV,DDM,PARDDF,DDF,PARDDE,DDEV,DD1BLK,
2 DD1BLL,NADD,LRAISE,DD1CMP,INBCMP,JNBCMP,
3 NPAR,ATMPAR,ATMPAS,BLATOM,PARDIM,NFREG,NFRET,
4 PARFRQ,CUTF1,ITMX,TOLDIM,IUNMOD,IUNRMD,
5 LBIG,LSCI,ATMPAD,SAVF,NBOND,IB,JB,DDVALM)
C-----------------------------------------------------------------------
C 01-Jul-1992 David Perahia, Liliane Mouawad
C 15-Dec-1994 Herman van Vlijmen
C
C This is the main routine for the mixed-basis diagonalization.
C See: L.Mouawad and D.Perahia, Biopolymers (1993), 33, 599,
C and: D.Perahia and L.Mouawad, Comput. Chem. (1995), 19, 241.
C The method iteratively solves the diagonalization of the
C Hessian matrix. To save memory space, it uses a compressed
C form of the Hessian, which only contains the nonzero elements.
C In the diagonalization process, approximate eigenvectors are
C mixed with Cartesian coordinates to form a reduced basis. The
C Hessian is then diagonalized in the reduced basis. By iterating
C over different sets of Cartesian coordinates the method ultimately
C converges to the exact eigenvalues and eigenvectors (up to the
C requested accuracy).
C If no existing basis set is read, an initial basis will be created
C which consists of the low-frequency eigenvectors of diagonal blocks
C of the Hessian.
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/impnon.fcm'
C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA
IMPLICIT NONE
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/stream.fcm'
LOGICAL LOWER,QLONGL
INTEGER MXSTRM,POUTU
PARAMETER (MXSTRM=20,POUTU=6)
INTEGER NSTRM,ISTRM,JSTRM,OUTU,PRNLEV,WRNLEV,IOLEV
COMMON /CASE/ LOWER, QLONGL
COMMON /STREAM/ NSTRM,ISTRM,JSTRM(MXSTRM),OUTU,PRNLEV,WRNLEV,IOLEV
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/dimens.fcm'
INTEGER LARGE,MEDIUM,SMALL,REDUCE
C..##IF QUANTA
C..##ELIF T3D
C..##ELSE
PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120)
C..##ENDIF
PARAMETER (REDUCE=15000)
INTEGER SIZE
C..##IF XLARGE
C..##ELIF XXLARGE
C..##ELIF LARGE
C..##ELIF MEDIUM
PARAMETER (SIZE=MEDIUM)
C..##ELIF REDUCE
C..##ELIF SMALL
C..##ELIF XSMALL
C..##ENDIF
C..##IF MMFF
integer MAXDEFI
parameter(MAXDEFI=250)
INTEGER NAME0,NAMEQ0,NRES0,KRES0
PARAMETER (NAME0=4,NAMEQ0=10,NRES0=4,KRES0=4)
integer MaxAtN
parameter (MaxAtN=55)
INTEGER MAXAUX
PARAMETER (MAXAUX = 10)
C..##ENDIF
INTEGER MAXCSP, MAXHSET
C..##IF HMCM
PARAMETER (MAXHSET = 200)
C..##ELSE
C..##ENDIF
C..##IF REDUCE
C..##ELSE
PARAMETER (MAXCSP = 500)
C..##ENDIF
C..##IF HMCM
INTEGER MAXHCM,MAXPCM,MAXRCM
C...##IF REDUCE
C...##ELSE
PARAMETER (MAXHCM=500)
PARAMETER (MAXPCM=5000)
PARAMETER (MAXRCM=2000)
C...##ENDIF
C..##ENDIF
INTEGER MXCMSZ
C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE
C..##ELSE
PARAMETER (MXCMSZ = 5000)
C..##ENDIF
INTEGER CHRSIZ
PARAMETER (CHRSIZ = SIZE)
INTEGER MAXATB
C..##IF REDUCE
C..##ELIF QUANTA
C..##ELSE
PARAMETER (MAXATB = 200)
C..##ENDIF
INTEGER MAXVEC
C..##IFN VECTOR PARVECT
PARAMETER (MAXVEC = 10)
C..##ELIF LARGE XLARGE XXLARGE
C..##ELIF MEDIUM
C..##ELIF SMALL REDUCE
C..##ELIF XSMALL
C..##ELSE
C..##ENDIF
INTEGER IATBMX
PARAMETER (IATBMX = 8)
INTEGER MAXHB
C..##IF LARGE XLARGE XXLARGE
C..##ELIF MEDIUM
PARAMETER (MAXHB = 8000)
C..##ELIF SMALL
C..##ELIF REDUCE XSMALL
C..##ELSE
C..##ENDIF
INTEGER MAXTRN,MAXSYM
C..##IFN NOIMAGES
PARAMETER (MAXTRN = 5000)
PARAMETER (MAXSYM = 192)
C..##ELSE
C..##ENDIF
C..##IF LONEPAIR (lonepair_max)
INTEGER MAXLP,MAXLPH
C...##IF REDUCE
C...##ELSE
PARAMETER (MAXLP = 2000)
PARAMETER (MAXLPH = 4000)
C...##ENDIF
C..##ENDIF (lonepair_max)
INTEGER NOEMAX,NOEMX2
C..##IF REDUCE
C..##ELSE
PARAMETER (NOEMAX = 2000)
PARAMETER (NOEMX2 = 4000)
C..##ENDIF
INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF
C..##IF REDUCE
C..##ELIF MMFF CFF
PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600,
& MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000)
C..##ELIF YAMMP
C..##ELIF LARGE
C..##ELSE
C..##ENDIF
INTEGER MAXCN
PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2)
INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP
INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES
INTEGER MAXSEG, MAXGRP
C..##IF LARGE XLARGE XXLARGE
C..##ELIF MEDIUM
PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE,
& MAXP = 2*SIZE)
PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160,
& MAXRES = 14000)
C...##IF MCSS
C...##ELSE
PARAMETER (MAXSEG = 1000)
C...##ENDIF
C..##ELIF SMALL
C..##ELIF XSMALL
C..##ELIF REDUCE
C..##ELSE
C..##ENDIF
C..##IF NOIMAGES
C..##ELSE
PARAMETER (MAXAIM = 2*SIZE)
PARAMETER (MAXGRP = 2*SIZE/3)
C..##ENDIF
INTEGER REDMAX,REDMX2
C..##IF REDUCE
C..##ELSE
PARAMETER (REDMAX = 20)
PARAMETER (REDMX2 = 80)
C..##ENDIF
INTEGER MXRTRS, MXRTA, MXRTB, MXRTT, MXRTP, MXRTI, MXRTX,
& MXRTHA, MXRTHD, MXRTBL, NICM
PARAMETER (MXRTRS = 200, MXRTA = 5000, MXRTB = 5000,
& MXRTT = 5000, MXRTP = 5000, MXRTI = 2000,
C..##IF YAMMP
C..##ELSE
& MXRTX = 5000, MXRTHA = 300, MXRTHD = 300,
C..##ENDIF
& MXRTBL = 5000, NICM = 10)
INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN
C..##IF REDUCE
C..##ELSE
PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3)
C..##ENDIF
INTEGER MAXSHK
C..##IF XSMALL
C..##ELIF REDUCE
C..##ELSE
PARAMETER (MAXSHK = SIZE*3/4)
C..##ENDIF
INTEGER SCRMAX
C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE
C..##ELSE
PARAMETER (SCRMAX = 5000)
C..##ENDIF
C..##IF TSM
INTEGER MXPIGG
C...##IF REDUCE
C...##ELSE
PARAMETER (MXPIGG=500)
C...##ENDIF
INTEGER MXCOLO,MXPUMB
PARAMETER (MXCOLO=20,MXPUMB=20)
C..##ENDIF
C..##IF ADUMB
INTEGER MAXUMP, MAXEPA, MAXNUM
C...##IF REDUCE
C...##ELSE
PARAMETER (MAXUMP = 10, MAXNUM = 4)
C...##ENDIF
C..##ENDIF
INTEGER MAXING
PARAMETER (MAXING=1000)
C..##IF MMFF
integer MAX_RINGSIZE, MAX_EACH_SIZE
parameter (MAX_RINGSIZE = 20, MAX_EACH_SIZE = 1000)
integer MAXPATHS
parameter (MAXPATHS = 8000)
integer MAX_TO_SEARCH
parameter (MAX_TO_SEARCH = 6)
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/number.fcm'
REAL*8 ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX,
& SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN,
& FIFTN, NINETN, TWENTY, THIRTY
C..##IF SINGLE
C..##ELSE
PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0,
& THREE = 3.D0, FOUR = 4.D0, FIVE = 5.D0,
& SIX = 6.D0, SEVEN = 7.D0, EIGHT = 8.D0,
& NINE = 9.D0, TEN = 10.D0, ELEVEN = 11.D0,
& TWELVE = 12.D0, THIRTN = 13.D0, FIFTN = 15.D0,
& NINETN = 19.D0, TWENTY = 20.D0, THIRTY = 30.D0)
C..##ENDIF
REAL*8 FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD,
& ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND,
& FTHSND,MEGA
C..##IF SINGLE
C..##ELSE
PARAMETER (FIFTY = 50.D0, SIXTY = 60.D0, SVNTY2 = 72.D0,
& EIGHTY = 80.D0, NINETY = 90.D0, HUNDRD = 100.D0,
& ONE2TY = 120.D0, ONE8TY = 180.D0, THRHUN = 300.D0,
& THR6TY=360.D0, NINE99 = 999.D0, FIFHUN = 1500.D0,
& THOSND = 1000.D0,FTHSND = 5000.D0, MEGA = 1.0D6)
C..##ENDIF
REAL*8 MINONE, MINTWO, MINSIX
PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0)
REAL*8 TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005,
& PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD,
& PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4
C..##IF SINGLE
C..##ELSE
PARAMETER (TENM20 = 1.0D-20, TENM14 = 1.0D-14, TENM8 = 1.0D-8,
& TENM5 = 1.0D-5, PT0001 = 1.0D-4, PT0005 = 5.0D-4,
& PT001 = 1.0D-3, PT005 = 5.0D-3, PT01 = 0.01D0,
& PT02 = 0.02D0, PT05 = 0.05D0, PTONE = 0.1D0,
& PT125 = 0.125D0, SIXTH = ONE/SIX,PT25 = 0.25D0,
& THIRD = ONE/THREE,PTFOUR = 0.4D0, HALF = 0.5D0,
& PTSIX = 0.6D0, PT75 = 0.75D0, PT9999 = 0.9999D0,
& ONEPT5 = 1.5D0, TWOPT4 = 2.4D0)
C..##ENDIF
REAL*8 ANUM,FMARK
REAL*8 RSMALL,RBIG
C..##IF SINGLE
C..##ELSE
PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0)
PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20)
C..##ENDIF
REAL*8 RPRECI,RBIGST
C..##IF VAX DEC
C..##ELIF IBM
C..##ELIF CRAY
C..##ELIF ALPHA T3D T3E
C..##ELSE
C...##IF SINGLE
C...##ELSE
PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307)
C...##ENDIF
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/consta.fcm'
REAL*8 PI,RADDEG,DEGRAD,TWOPI
PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI)
PARAMETER (RADDEG=180.0D0/PI)
PARAMETER (DEGRAD=PI/180.0D0)
REAL*8 COSMAX
PARAMETER (COSMAX=0.9999999999D0)
REAL*8 TIMFAC
PARAMETER (TIMFAC=4.88882129D-02)
REAL*8 KBOLTZ
PARAMETER (KBOLTZ=1.987191D-03)
REAL*8 CCELEC
C..##IF AMBER
C..##ELIF DISCOVER
C..##ELSE
PARAMETER (CCELEC=332.0716D0)
C..##ENDIF
REAL*8 CNVFRQ
PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0))
REAL*8 SPEEDL
PARAMETER (SPEEDL=2.99793D-02)
REAL*8 ATMOSP
PARAMETER (ATMOSP=1.4584007D-05)
REAL*8 PATMOS
PARAMETER (PATMOS = 1.D0 / ATMOSP )
REAL*8 BOHRR
PARAMETER (BOHRR = 0.529177249D0 )
REAL*8 TOKCAL
PARAMETER (TOKCAL = 627.5095D0 )
C..##IF MMFF
real*8 MDAKCAL
parameter(MDAKCAL=143.9325D0)
C..##ENDIF
REAL*8 DEBYEC
PARAMETER ( DEBYEC = 2.541766D0 / BOHRR )
REAL*8 ZEROC
PARAMETER ( ZEROC = 298.15D0 )
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/exfunc.fcm'
C..##IF ACE
C..##ENDIF
C..##IF ADUMB
C..##ENDIF
CHARACTER*4 GTRMA, NEXTA4, CURRA4
CHARACTER*6 NEXTA6
CHARACTER*8 NEXTA8
CHARACTER*20 NEXT20
INTEGER ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
* PARNUM, PARINS,
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE
C..##IF ACE
* ,GETNNB
C..##ENDIF
LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA
REAL*8 DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
* RANUMB, R8VAL, RETVAL8, SUMVEC
C..##IF ADUMB
* ,UMFI
C..##ENDIF
EXTERNAL GTRMA, NEXTA4, CURRA4, NEXTA6, NEXTA8,NEXT20,
* ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
* PARNUM, PARINS,
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE,
* CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA,
* DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
* RANUMB, R8VAL, RETVAL8, SUMVEC
C..##IF ADUMB
* ,UMFI
C..##ENDIF
C..##IF ACE
* ,GETNNB
C..##ENDIF
C..##IFN NOIMAGES
INTEGER IMATOM
EXTERNAL IMATOM
C..##ENDIF
C..##IF MBOND
C..##ENDIF
C..##IF MMFF
INTEGER LEN_TRIM
EXTERNAL LEN_TRIM
CHARACTER*4 AtName
external AtName
CHARACTER*8 ElementName
external ElementName
CHARACTER*10 QNAME
external QNAME
integer IATTCH, IBORDR, CONN12, CONN13, CONN14
integer LEQUIV, LPATH
integer nbndx, nbnd2, nbnd3, NTERMA
external IATTCH, IBORDR, CONN12, CONN13, CONN14
external LEQUIV, LPATH
external nbndx, nbnd2, nbnd3, NTERMA
external find_loc
real*8 vangle, OOPNGL, TORNGL, ElementMass
external vangle, OOPNGL, TORNGL, ElementMass
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/stack.fcm'
INTEGER STKSIZ
C..##IFN UNICOS
C...##IF LARGE XLARGE
C...##ELIF MEDIUM REDUCE
PARAMETER (STKSIZ=4000000)
C...##ELIF SMALL
C...##ELIF XSMALL
C...##ELIF XXLARGE
C...##ELSE
C...##ENDIF
INTEGER LSTUSD,MAXUSD,STACK
COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ)
C..##ELSE
C..##ENDIF
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/heap.fcm'
INTEGER HEAPDM
C..##IFN UNICOS (unicos)
C...##IF XXLARGE (size)
C...##ELIF LARGE XLARGE (size)
C...##ELIF MEDIUM (size)
C....##IF T3D (t3d2)
C....##ELIF TERRA (t3d2)
C....##ELIF ALPHA (t3d2)
C....##ELIF T3E (t3d2)
C....##ELSE (t3d2)
PARAMETER (HEAPDM=2048000)
C....##ENDIF (t3d2)
C...##ELIF SMALL (size)
C...##ELIF REDUCE (size)
C...##ELIF XSMALL (size)
C...##ELSE (size)
C...##ENDIF (size)
INTEGER FREEHP,HEAPSZ,HEAP
COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM)
LOGICAL LHEAP(HEAPDM)
EQUIVALENCE (LHEAP,HEAP)
C..##ELSE (unicos)
C..##ENDIF (unicos)
C..##IF SAVEFCM (save)
C..##ENDIF (save)
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/fast.fcm'
INTEGER IACNB, NITCC, ICUSED, FASTER, LFAST, LMACH, OLMACH
INTEGER ICCOUNT, LOWTP, IGCNB, NITCC2
INTEGER ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
COMMON /FASTI/ FASTER, LFAST, LMACH, OLMACH, NITCC, NITCC2,
& ICUSED(MAXATC), ICCOUNT(MAXATC), LOWTP(MAXATC),
& IACNB(MAXAIM), IGCNB(MAXATC),
& ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/deriv.fcm'
REAL*8 DX,DY,DZ
COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM)
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/energy.fcm'
INTEGER LENENP, LENENT, LENENV, LENENA
PARAMETER (LENENP = 50, LENENT = 70, LENENV = 50,
& LENENA = LENENP + LENENT + LENENV )
INTEGER TOTE, TOTKE, EPOT, TEMPS, GRMS, BPRESS, PJNK1, PJNK2,
& PJNK3, PJNK4, HFCTE, HFCKE, EHFC, EWORK, VOLUME, PRESSE,
& PRESSI, VIRI, VIRE, VIRKE, TEPR, PEPR, KEPR, KEPR2,
& DROFFA,
& XTLTE, XTLKE, XTLPE, XTLTEM, XTLPEP, XTLKEP, XTLKP2,
& TOT4, TOTK4, EPOT4, TEM4, MbMom, BodyT, PartT
C..##IF ACE
& , SELF, SCREEN, COUL ,SOLV, INTER
C..##ENDIF
C..##IF FLUCQ
& ,FQKIN
C..##ENDIF
PARAMETER (TOTE = 1, TOTKE = 2, EPOT = 3, TEMPS = 4,
& GRMS = 5, BPRESS = 6, PJNK1 = 7, PJNK2 = 8,
& PJNK3 = 9, PJNK4 = 10, HFCTE = 11, HFCKE = 12,
& EHFC = 13, EWORK = 11, VOLUME = 15, PRESSE = 16,
& PRESSI = 17, VIRI = 18, VIRE = 19, VIRKE = 20,
& TEPR = 21, PEPR = 22, KEPR = 23, KEPR2 = 24,
& DROFFA = 26, XTLTE = 27, XTLKE = 28,
& XTLPE = 29, XTLTEM = 30, XTLPEP = 31, XTLKEP = 32,
& XTLKP2 = 33,
& TOT4 = 37, TOTK4 = 38, EPOT4 = 39, TEM4 = 40,
& MbMom = 41, BodyT = 42, PartT = 43
C..##IF ACE
& , SELF = 45, SCREEN = 46, COUL = 47,
& SOLV = 48, INTER = 49
C..##ENDIF
C..##IF FLUCQ
& ,FQKIN = 50
C..##ENDIF
& )
C..##IF ACE
C..##ENDIF
C..##IF GRID
C..##ENDIF
C..##IF FLUCQ
C..##ENDIF
INTEGER BOND, ANGLE, UREYB, DIHE, IMDIHE, VDW, ELEC, HBOND,
& USER, CHARM, CDIHE, CINTCR, CQRT, NOE, SBNDRY,
& IMVDW, IMELEC, IMHBND, EWKSUM, EWSELF, EXTNDE, RXNFLD,
& ST2, IMST2, TSM, QMEL, QMVDW, ASP, EHARM, GEO, MDIP,
& PRMS, PANG, SSBP, BK4D, SHEL, RESD, SHAP,
& STRB, OOPL, PULL, POLAR, DMC, RGY, EWEXCL, EWQCOR,
& EWUTIL, PBELEC, PBNP, PINT, MbDefrm, MbElec, STRSTR,
& BNDBND, BNDTW, EBST, MBST, BBT, SST, GBEnr, GSBP
C..##IF HMCM
& , HMCM
C..##ENDIF
C..##IF ADUMB
& , ADUMB
C..##ENDIF
& , HYDR
C..##IF FLUCQ
& , FQPOL
C..##ENDIF
PARAMETER (BOND = 1, ANGLE = 2, UREYB = 3, DIHE = 4,
& IMDIHE = 5, VDW = 6, ELEC = 7, HBOND = 8,
& USER = 9, CHARM = 10, CDIHE = 11, CINTCR = 12,
& CQRT = 13, NOE = 14, SBNDRY = 15, IMVDW = 16,
& IMELEC = 17, IMHBND = 18, EWKSUM = 19, EWSELF = 20,
& EXTNDE = 21, RXNFLD = 22, ST2 = 23, IMST2 = 24,
& TSM = 25, QMEL = 26, QMVDW = 27, ASP = 28,
& EHARM = 29, GEO = 30, MDIP = 31, PINT = 32,
& PRMS = 33, PANG = 34, SSBP = 35, BK4D = 36,
& SHEL = 37, RESD = 38, SHAP = 39, STRB = 40,
& OOPL = 41, PULL = 42, POLAR = 43, DMC = 44,
& RGY = 45, EWEXCL = 46, EWQCOR = 47, EWUTIL = 48,
& PBELEC = 49, PBNP = 50, MbDefrm= 51, MbElec = 52,
& STRSTR = 53, BNDBND = 54, BNDTW = 55, EBST = 56,
& MBST = 57, BBT = 58, SST = 59, GBEnr = 60,
& GSBP = 65
C..##IF HMCM
& , HMCM = 61
C..##ENDIF
C..##IF ADUMB
& , ADUMB = 62
C..##ENDIF
& , HYDR = 63
C..##IF FLUCQ
& , FQPOL = 65
C..##ENDIF
& )
INTEGER VEXX, VEXY, VEXZ, VEYX, VEYY, VEYZ, VEZX, VEZY, VEZZ,
& VIXX, VIXY, VIXZ, VIYX, VIYY, VIYZ, VIZX, VIZY, VIZZ,
& PEXX, PEXY, PEXZ, PEYX, PEYY, PEYZ, PEZX, PEZY, PEZZ,
& PIXX, PIXY, PIXZ, PIYX, PIYY, PIYZ, PIZX, PIZY, PIZZ
PARAMETER ( VEXX = 1, VEXY = 2, VEXZ = 3, VEYX = 4,
& VEYY = 5, VEYZ = 6, VEZX = 7, VEZY = 8,
& VEZZ = 9,
& VIXX = 10, VIXY = 11, VIXZ = 12, VIYX = 13,
& VIYY = 14, VIYZ = 15, VIZX = 16, VIZY = 17,
& VIZZ = 18,
& PEXX = 19, PEXY = 20, PEXZ = 21, PEYX = 22,
& PEYY = 23, PEYZ = 24, PEZX = 25, PEZY = 26,
& PEZZ = 27,
& PIXX = 28, PIXY = 29, PIXZ = 30, PIYX = 31,
& PIYY = 32, PIYZ = 33, PIZX = 34, PIZY = 35,
& PIZZ = 36)
CHARACTER*4 CEPROP, CETERM, CEPRSS
COMMON /ANER/ CEPROP(LENENP), CETERM(LENENT), CEPRSS(LENENV)
LOGICAL QEPROP, QETERM, QEPRSS
COMMON /QENER/ QEPROP(LENENP), QETERM(LENENT), QEPRSS(LENENV)
REAL*8 EPROP, ETERM, EPRESS
COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV)
C..##IF SAVEFCM
C..##ENDIF
REAL*8 EPRPA, EPRP2A, EPRPP, EPRP2P,
& ETRMA, ETRM2A, ETRMP, ETRM2P,
& EPRSA, EPRS2A, EPRSP, EPRS2P
COMMON /ENACCM/ EPRPA(LENENP), ETRMA(LENENT), EPRSA(LENENV),
& EPRP2A(LENENP),ETRM2A(LENENT),EPRS2A(LENENV),
& EPRPP(LENENP), ETRMP(LENENT), EPRSP(LENENV),
& EPRP2P(LENENP),ETRM2P(LENENT),EPRS2P(LENENV)
C..##IF SAVEFCM
C..##ENDIF
INTEGER ECALLS, TOT1ST, TOT2ND
COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND
REAL*8 EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP,
& EAT0P, CORRP
COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA,
& FITP, DRIFTP, EAT0P, CORRP
C..##IF SAVEFCM
C..##ENDIF
C..##IF ACE
C..##ENDIF
C..##IF FLUCQ
C..##ENDIF
C..##IF ADUMB
C..##ENDIF
C..##IF GRID
C..##ENDIF
C..##IF FLUCQ
C..##ENDIF
C..##IF TSM
REAL*8 TSMTRM(LENENT),TSMTMP(LENENT)
COMMON /TSMENG/ TSMTRM,TSMTMP
C...##IF SAVEFCM
C...##ENDIF
C..##ENDIF
REAL*8 EHQBM
LOGICAL HQBM
COMMON /HQBMVAR/HQBM
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/dimb.fcm'
C..##IF DIMB (dimbfcm)
INTEGER NPARMX,MNBCMP,LENDSK
PARAMETER (NPARMX=1000,MNBCMP=300,LENDSK=200000)
INTEGER IJXXCM,IJXYCM,IJXZCM,IJYXCM,IJYYCM
INTEGER IJYZCM,IJZXCM,IJZYCM,IJZZCM
INTEGER IIXXCM,IIXYCM,IIXZCM,IIYYCM
INTEGER IIYZCM,IIZZCM
INTEGER JJXXCM,JJXYCM,JJXZCM,JJYYCM
INTEGER JJYZCM,JJZZCM
PARAMETER (IJXXCM=1,IJXYCM=2,IJXZCM=3,IJYXCM=4,IJYYCM=5)
PARAMETER (IJYZCM=6,IJZXCM=7,IJZYCM=8,IJZZCM=9)
PARAMETER (IIXXCM=1,IIXYCM=2,IIXZCM=3,IIYYCM=4)
PARAMETER (IIYZCM=5,IIZZCM=6)
PARAMETER (JJXXCM=1,JJXYCM=2,JJXZCM=3,JJYYCM=4)
PARAMETER (JJYZCM=5,JJZZCM=6)
INTEGER ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,PDD1CM,LENCMP
LOGICAL QDISK,QDW,QCMPCT
COMMON /DIMBI/ ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,LENCMP
COMMON /DIMBL/ QDISK,QDW,QCMPCT
C...##IF SAVEFCM
C...##ENDIF
C..##ENDIF (dimbfcm)
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C:::##INCLUDE '~/charmm_fcm/ctitla.fcm'
INTEGER MAXTIT
PARAMETER (MAXTIT=32)
INTEGER NTITLA,NTITLB
CHARACTER*80 TITLEA,TITLEB
COMMON /NTITLA/ NTITLA,NTITLB
COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT)
C..##IF SAVEFCM
C..##ENDIF
C-----------------------------------------------------------------------
C Passed variables
INTEGER NAT3,NADD,NPAR,NFREG,NFRET,BLATOM
INTEGER ATMPAR(2,*),ATMPAS(2,*),ATMPAD(2,*)
INTEGER BNBND(*),BIMAG(*)
INTEGER INBCMP(*),JNBCMP(*),PARDIM
INTEGER ITMX,IUNMOD,IUNRMD,SAVF
INTEGER NBOND,IB(*),JB(*)
REAL*8 X(*),Y(*),Z(*),AMASS(*),DDSCR(*)
REAL*8 DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*)
REAL*8 DDF(*),PARDDF(*),DDEV(*),PARDDE(*)
REAL*8 DD1BLK(*),DD1BLL(*),DD1CMP(*)
REAL*8 TOLDIM,DDVALM
REAL*8 PARFRQ,CUTF1
LOGICAL LNOMA,LRAISE,LSCI,LBIG
C Local variables
INTEGER NATOM,NATP,NDIM,I,J,II,OLDFAS,OLDPRN,IUPD
INTEGER NPARC,NPARD,NPARS,NFCUT1,NFREG2,NFREG6
INTEGER IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8
INTEGER IS1,IS2,IS3,IS4,JSPACE,JSP,DDSS,DD5
INTEGER ISTRT,ISTOP,IPA1,IPA2,IRESF
INTEGER ATMPAF,INIDS,TRAROT
INTEGER SUBLIS,ATMCOR
INTEGER NFRRES,DDVBAS
INTEGER DDV2,DDVAL
INTEGER LENCM,NTR,NFRE,NFC,N1,N2,NFCUT,NSUBP
INTEGER SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6
INTEGER DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ
INTEGER I620,I640,I660,I700,I720,I760,I800,I840,I880,I920
REAL*8 CVGMX,TOLER
LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG
C Begin
QCALC=.TRUE.
LWDINI=.FALSE.
INIDS=0
IS3=0
IS4=0
LPURG=.TRUE.
ITER=0
NADD=0
NFSAV=0
TOLER=TENM5
QDIAG=.TRUE.
CVGMX=HUNDRD
QMIX=.FALSE.
NATOM=NAT3/3
NFREG6=(NFREG-6)/NPAR
NFREG2=NFREG/2
NFRRES=(NFREG+6)/2
IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'NFREG IS LARGER THAN PARDIM*3')
C
C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
ASSIGN 801 TO I800
GOTO 800
801 CONTINUE
C ALLOCATE-SPACE-FOR-DIAGONALIZATION
ASSIGN 721 TO I720
GOTO 720
721 CONTINUE
C ALLOCATE-SPACE-FOR-REDUCED-BASIS
ASSIGN 761 TO I760
GOTO 760
761 CONTINUE
C ALLOCATE-SPACE-FOR-OTHER-ARRAYS
ASSIGN 921 TO I920
GOTO 920
921 CONTINUE
C
C Space allocation for working arrays of EISPACK
C diagonalization subroutines
IF(LSCI) THEN
C ALLOCATE-SPACE-FOR-LSCI
ASSIGN 841 TO I840
GOTO 840
841 CONTINUE
ELSE
C ALLOCATE-DUMMY-SPACE-FOR-LSCI
ASSIGN 881 TO I880
GOTO 880
881 CONTINUE
ENDIF
QMASWT=(.NOT.LNOMA)
IF(.NOT. QDISK) THEN
LENCM=INBCMP(NATOM-1)*9+NATOM*6
DO I=1,LENCM
DD1CMP(I)=0.0
ENDDO
OLDFAS=LFAST
QCMPCT=.TRUE.
LFAST = -1
CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1)
LFAST=OLDFAS
QCMPCT=.FALSE.
C
C Mass weight DD1CMP matrix
C
CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM)
ELSE
CALL WRNDIE(-3,'<NMDIMB>','QDISK OPTION NOT SUPPORTED YET')
C DO I=1,LENDSK
C DD1CMP(I)=0.0
C ENDDO
C OLDFAS=LFAST
C LFAST = -1
ENDIF
C
C Fill DDV with six translation-rotation vectors
C
CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM)
CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1)
NTR=6
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER)
PRNLEV=OLDPRN
IF(IUNRMD .LT. 0) THEN
C
C If no previous basis is read
C
IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR
502 FORMAT(/' NMDIMB: Calculating initial basis from block ',
1 'diagonals'/' NMDIMB: The number of blocks is ',I5/)
NFRET = 6
DO I=1,NPAR
IS1=ATMPAR(1,I)
IS2=ATMPAR(2,I)
NDIM=(IS2-IS1+1)*3
NFRE=NDIM
IF(NFRE.GT.NFREG6) NFRE=NFREG6
IF(NFREG6.EQ.0) NFRE=1
CALL FILUPT(HEAP(IUPD),NDIM)
CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD),
1 IS1,IS2,NATOM)
IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR',
1 'ENR',.TRUE.,1,ZERO,ZERO)
C
C Generate the lower section of the matrix and diagonalize
C
C..##IF EISPACK
C..##ENDIF
IH1=1
NATP=NDIM+1
IH2=IH1+NATP
IH3=IH2+NATP
IH4=IH3+NATP
IH5=IH4+NATP
IH6=IH5+NATP
IH7=IH6+NATP
IH8=IH7+NATP
CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3),
1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD)
C..##IF EISPACK
C..##ENDIF
C
C Put the PARDDV vectors into DDV and replace the elements which do
C not belong to the considered partitioned region by zeros.
C
CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2)
IF(LSCI) THEN
DO J=1,NFRE
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
ENDDO
ELSE
DO J=1,NFRE
PARDDE(J)=DDS(J)
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
ENDDO
ENDIF
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,512) I
WRITE(OUTU,514)
WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE)
ENDIF
NFRET=NFRET+NFRE
IF(NFRET .GE. NFREG) GOTO 10
ENDDO
512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed')
514 FORMAT(' NMDIMB: Frequencies'/)
516 FORMAT(5(I4,F12.6))
10 CONTINUE
C
C Orthonormalize the eigenvectors
C
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
C
C Do reduced basis diagonalization using the DDV vectors
C and get eigenvectors of zero iteration
C
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,521) ITER
WRITE(OUTU,523) NFRET
ENDIF
521 FORMAT(/' NMDIMB: Iteration number = ',I5)
523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5)
IF(LBIG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD
525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
REWIND (UNIT=IUNMOD)
LCARD=.FALSE.
CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
CALL SAVEIT(IUNMOD)
ELSE
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1)
ENDIF
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
C
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
C
ASSIGN 621 TO I620
GOTO 620
621 CONTINUE
C SAVE-MODES
ASSIGN 701 TO I700
GOTO 700
701 CONTINUE
IF(ITER.EQ.ITMX) THEN
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
1 DDVAL,JSPACE,TRAROT,
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
RETURN
ENDIF
ELSE
C
C Read in existing basis
C
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,531)
531 FORMAT(/' NMDIMB: Calculations restarted')
ENDIF
C READ-MODES
ISTRT=1
ISTOP=99999999
LCARD=.FALSE.
LAPPE=.FALSE.
CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM,
1 DDV,DDSCR,DDF,DDEV,
2 IUNRMD,LAPPE,ISTRT,ISTOP)
NFRET=NDIM
IF(NFRET.GT.NFREG) THEN
NFRET=NFREG
CALL WRNDIE(-1,'<NMDIMB>',
1 'Not enough space to hold the basis. Increase NMODes')
ENDIF
C PRINT-MODES
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,533) NFRET,IUNRMD
WRITE(OUTU,514)
WRITE(OUTU,516) (J,DDF(J),J=1,NFRET)
ENDIF
533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5)
NFRRES=NFRET
ENDIF
C
C -------------------------------------------------
C Here starts the mixed-basis diagonalization part.
C -------------------------------------------------
C
C
C Check cut-off frequency
C
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
C TEST-NFCUT1
IF(IUNRMD.LT.0) THEN
IF(NFCUT1*2-6.GT.NFREG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES)
NFCUT1=NFRRES
CUTF1=DDF(NFRRES)
ENDIF
ELSE
CUTF1=DDF(NFRRES)
ENDIF
537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency'
1 /' Cutoff frequency is decreased to',F9.3)
C
C Compute the new partioning of the molecule
C
CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES,
1 PARDIM)
NPARS=NPARC
DO I=1,NPARC
ATMPAS(1,I)=ATMPAR(1,I)
ATMPAS(2,I)=ATMPAR(2,I)
ENDDO
IF(QDW) THEN
IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE.
IF(IPAR1.GE.IPAR2) LWDINI=.TRUE.
IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE.
IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE.
IF(ITER.EQ.0) LWDINI=.TRUE.
ENDIF
ITMX=ITMX+ITER
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,543) ITER,ITMX
IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2
ENDIF
543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/
1 ' NMDIMB: Iteration number to reach = ',I8)
545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5)
C
IF(SAVF.LE.0) SAVF=NPARC
IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF
547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5,
1 ' iterations')
C
C If double windowing is defined, the original block sizes are divided
C in two.
C
IF(QDW) THEN
NSUBP=1
CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX)
ATMPAF=ALLHP(INTEG4(NPARD*NPARD))
ATMCOR=ALLHP(INTEG4(NATOM))
DDVAL=ALLHP(IREAL8(NPARD*NPARD))
CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM)
CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD,
2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM)
SUBLIS=ALLHP(INTEG4(NSUBP*2))
CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP)
CALL INIPAF(HEAP(ATMPAF),NPARD)
C
C Find out with which block to continue (double window method only)
C
IPA1=IPAR1
IPA2=IPAR2
IRESF=0
IF(LWDINI) THEN
ITER=0
LWDINI=.FALSE.
GOTO 500
ENDIF
DO II=1,NSUBP
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1 NPARD,QCALC)
IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500
ENDDO
ENDIF
500 CONTINUE
C
C Main loop.
C
DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX))
IF(.NOT.QDW) THEN
ITER=ITER+1
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
553 FORMAT(/' NMDIMB: Iteration number = ',I8)
IF(INIDS.EQ.0) THEN
INIDS=1
ELSE
INIDS=0
ENDIF
CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX,
1 DDF,NFREG,CUTF1,PARDIM,NFCUT1)
C DO-THE-DIAGONALISATIONS
ASSIGN 641 to I640
GOTO 640
641 CONTINUE
QDIAG=.FALSE.
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
ASSIGN 622 TO I620
GOTO 620
622 CONTINUE
QDIAG=.TRUE.
C SAVE-MODES
ASSIGN 702 TO I700
GOTO 700
702 CONTINUE
C
ELSE
DO II=1,NSUBP
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1 NPARD,QCALC)
IF(QCALC) THEN
IRESF=IRESF+1
ITER=ITER+1
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
C DO-THE-DWIN-DIAGONALISATIONS
ASSIGN 661 TO I660
GOTO 660
661 CONTINUE
ENDIF
IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN
IRESF=0
QDIAG=.FALSE.
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
ASSIGN 623 TO I620
GOTO 620
623 CONTINUE
QDIAG=.TRUE.
IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600
C SAVE-MODES
ASSIGN 703 TO I700
GOTO 700
703 CONTINUE
ENDIF
ENDDO
ENDIF
ENDDO
600 CONTINUE
C
C SAVE-MODES
ASSIGN 704 TO I700
GOTO 700
704 CONTINUE
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
1 DDVAL,JSPACE,TRAROT,
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
RETURN
C-----------------------------------------------------------------------
C INTERNAL PROCEDURES
C-----------------------------------------------------------------------
C TO DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
620 CONTINUE
IF(IUNRMD.LT.0) THEN
CALL SELNMD(DDF,NFRET,CUTF1,NFC)
N1=NFCUT1
N2=(NFRET+6)/2
NFCUT=MAX(N1,N2)
IF(NFCUT*2-6 .GT. NFREG) THEN
NFCUT=(NFREG+6)/2
CUTF1=DDF(NFCUT)
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,562) ITER
WRITE(OUTU,564) CUTF1
ENDIF
ENDIF
ELSE
NFCUT=NFRET
NFC=NFRET
ENDIF
562 FORMAT(/' NMDIMB: Not enough space to hold the residual vectors'/
1 ' into DDV array during iteration ',I5)
564 FORMAT(' Cutoff frequency is changed to ',F9.3)
C
C do reduced diagonalization with preceding eigenvectors plus
C residual vectors
C
ISTRT=1
ISTOP=NFCUT
CALL CLETR(DDV,HEAP(TRAROT),NAT3,ISTRT,ISTOP,NFCUT,DDEV,DDF)
CALL RNMTST(DDV,HEAP(DDVBAS),NAT3,DDSCR,DD1CMP,INBCMP,JNBCMP,
2 7,NFCUT,CVGMX,NFCUT,NFC,QDIAG,LBIG,IUNMOD)
NFSAV=NFCUT
IF(QDIAG) THEN
NFRET=NFCUT*2-6
IF(PRNLEV.GE.2) WRITE(OUTU,566) NFRET
566 FORMAT(/' NMDIMB: Diagonalization with residual vectors. '/
1 ' Dimension of the reduced basis set'/
2 ' before orthonormalization = ',I5)
NFCUT=NFRET
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
NFRET=NFCUT
IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET
568 FORMAT(' after orthonormalization = ',I5)
IF(LBIG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,570) NFCUT,IUNMOD
570 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
REWIND (UNIT=IUNMOD)
LCARD=.FALSE.
CALL WRTNMD(LCARD,1,NFCUT,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
CALL SAVEIT(IUNMOD)
ELSE
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
ENDIF
QMIX=.FALSE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
ENDIF
GOTO I620
C
C-----------------------------------------------------------------------
C TO DO-THE-DIAGONALISATIONS
640 CONTINUE
DO I=1,NPARC
NFCUT1=NFRRES
IS1=ATMPAR(1,I)
IS2=ATMPAR(2,I)
NDIM=(IS2-IS1+1)*3
IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2
573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/
1 ' NMDIMB: Block limits: ',I5,2X,I5)
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'Error in dimension of block')
NFRET=NFCUT1
IF(NFRET.GT.NFREG) NFRET=NFREG
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
NFCUT1=NFCUT
CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2)
NFSAV=NFCUT1
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
NFRET=NDIM+NFCUT
QMIX=.TRUE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
QMIX=.FALSE.
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
NFCUT1=NFCUT
NFRET=NFCUT
ENDDO
GOTO I640
C
C-----------------------------------------------------------------------
C TO DO-THE-DWIN-DIAGONALISATIONS
660 CONTINUE
C
C Store the DDV vectors into DDVBAS
C
NFCUT1=NFRRES
IS1=ATMPAD(1,IPAR1)
IS2=ATMPAD(2,IPAR1)
IS3=ATMPAD(1,IPAR2)
IS4=ATMPAD(2,IPAR2)
NDIM=(IS2-IS1+IS4-IS3+2)*3
IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4
577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ',
1 2I5/
2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5)
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'Error in dimension of block')
NFRET=NFCUT1
IF(NFRET.GT.NFREG) NFRET=NFREG
C
C Prepare the DDV vectors consisting of 6 translations-rotations
C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors
C spanning the atoms from IS1 to IS2
C
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
NFCUT1=NFCUT
NFSAV=NFCUT1
CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4)
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
C
NFRET=NDIM+NFCUT
QMIX=.TRUE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
QMIX=.FALSE.
C
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
NFCUT1=NFCUT
NFRET=NFCUT
GOTO I660
C
C-----------------------------------------------------------------------
C TO SAVE-MODES
700 CONTINUE
IF(PRNLEV.GE.2) WRITE(OUTU,583) IUNMOD
583 FORMAT(/' NMDIMB: Saving the eigenvalues and eigenvectors to unit'
1 ,I4)
REWIND (UNIT=IUNMOD)
ISTRT=1
ISTOP=NFSAV
LCARD=.FALSE.
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFSAV,IUNMOD
585 FORMAT(' NMDIMB: ',I5,' modes are saved in unit',I5)
CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD,
1 AMASS)
CALL SAVEIT(IUNMOD)
GOTO I700
C
C-----------------------------------------------------------------------
C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION
720 CONTINUE
DDV2=ALLHP(IREAL8((PARDIM+3)*(PARDIM+3)))
JSPACE=IREAL8((PARDIM+4))*8
JSP=IREAL8(((PARDIM+3)*(PARDIM+4))/2)
JSPACE=JSPACE+JSP
DDSS=ALLHP(JSPACE)
DD5=DDSS+JSPACE-JSP
GOTO I720
C
C-----------------------------------------------------------------------
C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS
760 CONTINUE
IF(LBIG) THEN
DDVBAS=ALLHP(IREAL8(NAT3))
ELSE
DDVBAS=ALLHP(IREAL8(NFREG*NAT3))
ENDIF
GOTO I760
C
C-----------------------------------------------------------------------
C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
800 CONTINUE
TRAROT=ALLHP(IREAL8(6*NAT3))
GOTO I800
C
C-----------------------------------------------------------------------
C TO ALLOCATE-SPACE-FOR-LSCI
840 CONTINUE
SCIFV1=ALLHP(IREAL8(PARDIM+3))
SCIFV2=ALLHP(IREAL8(PARDIM+3))
SCIFV3=ALLHP(IREAL8(PARDIM+3))
SCIFV4=ALLHP(IREAL8(PARDIM+3))
SCIFV6=ALLHP(IREAL8(PARDIM+3))
DRATQ=ALLHP(IREAL8(PARDIM+3))
ERATQ=ALLHP(IREAL8(PARDIM+3))
E2RATQ=ALLHP(IREAL8(PARDIM+3))
BDRATQ=ALLHP(IREAL8(PARDIM+3))
INRATQ=ALLHP(INTEG4(PARDIM+3))
GOTO I840
C
C-----------------------------------------------------------------------
C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI
880 CONTINUE
SCIFV1=ALLHP(IREAL8(2))
SCIFV2=ALLHP(IREAL8(2))
SCIFV3=ALLHP(IREAL8(2))
SCIFV4=ALLHP(IREAL8(2))
SCIFV6=ALLHP(IREAL8(2))
DRATQ=ALLHP(IREAL8(2))
ERATQ=ALLHP(IREAL8(2))
E2RATQ=ALLHP(IREAL8(2))
BDRATQ=ALLHP(IREAL8(2))
INRATQ=ALLHP(INTEG4(2))
GOTO I880
C
C-----------------------------------------------------------------------
C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS
920 CONTINUE
IUPD=ALLHP(INTEG4(PARDIM+3))
GOTO I920
C.##ELSE
C.##ENDIF
END
gcc/testsuite/g77.f-torture/compile/20020307-1.f deleted 100644 → 0
SUBROUTINE SWEEP
PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20)
REAL*8 B,W1,W2,BNORM,BINV,WT,W0,C1,C2,R1,R2
DIMENSION B(MAXVEC,0:3),W1(MAXVEC,0:3),W2(MAXVEC,0:3)
DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC)
DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC)
DO 200 ILAT=1,2**IDIM
DO 200 I1=1,IDIM
DO 220 I2=1,IDIM
CALL INTACT(ILAT,I1,I1,W1)
220 CONTINUE
DO 310 IATT=1,IDIM
DO 311 I=1,100
WT(I)=ONE + C1(I)*LOG(EPS+R1(I))
IF( R2(I)**2 .LE. (ONE-WT(I)**2) )THEN
W0(I)=WT(I)
ENDIF
311 CONTINUE
310 CONTINUE
200 CONTINUE
END
gcc/testsuite/g77.f-torture/compile/20030115-1.c deleted 100644 → 0
SUBROUTINE FOO (B)
10 CALL BAR(A)
ASSIGN 20 TO M
IF(100.LT.A) GOTO 10
GOTO 40
C
20 IF(B.LT.ABS(A)) GOTO 10
ASSIGN 30 TO M
GOTO 40
C
30 ASSIGN 10 TO M
40 GOTO M,(10,20,30)
END
gcc/testsuite/g77.f-torture/compile/20030326-1.f deleted 100644 → 0
C PR fortran/9793
C larson@w6yx.stanford.edu
C
integer a, b, c
c = -2147483648 / -1
a = 1
b = 0
c = a / b
print *, c
end
gcc/testsuite/g77.f-torture/compile/8485.f deleted 100644 → 0
C Extracted from PR fortran/8485
PARAMETER (PPMULT = 1.0E5)
INTEGER*8 NWRONG
PARAMETER (NWRONG = 8)
PARAMETER (DDMULT = PPMULT * NWRONG)
PRINT 10, DDMULT
10 FORMAT (F10.3)
END
gcc/testsuite/g77.f-torture/compile/960317-1.f deleted 100644 → 0
* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST)
* From: Kate Hedstrom <kate@ahab.Rutgers.EDU>
* To: burley@gnu.ai.mit.edu
* Subject: g77 bug in assign
*
* I found some files in the NCAR graphics source code which used to
* compile with g77 and now don't. All contain the following combination
* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a
* Sun running SunOS 5.5 (slightly older g77), but compiles on an
* IBM/RS6000:
*
C
SUBROUTINE QUICK
SAVE
C
ASSIGN 101 TO JUMP
101 Continue
C
RETURN
END
*
* Everything else in the NCAR distribution compiled, including quite a
* few C routines.
*
* Kate
*
*
* nemo% g77 -v -c quick.f
* gcc -v -c -xf77 quick.f
* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/specs
* gcc version 2.7.2
* /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/f771 quick.f -fset-g77-defaults -quiet -dumpbase quick.f -version -fversion -o /usr/tmp/cca24166.s
* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.1.
* GNU Fortran Front End version 0.5.18-960314 compiled: Mar 16 1996 14:28:11
* gcc: Internal compiler error: program f771 got fatal signal 11
*
*
* nemo% gdb /usr/local/lib/gcc-lib/*/*/f771 core
* GDB is free software and you are welcome to distribute copies of it
* under certain conditions; type "show copying" to see the conditions.
* There is absolutely no warranty for GDB; type "show warranty" for details.
* GDB 4.14 (sparc-sun-sunos4.1.3),
* Copyright 1995 Free Software Foundation, Inc...
* Core was generated by `f771'.
* Program terminated with signal 11, Segmentation fault.
* Couldn't read input and local registers from core file
* find_solib: Can't read pathname for load map: I/O error
*
* Couldn't read input and local registers from core file
* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
* 7881 if ((ffesymbol_save (s) || ffe_is_saveall ())
* (gdb) where
* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
* Error accessing memory address 0xefffefcc: Invalid argument.
* (gdb)
*
*
* ahab% g77 -v -c quick.f
* gcc -v -c -xf77 quick.f
* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/specs
* gcc version 2.7.2
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase quick.f -version -fversion -o /var/tmp/cca003D2.s
* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.2.
* GNU Fortran Front End version 0.5.18-960304 compiled: Mar 5 1996 16:12:46
* gcc: Internal compiler error: program f771 got fatal signal 11
*
*
* ahab% !gdb
* gdb /usr/local/lib/gcc-lib/*/*/f771 core
* GDB is free software and you are welcome to distribute copies of it
* under certain conditions; type "show copying" to see the conditions.
* There is absolutely no warranty for GDB; type "show warranty" for details.
* GDB 4.15.1 (sparc-sun-solaris2.4),
* Copyright 1995 Free Software Foundation, Inc...
* Core was generated by
* `/usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase'.
* Program terminated with signal 11, Segmentation fault.
* Reading symbols from /usr/lib/libc.so.1...done.
* Reading symbols from /usr/lib/libdl.so.1...done.
* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
* Source file is more recent than executable.
* 7963 assert (st != NULL);
* (gdb) where
* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
* #1 0x38044 in ffecom_expr_ (expr=0x3a23c0, dest_tree=0x0, dest=0x0, dest_used=0x0, assignp=true) at f/com.c:2100
* #2 0x489c8 in ffecom_expr_assign_w (expr=0x3a23c0) at f/com.c:10238
* #3 0xe9228 in ffeste_R838 (label=0x3a1ba8, target=0x3a23c0) at f/ste.c:2769
* #4 0xdae60 in ffestd_stmt_pass_ () at f/std.c:840
* #5 0xdc090 in ffestd_exec_end () at f/std.c:1405
* #6 0xcb534 in ffestc_shriek_subroutine_ (ok=true) at f/stc.c:4849
* #7 0xd8f00 in ffestc_R1225 (name=0x0) at f/stc.c:12307
* #8 0xcc808 in ffestc_end () at f/stc.c:5572
* #9 0x9fa84 in ffestb_end3_ (t=0x3a19c8) at f/stb.c:3216
* #10 0x9f30c in ffestb_end (t=0x3a19c8) at f/stb.c:2995
* #11 0x98414 in ffesta_save_ (t=0x3a19c8) at f/sta.c:453
* #12 0x997ec in ffesta_second_ (t=0x3a19c8) at f/sta.c:1178
* #13 0x8ed84 in ffelex_send_token_ () at f/lex.c:1614
* #14 0x8cab8 in ffelex_finish_statement_ () at f/lex.c:946
* #15 0x91684 in ffelex_file_fixed (wf=0x397780, f=0x37a560) at f/lex.c:2946
* #16 0x107a94 in ffe_file (wf=0x397780, f=0x37a560) at f/top.c:456
* #17 0x96218 in yyparse () at f/parse.c:77
* #18 0x10beac in compile_file (name=0xdffffaf7 "quick.f") at toplev.c:2239
* #19 0x110dc0 in main (argc=9, argv=0xdffff994, envp=0xdffff9bc) at toplev.c:3927
gcc/testsuite/g77.f-torture/compile/970125-0.f deleted 100644 → 0
C JCB comments:
C g77 doesn't accept the added line "integer(kind=7) ..." --
C it crashes!
C
C It's questionable that g77 DTRT with regarding to passing
C %LOC() as an argument (thus by reference) and the new global
C analysis. I need to look into that further; my feeling is that
C passing %LOC() as an argument should be treated like passing an
C INTEGER(KIND=7) by reference, and no more specially than that
C (and that INTEGER(KIND=7) should be permitted as equivalent to
C INTEGER(KIND=1), INTEGER(KIND=2), or whatever, depending on the
C system's pointer size).
C
C The back end *still* has a bug here, which should be fixed,
C because, currently, what g77 is passing to it is, IMO, correct.
C No options:
C ../../egcs/gcc/f/info.c:259: failed assertion `ffeinfo_types_[basictype][kindtype] != NULL'
C -fno-globals -O:
C ../../egcs/gcc/expr.c:7291: Internal compiler error in function expand_expr
c Frontend bug fixed by JCB 1998-06-01 com.c &c changes.
integer*4 i4
integer*8 i8
integer*8 max4
data max4/2147483647/
i4 = %loc(i4)
i8 = %loc(i8)
print *, max4
print *, i4, %loc(i4)
print *, i8, %loc(i8)
call foo(i4, %loc(i4), i8, %loc(i8))
end
subroutine foo(i4, i4a, i8, i8a)
integer(kind=7) i4a, i8a
integer*8 i8
print *, i4, i4a
print *, i8, i8a
end
gcc/testsuite/g77.f-torture/compile/970915-0.f deleted 100644 → 0
* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR
* node twice in a given top-level call to it.
* (JCB com.c patch of 1998-06-04.)
SUBROUTINE TSTSIG11
IMPLICIT COMPLEX (A-Z)
EXTERNAL gzi1,gzi2
branch3 = sw2 / cw
. * ( rdw * (epsh*gzi1(A,B)-gzi2(A,B))
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
. + (-1./2. + 2.*sw2/3.) / (sw*cw)
. * rdw * (epsh*gzi1(A,B)-gzi2(A,B)
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B))
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
. * rup * (epsh*gzi1(A,B)-gzi2(A,B)
. + rup * (epsh*gzi1(A,B)-gzi2(A,B)) )
. * 4.*(3.-tw**2) * gzi2(A,B)
. + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B)
RETURN
END
gcc/testsuite/g77.f-torture/compile/980310-1.f deleted 100644 → 0
C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4
C To: egcs-bugs@cygnus.com
C Subject: backend case range problem/fix
C From: Dave Love <d.love@dl.ac.uk>
C Date: 02 Dec 1997 18:11:35 +0000
C Message-ID: <rzqpvnfboo8.fsf@djlvig.dl.ac.uk>
C
C The following Fortran test case aborts the compiler because
C tree_int_cst_lt dereferences a null tree; this is a regression from
C gcc 2.7.
INTEGER N
READ(*,*) N
SELECT CASE (N)
CASE (1:)
WRITE(*,*) 'case 1'
CASE (0)
WRITE(*,*) 'case 0'
END SELECT
END
C The relevant change to cure this is:
C
C Thu Dec 4 06:34:40 1997 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
C
C * stmt.c (pushcase_range): Clean up handling of "infinite" values.
C
gcc/testsuite/g77.f-torture/compile/980310-2.f deleted 100644 → 0
C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl
C
C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT)
C From: David Bristow <dbristow@lynx.dac.neu.edu>
C To: egcs-bugs@cygnus.com
C Subject: g77 crashes compiling Dungeon
C Message-ID: <Pine.OSF.3.91.970823003521.11281A-100000@lynx.dac.neu.edu>
C
C The following small segment of Dungeon (the adventure that became the
C commercial hit Zork) causes an internal error in f771. The platform is
C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran
C 0.5.21-19970811)
C
C --cut here--cut here--cut here--cut here--cut here--cut here--
C g77 --verbose -fugly -fvxt -c subr_.f
C g77 version 0.5.21-19970811
C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm
C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs
C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental)
C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s
C f771: warning: -fugly is overloaded with meanings and likely to be removed;
C f771: warning: use only the specific -fugly-* options you need
C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental).
C GNU Fortran Front End version 0.5.21-19970811
C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))'
C gcc: Internal compiler error: program f771 got fatal signal 6
C --cut here--cut here--cut here--cut here--cut here--cut here--
C
C Here's the FORTRAN code, it's basically a single subroutine from subr.f
C in the Dungeon source, slightly altered (the original calls RAN(), which
C doesn't exist in the g77 runtime)
C
C RND - Return a random integer mod n
C
INTEGER FUNCTION RND (N)
IMPLICIT INTEGER (A-Z)
REAL RAND
COMMON /SEED/ RNSEED
RND = RAND(RNSEED)*FLOAT(N)
RETURN
END
gcc/testsuite/g77.f-torture/compile/980310-3.f deleted 100644 → 0
c
c This demonstrates a problem with g77 and pic on x86 where
c egcs 1.0.1 and earlier will generate bogus assembler output.
c unfortunately, gas accepts the bogus acssembler output and
c generates code that almost works.
c
C Date: Wed, 17 Dec 1997 23:20:29 +0000
C From: Joao Cardoso <jcardoso@inescn.pt>
C To: egcs-bugs@cygnus.com
C Subject: egcs-1.0 f77 bug on OSR5
C When trying to compile the Fortran file that I enclose bellow,
C I got an assembler error:
C
C ./g77 -B./ -fpic -O -c scaleg.f
C /usr/tmp/cca002D8.s:123:syntax error at (
C
C ./g77 -B./ -fpic -O0 -c scaleg.f
C /usr/tmp/cca002EW.s:246:invalid operand combination: leal
C
C Compiling without the -fpic flag runs OK.
subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
c
c *****parameters:
integer igh,low,ma,mb,n
double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
c
c *****local variables:
integer i,ir,it,j,jc,kount,nr,nrp2
double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor,
* ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc
c
c *****fortran functions:
double precision dabs, dlog10, dsign
c float
c
c *****subroutines called:
c none
c
c ---------------------------------------------------------------
c
c *****purpose:
c scales the matrices a and b in the generalized eigenvalue
c problem a*x = (lambda)*b*x such that the magnitudes of the
c elements of the submatrices of a and b (as specified by low
c and igh) are close to unity in the least squares sense.
c ref.: ward, r. c., balancing the generalized eigenvalue
c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
c 141-152.
c
c *****parameter description:
c
c on input:
c
c ma,mb integer
c row dimensions of the arrays containing matrices
c a and b respectively, as declared in the main calling
c program dimension statement;
c
c n integer
c order of the matrices a and b;
c
c a real(ma,n)
c contains the a matrix of the generalized eigenproblem
c defined above;
c
c b real(mb,n)
c contains the b matrix of the generalized eigenproblem
c defined above;
c
c low integer
c specifies the beginning -1 for the rows and
c columns of a and b to be scaled;
c
c igh integer
c specifies the ending -1 for the rows and columns
c of a and b to be scaled;
c
c cperm real(n)
c work array. only locations low through igh are
c referenced and altered by this subroutine;
c
c wk real(n,6)
c work array that must contain at least 6*n locations.
c only locations low through igh, n+low through n+igh,
c ..., 5*n+low through 5*n+igh are referenced and
c altered by this subroutine.
c
c on output:
c
c a,b contain the scaled a and b matrices;
c
c cscale real(n)
c contains in its low through igh locations the integer
c exponents of 2 used for the column scaling factors.
c the other locations are not referenced;
c
c wk contains in its low through igh locations the integer
c exponents of 2 used for the row scaling factors.
c
c *****algorithm notes:
c none.
c
c *****history:
c written by r. c. ward.......
c modified 8/86 by bobby bodenheimer so that if
c sum = 0 (corresponding to the case where the matrix
c doesn't need to be scaled) the routine returns.
c
c ---------------------------------------------------------------
c
if (low .eq. igh) go to 410
do 210 i = low,igh
wk(i,1) = 0.0d0
wk(i,2) = 0.0d0
wk(i,3) = 0.0d0
wk(i,4) = 0.0d0
wk(i,5) = 0.0d0
wk(i,6) = 0.0d0
cscale(i) = 0.0d0
cperm(i) = 0.0d0
210 continue
c
c compute right side vector in resulting linear equations
c
basl = dlog10(2.0d0)
do 240 i = low,igh
do 240 j = low,igh
tb = b(i,j)
ta = a(i,j)
if (ta .eq. 0.0d0) go to 220
ta = dlog10(dabs(ta)) / basl
220 continue
if (tb .eq. 0.0d0) go to 230
tb = dlog10(dabs(tb)) / basl
230 continue
wk(i,5) = wk(i,5) - ta - tb
wk(j,6) = wk(j,6) - ta - tb
240 continue
nr = igh-low+1
coef = 1.0d0/float(2*nr)
coef2 = coef*coef
coef5 = 0.5d0*coef2
nrp2 = nr+2
beta = 0.0d0
it = 1
c
c start generalized conjugate gradient iteration
c
250 continue
ew = 0.0d0
ewc = 0.0d0
gamma = 0.0d0
do 260 i = low,igh
gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
ew = ew + wk(i,5)
ewc = ewc + wk(i,6)
260 continue
gamma = coef*gamma - coef2*(ew**2 + ewc**2)
+ - coef5*(ew - ewc)**2
if (it .ne. 1) beta = gamma / pgamma
t = coef5*(ewc - 3.0d0*ew)
tc = coef5*(ew - 3.0d0*ewc)
do 270 i = low,igh
wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
270 continue
c
c apply matrix to vector
c
do 300 i = low,igh
kount = 0
sum = 0.0d0
do 290 j = low,igh
if (a(i,j) .eq. 0.0d0) go to 280
kount = kount+1
sum = sum + cperm(j)
280 continue
if (b(i,j) .eq. 0.0d0) go to 290
kount = kount+1
sum = sum + cperm(j)
290 continue
wk(i,3) = float(kount)*wk(i,2) + sum
300 continue
do 330 j = low,igh
kount = 0
sum = 0.0d0
do 320 i = low,igh
if (a(i,j) .eq. 0.0d0) go to 310
kount = kount+1
sum = sum + wk(i,2)
310 continue
if (b(i,j) .eq. 0.0d0) go to 320
kount = kount+1
sum = sum + wk(i,2)
320 continue
wk(j,4) = float(kount)*cperm(j) + sum
330 continue
sum = 0.0d0
do 340 i = low,igh
sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
340 continue
if(sum.eq.0.0d0) return
alpha = gamma / sum
c
c determine correction to current iterate
c
cmax = 0.0d0
do 350 i = low,igh
cor = alpha * wk(i,2)
if (dabs(cor) .gt. cmax) cmax = dabs(cor)
wk(i,1) = wk(i,1) + cor
cor = alpha * cperm(i)
if (dabs(cor) .gt. cmax) cmax = dabs(cor)
cscale(i) = cscale(i) + cor
350 continue
if (cmax .lt. 0.5d0) go to 370
do 360 i = low,igh
wk(i,5) = wk(i,5) - alpha*wk(i,3)
wk(i,6) = wk(i,6) - alpha*wk(i,4)
360 continue
pgamma = gamma
it = it+1
if (it .le. nrp2) go to 250
c
c end generalized conjugate gradient iteration
c
370 continue
do 380 i = low,igh
ir = wk(i,1) + dsign(0.5d0,wk(i,1))
wk(i,1) = ir
jc = cscale(i) + dsign(0.5d0,cscale(i))
cscale(i) = jc
380 continue
c
c scale a and b
c
do 400 i = 1,igh
ir = wk(i,1)
fi = 2.0d0**ir
if (i .lt. low) fi = 1.0d0
do 400 j =low,n
jc = cscale(j)
fj = 2.0d0**jc
if (j .le. igh) go to 390
if (i .lt. low) go to 400
fj = 1.0d0
390 continue
a(i,j) = a(i,j)*fi*fj
b(i,j) = b(i,j)*fi*fj
400 continue
410 continue
return
c
c last line of scaleg
c
end
gcc/testsuite/g77.f-torture/compile/980310-4.f deleted 100644 → 0
C To: egcs-bugs@cygnus.com
C Subject: -fPIC problem showing up with fortran on x86
C From: Dave Love <d.love@dl.ac.uk>
C Date: 19 Dec 1997 19:31:41 +0000
C
C
C This illustrates a long-standing problem noted at the end of the g77
C `Actual Bugs' info node and thought to be in the back end. Although
C the report is against gcc 2.7 I can reproduce it (specifically on
C redhat 4.2) with the 971216 egcs snapshot.
C
C g77 version 0.5.21
C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone
C -lf2c -lm
C
C ------------
subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr,
* neval,ier,alist,blist,rlist,elist,iord,last)
C --------------------------------------------------
C
C Modified Feb 1989 by Barry W. Brown to eliminate key
C as argument (use key=1) and to eliminate all Fortran
C output.
C
C Purpose: to make this routine usable from within S.
C
C --------------------------------------------------
c***begin prologue dqage
c***date written 800101 (yymmdd)
c***revision date 830518 (yymmdd)
c***category no. h2a1a1
c***keywords automatic integrator, general-purpose,
c integrand examinator, globally adaptive,
c gauss-kronrod
c***author piessens,robert,appl. math. & progr. div. - k.u.leuven
c de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose the routine calculates an approximation result to a given
c definite integral i = integral of f over (a,b),
c hopefully satisfying following claim for accuracy
c abs(i-reslt).le.max(epsabs,epsrel*abs(i)).
c***description
c
c computation of a definite integral
c standard fortran subroutine
c double precision version
c
c parameters
c on entry
c f - double precision
c function subprogram defining the integrand
c function f(x). the actual name for f needs to be
c declared e x t e r n a l in the driver program.
c
c a - double precision
c lower limit of integration
c
c b - double precision
c upper limit of integration
c
c epsabs - double precision
c absolute accuracy requested
c epsrel - double precision
c relative accuracy requested
c if epsabs.le.0
c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c the routine will end with ier = 6.
c
c key - integer
c key for choice of local integration rule
c a gauss-kronrod pair is used with
c 7 - 15 points if key.lt.2,
c 10 - 21 points if key = 2,
c 15 - 31 points if key = 3,
c 20 - 41 points if key = 4,
c 25 - 51 points if key = 5,
c 30 - 61 points if key.gt.5.
c
c limit - integer
c gives an upperbound on the number of subintervals
c in the partition of (a,b), limit.ge.1.
c
c on return
c result - double precision
c approximation to the integral
c
c abserr - double precision
c estimate of the modulus of the absolute error,
c which should equal or exceed abs(i-result)
c
c neval - integer
c number of integrand evaluations
c
c ier - integer
c ier = 0 normal and reliable termination of the
c routine. it is assumed that the requested
c accuracy has been achieved.
c ier.gt.0 abnormal termination of the routine
c the estimates for result and error are
c less reliable. it is assumed that the
c requested accuracy has not been achieved.
c error messages
c ier = 1 maximum number of subdivisions allowed
c has been achieved. one can allow more
c subdivisions by increasing the value
c of limit.
c however, if this yields no improvement it
c is rather advised to analyze the integrand
c in order to determine the integration
c difficulties. if the position of a local
c difficulty can be determined(e.g.
c singularity, discontinuity within the
c interval) one will probably gain from
c splitting up the interval at this point
c and calling the integrator on the
c subranges. if possible, an appropriate
c special-purpose integrator should be used
c which is designed for handling the type of
c difficulty involved.
c = 2 the occurrence of roundoff error is
c detected, which prevents the requested
c tolerance from being achieved.
c = 3 extremely bad integrand behavior occurs
c at some points of the integration
c interval.
c = 6 the input is invalid, because
c (epsabs.le.0 and
c epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c result, abserr, neval, last, rlist(1) ,
c elist(1) and iord(1) are set to zero.
c alist(1) and blist(1) are set to a and b
c respectively.
c
c alist - double precision
c vector of dimension at least limit, the first
c last elements of which are the left
c end points of the subintervals in the partition
c of the given integration range (a,b)
c
c blist - double precision
c vector of dimension at least limit, the first
c last elements of which are the right
c end points of the subintervals in the partition
c of the given integration range (a,b)
c
c rlist - double precision
c vector of dimension at least limit, the first
c last elements of which are the
c integral approximations on the subintervals
c
c elist - double precision
c vector of dimension at least limit, the first
c last elements of which are the moduli of the
c absolute error estimates on the subintervals
c
c iord - integer
c vector of dimension at least limit, the first k
c elements of which are pointers to the
c error estimates over the subintervals,
c such that elist(iord(1)), ...,
c elist(iord(k)) form a decreasing sequence,
c with k = last if last.le.(limit/2+2), and
c k = limit+1-last otherwise
c
c last - integer
c number of subintervals actually produced in the
c subdivision process
c
c***references (none)
c***routines called d1mach,dqk15,dqk21,dqk31,
c dqk41,dqk51,dqk61,dqpsrt
c***end prologue dqage
c
double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b,
* blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach,
* epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f,
* resabs,result,rlist,uflow
integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval,
* nrmax
c
dimension alist(limit),blist(limit),elist(limit),iord(limit),
* rlist(limit)
c
external f
c
c list of major variables
c -----------------------
c
c alist - list of left end points of all subintervals
c considered up to now
c blist - list of right end points of all subintervals
c considered up to now
c rlist(i) - approximation to the integral over
c (alist(i),blist(i))
c elist(i) - error estimate applying to rlist(i)
c maxerr - pointer to the interval with largest
c error estimate
c errmax - elist(maxerr)
c area - sum of the integrals over the subintervals
c errsum - sum of the errors over the subintervals
c errbnd - requested accuracy max(epsabs,epsrel*
c abs(result))
c *****1 - variable for the left subinterval
c *****2 - variable for the right subinterval
c last - index for subdivision
c
c
c machine dependent constants
c ---------------------------
c
c epmach is the largest relative spacing.
c uflow is the smallest positive magnitude.
c
c***first executable statement dqage
epmach = d1mach(4)
uflow = d1mach(1)
c
c test on validity of parameters
c ------------------------------
c
ier = 0
neval = 0
last = 0
result = 0.0d+00
abserr = 0.0d+00
alist(1) = a
blist(1) = b
rlist(1) = 0.0d+00
elist(1) = 0.0d+00
iord(1) = 0
if(epsabs.le.0.0d+00.and.
* epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6
if(ier.eq.6) go to 999
c
c first approximation to the integral
c -----------------------------------
c
neval = 0
call dqk15(f,a,b,result,abserr,defabs,resabs)
last = 1
rlist(1) = result
elist(1) = abserr
iord(1) = 1
c
c test on accuracy.
c
errbnd = dmax1(epsabs,epsrel*dabs(result))
if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2
if(limit.eq.1) ier = 1
if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs)
* .or.abserr.eq.0.0d+00) go to 60
c
c initialization
c --------------
c
c
errmax = abserr
maxerr = 1
area = result
errsum = abserr
nrmax = 1
iroff1 = 0
iroff2 = 0
c
c main do-loop
c ------------
c
do 30 last = 2,limit
c
c bisect the subinterval with the largest error estimate.
c
a1 = alist(maxerr)
b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
a2 = b1
b2 = blist(maxerr)
call dqk15(f,a1,b1,area1,error1,resabs,defab1)
call dqk15(f,a2,b2,area2,error2,resabs,defab2)
c
c improve previous approximations to integral
c and error and test for accuracy.
c
neval = neval+1
area12 = area1+area2
erro12 = error1+error2
errsum = errsum+erro12-errmax
area = area+area12-rlist(maxerr)
if(defab1.eq.error1.or.defab2.eq.error2) go to 5
if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12)
* .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1
if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1
5 rlist(maxerr) = area1
rlist(last) = area2
errbnd = dmax1(epsabs,epsrel*dabs(area))
if(errsum.le.errbnd) go to 8
c
c test for roundoff error and eventually set error flag.
c
if(iroff1.ge.6.or.iroff2.ge.20) ier = 2
c
c set error flag in the case that the number of subintervals
c equals limit.
c
if(last.eq.limit) ier = 1
c
c set error flag in the case of bad integrand behavior
c at a point of the integration range.
c
if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*
* epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3
c
c append the newly-created intervals to the list.
c
8 if(error2.gt.error1) go to 10
alist(last) = a2
blist(maxerr) = b1
blist(last) = b2
elist(maxerr) = error1
elist(last) = error2
go to 20
10 alist(maxerr) = a2
alist(last) = a1
blist(last) = b1
rlist(maxerr) = area2
rlist(last) = area1
elist(maxerr) = error2
elist(last) = error1
c
c call subroutine dqpsrt to maintain the descending ordering
c in the list of error estimates and select the subinterval
c with the largest error estimate (to be bisected next).
c
20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
if(ier.ne.0.or.errsum.le.errbnd) go to 40
30 continue
c
c compute final result.
c ---------------------
c
40 result = 0.0d+00
do 50 k=1,last
result = result+rlist(k)
50 continue
abserr = errsum
60 neval = 30*neval+15
999 return
end
gcc/testsuite/g77.f-torture/compile/980310-6.f deleted 100644 → 0
C From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de>
C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de>
C Subject: 971105 g77 bug
C To: egcs-bugs@cygnus.com
C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET)
C I found a bug in g77 in snapshot 971105
subroutine ai (a)
dimension a(-1:*)
return
end
C ai.f: In subroutine `ai':
C ai.f:1:
C subroutine ai (a)
C ^
C Array `a' at (^) is too large to handle
C
C This happens whenever the lower index boundary is negative and the upper index
C boundary is '*'.
gcc/testsuite/g77.f-torture/compile/980310-7.f deleted 100644 → 0
C From: "David C. Doherty" <doherty@networkcs.com>
C Message-Id: <199711171846.MAA27947@uh.msc.edu>
C Subject: g77: auto arrays + goto = no go
C To: egcs-bugs@cygnus.com
C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST)
C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love
C replied that he was able to reproduce it on rs6000-aix; not on
C others. He suggested that I send it to egcs-bugs.
C Hi - I've observed the following behavior regarding
C automatic arrays and gotos. Seems similar to what I found
C in the docs about computed gotos (but not exactly the same).
C
C I suspect from the nature of the error msg that it's in the GBE.
C
C I'm using egcs-971105, under linux-ppc.
C
C I also observed the same in g77-0.5.19 (and gcc 2.7.2?).
C
C I'd appreciate any advice on this. thanks for the great work.
C --
C >cat testg77.f
subroutine testg77(n, a)
c
implicit none
c
integer n
real a(n)
real b(n)
integer i
c
do i = 1, 10
if (i .gt. 4) goto 100
write(0, '(i2)')i
enddo
c
goto 200
100 continue
200 continue
c
return
end
C >g77 -c testg77.f
C testg77.f: In subroutine `testg77':
C testg77.f:19: label `200' used before containing binding contour
C testg77.f:18: label `100' used before containing binding contour
C --
C If I comment out the b(n) line or replace it with, e.g., b(10),
C it compiles fine.
gcc/testsuite/g77.f-torture/compile/980310-8.f deleted 100644 → 0
C To: egcs-bugs@cygnus.com
C Subject: egcs-g77 and array indexing
C Reply-To: etseidl@jutland.ca.sandia.gov
C Date: Wed, 26 Nov 1997 10:38:27 -0800
C From: Edward Seidl <etseidl@jutland.ca.sandia.gov>
C
C I have some horrible spaghetti code I'm trying compile with egcs-g77,
C but it's puking on code like the example below. I have no idea if it's
C legal fortran or not, and I'm in no position to change it. All I do know
C is it compiles with a number of other compilers, including f2c and
C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122
C I get the following (on both i686-pc-linux-gnu and alphaev56-unknown-linux-gnu):
C
C foo.f: In subroutine `foobar':
C foo.f:11:
C subroutine foobar(norb,nnorb)
C ^
C Array `norb' at (^) is too large to handle
program foo
implicit integer(A-Z)
dimension norb(6)
nnorb=6
call foobar(norb,nnorb)
stop
end
subroutine foobar(norb,nnorb)
implicit integer(A-Z)
dimension norb(-1:*)
do 10 i=-1,nnorb-2
norb(i) = i+999
10 continue
return
end
gcc/testsuite/g77.f-torture/compile/980419-2.f deleted 100644 → 0
c SEGVs in loop.c with -O2.
character*80 function nxtlin(lun,ierr,itok)
character onechr*1,twochr*2,thrchr*3
itok=0
do while (.true.)
read (lun,'(a)',iostat=ierr) nxtlin
if (nxtlin(1:1).ne.'#') then
ito=0
do 10 it=1,79
if (nxtlin(it:it).ne.' ' .and. nxtlin(it+1:it+1).eq.' ')
$ then
itast=0
itstrt=0
do itt=ito+1,it
if (nxtlin(itt:itt).eq.'*') itast=itt
enddo
itstrt=ito+1
do while (nxtlin(itstrt:itstrt).eq.' ')
itstrt=itstrt+1
enddo
if (itast.gt.0) then
nchrs=itast-itstrt
if (nchrs.eq.1) then
onechr=nxtlin(itstrt:itstrt)
read (onechr,*) itokn
elseif (nchrs.eq.2) then
twochr=nxtlin(itstrt:itstrt+1)
read (twochr,*) itokn
elseif (nchrs.eq.3) then
thrchr=nxtlin(itstrt:itstrt+2)
read (thrchr,*) itokn
elseif (nchrs.eq.4) then
thrchr=nxtlin(itstrt:itstrt+3)
read (thrchr,*) itokn
endif
itok=itok+itokn
else
itok=itok+1
endif
ito=it+1
endif
10 continue
return
endif
enddo
return
end
gcc/testsuite/g77.f-torture/compile/980424-0.f deleted 100644 → 0
C crashes in subst_stack_regs_pat on x86-linux, in the "abort();"
C within the switch statement.
SUBROUTINE C(A)
COMPLEX A
WRITE(*,*) A.NE.CMPLX(0.0D0)
END
gcc/testsuite/g77.f-torture/compile/980427-0.f deleted 100644 → 0
c ../../egcs/gcc/f/com.c:938: failed assertion `TREE_CODE (TREE_TYPE (e)) == REAL_TYPE'
c Fixed by 28-04-1998 global.c (ffeglobal_ref_progunit_) change.
external b
call y(b)
end
subroutine x
a = b()
end
gcc/testsuite/g77.f-torture/compile/980519-2.f deleted 100644 → 0
* Date: Fri, 17 Apr 1998 14:12:51 +0200
* From: Jean-Paul Jeannot <jeannot@gx-tech.fr>
* Organization: GX Technology France
* To: egcs-bugs@cygnus.com
* Subject: identified bug in g77 on Alpha
*
* Dear Sir,
*
* You will find below the assembly code of a simple Fortran routine which
* crashes with segmentation fault when storing the first element
* in( jT_f-hd_T ) = Xsp
* whereas everything is fine when commenting this line.
*
* The assembly code (generated with
* -ffast-math -fexpensive-optimizations -fomit-frame-pointer -fno-inline
* or with -O5)
* uses a zapnot instruction to copy an address.
* BUT the zapnot parameter is 15 (copuing 4 bytes) instead of 255 (to copy
* 8 bytes).
*
* I guess this is typically a 64 bit issue. As, from my understanding,
* zapnots are used a lot to copy registers, this may create problems
* elsewhere.
*
* Thanks for your help
*
* Jean-Paul Jeannot
*
subroutine simul_trace( in, Xsp, Ysp, Xrcv, Yrcv )
common /Idim/ jT_f, jT_l, nT, nT_dim
common /Idim/ jZ_f, jZ_l, nZ, nZ_dim
common /Idim/ jZ2_f, jZ2_l, nZ2, nZ2_dim
common /Idim/ jzs_f, jzs_l, nzs, nzs_dim, l_amp
common /Idim/ hd_S, hd_Z, hd_T
common /Idim/ nlay, nlayz
common /Idim/ n_work
common /Idim/ nb_calls
real Xsp, Ysp, Xrcv, Yrcv
real in( jT_f-hd_T : jT_l )
in( jT_f-hd_T ) = Xsp
in( jT_f-hd_T + 1 ) = Ysp
in( jT_f-hd_T + 2 ) = Xrcv
in( jT_f-hd_T + 3 ) = Yrcv
end
gcc/testsuite/g77.f-torture/compile/980729-0.f deleted 100644 → 0
c Got ICE on Alpha only with -mieee (currently not tested).
c Fixed by rth 1998-07-30 alpha.md change.
subroutine a(b,c)
b = max(b,c)
end
gcc/testsuite/g77.f-torture/compile/981117-1.f deleted 100644 → 0
* egcs-bugs:
* From: Martin Kahlert <martin.kahlert@mchp.siemens.de>
* Subject: ICE in g77 from egcs-19981109
* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de>
* As of 1998-11-17, fails -O2 -fomit-frame-pointer with
* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints:
* (insn 31 83 32 (set (reg:SF 8 %st(0))
* (mult:SF (reg:SF 8 %st(0))
* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil)
* (nil))
* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn
* Fixed sometime before 1998-11-21 -- don't know by which change.
SUBROUTINE SSPTRD
PARAMETER (HALF = 0.5 )
DO I = 1, N
CALL SSPMV(TAUI)
ALPHA = -HALF*TAUI
CALL SAXPY(ALPHA)
ENDDO
END
gcc/testsuite/g77.f-torture/compile/990115-1.f deleted 100644 → 0
C Derived from lapack
SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, RWORK, INFO )
COMPLEX*16 WORK( * )
DO 20 I = 1, RANK
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
END
gcc/testsuite/g77.f-torture/compile/alpha1.f deleted 100644 → 0
REAL*8 A,B,C
REAL*4 RARRAY(19)/19*(-1)/
INTEGER BOTTOM,RIGHT
INTEGER IARRAY(19)/0,0,0,0,0,0,0,0,0,0,0,0,13,14,0,0,0,0,0/
EQUIVALENCE (RARRAY(13),BOTTOM),(RARRAY(14),RIGHT)
C
IF(I.NE.0) call exit(1)
C gcc: Internal compiler error: program f771 got fatal signal 11
C at this point!
END
gcc/testsuite/g77.f-torture/compile/alpha1.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/compile/compile.exp deleted 100644 → 0
# Expect driver script for GCC Regression Tests
# Copyright (C) 1993, 1995, 1997 Free Software Foundation
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# These tests come from Torbjorn Granlund's (tege@cygnus.com)
# F torture test suite, and other contributors.
if $tracelevel then {
strace $tracelevel
}
# load support procs
load_lib f-torture.exp
foreach testcase [glob -nocomplain $srcdir/$subdir/*.f] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] then {
continue
}
f-torture $testcase
}
foreach testcase [glob -nocomplain $srcdir/$subdir/*.F] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] then {
continue
}
f-torture $testcase
}
gcc/testsuite/g77.f-torture/compile/cpp.F deleted 100644 → 0
C When run through the C preprocessor, the indentation of the
C CONTINUE line must not be mangled.
subroutine aap(a, n)
dimension a(n)
do 10 i = 1, n
a(i) = i
10 continue
print *, a(1)
end
gcc/testsuite/g77.f-torture/compile/cpp2.F deleted 100644 → 0
C The preprocessor must not introduce a newline after
C the "a" when ARGUMENTS is expanded.
#define ARGUMENTS a\
subroutine yada (ARGUMENTS)
end
gcc/testsuite/g77.f-torture/compile/toon_1.f deleted 100644 → 0
SUBROUTINE AAP(NOOT)
DIMENSION NOOT(*)
END
gcc/testsuite/g77.f-torture/compile/xformat.f deleted 100644 → 0
PRINT 10, 2, 3
10 FORMAT (I1, X, I1)
END
gcc/testsuite/g77.f-torture/execute/10197.f deleted 100644 → 0
IMPLICIT NONE
LOGICAL ERROR
CHARACTER*12 FORM
DATA ERROR /.FALSE./
DATA FORM /' '/
OPEN(UNIT=60,ACCESS='DIRECT',STATUS='SCRATCH',RECL=255)
INQUIRE(UNIT=60,FORM=FORM)
IF (FORM.EQ.'UNFORMATTED') THEN
ERROR = .FALSE.
ELSE
ERROR = .TRUE.
ENDIF
CLOSE(UNIT=60)
IF (ERROR) CALL ABORT
END
gcc/testsuite/g77.f-torture/execute/10197.x deleted 100644 → 0
# Scratch files aren't implemented for mmixware
# (_stat is a stub and files can't be deleted).
# Similar restrictions exist for most simulators.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscale*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_execute_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/execute/13037.f deleted 100644 → 0
c PR optimization/13037
c Contributed by Kirill Smelkov
c bug symptom: zeta(kkzc) seems to reference to zeta(kkzc-1) instead
c with gcc-3.2.2 it is OK, so it is a regression.
c
subroutine bug1(expnt)
implicit none
double precision zeta
common /bug1_area/zeta(3)
double precision expnt(3)
integer k, kkzc
kkzc=0
do k=1,3
kkzc = kkzc + 1
zeta(kkzc) = expnt(k)
enddo
c the following line activates the bug
call bug1_activator(kkzc)
end
c dummy subroutine
subroutine bug1_activator(inum)
implicit none
integer inum
end
c test driver
program test_bug1
implicit none
double precision zeta
common /bug1_area/zeta(3)
double precision expnt(3)
zeta(1) = 0.0d0
zeta(2) = 0.0d0
zeta(3) = 0.0d0
expnt(1) = 1.0d0
expnt(2) = 2.0d0
expnt(3) = 3.0d0
call bug1(expnt)
if ((zeta(1).ne.1) .or. (zeta(2).ne.2) .or. (zeta(3).ne.3)) then
call abort
endif
end
gcc/testsuite/g77.f-torture/execute/1832.f deleted 100644 → 0
character*120 file
character*5 string
file = "c:/dos/adir/bdir/cdir/text.doc"
write(string, *) "a ", file
if (string .ne. ' a') call abort
C-- The leading space is normal for list-directed output
C-- "file" is not printed because it would overflow "string".
end
gcc/testsuite/g77.f-torture/execute/19981119-0.f deleted 100644 → 0
* X-Delivered: at request of burley on mescaline.gnu.org
* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET)
* From: "B. Yanchitsky" <yan@im.imag.kiev.ua>
* To: fortran@gnu.org
* Subject: Bug report
* MIME-Version: 1.0
* Content-Type: TEXT/PLAIN; charset=US-ASCII
*
* There is a trouble with g77 on Alpha.
* My configuration:
* Digital Personal Workstation 433au,
* Digital Unix 4.0D,
* GNU Fortran 0.5.23 and GNU C 2.8.1.
*
* The following program treated successfully but crashed when running.
*
* C --- PROGRAM BEGIN -------
*
subroutine sub(N,u)
integer N
double precision u(-N:N,-N:N)
C vvvv CRASH HERE vvvvv
u(-N,N)=0d0
return
end
program bug
integer N
double precision a(-10:10,-10:10)
data a/441*1d0/
N=10
call sub(N,a)
if (a(-N,N) .ne. 0d0) call abort
end
*
* C --- PROGRAM END -------
*
* Good luck!
gcc/testsuite/g77.f-torture/execute/19990313-0.f deleted 100644 → 0
* To: craig@jcb-sc.com
* Subject: Re: G77 and KIND=2
* Content-Type: text/plain; charset=us-ascii
* From: Dave Love <d.love@dl.ac.uk>
* Date: 03 Mar 1999 18:20:11 +0000
* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000"
* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3
* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0
*
* ISTM that there is a real problem printing integer*8 (on x86):
*
* $ cat x.f
*[modified for test suite]
integer *8 foo, bar
data r/4e10/
foo = 4e10
bar = r
if (foo .ne. bar) call abort
end
* $ g77 x.f && ./a.out
* 1345294336
* 123
* $ f2c x.f && g77 x.c && ./a.out
* x.f:
* MAIN:
* 40000000000
* 123
* $
*
* Gdb shows the upper half of the buffer passed to do_lio is zeroed in
* the g77 case.
*
* I've forgotten how the code generation happens.
gcc/testsuite/g77.f-torture/execute/19990313-1.f deleted 100644 → 0
integer *8 foo, bar
double precision r
data r/4d10/
foo = 4d10
bar = r
if (foo .ne. bar) call abort
end
gcc/testsuite/g77.f-torture/execute/19990313-2.f deleted 100644 → 0
integer *8 foo, bar
complex c
data c/(4e10,0)/
foo = 4e10
bar = c
if (foo .ne. bar) call abort
end
gcc/testsuite/g77.f-torture/execute/19990313-3.f deleted 100644 → 0
integer *8 foo, bar
double complex c
data c/(4d10,0)/
foo = 4d10
bar = c
if (foo .ne. bar) call abort
end
gcc/testsuite/g77.f-torture/execute/19990325-0.f deleted 100644 → 0
* test whether complex operators properly handle
* full and partial aliasing.
* (libf2c/libF77 routines used to assume no aliasing,
* then were changed to accommodate full aliasing, while
* the libg2c/libF77 versions were changed to accommodate
* both full and partial aliasing.)
*
* NOTE: this (19990325-0.f) is the single-precision version.
* See 19990325-1.f for the double-precision version.
program complexalias
implicit none
* Make sure non-aliased cases work. (Catch roundoff/precision
* problems, etc., here. Modify subroutine check if they occur.)
call tryfull (1, 3, 5)
* Now check various combinations of aliasing.
* Full aliasing.
call tryfull (1, 1, 5)
* Partial aliasing.
call trypart (2, 3, 5)
call trypart (2, 1, 5)
call trypart (2, 5, 3)
call trypart (2, 5, 1)
end
subroutine tryfull (xout, xin1, xin2)
implicit none
integer xout, xin1, xin2
* out, in1, and in2 are the desired indexes into the REAL array (array).
complex expect
integer pwr
integer out, in1, in2
real array(6)
complex carray(3)
equivalence (carray(1), array(1))
* Make sure the indexes can be accommodated by the equivalences above.
if (mod (xout, 2) .ne. 1) call abort
if (mod (xin1, 2) .ne. 1) call abort
if (mod (xin2, 2) .ne. 1) call abort
* Convert the indexes into ones suitable for the COMPLEX array (carray).
out = (xout + 1) / 2
in1 = (xin1 + 1) / 2
in2 = (xin2 + 1) / 2
* Check some open-coded stuff, just in case.
call prepare1 (carray(in1))
expect = + carray(in1)
carray(out) = + carray(in1)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = - carray(in1)
carray(out) = - carray(in1)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) + carray(in2)
carray(out) = carray(in1) + carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) - carray(in2)
carray(out) = carray(in1) - carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) * carray(in2)
carray(out) = carray(in1) * carray(in2)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 2
carray(out) = carray(in1) ** 2
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 3
carray(out) = carray(in1) ** 3
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = abs (carray(in1))
array(out*2-1) = abs (carray(in1))
array(out*2) = 0
call check (expect, carray(out))
* Now check the stuff implemented in libF77.
call prepare1 (carray(in1))
expect = cos (carray(in1))
carray(out) = cos (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = exp (carray(in1))
carray(out) = exp (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = log (carray(in1))
carray(out) = log (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = sin (carray(in1))
carray(out) = sin (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = sqrt (carray(in1))
carray(out) = sqrt (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = conjg (carray(in1))
carray(out) = conjg (carray(in1))
call check (expect, carray(out))
call prepare1i (carray(in1), pwr)
expect = carray(in1) ** pwr
carray(out) = carray(in1) ** pwr
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) / carray(in2)
carray(out) = carray(in1) / carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) ** carray(in2)
carray(out) = carray(in1) ** carray(in2)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** .2
carray(out) = carray(in1) ** .2
call check (expect, carray(out))
end
subroutine trypart (xout, xin1, xin2)
implicit none
integer xout, xin1, xin2
* out, in1, and in2 are the desired indexes into the REAL array (array).
complex expect
integer pwr
integer out, in1, in2
real array(6)
complex carray(3), carrayp(2)
equivalence (carray(1), array(1))
equivalence (carrayp(1), array(2))
* Make sure the indexes can be accommodated by the equivalences above.
if (mod (xout, 2) .ne. 0) call abort
if (mod (xin1, 2) .ne. 1) call abort
if (mod (xin2, 2) .ne. 1) call abort
* Convert the indexes into ones suitable for the COMPLEX array (carray).
out = xout / 2
in1 = (xin1 + 1) / 2
in2 = (xin2 + 1) / 2
* Check some open-coded stuff, just in case.
call prepare1 (carray(in1))
expect = + carray(in1)
carrayp(out) = + carray(in1)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = - carray(in1)
carrayp(out) = - carray(in1)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) + carray(in2)
carrayp(out) = carray(in1) + carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) - carray(in2)
carrayp(out) = carray(in1) - carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) * carray(in2)
carrayp(out) = carray(in1) * carray(in2)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 2
carrayp(out) = carray(in1) ** 2
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 3
carrayp(out) = carray(in1) ** 3
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = abs (carray(in1))
array(out*2) = abs (carray(in1))
array(out*2+1) = 0
call check (expect, carrayp(out))
* Now check the stuff implemented in libF77.
call prepare1 (carray(in1))
expect = cos (carray(in1))
carrayp(out) = cos (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = exp (carray(in1))
carrayp(out) = exp (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = log (carray(in1))
carrayp(out) = log (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = sin (carray(in1))
carrayp(out) = sin (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = sqrt (carray(in1))
carrayp(out) = sqrt (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = conjg (carray(in1))
carrayp(out) = conjg (carray(in1))
call check (expect, carrayp(out))
call prepare1i (carray(in1), pwr)
expect = carray(in1) ** pwr
carrayp(out) = carray(in1) ** pwr
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) / carray(in2)
carrayp(out) = carray(in1) / carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) ** carray(in2)
carrayp(out) = carray(in1) ** carray(in2)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** .2
carrayp(out) = carray(in1) ** .2
call check (expect, carrayp(out))
end
subroutine prepare1 (in)
implicit none
complex in
in = (3.2, 4.2)
end
subroutine prepare1i (in, i)
implicit none
complex in
integer i
in = (2.3, 2.5)
i = 4
end
subroutine prepare2 (in1, in2)
implicit none
complex in1, in2
in1 = (1.3, 2.4)
in2 = (3.5, 7.1)
end
subroutine check (expect, got)
implicit none
complex expect, got
if (aimag(expect) .ne. aimag(got)) call abort
if (real(expect) .ne. real(got)) call abort
end
gcc/testsuite/g77.f-torture/execute/19990325-1.f deleted 100644 → 0
* test whether complex operators properly handle
* full and partial aliasing.
* (libf2c/libF77 routines used to assume no aliasing,
* then were changed to accommodate full aliasing, while
* the libg2c/libF77 versions were changed to accommodate
* both full and partial aliasing.)
*
* NOTE: this (19990325-1.f) is the double-precision version.
* See 19990325-0.f for the single-precision version.
program doublecomplexalias
implicit none
* Make sure non-aliased cases work. (Catch roundoff/precision
* problems, etc., here. Modify subroutine check if they occur.)
call tryfull (1, 3, 5)
* Now check various combinations of aliasing.
* Full aliasing.
call tryfull (1, 1, 5)
* Partial aliasing.
call trypart (2, 3, 5)
call trypart (2, 1, 5)
call trypart (2, 5, 3)
call trypart (2, 5, 1)
end
subroutine tryfull (xout, xin1, xin2)
implicit none
integer xout, xin1, xin2
* out, in1, and in2 are the desired indexes into the REAL array (array).
double complex expect
integer pwr
integer out, in1, in2
double precision array(6)
double complex carray(3)
equivalence (carray(1), array(1))
* Make sure the indexes can be accommodated by the equivalences above.
if (mod (xout, 2) .ne. 1) call abort
if (mod (xin1, 2) .ne. 1) call abort
if (mod (xin2, 2) .ne. 1) call abort
* Convert the indexes into ones suitable for the COMPLEX array (carray).
out = (xout + 1) / 2
in1 = (xin1 + 1) / 2
in2 = (xin2 + 1) / 2
* Check some open-coded stuff, just in case.
call prepare1 (carray(in1))
expect = + carray(in1)
carray(out) = + carray(in1)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = - carray(in1)
carray(out) = - carray(in1)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) + carray(in2)
carray(out) = carray(in1) + carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) - carray(in2)
carray(out) = carray(in1) - carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) * carray(in2)
carray(out) = carray(in1) * carray(in2)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 2
carray(out) = carray(in1) ** 2
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 3
carray(out) = carray(in1) ** 3
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = abs (carray(in1))
array(out*2-1) = abs (carray(in1))
array(out*2) = 0
call check (expect, carray(out))
* Now check the stuff implemented in libF77.
call prepare1 (carray(in1))
expect = cos (carray(in1))
carray(out) = cos (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = exp (carray(in1))
carray(out) = exp (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = log (carray(in1))
carray(out) = log (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = sin (carray(in1))
carray(out) = sin (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = sqrt (carray(in1))
carray(out) = sqrt (carray(in1))
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = conjg (carray(in1))
carray(out) = conjg (carray(in1))
call check (expect, carray(out))
call prepare1i (carray(in1), pwr)
expect = carray(in1) ** pwr
carray(out) = carray(in1) ** pwr
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) / carray(in2)
carray(out) = carray(in1) / carray(in2)
call check (expect, carray(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) ** carray(in2)
carray(out) = carray(in1) ** carray(in2)
call check (expect, carray(out))
call prepare1 (carray(in1))
expect = carray(in1) ** .2
carray(out) = carray(in1) ** .2
call check (expect, carray(out))
end
subroutine trypart (xout, xin1, xin2)
implicit none
integer xout, xin1, xin2
* out, in1, and in2 are the desired indexes into the REAL array (array).
double complex expect
integer pwr
integer out, in1, in2
double precision array(6)
double complex carray(3), carrayp(2)
equivalence (carray(1), array(1))
equivalence (carrayp(1), array(2))
* Make sure the indexes can be accommodated by the equivalences above.
if (mod (xout, 2) .ne. 0) call abort
if (mod (xin1, 2) .ne. 1) call abort
if (mod (xin2, 2) .ne. 1) call abort
* Convert the indexes into ones suitable for the COMPLEX array (carray).
out = xout / 2
in1 = (xin1 + 1) / 2
in2 = (xin2 + 1) / 2
* Check some open-coded stuff, just in case.
call prepare1 (carray(in1))
expect = + carray(in1)
carrayp(out) = + carray(in1)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = - carray(in1)
carrayp(out) = - carray(in1)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) + carray(in2)
carrayp(out) = carray(in1) + carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) - carray(in2)
carrayp(out) = carray(in1) - carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) * carray(in2)
carrayp(out) = carray(in1) * carray(in2)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 2
carrayp(out) = carray(in1) ** 2
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** 3
carrayp(out) = carray(in1) ** 3
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = abs (carray(in1))
array(out*2) = abs (carray(in1))
array(out*2+1) = 0
call check (expect, carrayp(out))
* Now check the stuff implemented in libF77.
call prepare1 (carray(in1))
expect = cos (carray(in1))
carrayp(out) = cos (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = exp (carray(in1))
carrayp(out) = exp (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = log (carray(in1))
carrayp(out) = log (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = sin (carray(in1))
carrayp(out) = sin (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = sqrt (carray(in1))
carrayp(out) = sqrt (carray(in1))
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = conjg (carray(in1))
carrayp(out) = conjg (carray(in1))
call check (expect, carrayp(out))
call prepare1i (carray(in1), pwr)
expect = carray(in1) ** pwr
carrayp(out) = carray(in1) ** pwr
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) / carray(in2)
carrayp(out) = carray(in1) / carray(in2)
call check (expect, carrayp(out))
call prepare2 (carray(in1), carray(in2))
expect = carray(in1) ** carray(in2)
carrayp(out) = carray(in1) ** carray(in2)
call check (expect, carrayp(out))
call prepare1 (carray(in1))
expect = carray(in1) ** .2
carrayp(out) = carray(in1) ** .2
call check (expect, carrayp(out))
end
subroutine prepare1 (in)
implicit none
double complex in
in = (3.2d0, 4.2d0)
end
subroutine prepare1i (in, i)
implicit none
double complex in
integer i
in = (2.3d0, 2.5d0)
i = 4
end
subroutine prepare2 (in1, in2)
implicit none
double complex in1, in2
in1 = (1.3d0, 2.4d0)
in2 = (3.5d0, 7.1d0)
end
subroutine check (expect, got)
implicit none
double complex expect, got
if (dimag(expect) .ne. dimag(got)) call abort
if (dble(expect) .ne. dble(got)) call abort
end
gcc/testsuite/g77.f-torture/execute/19990419-1.f deleted 100644 → 0
* Test DO WHILE, to make sure it fully reevaluates its expression.
* Belongs in execute/.
common /x/ ival
j = 0
do while (i() .eq. 1)
j = j + 1
if (j .gt. 5) call abort
end do
if (j .ne. 4) call abort
if (ival .ne. 5) call abort
end
function i()
common /x/ ival
ival = ival + 1
i = 10
if (ival .lt. 5) i = 1
end
block data
common /x/ ival
data ival/0/
end
gcc/testsuite/g77.f-torture/execute/19990826-0.f deleted 100644 → 0
* From: niles@fan745.gsfc.nasa.gov
* To: fortran@gnu.org
* Cc: niles@fan745.gsfc.nasa.gov
* Subject: problem with DNINT() on Linux/Alpha.
* Date: Sun, 06 Jun 1999 16:39:35 -0400
* X-UIDL: 6aa9208d7bda8b6182a095dfd37016b7
IF (DNINT(0.0D0) .NE. 0.) CALL ABORT
STOP
END
* Result on Linux/i386: " 0." (and every other computer!)
* Result on Linux/alpha: " 3.6028797E+16"
* It seems to work fine if I change it to the generic NINT(). Probably
* a name pollution problem in the new C library, but it seems bad. no?
* Thanks,
* Rick Niles.
gcc/testsuite/g77.f-torture/execute/19990826-2.f deleted 100644 → 0
* From: "Billinghurst, David (RTD)" <David.Billinghurst@riotinto.com.au>
* Subject: RE: single precision complex bug in g77 - was Testing g77 with LA
* PACK 3.0
* Date: Thu, 8 Jul 1999 00:55:11 +0100
* X-UIDL: b00d9d8081a36fef561b827d255dd4a5
* Here is a slightly simpler and neater test case
program labug3
implicit none
* This program gives the wrong answer on mips-sgi-irix6.5
* when compiled with g77 from egcs-19990629 (gcc 2.95 prerelease)
* Get a = 0.0 when it should be 1.0
*
* Works with: -femulate-complex
* egcs-1.1.2
*
* Originally derived from LAPACK 3.0 test suite.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 8 July 1999
*
complex one, z
real a, f1
f1(z) = real(z)
one = (1.,0.)
a = f1(one)
if ( abs(a-1.0) .gt. 1.0e-5 ) then
write(6,*) 'A should be 1.0 but it is',a
call abort()
end if
end
gcc/testsuite/g77.f-torture/execute/20000503-1.f deleted 100644 → 0
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 23 February 2000
*
INTEGER N, I, SLASQX
N = 20
I = SLASQX( N )
IF ( I .NE. 2*N ) THEN
WRITE(6,*) 'I = ', I, ' but should be ', 2*N
CALL ABORT()
END IF
END
INTEGER FUNCTION SLASQX( N )
INTEGER N, I0, I, K
I0 = 1
DO I = 4*I0, 2*( I0+N-1 ), 4
K = I
END DO
SLASQX = K
RETURN
END
gcc/testsuite/g77.f-torture/execute/20001111.f deleted 100644 → 0
DOUBLE PRECISION VALUE(2), TOLD, BK
DATA VALUE /0D0, 1D0/
DATA TOLD /0D0/
DO I=1, 2
BK = VALUE(I)
IF(BK .GT. TOLD) GOTO 10
ENDDO
WRITE(*,*)'Error: BK = ', BK
CALL ABORT
10 CONTINUE
WRITE(*,*)'No Error: BK = ', BK
END
gcc/testsuite/g77.f-torture/execute/20001201.f deleted 100644 → 0
LOGICAL TF(5)
CHARACTER*60 LINE
NAMELIST /LIST/ TF,TT,FF,XYZ
DATA TF /5*.FALSE./
DATA LINE /'&LIST,TF=.T.,.F.,.T.,FF=33.,TT=23.,XYZ=-1234.55,/'/
OPEN(1,STATUS='SCRATCH')
WRITE(1,*) LINE
REWIND(1)
READ(1,LIST)
CLOSE(1)
IF (TF(5)) CALL ABORT
END
gcc/testsuite/g77.f-torture/execute/20001201.x deleted 100644 → 0
# Scratch files aren't implemented for mmixware
# (_stat is a stub and files can't be deleted).
# Similar restrictions exist for most simulators.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscale*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_execute_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/execute/20010116.f deleted 100644 → 0
*
* Derived from LAPACK 3.0 routine CHGEQZ
* Fails on i686-pc-cygwin with gcc-2.97 snapshots at -O2 and higher
* PR fortran/1645
*
* David Billinghurst, (David.Billinghurst@riotinto.com)
* 14 January 2001
* Rewritten by Toon Moene (toon@moene.indiv.nluug.nl)
* 15 January 2001
*
COMPLEX A(5,5)
DATA A/25*(0.0,0.0)/
A(4,3) = (0.05,0.2)/3.0E-7
A(4,4) = (-0.03,-0.4)
A(5,4) = (-2.0E-07,2.0E-07)
CALL CHGEQZ( 5, A )
END
SUBROUTINE CHGEQZ( N, A )
COMPLEX A(N,N), X
ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
DO J = 4, 2, -1
I = J
TEMP = ABS1( A(J,J) )
TEMP2 = ABS1( A( J+1, J ) )
TEMPR = MAX( TEMP, TEMP2 )
IF( TEMPR .LT. 1.0 .AND. TEMPR .NE. 0.0 ) THEN
TEMP = TEMP / TEMPR
TEMP2 = TEMP2 / TEMPR
END IF
IF ( ABS1(A(J,J-1))*TEMP2 .LE. TEMP ) GO TO 90
END DO
c Should not reach here, but need a statement
PRINT*
90 IF ( I .NE. 4 ) THEN
PRINT*,'I =', I, ' but should be 4'
CALL ABORT()
END IF
END
gcc/testsuite/g77.f-torture/execute/20010430.f deleted 100644 → 0
REAL DAT(2,5)
DO I = 1, 5
DAT(1,I) = I*1.6356-NINT(I*1.6356)
DAT(2,I) = I
ENDDO
DO I = 1, 4
DO J = I+1, 5
IF (DAT(1,J) - DAT(1,I) .LT. 0.0) THEN
DO K = 1, 2
TMP = DAT(K,I)
DAT(K,I) = DAT(K,J)
DAT(K,J) = TMP
ENDDO
ENDIF
ENDDO
ENDDO
DO I = 1, 4
IF (DAT(1,I) .GT. DAT(1,I+1)) CALL ABORT
ENDDO
END
gcc/testsuite/g77.f-torture/execute/20010610.f deleted 100644 → 0
DO I = 0, 255
IF (ICHAR(CHAR(I)) .NE. I) CALL ABORT
ENDDO
END
gcc/testsuite/g77.f-torture/execute/5122.f deleted 100644 → 0
CHARACTER*20 PARTD(6)
INTEGER*2 L
DATA (PARTD(L),L=1,6)/'A','B','C','D','E','F'/
IF ( PARTD(1) .NE. 'A' .OR. PARTD(2) .NE. 'B'
, .OR. PARTD(3) .NE. 'C' .OR. PARTD(4) .NE. 'D'
, .OR. PARTD(5) .NE. 'E' .OR. PARTD(6) .NE. 'F')
, CALL ABORT
END
gcc/testsuite/g77.f-torture/execute/6177.f deleted 100644 → 0
program pr6177
C
C Test case for PR optimization/6177.
C This bug (an ICE) originally showed up in file cblat2.f from LAPACK.
C
complex x
complex w(1)
intrinsic conjg
x = (2.0d0, 1.0d0)
w(1) = x
x = conjg(x)
w(1) = conjg(w(1))
if (abs(x-w(1)) .gt. 1.0e-5) call abort
end
gcc/testsuite/g77.f-torture/execute/6367.f deleted 100644 → 0
program testnl
character*80 line
dimension a(10),b(10)
namelist /nl/ a
data a / 10 * 0.0 /
data b / 0., 1., 1., 1., 2., 2., 3., 3., 3., 0. /
data line /'&nl a(2) = 3*1.0, 2*2.0, 3*3.0 /'/
open(1,status='scratch')
write(1,'(a)') line
rewind(1)
read(1,nl)
close(1)
do i = 1, 10
if (a(i) .ne. b(i)) call abort
enddo
end
gcc/testsuite/g77.f-torture/execute/6367.x deleted 100644 → 0
# Scratch files aren't implemented for mmixware
# (_stat is a stub and files can't be deleted).
# Similar restrictions exist for most simulators.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscalearm*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_execute_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/execute/947.f deleted 100644 → 0
DIMENSION A(-5:5)
INTEGER*1 IM5, IZ, IP5
INTEGER*2 IM1, IP1
PARAMETER (IM5=-5, IM1=-1, IZ=0, IP1=1, IP5=5)
DATA A(IM5) /-5./, A(IM1) /-1./
DATA A(IZ) /0./
DATA A(IP5) /+5./, A(IP1) /+1./
IF (A(IM5) .NE. -5. .OR. A(IM1) .NE. -1. .OR.
, A(IZ) .NE. 0. .OR.
, A(IP5) .NE. +5. .OR. A(IP1) .NE. +1. )
, CALL ABORT
END
gcc/testsuite/g77.f-torture/execute/970625-2.f deleted 100644 → 0
* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST)
* MIME-Version: 1.0
* From: R.Hooft@EuroMail.com (Rob Hooft)
* To: g77-alpha@gnu.ai.mit.edu
* Subject: Re: testing 970624.
* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu>
* References: <199706251018.MAA21538@nu>
* <199706251027.GAA07892@churchy.gnu.ai.mit.edu>
* X-Mailer: VM 6.30 under Emacs 19.34.1
* Content-Type: text/plain; charset=US-ASCII
*
* >>>>> "CB" == Craig Burley <burley@gnu.ai.mit.edu> writes:
*
* CB> but OTOH I'd like to see more problems like this on other
* CB> applications, and especially other systems
*
* How about this one: An application that prints "112." on all
* compilers/platforms I have tested, except with the new g77 on ALPHA (I
* don't have the new g77 on any other platform here to test)?
*
* Application Appended. Source code courtesy of my boss.....
* Disclaimer: I do not know the right answer, or even whether there is a
* single right answer.....
*
* Regards,
* --
* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ ==
* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/
* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ====
* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! =============
*
* nu[152]for% cat humor.f
PROGRAM SUBROUTINE
LOGICAL ELSE IF
INTEGER REAL, GO TO PROGRAM, WHILE
REAL FORMAT(2)
DATA IF,REAL,END DO,WHILE,FORMAT(2),I2/2,6,7,1,112.,1/
DO THEN=1, END DO, WHILE
CALL = END DO - IF
PROGRAM = THEN - IF
ELSE IF = THEN .GT. IF
IF (THEN.GT.REAL) THEN
CALL FUNCTION PROGRAM (ELSE IF, GO TO PROGRAM, THEN)
ELSE IF (ELSE IF) THEN
REAL = THEN + END DO
END IF
END DO
10 FORMAT(I2/I2) = WHILE*REAL*THEN
IF (FORMAT(I2) .NE. FORMAT(I2+I2)) CALL ABORT
END ! DO
SUBROUTINE FUNCTION PROGRAM (REAL,INTEGER, LOGICAL)
LOGICAL REAL
REAL LOGICAL
INTEGER INTEGER, STOP, RETURN, GO TO
ASSIGN 9 TO STOP
ASSIGN = 9 + LOGICAL
ASSIGN 7 TO RETURN
ASSIGN 9 TO GO TO
GO TO = 5
STOP = 8
IF (.NOT.REAL) GOTO STOP
IF (LOGICAL.GT.INTEGER) THEN
IF = LOGICAL +5
IF (LOGICAL.EQ.5) ASSIGN 5 TO IF
INTEGER=IF
ELSE
IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO
ELSE = GO TO
END IF = ELSE + GO TO
IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN
END IF
5 CONTINUE
7 LOGICAL=LOGICAL+STOP
9 RETURN
END ! IF
* nu[153]for% f77 humor.f
* nu[154]for% ./a.out
* 112.0000
* nu[155]for% f90 humor.f
* nu[156]for% ./a.out
* 112.0000
* nu[157]for% g77 humor.f
* nu[158]for% ./a.out
* 40.
gcc/testsuite/g77.f-torture/execute/970816-3.f deleted 100644 → 0
* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST)
* From: Claus Denk <denk@cica.es>
* To: g77-alpha@gnu.ai.mit.edu
* Subject: 970811 report - segfault bug on alpha still there
*[...]
* Now, the bug that I reported some weeks ago is still there, I'll post
* the test program again:
*
PROGRAM TEST
C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with
C NSTART=1 on the second write.
PARAMETER (NSTART=1,NADD=NSTART+1)
REAL AB(NSTART:NSTART)
AB(NSTART)=1.0
I=1
J=2
IND=I-J+NADD
write(*,*) AB(IND)
write(*,*) AB(I-J+NADD)
END
gcc/testsuite/g77.f-torture/execute/971102-1.f deleted 100644 → 0
i=3
j=0
do i=i,5
j = j+i
end do
do i=3,i
j = j+i
end do
if (i.ne.7) call abort()
print *, i,j
end
gcc/testsuite/g77.f-torture/execute/980520-1.f deleted 100644 → 0
c Produced a link error through not eliminating the unused statement
c function after 1998-05-15 change to gcc/toplev.c. It's in
c `execute' since it needs to link.
c Fixed by 1998-05-23 change to f/com.c.
values(i,j) = val((i-1)*n+j)
end
gcc/testsuite/g77.f-torture/execute/980628-0.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (r1(2), d1)
equivalence (r2(2), d2)
equivalence (r3(2), d3)
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
end
subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/980628-1.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
save
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (r1(2), d1)
equivalence (r2(2), d2)
equivalence (r3(2), d3)
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
end
subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/980628-10.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
save
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
equivalence (r1, c1(2))
equivalence (r2, c2(2))
equivalence (r3, c3(2))
c1(1) = '1'
r1 = 1.
c1(11) = '1'
c4 = '4'
c2(1) = '2'
r2 = 2.
c2(11) = '2'
c5 = '5'
c3(1) = '3'
r3 = 3.
c3(11) = '3'
c6 = '6'
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
end
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
if (c1(1) .ne. '1') call abort
if (r1 .ne. 1.) call abort
if (c1(11) .ne. '1') call abort
if (c4 .ne. '4') call abort
if (c2(1) .ne. '2') call abort
if (r2 .ne. 2.) call abort
if (c2(11) .ne. '2') call abort
if (c5 .ne. '5') call abort
if (c3(1) .ne. '3') call abort
if (r3 .ne. 3.) call abort
if (c3(11) .ne. '3') call abort
if (c6 .ne. '6') call abort
end
gcc/testsuite/g77.f-torture/execute/980628-2.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
equivalence (c1(2), r1)
equivalence (c2(2), r2)
equivalence (c3(2), r3)
c1(1) = '1'
r1 = 1.
c1(11) = '1'
c4 = '4'
c2(1) = '2'
r2 = 2.
c2(11) = '2'
c5 = '5'
c3(1) = '3'
r3 = 3.
c3(11) = '3'
c6 = '6'
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
end
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
if (c1(1) .ne. '1') call abort
if (r1 .ne. 1.) call abort
if (c1(11) .ne. '1') call abort
if (c4 .ne. '4') call abort
if (c2(1) .ne. '2') call abort
if (r2 .ne. 2.) call abort
if (c2(11) .ne. '2') call abort
if (c5 .ne. '5') call abort
if (c3(1) .ne. '3') call abort
if (r3 .ne. 3.) call abort
if (c3(11) .ne. '3') call abort
if (c6 .ne. '6') call abort
end
gcc/testsuite/g77.f-torture/execute/980628-3.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
save
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
equivalence (c1(2), r1)
equivalence (c2(2), r2)
equivalence (c3(2), r3)
c1(1) = '1'
r1 = 1.
c1(11) = '1'
c4 = '4'
c2(1) = '2'
r2 = 2.
c2(11) = '2'
c5 = '5'
c3(1) = '3'
r3 = 3.
c3(11) = '3'
c6 = '6'
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
end
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
if (c1(1) .ne. '1') call abort
if (r1 .ne. 1.) call abort
if (c1(11) .ne. '1') call abort
if (c4 .ne. '4') call abort
if (c2(1) .ne. '2') call abort
if (r2 .ne. 2.) call abort
if (c2(11) .ne. '2') call abort
if (c5 .ne. '5') call abort
if (c3(1) .ne. '3') call abort
if (r3 .ne. 3.) call abort
if (c3(11) .ne. '3') call abort
if (c6 .ne. '6') call abort
end
gcc/testsuite/g77.f-torture/execute/980628-4.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system,
* including when initial values are provided (e.g. DATA).
program test
implicit none
real r
double precision d
common /cmn/ r, d
if (r .ne. 1.) call abort
if (d .ne. 10.) call abort
end
block data init
implicit none
real r
double precision d
common /cmn/ r, d
data r/1./, d/10./
end
gcc/testsuite/g77.f-torture/execute/980628-4.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/980628-5.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system,
* including when initial values are provided (e.g. DATA).
program test
implicit none
character c
double precision d
common /cmn/ c, d
if (c .ne. '1') call abort
if (d .ne. 10.) call abort
end
block data init
implicit none
character c
double precision d
common /cmn/ c, d
data c/'1'/, d/10./
end
gcc/testsuite/g77.f-torture/execute/980628-5.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/980628-6.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system,
* including when initial values are provided (e.g. DATA).
program test
implicit none
character c
double precision d(100)
common /cmn/ c, d
if (d(80) .ne. 10.) call abort
end
block data init
implicit none
character c
double precision d(100)
common /cmn/ c, d
data d(80)/10./
end
gcc/testsuite/g77.f-torture/execute/980628-6.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/980628-7.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (d1, r1(2))
equivalence (d2, r2(2))
equivalence (d3, r3(2))
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
end
subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/980628-8.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
save
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (d1, r1(2))
equivalence (d2, r2(2))
equivalence (d3, r3(2))
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
end
subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
double precision d1, d2, d3
integer i1, i2, i3
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/980628-9.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
equivalence (r1, c1(2))
equivalence (r2, c2(2))
equivalence (r3, c3(2))
c1(1) = '1'
r1 = 1.
c1(11) = '1'
c4 = '4'
c2(1) = '2'
r2 = 2.
c2(11) = '2'
c5 = '5'
c3(1) = '3'
r3 = 3.
c3(11) = '3'
c6 = '6'
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
end
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
implicit none
character c1(11), c2(11), c3(11)
real r1, r2, r3
character c4, c5, c6
if (c1(1) .ne. '1') call abort
if (r1 .ne. 1.) call abort
if (c1(11) .ne. '1') call abort
if (c4 .ne. '4') call abort
if (c2(1) .ne. '2') call abort
if (r2 .ne. 2.) call abort
if (c2(11) .ne. '2') call abort
if (c5 .ne. '5') call abort
if (c3(1) .ne. '3') call abort
if (r3 .ne. 3.) call abort
if (c3(11) .ne. '3') call abort
if (c6 .ne. '6') call abort
end
gcc/testsuite/g77.f-torture/execute/980701-0.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
real r1(5), r2(5), r3(5)
real s1(2), s2(2), s3(2)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (r1, s1(2))
equivalence (d1, r1(2))
equivalence (r2, s2(2))
equivalence (d2, r2(2))
equivalence (r3, s3(2))
equivalence (d3, r3(2))
s1(1) = 1.
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
s2(1) = 2.
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
s3(1) = 3.
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
end
subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
real s1(2), s2(2), s3(2)
double precision d1, d2, d3
integer i1, i2, i3
if (s1(1) .ne. 1.) call abort
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (s2(1) .ne. 2.) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (s3(1) .ne. 3.) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/980701-1.f deleted 100644 → 0
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
call subr
end
subroutine subr
implicit none
real r1(5), r2(5), r3(5)
real s1(2), s2(2), s3(2)
double precision d1, d2, d3
integer i1, i2, i3
equivalence (d1, r1(2))
equivalence (r1, s1(2))
equivalence (d2, r2(2))
equivalence (r2, s2(2))
equivalence (d3, r3(2))
equivalence (r3, s3(2))
s1(1) = 1.
r1(1) = 1.
d1 = 10.
r1(4) = 1.
r1(5) = 1.
i1 = 1
s2(1) = 2.
r2(1) = 2.
d2 = 20.
r2(4) = 2.
r2(5) = 2.
i2 = 2
s3(1) = 3.
r3(1) = 3.
d3 = 30.
r3(4) = 3.
r3(5) = 3.
i3 = 3
call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
end
subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
implicit none
real r1(5), r2(5), r3(5)
real s1(2), s2(2), s3(2)
double precision d1, d2, d3
integer i1, i2, i3
if (s1(1) .ne. 1.) call abort
if (r1(1) .ne. 1.) call abort
if (d1 .ne. 10.) call abort
if (r1(4) .ne. 1.) call abort
if (r1(5) .ne. 1.) call abort
if (i1 .ne. 1) call abort
if (s2(1) .ne. 2.) call abort
if (r2(1) .ne. 2.) call abort
if (d2 .ne. 20.) call abort
if (r2(4) .ne. 2.) call abort
if (r2(5) .ne. 2.) call abort
if (i2 .ne. 2) call abort
if (s3(1) .ne. 3.) call abort
if (r3(1) .ne. 3.) call abort
if (d3 .ne. 30.) call abort
if (r3(4) .ne. 3.) call abort
if (r3(5) .ne. 3.) call abort
if (i3 .ne. 3) call abort
end
gcc/testsuite/g77.f-torture/execute/alpha2.f deleted 100644 → 0
c This was originally a compile test.
IMPLICIT REAL*8 (A-H,O-Z)
COMMON /C/ A(9), INT
DATA A /
1 0.49999973986348730D01, 0.40000399113084100D01,
2 0.29996921166596490D01, 0.20016917082678680D01,
3 0.99126390351864390D00, 0.97963256554443300D-01,
4 -0.87360964813570100D-02, 0.16917082678692080D-02,
5 7./
C Data values were once mis-compiled on (OSF/1 ?) Alpha with -O2
c such that, for instance, `7.' appeared as `4.' in the assembler
c output.
call test(a(9), 7)
END
subroutine test(r, i)
double precision r
if (nint(r)/=i) call abort
end
gcc/testsuite/g77.f-torture/execute/alpha2.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/auto0.f deleted 100644 → 0
* Test automatic arrays.
program auto0
implicit none
integer i
integer j0(40)
integer j1(40)
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
data j0/40*3/
data j1/40*4/
i = 40
call a1 (j0, j1, i)
do i = 1, 40
if (j0(i) .ne. 4) call abort
if (j1(i) .ne. 3) call abort
if (jc0(i) .ne. 6) call abort
if (jc1(i) .ne. 5) call abort
end do
end
block data jc
implicit none
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
data jc0/40*5/
data jc1/40*6/
end
subroutine a1 (j0, j1, n)
implicit none
integer j0(40), j1(40), n
integer k0(n), k1(n)
integer i
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
do i = 1, 40
j0(i) = j1(i) - j0(i)
jc0(i) = jc1(i) - jc0(i)
end do
n = -1
do i = 1, 40
k0(i) = n
k1(i) = n
end do
do i = 1, 40
j1(i) = j1(i) + k0(i) * j0(i)
jc1(i) = jc1(i) + k1(i) * jc0(i)
end do
n = 500
do i = 1, 40
if (k0(i) .ne. -1) call abort
k0(i) = n
if (k1(i) .ne. -1) call abort
k1(i) = n
end do
do i = 1, 40
j0(i) = j1(i) + j0(i)
jc0(i) = jc1(i) + jc0(i)
end do
end
gcc/testsuite/g77.f-torture/execute/auto0.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/auto1.f deleted 100644 → 0
* Test automatic arrays.
program auto1
implicit none
integer i
integer j0(40)
integer j1(40)
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
data j0/40*3/
data j1/40*4/
i = 40
call a1 (j0, j1, i)
do i = 1, 40
if (j0(i) .ne. 4) call abort
if (j1(i) .ne. 3) call abort
if (jc0(i) .ne. 6) call abort
if (jc1(i) .ne. 5) call abort
end do
end
block data jc
implicit none
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
data jc0/40*5/
data jc1/40*6/
end
subroutine a1 (j0, j1, n)
implicit none
integer j0(40), j1(40), n
integer k0(n,3,2), k1(n,3,2)
integer i,j,k
integer jc0(40)
integer jc1(40)
common /jc0/ jc0
common /jc1/ jc1
do i = 1, 40
j0(i) = j1(i) - j0(i)
jc0(i) = jc1(i) - jc0(i)
end do
n = -1
do k = 1, 2
do j = 1, 3
do i = 1, 40
k0(i, j, k) = n
k1(i, j, k) = n
end do
end do
end do
do i = 1, 40
j1(i) = j1(i) + k0(i, 3, 2) * j0(i)
jc1(i) = jc1(i) + k1(i, 1, 1) * jc0(i)
end do
n = 500
do k = 1, 2
do j = 1, 3
do i = 1, 40
if (k0(i, j, k) .ne. -1) call abort
k0(i, j, k) = n
if (k1(i, j, k) .ne. -1) call abort
k1(i, j, k) = n
end do
end do
end do
do i = 1, 40
j0(i) = j1(i) + j0(i)
jc0(i) = jc1(i) + jc0(i)
end do
end
gcc/testsuite/g77.f-torture/execute/auto1.x deleted 100644 → 0
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0
gcc/testsuite/g77.f-torture/execute/cabs.f deleted 100644 → 0
program cabs_1
complex z0
real r0
complex*16 z1
real*8 r1
z0 = cmplx(3.,4.)
r0 = cabs(z0)
if (r0 .ne. 5.) call abort
z1 = dcmplx(3.d0,4.d0)
r1 = zabs(z1)
if (r1 .ne. 5.d0) call abort
end
gcc/testsuite/g77.f-torture/execute/claus.f deleted 100644 → 0
PROGRAM TEST
REAL AB(3)
do i=1,3
AB(i)=i
enddo
k=1
n=2
ind=k-n+2
if (ind /= 1) call abort
if (ab(ind) /= 1) call abort
if (k-n+2 /= 1) call abort
if (ab(k-n+2) /= 1) call abort
END
gcc/testsuite/g77.f-torture/execute/complex_1.f deleted 100644 → 0
program complex_1
complex z0, z1, z2
z0 = cmplx(0.,.5)
z1 = 1./z0
if (z1 .ne. cmplx(0.,-2)) call abort
z0 = 10.*z0
if (z0 .ne. cmplx(0.,5.)) call abort
z2 = cmplx(1.,2.)
z1 = z0/z2
if (z1 .ne. cmplx(2.,1.)) call abort
z1 = z0*z2
if (z1 .ne. cmplx(-10.,5.)) call abort
end
gcc/testsuite/g77.f-torture/execute/cpp.F deleted 100644 → 0
! Some versions of cpp will delete "//'World' as a C++ comment.
character*40 title
title = 'Hello '//'World'
if (title .ne. 'Hello World') call abort
end
gcc/testsuite/g77.f-torture/execute/cpp2.F deleted 100644 → 0
C The preprocessor must not mangle Hollerith constants
C which contain apostrophes.
integer i, j
data i /4hbla'/
data j /"bla'"/
if (i .ne. j) call abort
end
gcc/testsuite/g77.f-torture/execute/dcomplex.f deleted 100644 → 0
program foo
complex*16 z0, z1, z2
z0 = dcmplx(0.,.5)
z1 = 1./z0
if (z1 .ne. dcmplx(0.,-2)) call abort
z0 = 10.*z0
if (z0 .ne. dcmplx(0.,5.)) call abort
z2 = cmplx(1.,2.)
z1 = z0/z2
if (z1 .ne. dcmplx(2.,1.)) call abort
z1 = z0*z2
if (z1 .ne. dcmplx(-10.,5.)) call abort
end
gcc/testsuite/g77.f-torture/execute/dnrm2.f deleted 100644 → 0
CCC g77 0.5.21 `Actual Bugs':
CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is
CCC specified compiling, for example, an old version of the `DNRM2'
CCC routine. The x87 coprocessor stack is being somewhat mismanaged
CCC in cases where assigned `GOTO' and `ASSIGN' are involved.
CCC
CCC Version 0.5.21 of `g77' contains an initial effort to fix the
CCC problem, but this effort is incomplete, and a more complete fix is
CCC planned for the next release.
C Currently this test fails with (at least) `-O2 -funroll-loops' on
C i586-unknown-linux-gnulibc1.
C (This is actually an obsolete version of dnrm2 -- consult the
c current Netlib BLAS.)
integer i
double precision a(1:100), dnrm2
do i=1,100
a(i)=0.D0
enddo
if (dnrm2(100,a,1) .ne. 0.0) call abort
end
double precision function dnrm2 ( n, dx, incx)
integer i, incx, ix, j, n, next
double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one
data zero, one /0.0d0, 1.0d0/
data cutlo, cuthi / 8.232d-11, 1.304d19 /
j = 0
if(n .gt. 0 .and. incx.gt.0) go to 10
dnrm2 = zero
go to 300
10 assign 30 to next
sum = zero
i = 1
ix = 1
20 go to next,(30, 50, 70, 110)
30 if( dabs(dx(i)) .gt. cutlo) go to 85
assign 50 to next
xmax = zero
50 if( dx(i) .eq. zero) go to 200
if( dabs(dx(i)) .gt. cutlo) go to 85
assign 70 to next
go to 105
100 continue
ix = j
assign 110 to next
sum = (sum / dx(i)) / dx(i)
105 xmax = dabs(dx(i))
go to 115
70 if( dabs(dx(i)) .gt. cutlo ) go to 75
110 if( dabs(dx(i)) .le. xmax ) go to 115
sum = one + sum * (xmax / dx(i))**2
xmax = dabs(dx(i))
go to 200
115 sum = sum + (dx(i)/xmax)**2
go to 200
75 sum = (sum * xmax) * xmax
85 hitest = cuthi/float( n )
do 95 j = ix,n
if(dabs(dx(i)) .ge. hitest) go to 100
sum = sum + dx(i)**2
i = i + incx
95 continue
dnrm2 = dsqrt( sum )
go to 300
200 continue
ix = ix + 1
i = i + incx
if( ix .le. n ) go to 20
dnrm2 = xmax * dsqrt(sum)
300 continue
end
gcc/testsuite/g77.f-torture/execute/erfc.f deleted 100644 → 0
c============================================== test.f
real x, y
real*8 x1, y1
x=0.
y = erfc(x)
if (y .ne. 1.) call abort
x=1.1
y = erfc(x)
if (abs(y - .1197949) .ge. 1.e-6) call abort
* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas.
x=8
y = erfc(x)
if (y .gt. 1.2e-28) call abort
x1=0.
y1 = erfc(x1)
if (y1 .ne. 1.) call abort
x1=1.1d0
y1 = erfc(x1)
if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort
x1=10
y1 = erfc(x1)
if (y1 .gt. 1.5d-44) call abort
end
c=================================================
!output:
! 0. 1.875
! 1.10000002 1.48958981
! 10. 5.00220949E-06
!
!The values should be:
!erfc(0)=1
!erfc(1.1)= 0.1197949
!erfc(10)<1.543115467311259E-044
gcc/testsuite/g77.f-torture/execute/execute.exp deleted 100644 → 0
# Copyright (C) 1991, 1992, 1993, 1995, 1997 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 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# This file was written by Rob Savoye. (rob@cygnus.com)
# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com)
#
# These tests come from Torbjorn Granlund (tege@cygnus.com)
# Fortran torture test suite.
#
if $tracelevel then {
strace $tracelevel
}
# load support procs
load_lib f-torture.exp
#
# main test loop
#
foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $src] then {
continue
}
f-torture-execute $src
}
foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.F]] {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $src] then {
continue
}
f-torture-execute $src
}
gcc/testsuite/g77.f-torture/execute/exp.f deleted 100644 → 0
a = 2**-2*1.
if (a .ne. .25) call abort
end
gcc/testsuite/g77.f-torture/execute/f90-intrinsic-bit.f deleted 100644 → 0
c f90-intrinsic-bit.f
c
c Test Fortran 90
c * intrinsic bit manipulation functions - Section 13.10.10
c * bitcopy subroutine - Section 13.9.3
c David Billinghurst <David.Billinghurst@riotinto.com>
c
c Notes:
c * g77 only supports scalar arguments
c * third argument of ISHFTC is not optional in g77
logical fail
integer i, i2, ia, i3
integer*2 j, j2, j3, ja
integer*1 k, k2, k3, ka
integer*8 m, m2, m3, ma
common /flags/ fail
fail = .false.
c BIT_SIZE - Section 13.13.16
c Determine BIT_SIZE by counting the bits
ia = 0
i = 0
i = not(i)
do while ( (i.ne.0) .and. (ia.lt.127) )
ia = ia + 1
i = ishft(i,-1)
end do
call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)')
ja = 0
j = 0
j = not(j)
do while ( (j.ne.0) .and. (ja.lt.127) )
ja = ja + 1
j = ishft(j,-1)
end do
call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer*2)')
ka = 0
k = 0
k = not(k)
do while ( (k.ne.0) .and. (ka.lt.127) )
ka = ka + 1
k = ishft(k,-1)
end do
call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer*1)')
ma = 0
m = 0
m = not(m)
do while ( (m.ne.0) .and. (ma.lt.127) )
ma = ma + 1
m = ishft(m,-1)
end do
call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer*8)')
c BTEST - Section 13.13.17
j = 7
j2 = 3
k = 7
k2 = 3
m = 7
m2 = 3
call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)')
call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer*2)')
call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer*1)')
call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer*8)')
call c_l(BTEST(j,3),.true.,'BTEST(integer*2,integer)')
call c_l(BTEST(j,j2),.true.,'BTEST(integer*2,integer*2)')
call c_l(BTEST(j,k2),.true.,'BTEST(integer*2,integer*1)')
call c_l(BTEST(j,m2),.true.,'BTEST(integer*2,integer*8)')
call c_l(BTEST(k,3),.true.,'BTEST(integer*1,integer)')
call c_l(BTEST(k,j2),.true.,'BTEST(integer*1,integer*2)')
call c_l(BTEST(k,k2),.true.,'BTEST(integer*1,integer*1)')
call c_l(BTEST(k,m2),.true.,'BTEST(integer*1,integer*8)')
call c_l(BTEST(m,3),.true.,'BTEST(integer*8,integer)')
call c_l(BTEST(m,j2),.true.,'BTEST(integer*8,integer*2)')
call c_l(BTEST(m,k2),.true.,'BTEST(integer*8,integer*1)')
call c_l(BTEST(m,m2),.true.,'BTEST(integer*8,integer*8)')
c IAND - Section 13.13.40
j = 3
j2 = 1
ja = 1
k = 3
k2 = 1
ka = 1
m = 3
m2 = 1
ma = 1
call c_i(IAND(3,1),1,'IAND(integer,integer)')
call c_i2(IAND(j,j2),ja,'IAND(integer*2,integer*2)')
call c_i1(IAND(k,k2),ka,'IAND(integer*1,integer*1)')
call c_i8(IAND(m,m2),ma,'IAND(integer*8,integer*8)')
c IBCLR - Section 13.13.41
j = 14
j2 = 1
ja = 12
k = 14
k2 = 1
ka = 12
m = 14
m2 = 1
ma = 12
call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)')
call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer*2)')
call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer*1)')
call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer*8)')
call c_i2(IBCLR(j,1),ja,'IBCLR(integer*2,integer)')
call c_i2(IBCLR(j,j2),ja,'IBCLR(integer*2,integer*2)')
call c_i2(IBCLR(j,k2),ja,'IBCLR(integer*2,integer*1)')
call c_i2(IBCLR(j,m2),ja,'IBCLR(integer*2,integer*8)')
call c_i1(IBCLR(k,1),ka,'IBCLR(integer*1,integer)')
call c_i1(IBCLR(k,j2),ka,'IBCLR(integer*1,integer*2)')
call c_i1(IBCLR(k,k2),ka,'IBCLR(integer*1,integer*1)')
call c_i1(IBCLR(k,m2),ka,'IBCLR(integer*1,integer*8)')
call c_i8(IBCLR(m,1),ma,'IBCLR(integer*8,integer)')
call c_i8(IBCLR(m,j2),ma,'IBCLR(integer*8,integer*2)')
call c_i8(IBCLR(m,k2),ma,'IBCLR(integer*8,integer*1)')
call c_i8(IBCLR(m,m2),ma,'IBCLR(integer*8,integer*8)')
c IBSET - Section 13.13.43
j = 12
j2 = 1
ja = 14
k = 12
k2 = 1
ka = 14
m = 12
m2 = 1
ma = 14
call c_i(IBSET(12,1),14,'IBSET(integer,integer)')
call c_i(IBSET(12,j2),14,'IBSET(integer,integer*2)')
call c_i(IBSET(12,k2),14,'IBSET(integer,integer*1)')
call c_i(IBSET(12,m2),14,'IBSET(integer,integer*8)')
call c_i2(IBSET(j,1),ja,'IBSET(integer*2,integer)')
call c_i2(IBSET(j,j2),ja,'IBSET(integer*2,integer*2)')
call c_i2(IBSET(j,k2),ja,'IBSET(integer*2,integer*1)')
call c_i2(IBSET(j,m2),ja,'IBSET(integer*2,integer*8)')
call c_i1(IBSET(k,1),ka,'IBSET(integer*1,integer)')
call c_i1(IBSET(k,j2),ka,'IBSET(integer*1,integer*2)')
call c_i1(IBSET(k,k2),ka,'IBSET(integer*1,integer*1)')
call c_i1(IBSET(k,m2),ka,'IBSET(integer*1,integer*8)')
call c_i8(IBSET(m,1),ma,'IBSET(integer*8,integer)')
call c_i8(IBSET(m,j2),ma,'IBSET(integer*8,integer*2)')
call c_i8(IBSET(m,k2),ma,'IBSET(integer*8,integer*1)')
call c_i8(IBSET(m,m2),ma,'IBSET(integer*8,integer*8)')
c IEOR - Section 13.13.45
j = 3
j2 = 1
ja = 2
k = 3
k2 = 1
ka = 2
m = 3
m2 = 1
ma = 2
call c_i(IEOR(3,1),2,'IEOR(integer,integer)')
call c_i2(IEOR(j,j2),ja,'IEOR(integer*2,integer*2)')
call c_i1(IEOR(k,k2),ka,'IEOR(integer*1,integer*1)')
call c_i8(IEOR(m,m2),ma,'IEOR(integer*8,integer*8)')
c ISHFT - Section 13.13.49
i = 3
i2 = 1
i3 = 0
ia = 6
j = 3
j2 = 1
j3 = 0
ja = 6
k = 3
k2 = 1
k3 = 0
ka = 6
m = 3
m2 = 1
m3 = 0
ma = 6
call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)')
call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2')
call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3')
call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4')
call c_i2(ISHFT(j,j2),ja,'ISHFT(integer*2,integer*2)')
call c_i2(ISHFT(j,BIT_SIZE(j)),j3,
$ 'ISHFT(integer*2,integer*2) 2')
call c_i2(ISHFT(j,-BIT_SIZE(j)),j3,
$ 'ISHFT(integer*2,integer*2) 3')
call c_i2(ISHFT(j,0),j,'ISHFT(integer*2,integer*2) 4')
call c_i1(ISHFT(k,k2),ka,'ISHFT(integer*1,integer*1)')
call c_i1(ISHFT(k,BIT_SIZE(k)),k3,
$ 'ISHFT(integer*1,integer*1) 2')
call c_i1(ISHFT(k,-BIT_SIZE(k)),k3,
$ 'ISHFT(integer*1,integer*1) 3')
call c_i1(ISHFT(k,0),k,'ISHFT(integer*1,integer*1) 4')
call c_i8(ISHFT(m,m2),ma,'ISHFT(integer*8,integer*8)')
call c_i8(ISHFT(m,BIT_SIZE(m)),m3,
$ 'ISHFT(integer*8,integer*8) 2')
call c_i8(ISHFT(m,-BIT_SIZE(m)),m3,
$ 'ISHFT(integer*8,integer*8) 3')
call c_i8(ISHFT(m,0),m,'ISHFT(integer*8,integer*8) 4')
c ISHFTC - Section 13.13.50
c The third argument is not optional in g77
i = 3
i2 = 2
i3 = 3
ia = 5
j = 3
j2 = 2
j3 = 3
ja = 5
k = 3
k2 = 2
k3 = 3
ka = 5
m2 = 2
m3 = 3
ma = 5
c test all the combinations of arguments
call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)')
call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer*2)')
call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer*1)')
call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer*8)')
call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer*2,integer)')
call c_i(ISHFTC(i,j2,j3),5,'ISHFTC(integer,integer*2,integer*2)')
call c_i(ISHFTC(i,j2,k3),5,'ISHFTC(integer,integer*2,integer*1)')
call c_i(ISHFTC(i,j2,m3),5,'ISHFTC(integer,integer*2,integer*8)')
call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer*1,integer)')
call c_i(ISHFTC(i,k2,j3),5,'ISHFTC(integer,integer*1,integer*2)')
call c_i(ISHFTC(i,k2,k3),5,'ISHFTC(integer,integer*1,integer*1)')
call c_i(ISHFTC(i,k2,m3),5,'ISHFTC(integer,integer*1,integer*8)')
call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer*8,integer)')
call c_i(ISHFTC(i,m2,j3),5,'ISHFTC(integer,integer*8,integer*2)')
call c_i(ISHFTC(i,m2,k3),5,'ISHFTC(integer,integer*8,integer*1)')
call c_i(ISHFTC(i,m2,m3),5,'ISHFTC(integer,integer*8,integer*8)')
call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer*2,integer,integer)')
call c_i2(ISHFTC(j,i2,j3),ja,
$ 'ISHFTC(integer*2,integer,integer*2)')
call c_i2(ISHFTC(j,i2,k3),ja,
$ 'ISHFTC(integer*2,integer,integer*1)')
call c_i2(ISHFTC(j,i2,m3),ja,
$ 'ISHFTC(integer*2,integer,integer*8)')
call c_i2(ISHFTC(j,j2,i3),ja,
$ 'ISHFTC(integer*2,integer*2,integer)')
call c_i2(ISHFTC(j,j2,j3),ja,
$ 'ISHFTC(integer*2,integer*2,integer*2)')
call c_i2(ISHFTC(j,j2,k3),ja,
$ 'ISHFTC(integer*2,integer*2,integer*1)')
call c_i2(ISHFTC(j,j2,m3),ja,
$ 'ISHFTC(integer*2,integer*2,integer*8)')
call c_i2(ISHFTC(j,k2,i3),ja,
$ 'ISHFTC(integer*2,integer*1,integer)')
call c_i2(ISHFTC(j,k2,j3),ja,
$ 'ISHFTC(integer*2,integer*1,integer*2)')
call c_i2(ISHFTC(j,k2,k3),ja,
$ 'ISHFTC(integer*2,integer*1,integer*1)')
call c_i2(ISHFTC(j,k2,m3),ja,
$ 'ISHFTC(integer*2,integer*1,integer*8)')
call c_i2(ISHFTC(j,m2,i3),ja,
$ 'ISHFTC(integer*2,integer*8,integer)')
call c_i2(ISHFTC(j,m2,j3),ja,
$ 'ISHFTC(integer*2,integer*8,integer*2)')
call c_i2(ISHFTC(j,m2,k3),ja,
$ 'ISHFTC(integer*2,integer*8,integer*1)')
call c_i2(ISHFTC(j,m2,m3),ja,
$ 'ISHFTC(integer*2,integer*8,integer*8)')
call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer*1,integer,integer)')
call c_i1(ISHFTC(k,i2,j3),ka,
$ 'ISHFTC(integer*1,integer,integer*2)')
call c_i1(ISHFTC(k,i2,k3),ka,
$ 'ISHFTC(integer*1,integer,integer*1)')
call c_i1(ISHFTC(k,i2,m3),ka,
$ 'ISHFTC(integer*1,integer,integer*8)')
call c_i1(ISHFTC(k,j2,i3),ka,
$ 'ISHFTC(integer*1,integer*2,integer)')
call c_i1(ISHFTC(k,j2,j3),ka,
$ 'ISHFTC(integer*1,integer*2,integer*2)')
call c_i1(ISHFTC(k,j2,k3),ka,
$ 'ISHFTC(integer*1,integer*2,integer*1)')
call c_i1(ISHFTC(k,j2,m3),ka,
$ 'ISHFTC(integer*1,integer*2,integer*8)')
call c_i1(ISHFTC(k,k2,i3),ka,
$ 'ISHFTC(integer*1,integer*1,integer)')
call c_i1(ISHFTC(k,k2,j3),ka,
$ 'ISHFTC(integer*1,integer*1,integer*2)')
call c_i1(ISHFTC(k,k2,k3),ka,
$ 'ISHFTC(integer*1,integer*1,integer*1)')
call c_i1(ISHFTC(k,k2,m3),ka,
$ 'ISHFTC(integer*1,integer*1,integer*8)')
call c_i1(ISHFTC(k,m2,i3),ka,
$ 'ISHFTC(integer*1,integer*8,integer)')
call c_i1(ISHFTC(k,m2,j3),ka,
$ 'ISHFTC(integer*1,integer*8,integer*2)')
call c_i1(ISHFTC(k,m2,k3),ka,
$ 'ISHFTC(integer*1,integer*8,integer*1)')
call c_i1(ISHFTC(k,m2,m3),ka,
$ 'ISHFTC(integer*1,integer*8,integer*8)')
call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer*8,integer,integer)')
call c_i8(ISHFTC(m,i2,j3),ma,
$ 'ISHFTC(integer*8,integer,integer*2)')
call c_i8(ISHFTC(m,i2,k3),ma,
$ 'ISHFTC(integer*8,integer,integer*1)')
call c_i8(ISHFTC(m,i2,m3),ma,
$ 'ISHFTC(integer*8,integer,integer*8)')
call c_i8(ISHFTC(m,j2,i3),ma,
$ 'ISHFTC(integer*8,integer*2,integer)')
call c_i8(ISHFTC(m,j2,j3),ma,
$ 'ISHFTC(integer*8,integer*2,integer*2)')
call c_i8(ISHFTC(m,j2,k3),ma,
$ 'ISHFTC(integer*8,integer*2,integer*1)')
call c_i8(ISHFTC(m,j2,m3),ma,
$ 'ISHFTC(integer*8,integer*2,integer*8)')
call c_i8(ISHFTC(m,k2,i3),ma,
$ 'ISHFTC(integer*8,integer*1,integer)')
call c_i8(ISHFTC(m,k2,j3),ma,
$ 'ISHFTC(integer*1,integer*8,integer*2)')
call c_i8(ISHFTC(m,k2,k3),ma,
$ 'ISHFTC(integer*1,integer*8,integer*1)')
call c_i8(ISHFTC(m,k2,m3),ma,
$ 'ISHFTC(integer*1,integer*8,integer*8)')
call c_i8(ISHFTC(m,m2,i3),ma,
$ 'ISHFTC(integer*8,integer*8,integer)')
call c_i8(ISHFTC(m,m2,j3),ma,
$ 'ISHFTC(integer*8,integer*8,integer*2)')
call c_i8(ISHFTC(m,m2,k3),ma,
$ 'ISHFTC(integer*8,integer*8,integer*1)')
call c_i8(ISHFTC(m,m2,m3),ma,
$ 'ISHFTC(integer*8,integer*8,integer*8)')
c test the corner cases
call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i,
$ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer')
call c_i(ISHFTC(i,0,BIT_SIZE(i)),i,
$ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer')
call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i,
$ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer')
call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j,
$ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j,
$ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer*2')
call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j,
$ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k,
$ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k,
$ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer*1')
call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k,
$ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m,
$ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')
call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m,
$ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer*8')
call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m,
$ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')
c MVBITS - Section 13.13.74
i = 6
call MVBITS(7,2,2,i,0)
call c_i(i,5,'MVBITS 1')
j = 6
j2 = 7
ja = 5
call MVBITS(j2,2,2,j,0)
call c_i2(j,ja,'MVBITS 2')
k = 6
k2 = 7
ka = 5
call MVBITS(k2,2,2,k,0)
call c_i1(k,ka,'MVBITS 3')
m = 6
m2 = 7
ma = 5
call MVBITS(m2,2,2,m,0)
call c_i8(m,ma,'MVBITS 4')
c NOT - Section 13.13.77
c Rather than assume integer sizes, mask off high bits
j = 21
j2 = 31
ja = 10
k = 21
k2 = 31
ka = 10
m = 21
m2 = 31
ma = 10
call c_i(IAND(NOT(21),31),10,'NOT(integer)')
call c_i2(IAND(NOT(j),j2),ja,'NOT(integer*2)')
call c_i1(IAND(NOT(k),k2),ka,'NOT(integer*1)')
call c_i8(IAND(NOT(m),m2),ma,'NOT(integer*8)')
if ( fail ) call abort()
end
subroutine failure(label)
c 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_l(i,j,label)
c Check if LOGICAL i equals j, and fail otherwise
logical i,j
character*(*) label
if ( i .eqv. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i(i,j,label)
c Check if INTEGER i equals j, and fail otherwise
integer i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i2(i,j,label)
c Check if INTEGER*2 i equals j, and fail otherwise
integer*2 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i1(i,j,label)
c Check if INTEGER*1 i equals j, and fail otherwise
integer*1 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i8(i,j,label)
c Check if INTEGER*8 i equals j, and fail otherwise
integer*8 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
gcc/testsuite/g77.f-torture/execute/f90-intrinsic-mathematical.f deleted 100644 → 0
c f90-intrinsic-mathematical.f
c
c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and
c 13.13
c David Billinghurst <David.Billinghurst@riotinto.com>
c
c Notes:
c * g77 does not fully comply with F90. Noncompliances noted in comments.
c * Section 13.12: Specific names for intrinsic functions tested in
c intrinsic77.f
logical fail
common /flags/ fail
fail = .false.
c ACOS - Section 13.13.3
call c_r(ACOS(0.54030231),1.0,'ACOS(real)')
call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)')
c ASIN - Section 13.13.12
call c_r(ASIN(0.84147098),1.0,'ASIN(real)')
call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)')
c ATAN - Section 13.13.14
call c_r(ATAN(1.5574077),1.0,'ATAN(real)')
call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)')
c ATAN2 - Section 13.13.15
call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)')
call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)')
c COS - Section 13.13.22
call c_r(COS(1.0),0.54030231,'COS(real)')
call c_d(COS(1.d0),0.54030231d0,'COS(double)')
call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)')
call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0),
$ 'COS(double complex)')
c COSH - Section 13.13.23
call c_r(COSH(1.0),1.5430806,'COSH(real)')
call c_d(COSH(1.d0),1.5430806d0,'COSH(double)')
c EXP - Section 13.13.34
call c_r(EXP(1.0),2.7182818,'EXP(real)')
call c_d(EXP(1.d0),2.7182818d0,'EXP(double)')
call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)')
call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0),
$ 'EXP(double complex)')
c LOG - Section 13.13.59
call c_r(LOG(10.0),2.3025851,'LOG(real)')
call c_d(LOG(10.d0),2.3025851d0,'LOG(double)')
call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)')
call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0),
$ 'LOG(double complex)')
c LOG10 - Section 13.13.60
call c_r(LOG10(10.0),1.0,'LOG10(real)')
call c_d(LOG10(10.d0),1.d0,'LOG10(double)')
c SIN - Section 13.13.97
call c_r(SIN(1.0),0.84147098,'SIN(real)')
call c_d(SIN(1.d0),0.84147098d0,'SIN(double)')
call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)')
call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0),
$ 'SIN(double complex)')
c SINH - Section 13.13.98
call c_r(SINH(1.0),1.175201,'SINH(real)')
call c_d(SINH(1.d0),1.175201d0,'SINH(double)')
c SQRT - Section 13.13.102
call c_r(SQRT(4.0),2.0,'SQRT(real)')
call c_d(SQRT(4.d0),2.d0,'SQRT(double)')
call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)')
call c_z(SQRT((4.d0,0.)),(2.d0,0.),
$ 'SQRT(double complex)')
c TAN - Section 13.13.105
call c_r(TAN(1.0),1.5574077,'TAN(real)')
call c_d(TAN(1.d0),1.5574077d0,'TAN(double)')
c TANH - Section 13.13.106
call c_r(TANH(1.0),0.76159416,'TANH(real)')
call c_d(TANH(1.d0),0.76159416d0,'TANH(double)')
if ( fail ) call abort()
end
subroutine failure(label)
c 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)
c 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)
c 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)
c 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 c_z(a,b,label)
c Check if COMPLEX a equals b, and fail otherwise
double complex 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
gcc/testsuite/g77.f-torture/execute/f90-intrinsic-numeric.f deleted 100644 → 0
c f90-intrinsic-numeric.f
c
c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13
c David Billinghurst <David.Billinghurst@riotinto.com>
c
c Notes:
c * g77 does not fully comply with F90. Noncompliances noted in comments.
c * Section 13.12: Specific names for intrinsic functions tested in
c intrinsic77.f
logical fail
integer*2 j, j2, ja
integer*1 k, k2, ka
common /flags/ fail
fail = .false.
c ABS - Section 13.13.1
j = -9
ja = 9
k = j
ka = ja
call c_i(ABS(-7),7,'ABS(integer)')
call c_i2(ABS(j),ja,'ABS(integer*2)')
call c_i1(ABS(k),ka,'ABS(integer*1)')
call c_r(ABS(-7.),7.,'ABS(real)')
call c_d(ABS(-7.d0),7.d0,'ABS(double)')
call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
call c_d(ABS((3.d0,-4.d0)),5.0d0,'ABS(double complex)')
c AIMAG - Section 13.13.6
call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
c g77: AIMAG(double complex) does not comply with F90
c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(double complex)')
c AINT - Section 13.13.7
call c_r(AINT(2.783),2.0,'AINT(real) 1')
call c_r(AINT(-2.783),-2.0,'AINT(real) 2')
call c_d(AINT(2.783d0),2.0d0,'AINT(double precision) 1')
call c_d(AINT(-2.783d0),-2.0d0,'AINT(double precision) 2')
c Note: g77 does not support optional argument KIND
c ANINT - Section 13.13.10
call c_r(ANINT(2.783),3.0,'ANINT(real) 1')
call c_r(ANINT(-2.783),-3.0,'ANINT(real) 2')
call c_d(ANINT(2.783d0),3.0d0,'ANINT(double precision) 1')
call c_d(ANINT(-2.783d0),-3.0d0,'ANINT(double precision) 2')
c Note: g77 does not support optional argument KIND
c CEILING - Section 13.13.18
c Not implemented
c CMPLX - Section 13.13.20
j = 1
ja = 2
k = 1
ka = 2
call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
call c_c(CMPLX(j),(1.,0.),'CMPLX(integer*2)')
call c_c(CMPLX(j,ja),(1.,2.),'CMPLX(integer*2, integer*2)')
call c_c(CMPLX(k),(1.,0.),'CMPLX(integer*1)')
call c_c(CMPLX(k,ka),(1.,2.),'CMPLX(integer*1, integer*1)')
call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double complex)')
c NOTE: g77 does not support optional argument KIND
c CONJG - Section 13.13.21
call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
call c_z(CONJG((2.d0,-7.d0)),(2.d0,7.d0),'CONJG(double complex)')
c DBLE - Section 13.13.27
j = 5
k = 5
call c_d(DBLE(5),5.0d0,'DBLE(integer)')
call c_d(DBLE(j),5.0d0,'DBLE(integer*2)')
call c_d(DBLE(k),5.0d0,'DBLE(integer*1)')
call c_d(DBLE(5.),5.0d0,'DBLE(real)')
call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
call c_d(DBLE((5.0d0,0.5d0)),5.0d0,'DBLE(double complex)')
c DIM - Section 13.13.29
j = -8
j2 = -3
ja = 0
k = -8
k2 = -3
ka = 0
call c_i(DIM(-8,-3),0,'DIM(integer)')
call c_i2(DIM(j,j2),ja,'DIM(integer*2)')
call c_i1(DIM(k,k2),ka,'DIM(integer*1)')
call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
c DPROD - Section 13.13.31
call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
c FLOOR - Section 13.13.36
c Not implemented
c INT - Section 13.13.47
j = 5
k = 5
call c_i(INT(5),5,'INT(integer)')
call c_i(INT(j),5,'INT(integer*2)')
call c_i(INT(k),5,'INT(integer*1)')
call c_i(INT(5.01),5,'INT(real)')
call c_i(INT(5.01d0),5,'INT(double)')
c Note: Does not accept optional second argument KIND
c MAX - Section 13.13.63
j = 1
j2 = 2
ja = 2
k = 1
k2 = 2
ka = 2
call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
call c_i2(MAX(j,j2),ja,'MAX(integer*2,integer*2)')
call c_i1(MAX(k,k2),ka,'MAX(integer*1,integer*1)')
call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
c MIN - Section 13.13.68
j = 1
j2 = 2
ja = 1
k = 1
k2 = 2
ka = 1
call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
call c_i2(MIN(j,j2),ja,'MIN(integer*2,integer*2)')
call c_i1(MIN(k,k2),ka,'MIN(integer*1,integer*1)')
call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
c MOD - Section 13.13.72
call c_i(MOD(8,5),3,'MOD(integer,integer) 1')
call c_i(MOD(-8,5),-3,'MOD(integer,integer) 2')
call c_i(MOD(8,-5),3,'MOD(integer,integer) 3')
call c_i(MOD(-8,-5),-3,'MOD(integer,integer) 4')
j = 8
j2 = 5
ja = 3
call c_i2(MOD(j,j2),ja,'MOD(integer*2,integer*2) 1')
call c_i2(MOD(-j,j2),-ja,'MOD(integer*2,integer*2) 2')
call c_i2(MOD(j,-j2),ja,'MOD(integer*2,integer*2) 3')
call c_i2(MOD(-j,-j2),-ja,'MOD(integer*2,integer*2) 4')
k = 8
k2 = 5
ka = 3
call c_i1(MOD(k,k2),ka,'MOD(integer*1,integer*1) 1')
call c_i1(MOD(-k,k2),-ka,'MOD(integer*1,integer*1) 2')
call c_i1(MOD(k,-k2),ka,'MOD(integer*1,integer*1) 3')
call c_i1(MOD(-k,-k2),-ka,'MOD(integer*1,integer*1) 4')
call c_r(MOD(8.,5.),3.,'MOD(real,real) 1')
call c_r(MOD(-8.,5.),-3.,'MOD(real,real) 2')
call c_r(MOD(8.,-5.),3.,'MOD(real,real) 3')
call c_r(MOD(-8.,-5.),-3.,'MOD(real,real) 4')
call c_d(MOD(8.d0,5.d0),3.d0,'MOD(double,double) 1')
call c_d(MOD(-8.d0,5.d0),-3.d0,'MOD(double,double) 2')
call c_d(MOD(8.d0,-5.d0),3.d0,'MOD(double,double) 3')
call c_d(MOD(-8.d0,-5.d0),-3.d0,'MOD(double,double) 4')
c MODULO - Section 13.13.73
c Not implemented
c NINT - Section 13.13.76
call c_i(NINT(2.783),3,'NINT(real)')
call c_i(NINT(2.783d0),3,'NINT(double)')
c Optional second argument KIND not implemented
c REAL - Section 13.13.86
j = -2
k = -2
call c_r(REAL(-2),-2.0,'REAL(integer)')
call c_r(REAL(j),-2.0,'REAL(integer*2)')
call c_r(REAL(k),-2.0,'REAL(integer*1)')
call c_r(REAL(-2.0),-2.0,'REAL(real)')
call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
c REAL(double complex) not implemented
c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(double complex)')
c SIGN - Section 13.13.96
j = -3
j2 = 2
ja = 3
k = -3
k2 = 2
ka = 3
call c_i(SIGN(-3,2),3,'SIGN(integer)')
call c_i2(SIGN(j,j2),ja,'SIGN(integer*2)')
call c_i1(SIGN(k,k2),ka,'SIGN(integer*1)')
call c_r(SIGN(-3.0,2.),3.,'SIGN(real,real)')
call c_d(SIGN(-3.d0,2.d0),3.d0,'SIGN(double,double)')
if ( fail ) call abort()
end
subroutine failure(label)
c 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_i(i,j,label)
c Check if INTEGER i equals j, and fail otherwise
integer i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i2(i,j,label)
c Check if INTEGER*2 i equals j, and fail otherwise
integer*2 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_i1(i,j,label)
c Check if INTEGER*1 i equals j, and fail otherwise
integer*1 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_r(a,b,label)
c 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)
c 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)
c 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 c_z(a,b,label)
c Check if COMPLEX a equals b, and fail otherwise
double complex 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
gcc/testsuite/g77.f-torture/execute/int8421.f deleted 100644 → 0
integer*1 i1, i11
integer*2 i2, i22
integer i, ii
integer*4 i4, i44
integer*8 i8, i88
real r, rr
real*4 r4, r44
double precision d, dd
real*8 r8, r88
parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1)
parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1)
if (i8 .ne. 15 ) call abort
if (d .ne. 61.d0) call abort
i11 = 1; i22 = 2; i44 = 4; ii = 5
i88 = i + i4*i2 + i2*i1
if (i88 .ne. i8) call abort
rr = 3.0; r44 = 4.0; r88 = 8.0d0
dd = i88*rr + r44*i22 + r88*i11
if (dd .ne. d) call abort
end
gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f deleted 100644 → 0
c intrinsic-f2c-z.f
c
c Test double complex intrinsics Z*.
c These functions are f2c extensions
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
double complex z, a
double precision x
logical fail
intrinsic zabs, zcos, zexp, zlog, zsin, zsqrt
common /flags/ fail
fail = .false.
c ZABS - Absolute value
z = (3.0d0,-4.0d0)
x = 5.0d0
call c_d(ZABS(z),x,'ZABS(double complex)')
call p_d_z(ZABS,z,x,'ZABS')
c ZCOS - Cosine
z = (3.0d0,1.0d0)
a = (-1.52763825012d0,-0.165844401919)
call c_z(ZCOS(z),a,'ZCOS(double complex)')
call p_z_z(ZCOS,z,a,'ZCOS')
c ZEXP - Exponential
z = (3.0d0,1.0d0)
a = (10.8522619142d0,16.9013965352)
call c_z(ZEXP(z),a,'ZEXP(double complex)')
call p_z_z(ZEXP,z,a,'ZEXP')
c ZLOG - Natural logarithm
call c_z(ZLOG(a),z,'ZLOG(double complex)')
call p_z_z(ZLOG,a,z,'ZLOG')
c ZSIN - Sine
z = (3.0d0,1.0d0)
a = (0.217759551622d0,-1.1634403637d0)
call c_z(ZSIN(z),a,'ZSIN(double complex)')
call p_z_z(ZSIN,z,a,'ZSIN')
c ZSQRT - Square root
z = (0.0d0,-4.0d0)
a = sqrt(2.0d0)*(1.0d0,-1.0d0)
call c_z(ZSQRT(z),a,'ZSQRT(double complex)')
call p_z_z(ZSQRT,z,a,'ZSQRT')
if ( fail ) call abort()
end
subroutine failure(label)
c 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_z(a,b,label)
c Check if DOUBLE COMPLEX a equals b, and fail otherwise
double 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 c_d(a,b,label)
c 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 p_z_z(f,x,a,label)
c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
double complex f,x,a
character*(*) label
call c_z(f(x),a,label)
end
subroutine p_d_z(f,x,a,label)
c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
double precision f,x
double complex a
character*(*) label
call c_d(f(x),a,label)
end
gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f deleted 100644 → 0
c intrinsic-unix-bessel.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
real x, a
double precision dx, da
integer i
integer*2 j
integer*1 k
integer*8 m
logical fail
common /flags/ fail
fail = .false.
x = 2.0
dx = x
i = 2
j = i
k = i
m = i
c BESJ0 - Bessel function of first kind of order zero
a = 0.22389077
da = a
call c_r(BESJ0(x),a,'BESJ0(real)')
call c_d(BESJ0(dx),da,'BESJ0(double)')
call c_d(DBESJ0(dx),da,'DBESJ0(double)')
c BESJ1 - Bessel function of first kind of order one
a = 0.57672480
da = a
call c_r(BESJ1(x),a,'BESJ1(real)')
call c_d(BESJ1(dx),da,'BESJ1(double)')
call c_d(DBESJ1(dx),da,'DBESJ1(double)')
c BESJN - Bessel function of first kind of order N
a = 0.3528340
da = a
call c_r(BESJN(i,x),a,'BESJN(integer,real)')
call c_r(BESJN(j,x),a,'BESJN(integer*2,real)')
call c_r(BESJN(k,x),a,'BESJN(integer*1,real)')
call c_d(BESJN(i,dx),da,'BESJN(integer,double)')
call c_d(BESJN(j,dx),da,'BESJN(integer*2,double)')
call c_d(BESJN(k,dx),da,'BESJN(integer*1,double)')
call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)')
call c_d(DBESJN(j,dx),da,'DBESJN(integer*2,double)')
call c_d(DBESJN(k,dx),da,'DBESJN(integer*1,double)')
c BESY0 - Bessel function of second kind of order zero
a = 0.51037567
da = a
call c_r(BESY0(x),a,'BESY0(real)')
call c_d(BESY0(dx),da,'BESY0(double)')
call c_d(DBESY0(dx),da,'DBESY0(double)')
c BESY1 - Bessel function of second kind of order one
a = 0.-0.1070324
da = a
call c_r(BESY1(x),a,'BESY1(real)')
call c_d(BESY1(dx),da,'BESY1(double)')
call c_d(DBESY1(dx),da,'DBESY1(double)')
c BESYN - Bessel function of second kind of order N
a = -0.6174081
da = a
call c_r(BESYN(i,x),a,'BESYN(integer,real)')
call c_r(BESYN(j,x),a,'BESYN(integer*2,real)')
call c_r(BESYN(k,x),a,'BESYN(integer*1,real)')
call c_d(BESYN(i,dx),da,'BESYN(integer,double)')
call c_d(BESYN(j,dx),da,'BESYN(integer*2,double)')
call c_d(BESYN(k,dx),da,'BESYN(integer*1,double)')
call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)')
call c_d(DBESYN(j,dx),da,'DBESYN(integer*2,double)')
call c_d(DBESYN(k,dx),da,'DBESYN(integer*1,double)')
if ( fail ) call abort()
end
subroutine failure(label)
c 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)
c 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)
c 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
gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f deleted 100644 → 0
c intrinsic-unix-erf.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
real x, a
double precision dx, da
logical fail
common /flags/ fail
fail = .false.
x = 0.6
dx = x
c ERF - error function
a = 0.6038561
da = a
call c_r(ERF(x),a,'ERF(real)')
call c_d(ERF(dx),da,'ERF(double)')
call c_d(DERF(dx),da,'DERF(double)')
c ERFC - complementary error function
a = 1.0 - a
da = a
call c_r(ERFC(x),a,'ERFC(real)')
call c_d(ERFC(dx),da,'ERFC(double)')
call c_d(DERFC(dx),da,'DERFC(double)')
if ( fail ) call abort()
end
subroutine failure(label)
c 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)
c 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)
c 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
gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f deleted 100644 → 0
c intrinsic-vax-cd.f
c
c Test double complex intrinsics CD*.
c These functions are VAX extensions
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
double complex z, a
double precision x
logical fail
intrinsic cdabs, cdcos, cdexp, cdlog, cdsin, cdsqrt
common /flags/ fail
fail = .false.
c CDABS - Absolute value
z = (3.0d0,-4.0d0)
x = 5.0d0
call c_d(CDABS(z),x,'CDABS(double complex)')
call p_d_z(CDABS,z,x,'CDABS')
c CDCOS - Cosine
z = (3.0d0,1.0d0)
a = (-1.52763825012d0,-0.165844401919)
call c_z(CDCOS(z),a,'CDCOS(double complex)')
call p_z_z(CDCOS,z,a,'CDCOS')
c CDEXP - Exponential
z = (3.0d0,1.0d0)
a = (10.8522619142d0,16.9013965352)
call c_z(CDEXP(z),a,'CDEXP(double complex)')
call p_z_z(CDEXP,z,a,'CDEXP')
c CDLOG - Natural logarithm
call c_z(CDLOG(a),z,'CDLOG(double complex)')
call p_z_z(CDLOG,a,z,'CDLOG')
c CDSIN - Sine
z = (3.0d0,1.0d0)
a = (0.217759551622d0,-1.1634403637d0)
call c_z(CDSIN(z),a,'CDSIN(double complex)')
call p_z_z(CDSIN,z,a,'CDSIN')
c CDSQRT - Square root
z = (0.0d0,-4.0d0)
a = sqrt(2.0d0)*(1.0d0,-1.0d0)
call c_z(CDSQRT(z),a,'CDSQRT(double complex)')
call p_z_z(CDSQRT,z,a,'CDSQRT')
if ( fail ) call abort()
end
subroutine failure(label)
c 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_z(a,b,label)
c Check if DOUBLE COMPLEX a equals b, and fail otherwise
double 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 c_d(a,b,label)
c 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 p_z_z(f,x,a,label)
c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
double complex f,x,a
character*(*) label
call c_z(f(x),a,label)
end
subroutine p_d_z(f,x,a,label)
c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
double precision f,x
double complex a
character*(*) label
call c_d(f(x),a,label)
end
gcc/testsuite/g77.f-torture/execute/intrinsic77.f deleted 100644 → 0
program intrinsic77
c
c Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10)
c
c Test:
c * specific functions
c * generic functions with each argument type
c * specific functions by passing as subroutine argument
c where permiited by Section 13.12 of Fortran 90 standard
c
logical fail
common /flags/ fail
fail = .false.
call type_conversion
call truncation
call nearest_whole_number
call nearest_integer
call absolute_value
call remaindering
call transfer_of_sign
call positive_difference
call double_precision_product
call choosing_largest_value
call choosing_smallest_value
call length_of_character_array
call index_of_substring
call imaginary_part
call complex_conjugate
call square_root
call exponential
call natural_logarithm
call common_logarithm
call sine
call cosine
call tangent
call arcsine
call arccosine
call arctangent
call hyperbolic_sine
call hyperbolic_cosine
call hyperbolic_tangent
call lexically_greater_than_or_equal
call lexically_greater_than
call lexically_less_than_or_equal
call lexically_less_than
if ( fail ) call abort()
end
subroutine failure(label)
c 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_i(i,j,label)
c Check if INTEGER i equals j, and fail otherwise
integer i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end
subroutine c_r(a,b,label)
c 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)
c 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)
c 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 c_l(a,b,label)
c Check if LOGICAL a equals b, and fail otherwise
logical a, b
character*(*) label
if ( a .neqv. b ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine c_ch(a,b,label)
c Check if CHARACTER a equals b, and fail otherwise
character*(*) a, b
character*(*) label
if ( a .ne. b ) then
call failure(label)
write(6,*) 'Got ',a,' expected ', b
end if
end
subroutine p_i_i(f,x,i,label)
c Check if INTEGER f(x) equals i for INTEGER x
integer f,x,i
character*(*) label
call c_i(f(x),i,label)
end
subroutine p_i_ii(f,x1,x2,i,label)
c Check if INTEGER f(x1,x2) equals i for INTEGER x
integer f,x1,x2,i
character*(*) label
call c_i(f(x1,x2),i,label)
end
subroutine p_i_r(f,x,i,label)
c Check if INTEGER f(x) equals i for REAL x
real x
integer f,i
character*(*) label
call c_i(f(x),i,label)
end
subroutine p_i_d(f,x,i,label)
c Check if INTEGER f(x) equals i for DOUBLE PRECISION x
double precision x
integer f,i
character*(*) label
call c_i(f(x),i,label)
end
subroutine p_i_ch(f,x,a,label)
c Check if INTEGER f(x) equals a for CHARACTER x
character*(*) x
integer f, a
character*(*) label
call c_i(f(x),a,label)
end
subroutine p_i_chch(f,x1,x2,a,label)
c Check if INTEGER f(x1,x2) equals a for CHARACTER x1 and x2
character*(*) x1,x2
integer f, a
character*(*) label
call c_i(f(x1,x2),a,label)
end
subroutine p_r_r(f,x,a,label)
c 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_r_rr(f,x1,x2,a,label)
c Check if REAL f(x1,x2) equals a for REAL x1, x2
real f,x1,x2,a
character*(*) label
call c_r(f(x1,x2),a,label)
end
subroutine p_d_d(f,x,a,label)
c 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_d_rr(f,x1,x2,a,label)
c Check if DOUBLE PRECISION f(x1,x2) equals a for real x1,x2
double precision f,a
real x1,x2
character*(*) label
call c_d(f(x1,x2),a,label)
end
subroutine p_d_dd(f,x1,x2,a,label)
c Check if DOUBLE PRECISION f(x1,x2) equals a for DOUBLE PRECISION x1,x2
double precision f,x1,x2,a
character*(*) label
call c_d(f(x1,x2),a,label)
end
subroutine p_c_c(f,x,a,label)
c Check if COMPLEX f(x) equals a for COMPLEX x
complex f,x,a
character*(*) label
call c_c(f(x),a,label)
end
subroutine p_r_c(f,x,a,label)
c Check if REAL f(x) equals a for COMPLEX x
complex x
real f, a
character*(*) label
call c_r(f(x),a,label)
end
subroutine type_conversion
integer i
character*1 c
c conversion to integer
call c_i(INT(5),5,'INT(integer)')
call c_i(INT(5.01),5,'INT(real)')
call c_i(INT(5.01d0),5,'INT(double)')
call c_i(INT((5.01,-3.0)),5,'INT(complex)')
call c_i(IFIX(5.01),5,'IFIX(real)')
call c_i(IDINT(5.01d0),5,'IDINT(double)')
c conversion to real
call c_r(REAL(-2),-2.0,'REAL(integer)')
call c_r(REAL(-2.0),-2.0,'REAL(real)')
call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
call c_r(FLOAT(-2),-2.0,'FLOAT(int)')
call c_r(SNGL(-2.0d0),-2.0,'SNGL(double)')
c conversion to double
call c_d(DBLE(5),5.0d0,'DBLE(integer)')
call c_d(DBLE(5.),5.0d0,'DBLE(real)')
call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
c conversion to complex
call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(real,real)')
call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
c character conversion
c = 'C'
i = ichar(c)
call c_i(ICHAR(c),i,'ICHAR')
call c_ch(CHAR(i),c,'CHAR')
end
subroutine truncation
intrinsic aint, dint
call c_r(AINT(9.2),9.0,'AINT(real)')
call c_d(AINT(9.2d0),9.0d0,'AINT(double)')
call c_d(DINT(9.2d0),9.0d0,'DINT(double)')
call p_r_r(AINT,9.2,9.0,'AINT')
call p_d_d(DINT,9.2d0,9.0d0,'DINT')
end
subroutine nearest_whole_number
intrinsic anint, dnint
call c_r(ANINT(9.2),9.0,'ANINT(real)')
call c_d(ANINT(9.2d0),9.0d0,'ANINT(double)')
call c_d(DNINT(9.2d0),9.0d0,'DNINT(double)')
call p_r_r(ANINT,9.2,9.0,'ANINT')
call p_d_d(DNINT,9.2d0,9.0d0,'DNINT')
end
subroutine nearest_integer
intrinsic nint, idnint
call c_i(NINT(9.2),9,'NINT(real)')
call c_i(NINT(9.2d0),9,'NINT(double)')
call c_i(IDNINT(9.2d0),9,'IDNINT(double)')
call p_i_r(NINT,9.2,9,'NINT')
call p_i_d(IDNINT,9.2d0,9,'IDNINT')
end
subroutine absolute_value
intrinsic iabs, abs, dabs, cabs
call c_i(ABS(-7),7,'ABS(integer)')
call c_r(ABS(-7.),7.,'ABS(real)')
call c_d(ABS(-7.d0),7.d0,'ABS(double)')
call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
call c_i(IABS(-7),7,'IABS(integer)')
call c_d( DABS(-7.d0),7.d0,'DABS(double)')
call c_r( CABS((3.,-4.)),5.0,'CABS(complex)')
call p_i_i(IABS,-7,7,'IABS')
call p_r_r(ABS,-7.,7.,'ABS')
call p_d_d(DABS,-7.0d0,7.0d0,'DABS')
call p_r_c(CABS,(3.,-4.), 5.0,'CABS')
end
subroutine remaindering
intrinsic mod, amod, dmod
call c_i( MOD(8,3),2,'MOD(integer,integer)')
call c_r( MOD(8.,3.),2.,'MOD(real,real)')
call c_d( MOD(8.d0,3.d0),2.d0,'MOD(double,double)')
call c_r( AMOD(8.,3.),2.,'AMOD(real,real)')
call c_d( DMOD(8.d0,3.d0),2.d0,'DMOD(double,double)')
call p_i_ii(MOD,8,3,2,'MOD')
call p_r_rr(AMOD,8.,3.,2.,'AMOD')
call p_d_dd(DMOD,8.d0,3.d0,2.d0,'DMOD')
end
subroutine transfer_of_sign
intrinsic isign,sign,dsign
call c_i(SIGN(8,-3),-8,'SIGN(integer)')
call c_r(SIGN(8.,-3.),-8.,'SIGN(real,real)')
call c_d(SIGN(8.d0,-3.d0),-8.d0,'SIGN(double,double)')
call c_i(ISIGN(8,-3),-8,'ISIGN(integer)')
call c_d(DSIGN(8.d0,-3.d0),-8.d0,'DSIGN(double,double)')
call p_i_ii(ISIGN,8,-3,-8,'ISIGN')
call p_r_rr(SIGN,8.,-3.,-8.,'SIGN')
call p_d_dd(DSIGN,8.d0,-3.d0,-8.d0,'DSIGN')
end
subroutine positive_difference
intrinsic idim, dim, ddim
call c_i(DIM(-8,-3),0,'DIM(integer)')
call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
call c_i(IDIM(-8,-3),0,'IDIM(integer)')
call c_d(DDIM(-8.d0,-3.d0),0.d0,'DDIM(double,double)')
call p_i_ii(IDIM,-8,-3,0,'IDIM')
call p_r_rr(DIM,-8.,-3.,0.,'DIM')
call p_d_dd(DDIM,-8.d0,-3.d0,0.d0,'DDIM')
end
subroutine double_precision_product
intrinsic dprod
call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
call p_d_rr(DPROD,-8.,-3.,24.d0,'DPROD')
end
subroutine choosing_largest_value
call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
call c_i(MAX0(1,2,3),3,'MAX0(integer,integer,integer)')
call c_r(AMAX1(1.,2.,3.),3.,'MAX(real,real,real)')
call c_d(DMAX1(1.d0,2.d0,3.d0),3.d0,'DMAX1(double,double,double)')
call c_r(AMAX0(1,2,3),3.,'AMAX0(integer,integer,integer)')
call c_i(MAX1(1.,2.,3.),3,'MAX1(real,real,real)')
end
subroutine choosing_smallest_value
call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
call c_i(MIN0(1,2,3),1,'MIN0(integer,integer,integer)')
call c_r(AMIN1(1.,2.,3.),1.,'MIN(real,real,real)')
call c_d(DMIN1(1.d0,2.d0,3.d0),1.d0,'DMIN1(double,double,double)')
call c_r(AMIN0(1,2,3),1.,'AMIN0(integer,integer,integer)')
call c_i(MIN1(1.,2.,3.),1,'MIN1(real,real,real)')
end
subroutine length_of_character_array
intrinsic len
call c_i(LEN('ABCDEF'),6,'LEN 1')
call p_i_ch(LEN,'ABCDEF',6,'LEN 2')
end
subroutine index_of_substring
intrinsic index
call c_i(INDEX('ABCDEF','C'),3,'INDEX 1')
call p_i_chch(INDEX,'ABCDEF','C',3,'INDEX 2')
end
subroutine imaginary_part
intrinsic aimag
call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
call p_r_c(AIMAG,(2.,-7.),-7.,'AIMAG(complex)')
end
subroutine complex_conjugate
intrinsic conjg
call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
call p_c_c(CONJG,(2.,-7.),(2.,7.),'CONJG')
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 exponential
intrinsic exp, dexp, cexp
real x, a
x = 0.0
a = 1.0
call c_r(EXP(x),a,'EXP(real)')
call c_d(EXP(1.d0*x),1.d0*a,'EXP(double)')
call c_c(EXP((1.,0.)*x),(1.,0.)*a,'EXP(complex)')
call c_d(DEXP(1.d0*x),1.d0*a,'DEXP(double)')
call c_c(CEXP((1.,0.)*x),(1.,0.)*a,'CEXP(complex)')
call p_r_r(EXP,x,a,'EXP')
call p_d_d(DEXP,1.d0*x,1.d0*a,'DEXP')
call p_c_c(CEXP,(1.,0.)*x,(1.,0.)*a ,'CEXP')
end
subroutine natural_logarithm
intrinsic alog, dlog, clog
real x, a
a = 1.234
x = exp(a)
call c_r(LOG(x),a,'LOG(real)')
call c_d(LOG(1.d0*x),1.d0*a,'LOG(double)')
call c_c(LOG((1.,0.)*x),(1.,0.)*a,'LOG(complex)')
call c_r(ALOG(x),a,'ALOG(real)')
call c_d(DLOG(1.d0*x),1.d0*a,'DLOG(double)')
call c_c(CLOG((1.,0.)*x),(1.,0.)*a,'CLOG(complex)')
call p_r_r(ALOG,x,a,'LOG')
call p_d_d(DLOG,1.d0*x,1.d0*a,'DLOG')
call p_c_c(CLOG,(1.,0.)*x,(1.,0.)*a,'CLOG')
end
subroutine common_logarithm
intrinsic alog10, dlog10
real x, a
x = 100.0
a = 2.0
call c_r(LOG10(x),a,'LOG10(real)')
call c_d(LOG10(1.d0*x),1.d0*a,'LOG10(double)')
call c_r(ALOG10(x),a,'ALOG10(real)')
call c_d(DLOG10(1.d0*x),1.d0*a,'DLOG10(double)')
call p_r_r(ALOG10,x,a,'ALOG10')
call p_d_d(DLOG10,1.d0*x,1.d0*a ,'DLOG10')
end
subroutine sine
intrinsic sin, dsin, csin
real x, a
a = 1.0
x = asin(a)
call c_r(SIN(x),a,'SIN(real)')
call c_d(SIN(1.d0*x),1.d0*a,'SIN(double)')
call c_c(SIN((1.,0.)*x),(1.,0.)*a,'SIN(complex)')
call c_d(DSIN(1.d0*x),1.d0*a,'DSIN(double)')
call c_c(CSIN((1.,0.)*x),(1.,0.)*a,'CSIN(complex)')
call p_r_r(SIN,x,a,'SIN')
call p_d_d(DSIN,1.d0*x,1.d0*a,'DSIN')
call p_c_c(CSIN,(1.,0.)*x,(1.,0.)*a ,'CSIN')
end
subroutine cosine
intrinsic cos, dcos, ccos
real x, a
a = 0.123456
x = acos(a)
call c_r(COS(x),a,'COS(real)')
call c_d(COS(1.d0*x),1.d0*a,'COS(double)')
call c_c(COS((1.,0.)*x),(1.,0.)*a,'COS(complex)')
call c_r(COS(x),a,'COS(real)')
call c_d(DCOS(1.d0*x),1.d0*a,'DCOS(double)')
call c_c(CCOS((1.,0.)*x),(1.,0.)*a,'CCOS(complex)')
call p_r_r(COS,x,a,'COS')
call p_d_d(DCOS,1.d0*x,1.d0*a ,'DCOS')
call p_c_c(CCOS,(1.,0.)*x, (1.,0.)*a ,'CCOS')
end
subroutine tangent
intrinsic tan, dtan
real x, a
a = 0.5
x = atan(a)
call c_r(TAN(x),a,'TAN(real)')
call c_d(TAN(1.d0*x),1.d0*a,'TAN(double)')
call c_d(DTAN(1.d0*x),1.d0*a,'DTAN(double)')
call p_r_r(TAN,x,a,'TAN')
call p_d_d(DTAN,1.d0*x,1.d0*a ,'DTAN')
end
subroutine arcsine
intrinsic asin, dasin
real x, a
a = 0.5
x = sin(a)
call c_r(ASIN(x),a,'ASIN(real)')
call c_d(ASIN(1.d0*x),1.d0*a,'ASIN(double)')
call c_d(DASIN(1.d0*x),1.d0*a,'DASIN(double)')
call p_r_r(ASIN,x,a,'ASIN')
call p_d_d(DASIN,1.d0*x,1.d0*a ,'DASIN')
end
subroutine arccosine
intrinsic acos, dacos
real x, a
x = 0.70710678
a = 0.785398
call c_r(ACOS(x),a,'ACOS(real)')
call c_d(ACOS(1.d0*x),1.d0*a,'ACOS(double)')
call c_d(DACOS(1.d0*x),1.d0*a,'DACOS(double)')
call p_r_r(ACOS,x,a,'ACOS')
call p_d_d(DACOS,1.d0*x,1.d0*a ,'DACOS')
end
subroutine arctangent
intrinsic atan, atan2, datan, datan2
real x1, x2, a
a = 0.75
x1 = tan(a)
x2 = 1.0
call c_r(ATAN(x1),a,'ATAN(real)')
call c_d(ATAN(1.d0*x1),1.d0*a,'ATAN(double)')
call c_d(DATAN(1.d0*x1),1.d0*a,'DATAN(double)')
call c_r(ATAN2(x1,x2),a,'ATAN2(real)')
call c_d(ATAN2(1.d0*x1,1.d0*x2),1.d0*a,'ATAN2(double)')
call c_d(DATAN2(1.d0*x1,1.d0*x2),1.0d0*a,'DATAN2(double)')
call p_r_r(ATAN,x1,a,'ATAN')
call p_d_d(DATAN,1.d0*x1,1.d0*a,'DATAN')
call p_r_rr(ATAN2,x1,x2,a,'ATAN2')
call p_d_dd(DATAN2,1.d0*x1,1.d0*x2,1.d0*a,'DATAN2')
end
subroutine hyperbolic_sine
intrinsic sinh, dsinh
real x, a
x = 1.0
a = 1.1752012
call c_r(SINH(x),a,'SINH(real)')
call c_d(SINH(1.d0*x),1.d0*a,'SINH(double)')
call c_d(DSINH(1.d0*x),1.d0*a,'DSINH(double)')
call p_r_r(SINH,x,a,'SINH')
call p_d_d(DSINH,1.d0*x,1.d0*a ,'DSINH')
end
subroutine hyperbolic_cosine
intrinsic cosh, dcosh
real x, a
x = 1.0
a = 1.5430806
call c_r(COSH(x),a,'COSH(real)')
call c_d(COSH(1.d0*x),1.d0*a,'COSH(double)')
call c_d(DCOSH(1.d0*x),1.d0*a,'DCOSH(double)')
call p_r_r(COSH,x,a,'COSH')
call p_d_d(DCOSH,1.d0*x,1.d0*a ,'DCOSH')
end
subroutine hyperbolic_tangent
intrinsic tanh, dtanh
real x, a
x = 1.0
a = 0.76159416
call c_r(TANH(x),a,'TANH(real)')
call c_d(TANH(1.d0*x),1.d0*a,'TANH(double)')
call c_d(DTANH(1.d0*x),1.d0*a,'DTANH(double)')
call p_r_r(TANH,x,a,'TANH')
call p_d_d(DTANH,1.d0*x,1.d0*a ,'DTANH')
end
subroutine lexically_greater_than_or_equal
call c_l(LGE('A','B'),.FALSE.,'LGE(character,character) 1')
call c_l(LGE('B','A'),.TRUE.,'LGE(character,character) 2')
call c_l(LGE('A','A'),.TRUE.,'LGE(character,character) 3')
end
subroutine lexically_greater_than
call c_l(LGT('A','B'),.FALSE.,'LGT(character,character) 1')
call c_l(LGT('B','A'),.TRUE.,'LGT(character,character) 2')
call c_l(LGT('A','A'),.FALSE.,'LGT(character,character) 3')
end
subroutine lexically_less_than_or_equal
call c_l(LLE('A','B'),.TRUE.,'LLE(character,character) 1')
call c_l(LLE('B','A'),.FALSE.,'LLE(character,character) 2')
call c_l(LLE('A','A'),.TRUE.,'LLE(character,character) 3')
end
subroutine lexically_less_than
call c_l(LLT('A','B'),.TRUE.,'LLT(character,character) 1')
call c_l(LLT('B','A'),.FALSE.,'LLT(character,character) 2')
call c_l(LLT('A','A'),.FALSE.,'LLT(character,character) 3')
end
gcc/testsuite/g77.f-torture/execute/io0.f deleted 100644 → 0
* Preliminary tests for a few things in the i/o library.
* Thrown together by Dave Love not from specific bug reports --
* other ideas welcome.
character *(*) fmt
parameter (fmt='(1x,i3,f5.1)')
* Scratch file makes sure we can use one and avoids dealing with
* explicit i/o in the testsuite.
open(90, status='scratch') ! try a biggish unit number
write(90, '()') ! extra record for interest
* Formatted i/o can go wild (endless loop AFAIR) if we're wrongly
* assuming an ANSI sprintf.
write(90, fmt) 123, 123.0
backspace 90 ! backspace problems reported on DOSish systems
read(90, fmt) i, r
endfile 90
if (i/=123 .or. nint(r)/=123) call abort
rewind 90 ! make sure we can rewind too
read(90, '()')
read(90, fmt) i, r
if (i/=123 .or. nint(r)/=123) call abort
close(90)
* Make sure we can do unformatted i/o OK. This might be
* problematic on DOS-like systems if we've done an fopen in text
* mode, not binary.
open(90, status='scratch', access='direct', form='unformatted',
+ recl=8)
write(90, rec=1) 123, 123.0
read(90, rec=1) i, r
if (i/=123 .or. nint(r)/=123) call abort
close(90)
open(90, status='scratch', form='unformatted')
write(90) 123, 123.0
backspace 90
read(90) i, r
if (i/=123 .or. nint(r)/=123) call abort
close(90)
* Fails at 1998-09-01 on spurious recursive i/o check (fixed by
* 1998-09-06 libI77 change):
open(90, status='scratch', form='formatted', recl=16,
+ access='direct')
write(90, '(i8,f8.1)',rec=1) 123, 123.0
read(90, '(i8,f8.1)', rec=1) i, r
if (i/=123 .or. nint(r)/=123) call abort
close(90)
end
gcc/testsuite/g77.f-torture/execute/io0.x deleted 100644 → 0
# Scratch files aren't implemented for mmixware
# (_stat is a stub and files can't be deleted).
# Similar restrictions exist for most simulators.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscale*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_execute_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/execute/io1.f deleted 100644 → 0
* Fixed by 1998-09-28 libI77/open.c change.
open(90,status='scratch')
write(90, '(1X, I1 / 1X, I1)') 1, 2
rewind 90
write(90, '(1X, I1)') 1
rewind 90 ! implicit ENDFILE expected
read(90, *) i
read(90, *, end=10) j
call abort()
10 end
gcc/testsuite/g77.f-torture/execute/io1.x deleted 100644 → 0
# Scratch files aren't implemented for mmixware
# (_stat is a stub and files can't be deleted).
# Similar restrictions exist for most simulators.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscale*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_execute_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/execute/labug1.f deleted 100644 → 0
PROGRAM LABUG1
* This program core dumps on mips-sgi-irix6.2 when compiled
* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
* with -O2
*
* Originally derived from LAPACK test suite.
* Almost any change allows it to run.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 25 November 1998
*
* .. Parameters ..
INTEGER LDA, LDE
PARAMETER ( LDA = 2500, LDE = 50 )
COMPLEX CZERO
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
INTEGER I, J, M, N
REAL V
COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)
COMPLEX Z
N=2
M=1
*
do i = 1, m
do j = 1, n
e(i,j) = czero
f(i,j) = czero
end do
end do
*
DO J = 1, N
DO I = 1, M
V = ABS( E(I,J) - F(I,J) )
END DO
END DO
CALL SUB2(M,Z)
END
subroutine SUB2(I,A)
integer i
complex a
end
gcc/testsuite/g77.f-torture/execute/large_vec.f deleted 100644 → 0
parameter (nmax=165000)
double precision x(nmax)
end
gcc/testsuite/g77.f-torture/execute/le.f deleted 100644 → 0
program fool
real foo
integer n
logical t
foo = 2.5
n = 5
t = (n > foo)
if (t .neqv. .true.) call abort
t = (n >= foo)
if (t .neqv. .true.) call abort
t = (n < foo)
if (t .neqv. .false.) call abort
t = (n <= 5)
if (t .neqv. .true.) call abort
t = (n >= 5 )
if (t .neqv. .true.) call abort
t = (n == 5)
if (t .neqv. .true.) call abort
t = (n /= 5)
if (t .neqv. .false.) call abort
t = (n /= foo)
if (t .neqv. .true.) call abort
t = (n == foo)
if (t .neqv. .false.) call abort
end
gcc/testsuite/g77.f-torture/execute/select.f deleted 100644 → 0
C integer byte case with integer byte parameters as case(s)
subroutine ib
integer *1 a /1/
integer *1 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal ib'
end
C integer halfword case with integer halfword parameters
subroutine ih
integer *2 a /1/
integer *2 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal ih'
end
C integer case with integer parameters
subroutine iw
integer *4 a /1/
integer *4 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal iw'
end
C integer double case with integer double parameters
subroutine id
integer *8 a /1/
integer *8 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal id'
end
C integer byte select with integer case
subroutine ib_mixed
integer*1 s /1/
select case (s)
case (1)
case (2)
call abort
end select
print*,'ib ok'
end
C integer halfword with integer case
subroutine ih_mixed
integer*2 s /1/
select case (s)
case (1)
case default
call abort
end select
print*,'ih ok'
end
C integer word with integer case
subroutine iw_mixed
integer s /5/
select case (s)
case (1)
call abort
case (2)
call abort
case (3)
call abort
case (4)
call abort
case (5)
C
case (6)
call abort
case default
call abort
end select
print*,'iw ok'
end
C integer doubleword with integer case
subroutine id_mixed
integer *8 s /1024/
select case (s)
case (1)
call abort
case (1023)
call abort
case (1025)
call abort
case (1024)
C
end select
print*,'i8 ok'
end
subroutine l1_mixed
logical*1 s /.TRUE./
select case (s)
case (.TRUE.)
case (.FALSE.)
call abort
end select
print*,'l1 ok'
end
subroutine l2_mixed
logical*2 s /.FALSE./
select case (s)
case (.TRUE.)
call abort
case (.FALSE.)
end select
print*,'lh ok'
end
subroutine l4_mixed
logical*4 s /.TRUE./
select case (s)
case (.FALSE.)
call abort
case (.TRUE.)
end select
print*,'lw ok'
end
subroutine l8_mixed
logical*8 s /.TRUE./
select case (s)
case (.TRUE.)
case (.FALSE.)
call abort
end select
print*,'ld ok'
end
C main
C -- regression cases
call ib
call ih
call iw
call id
C -- new functionality
call ib_mixed
call ih_mixed
call iw_mixed
call id_mixed
end
gcc/testsuite/g77.f-torture/execute/short.f deleted 100644 → 0
program short
parameter ( N=2 )
common /chb/ pi,sig(0:N)
common /parm/ h(2,2)
c initialize some variables
h(2,2) = 1117
h(2,1) = 1178
h(1,2) = 1568
h(1,1) = 1621
sig(0) = -1.
sig(1) = 0.
sig(2) = 1.
call printout
stop
end
c ******************************************************************
subroutine printout
parameter ( N=2 )
common /chb/ pi,sig(0:N)
common /parm/ h(2,2)
dimension yzin1(0:N), yzin2(0:N)
c function subprograms
z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
c a four-way average of rhobar
do 260 k=0,N
yzin1(k) = 0.25 *
& ( z(2,2,k) + z(1,2,k) +
& z(2,1,k) + z(1,1,k) )
260 continue
c another four-way average of rhobar
do 270 k=0,N
rtmp1 = z(2,2,k)
rtmp2 = z(1,2,k)
rtmp3 = z(2,1,k)
rtmp4 = z(1,1,k)
yzin2(k) = 0.25 *
& ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
270 continue
do k=0,N
if (yzin1(k) .ne. yzin2(k)) call abort
enddo
if (yzin1(0) .ne. -1371.) call abort
if (yzin1(1) .ne. -685.5) call abort
if (yzin1(2) .ne. 0.) call abort
return
end
gcc/testsuite/g77.f-torture/execute/u77-test.f deleted 100644 → 0
*** Some random stuff for testing libU77. Should be done better. It's
* hard to test things where you can't guarantee the result. Have a
* good squint at what it prints, though detected errors will cause
* starred messages.
*
* Currently not tested:
* ALARM
* CHDIR (func)
* CHMOD (func)
* FGET (func/subr)
* FGETC (func)
* FPUT (func/subr)
* FPUTC (func)
* FSTAT (subr)
* GETCWD (subr)
* HOSTNM (subr)
* IRAND
* KILL
* LINK (func)
* LSTAT (subr)
* RENAME (func/subr)
* SIGNAL (subr)
* SRAND
* STAT (subr)
* SYMLNK (func/subr)
* UMASK (func)
* UNLINK (func)
*
* NOTE! This is the testsuite version, so it should compile and
* execute on all targets, and either run to completion (with
* success status) or fail (by calling abort). The *other* version,
* which is a bit more interactive and tests a couple of things
* this one cannot, should be generally the same, and is in
* libf2c/libU77/u77-test.f. Please keep it up-to-date.
implicit none
external hostnm
* intrinsic hostnm
integer hostnm
integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
+ pid, mask
real tarray1(2), tarray2(2), r1, r2
double precision d1
integer(kind=2) bigi
logical issum
intrinsic getpid, getuid, getgid, ierrno, gerror, time8,
+ fnum, isatty, getarg, access, unlink, fstat, iargc,
+ stat, lstat, getcwd, gmtime, etime, chmod, itime, date,
+ chdir, fgetc, fputc, system_clock, second, idate, secnds,
+ time, ctime, fdate, ttynam, date_and_time, mclock, mclock8,
+ cpu_time, dtime, ftell, abort
external lenstr, ctrlc
integer lenstr
logical l
character gerr*80, c*1
character ctim*25, line*80, lognam*20, wd*1000, line2*80,
+ ddate*8, ttime*10, zone*5, ctim2*25
integer fstatb (13), statb (13)
integer *2 i2zero
integer values(8)
integer(kind=7) sigret
i = time ()
ctim = ctime (i)
WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim))
write (6,'(A,I3,'', '',I3)')
+ ' Logical units 5 and 6 correspond (FNUM) to'
+ // ' Unix i/o units ', fnum(5), fnum(6)
if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
print *, 'LNBLNK or LEN_TRIM failed'
call abort
end if
bigi = time8 ()
call ctime (i, ctim2)
if (ctim .ne. ctim2) then
write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
+ ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
call doabort
end if
j = time ()
if (i .gt. bigi .or. bigi .gt. j) then
write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
+ i, bigi, j
call doabort
end if
print *, 'Command-line arguments: ', iargc ()
do i = 0, iargc ()
call getarg (i, line)
print *, 'Arg ', i, ' is: ', line(:lenstr (line))
end do
l= isatty(6)
line2 = ttynam(6)
if (l) then
line = 'and 6 is a tty device (ISATTY) named '//line2
else
line = 'and 6 isn''t a tty device (ISATTY)'
end if
write (6,'(1X,A)') line(:lenstr(line))
call ttynam (6, line)
if (line .ne. line2) then
print *, '*** CALL TTYNAM disagrees with TTYNAM: ',
+ line(:lenstr (line))
call doabort
end if
* regression test for compiler crash fixed by JCB 1998-08-04 com.c
sigret = signal(2, ctrlc)
pid = getpid()
WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
WRITE (6, *) 'If you have the `id'' program, the following call'
write (6, *) 'of SYSTEM should agree with the above:'
call flush(6)
CALL SYSTEM ('echo " " `id`')
call flush
lognam = 'blahblahblah'
call getlog (lognam)
write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
wd = 'blahblahblah'
call getenv ('LOGNAME', wd)
write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
call umask(0, mask)
write(6,*) 'UMASK returns', mask
call umask(mask)
ctim = fdate()
write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
call fdate (ctim)
write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
j=time()
call ltime (j, ltarray)
write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
call gmtime (j, ltarray)
write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
call system_clock(count) ! omitting optional args
call system_clock(count, rate, count_max)
write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
call date_and_time(ddate) ! omitting optional args
call date_and_time(ddate, ttime, zone, values)
write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
+ zone, ' ', values
write (6,*) 'Sleeping for 1 second (SLEEP) ...'
call sleep (1)
c consistency-check etime vs. dtime for first call
r1 = etime (tarray1)
r2 = dtime (tarray2)
if (abs (r1-r2).gt.1.0) then
write (6,*)
+ 'Results of ETIME and DTIME differ by more than a second:',
+ r1, r2
call doabort
end if
if (.not. issum (r1, tarray1(1), tarray1(2))) then
write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call doabort
end if
if (.not. issum (r2, tarray2(1), tarray2(2))) then
write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
call doabort
end if
write (6, '(A,3F10.3)')
+ ' Elapsed total, user, system time (ETIME): ',
+ r1, tarray1
c now try to get times to change enough to see in etime/dtime
write (6,*) 'Looping until clock ticks at least once...'
do i = 1,1000
do j = 1,1000
end do
call dtime (tarray2, r2)
if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
end do
call etime (tarray1, r1)
if (.not. issum (r1, tarray1(1), tarray1(2))) then
write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call doabort
end if
if (.not. issum (r2, tarray2(1), tarray2(2))) then
write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
call doabort
end if
write (6, '(A,3F10.3)')
+ ' Differences in total, user, system time (DTIME): ',
+ r2, tarray2
write (6, '(A,3F10.3)')
+ ' Elapsed total, user, system time (ETIME): ',
+ r1, tarray1
write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
call idate (i,j,k)
call idate (idat)
write (6,*) 'IDATE (date,month,year): ',idat
print *, '... and the VXT version (month,date,year): ', i,j,k
if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
print *, '*** VXT and U77 versions don''t agree'
call doabort
end if
call date (ctim)
write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
call itime (idat)
write (6,*) 'ITIME (hour,minutes,seconds): ', idat
call time(line(:8))
print *, 'TIME: ', line(:8)
write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
write (6,*) 'SECOND returns: ', second()
call dumdum(r1)
call second(r1)
write (6,*) 'CALL SECOND returns: ', r1
* compiler crash fixed by 1998-10-01 com.c change
if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
write (6,*) '*** rand(0) error'
call doabort()
end if
i = getcwd(wd)
if (i.ne.0) then
call perror ('*** getcwd')
call doabort
else
write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
end if
call chdir ('.',i)
if (i.ne.0) then
write (6,*) '***CHDIR to ".": ', i
call doabort
end if
i=hostnm(wd)
if(i.ne.0) then
call perror ('*** hostnm')
call doabort
else
write (6,*) 'Host name is ', wd(:lenstr(wd))
end if
i = access('/dev/null ', 'rw')
if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
write (6,*) 'Creating file "foo" for testing...'
open (3,file='foo',status='UNKNOWN')
rewind 3
call fputc(3, 'c',i)
call fputc(3, 'd',j)
if (i+j.ne.0) write(6,*) '***FPUTC: ', i
C why is it necessary to reopen? (who wrote this?)
C the better to test with, my dear! (-- burley)
close(3)
open(3,file='foo',status='old')
call fseek(3,0,0,*10)
go to 20
10 write(6,*) '***FSEEK failed'
call doabort
20 call fgetc(3, c,i)
if (i.ne.0) then
write(6,*) '***FGETC: ', i
call doabort
end if
if (c.ne.'c') then
write(6,*) '***FGETC read the wrong thing: ', ichar(c)
call doabort
end if
i= ftell(3)
if (i.ne.1) then
write(6,*) '***FTELL offset: ', i
call doabort
end if
call ftell(3, i)
if (i.ne.1) then
write(6,*) '***CALL FTELL offset: ', i
call doabort
end if
call chmod ('foo', 'a+w',i)
if (i.ne.0) then
write (6,*) '***CHMOD of "foo": ', i
call doabort
end if
i = fstat (3, fstatb)
if (i.ne.0) then
write (6,*) '***FSTAT of "foo": ', i
call doabort
end if
i = stat ('foo', statb)
if (i.ne.0) then
write (6,*) '***STAT of "foo": ', i
call doabort
end if
write (6,*) ' with stat array ', statb
if (statb(6) .ne. getgid ()) then
write (6,*) 'Note: FSTAT gid wrong (happens on some systems).'
end if
if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
write (6,*) '*** FSTAT uid or nlink is wrong'
call doabort
end if
do i=1,13
if (fstatb (i) .ne. statb (i)) then
write (6,*) '*** FSTAT and STAT don''t agree on '// '
+ array element ', i, ' value ', fstatb (i), statb (i)
call abort
end if
end do
i = lstat ('foo', fstatb)
do i=1,13
if (fstatb (i) .ne. statb (i)) then
write (6,*) '*** LSTAT and STAT don''t agree on '//
+ 'array element ', i, ' value ', fstatb (i), statb (i)
call abort
end if
end do
C in case it exists already:
call unlink ('bar',i)
call link ('foo ', 'bar ',i)
if (i.ne.0) then
write (6,*) '***LINK "foo" to "bar" failed: ', i
call doabort
end if
call unlink ('foo',i)
if (i.ne.0) then
write (6,*) '***UNLINK "foo" failed: ', i
call doabort
end if
call unlink ('foo',i)
if (i.eq.0) then
write (6,*) '***UNLINK "foo" again: ', i
call doabort
end if
call gerror (gerr)
i = ierrno()
write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
+ i,
+ ' and the corresponding message is:', gerr(:lenstr(gerr))
write (6,*) 'This is sent to stderr prefixed by the program name'
call getarg (0, line)
call perror (line (:lenstr (line)))
call unlink ('bar')
print *, 'MCLOCK returns ', mclock ()
print *, 'MCLOCK8 returns ', mclock8 ()
call cpu_time (d1)
print *, 'CPU_TIME returns ', d1
C WRITE (6,*) 'You should see exit status 1'
CALL EXIT(0)
99 END
* Return length of STR not including trailing blanks, but always > 0.
integer function lenstr (str)
character*(*) str
if (str.eq.' ') then
lenstr=1
else
lenstr = lnblnk (str)
end if
end
* Just make sure SECOND() doesn't "magically" work the second time.
subroutine dumdum(r)
r = 3.14159
end
* Test whether sum is approximately left+right.
logical function issum (sum, left, right)
implicit none
real sum, left, right
real mysum, delta, width
mysum = left + right
delta = abs (mysum - sum)
width = abs (left) + abs (right)
issum = (delta .le. .0001 * width)
end
* Signal handler
subroutine ctrlc
print *, 'Got ^C'
call doabort
end
* A problem has been noticed, so maybe abort the test.
subroutine doabort
* For this version, call the ABORT intrinsic.
intrinsic abort
call abort
end
* Testsuite version only.
* Don't actually reference the HOSTNM intrinsic, because some targets
* need -lsocket, which we don't have a mechanism for supplying.
integer function hostnm(nm)
character*(*) nm
nm = 'not determined by this version of u77-test.f'
hostnm = 0
end
gcc/testsuite/g77.f-torture/execute/u77-test.x deleted 100644 → 0
# Various intrinsics not implemented and not implementable; will fail at
# link time.
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "arm*-*-elf"]
|| [istarget "strongarm*-*-elf"]
|| [istarget "xscale*-*-elf"]
|| [istarget "cris-*-elf"] } {
set torture_compile_xfail [istarget]
}
return 0
gcc/testsuite/g77.f-torture/noncompile/19981216-0.f deleted 100644 → 0
* Resent-From: Craig Burley <burley@gnu.org>
* Resent-To: craig@jcb-sc.com
* X-Delivered: at request of burley on mescaline.gnu.org
* Date: Wed, 16 Dec 1998 18:31:24 +0100
* From: Dieter Stueken <stueken@conterra.de>
* Organization: con terra GmbH
* To: fortran@gnu.org
* Subject: possible bug
* Content-Type: text/plain; charset=iso-8859-1
* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
*
* Hi,
*
* I'm about to compile a very old, very ugly Fortran program.
* For one part I got:
*
* f77: Internal compiler error: program f771 got fatal signal 6
*
* instead of any detailed error message. I was able to break down the
* problem to the following source fragment:
*
* -------------------------------------------
PROGRAM WAP
integer*2 ios
character*80 name
name = 'blah'
open(unit=8,status='unknown',file=name,form='formatted',
F iostat=ios)
END
* -------------------------------------------
*
* The problem seems to be caused by the "integer*2 ios" declaration.
* So far I solved it by simply using a plain integer instead.
*
* I'm running gcc on a Linux system compiled/installed
* with no special options:
*
* -> g77 -v
* g77 version 0.5.23
* Driving: g77 -v -c -xf77-version /dev/null -xnone
* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
* gcc version 2.8.1
* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
* /dev/null
* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
* #include "..." search starts here:
* #include <...> search starts here:
* /usr/local/include
* /usr/i686-pc-linux-gnulibc1/include
* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
* /usr/include
* End of search list.
* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
* /dev/null
* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
* 2.8.1.
* GNU Fortran Front End version 0.5.23
* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
* /usr/lib/crtn.o
* /tmp/cca24911
* __G77_LIBF77_VERSION__: 0.5.23
* @(#)LIBF77 VERSION 19970919
* __G77_LIBI77_VERSION__: 0.5.23
* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
* __G77_LIBU77_VERSION__: 0.5.23
* @(#) LIBU77 VERSION 19970919
*
*
* Regards, Dieter.
* --
* Dieter Stken, con terra GmbH, Mnster
* stueken@conterra.de stueken@qgp.uni-muenster.de
* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken
* (0)251-980-2027 (0)251-83-334974
gcc/testsuite/g77.f-torture/noncompile/19990218-1.f deleted 100644 → 0
double precision function fun(a,b)
double precision a,b
print*,'in sub: a,b=',a,b
fun=a*b
print*,'in sub: fun=',fun
return
end
program test
double precision a,b,c
data a,b/1.0d-46,1.0d0/
c=fun(a,b)
print*,'in main: fun=',c
end
gcc/testsuite/g77.f-torture/noncompile/19990826-4.f deleted 100644 → 0
* Culled from 970528-1.f in Burley's g77 test suite. Copyright
* status not clear. Feel free to chop down if the bug is still
* reproducible (see end of test case for how bug shows up in gdb
* run of f771). No particular reason it should be a noncompile
* case, other than that I didn't want to spend time "fixing" it
* to compile cleanly (with -O0, which works) while making sure the
* ICE remained reproducible. -- burley 1999-08-26
* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200)
* From: "D. O'Donoghue" <dod@da.saao.ac.za>
* To: Craig Burley <burley@gnu.ai.mit.edu>
* Cc: fortran@gnu.ai.mit.edu
* Subject: Re: g77 problems
program dophot
parameter (napple = 4)
common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50)
common/io/luout,ludebg
common/search/nstot,thresh
common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1,
+ mfit2,ind(npmax)
common /starlist/ starpar(npmax,nsmax), imtype(nsmax),
1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax)
common /aperlist/ apple(napple ,nsmax)
common /parpred / ava(npmax)
common /unitize / ufactor
common /undergnd/ nfast, nslow
common/bzero/ scale,zero
common /ctimes / chiimp, apertime, filltime, addtime
common / drfake / needit
common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim
common /vers/ version
logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy
logical fixed,piped,debug,ex,clinfo
character header*5760,rhead*2880
character yn*1,version*40,ccd*4,infile*20
character*30 numf,odir,record*80
integer*2 instr(8)
character*800 line
external pseud0d, pseud2d, pseud4d, pseudmd, shape
C
C Initialization
data burn, fixedxy,fixed, piped
+ /.false.,.false.,.false.,.false./
data needit,screen,comd,isub
+ /.true.,.false.,.true.,.false. /
data acc / .01, -.03, -.03, .01, .03, .1, .03 /
data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 /
C
version = 'DoPHOT Version 1.0 LINUX May 97 '
debug=.false.
clinfo=.false.
line(1:800) = ' '
odir = ' '
C
C
C Read default tuneable parameters
call tuneup ( nccd, ccd, piped, debug )
version(33:36) = ccd(1:4)
C
ludebg=6
if(piped)then
yn='n'
else
write(*,'(''****************************************'')')
write(*,1000) version
write(*,'(''****************************************''//)')
C
write(*,'(''Screen output (y/[n])? '',$)')
read(*,1000) yn
end if
if(yn.eq.'y'.or.yn.eq.'Y') then
screen=.true.
luout=6
else
luout=2
end if
C
if(piped)then
yn='y'
else
write(*,'(''Batch mode ([y]/n)? '',$)')
read(*,1000) yn
end if
if(yn.eq.'n'.or.yn.eq.'N') comd = .false.
C
if(.not.comd) then
write(*,
* '(''Do you want windowing ([y]/n)? '',$)')
read(*,1000)yn
iwindo=1
if(yn.eq.'n'.or.yn.eq.'N')then
nwindo=0
iwindo=0
end if
C
write(*,
* '(''Star classification info (y/[n]) ?'',$)')
read(*,1000)yn
clinfo=.false.
if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true.
C
write(*,
* '(''Create a star-subtracted frame (y/[n])? '',$)')
read(*,1000) yn
if(yn.eq.'y'.or.yn.eq.'Y') isub = .true.
C
write(*,'(''Apply after-burner (y/[n])? '',$)')
read(*,1000) yn
if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true.
wrtres = burn
C
write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
read(*,1000) yn
if ( yn.eq.'y'.or.yn.eq.'Y' ) then
fixedxy = .true.
fixed = .true.
burn = .true.
wrtres = .true.
endif
endif
iopen=0
C
C This is the start of the loop over the input files
c
iframe=0
open(10,file='timing',status='unknown',access='append')
1 ifit = 0
iapr = 0
itmn = 0
model = 1
xc = 0.0
yc = 0.0
rc = 0.0
ibr = 0
ixy = 0
C
iframe=iframe+1
tgetpar=0.0
tsearch=0.0
tshape=0.0
timprove=0.0
C
C Batch mode ...
if ( comd ) then
if(iopen.eq.0)then
iopen=1
open(11,file='dophot.bat',status='old',err=995)
end if
read(11,1000,end=999)infile
c now read in the parameter instructions. these are:
c instr(1) : if 1, specifies uncrowded field, otherwise crowded
c instr(2) : if 1, specifies sequential frames of same field
c with a window around the stars of interest -
c all other objects are ignored
c instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
c if>0, sets cmin=instr(3)
c instr(4) : if 0, does nothing
c if 1, then opens a file called classifications
c sets clinfo to .true. and writes out the star
c typing info to this file
c instr(5) : Delete the shd.nnnnnnn file
c instr(6) : Delete the out.nnnnnnn file
c instr(7) : Delete the input frame
c instr(8) : Create a star-subtracted frame
read(11,*)instr
read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy
nocrwd = instr(1)
iwindo=instr(2)
if(iwindo.eq.0)nwindo=0
itmn=tmn
if ( instr(3).gt.0 ) cmin=instr(3)
clinfo=.false.
if ( instr(4).gt.0 )then
clinfo=.true.
open(12,file='classifications',status='unknown')
ludebg=12
end if
if ( instr(8).ne.0 ) then
isub = .true.
else
isub = .false.
endif
C
if(ibr.ne.0) burn = .true.
if(ixy.ne.0) then
fixedxy = .true.
fixed = .true.
burn = .true.
goto 20
endif
if(iwindo.eq.0)then
write(6,10)iframe,infile(1:15)
10 format(' ***** DoPHOT-ing frame ',i4,': ',a)
if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15)
11 format(////' ',62('*')/
* ' * DoPHOT-ing frame ',i4,': ',a,
* ' *'/' ',62('*'))
end if
if(iwindo.eq.1)then
write(6,12)iframe,infile(1:15)
12 format(' ***** DoPHOT-ing frame ',i4,': ',a,
* ' - Windowed *****')
if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15)
13 format(////' ',62('*')/
* ' * DoPHOT-ing frame ',i4,': ',a,
* ' - Windowed *'/2x,62('*'))
end if
C
C Interactive...
else
write(*,'(''Image name: '',$)')
read(*,1000) infile
if(infile(1:1).eq.' ') goto 999
1000 format(a)
write(*,'(''Crowded field mode ([y]/n) ? '',$)')
read(*,1000)yn
nocrwd=0
if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1
if(.not.fixed) then
write(*,1001)
1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$)
read(*,1000)record
if(record.ne.' ')then
read(record,*) model
else
model=1
end if
else
burn=.true.
goto 20
endif
endif
C
C if windowing, open the file and read the window
if(iwindo.eq.1)then
inquire(file='windows',exist=ex)
if(.not.ex)go to 997
if(iframe.eq.1)open(9,file='windows',status='old')
nwindo=0
2 read(9,*,end=3)intype,inx,iny,inbox
nwindo=nwindo+1
if(nwindo.gt.50)then
print *,'too many windows - max = 50'
stop
end if
ixwin(nwindo)=inx
iywin(nwindo)=iny
iboxwin(nwindo)=inbox
itype(nwindo)=intype
go to 2
3 rewind 9
if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j),
* j=1,nwindo)
4 format(' Windows: Type X Y Size'/
* (I13,i6,i5,i5))
end if
t1 = cputime(0.0)
C
C Read FITS frame.
call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd)
C
C Ignore frame if not the correct chip
if(nc.lt.0) goto 900
C
C Estimate starting PSF parameters.
15 call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax,
* iframe)
tgetpar = cputime(t1) + tgetpar
if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax
16 format(' Getparams on frame ',i4,' sky ',f6.1,' gxwid ',f5.1,
* ' gywid ',f5.1,' tmin ',f5.1,' tmax ',f5.1)
C
C Initialize
do j=1,nsmax
imtype(j) = 0
do i=1,npmax
shadow(i,j)=0.
shaderr(i,j)=0.
enddo
enddo
C
skyguess=skyval
tfac = 1.0
C Use 4.5 X SD as fitting width
fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5
i=fitr
irect(1)=i
irect(2)=fitr/asprat
C Use 4/3 X FitFac X SD as aperture width
gmax = asprat*gywid
if(gxwid.gt.gmax) gmax=gxwid
aprw = 1.33*fitfac*sqrt(gmax) + 0.5
i = aprw
arect(1) = i
i = aprw/asprat + 0.1
arect(2) = i
C
if(irect(1).gt.50) irect(1)=50
if(irect(2).gt.50) irect(2)=50
if(arect(1).gt.45.) arect(1)=45.
if(arect(2).gt.45.) arect(2)=45.
C
if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon)
C
C Prompt for further information
if ( .not.comd ) then
write(*,1002)
1002 format(/'The above are the inital parameters DoPHOT'/
* 'has found. You can change them now or accept'/
* 'the values in [ ] by pressing enter'/)
write(*,1004)tmin
1004 format('Enter Tmin: threshold for star detection',
* ' [',f5.1,'] ',$)
read(*,1000)record
if(record.ne.' ')read(record,*)tmin
write(*,1005)cmin
1005 format('Enter Cmin: threshold for PSF stars',
* ' [',f5.1,'] ',$)
read(*,1000)record
if(record.ne.' ')read(record,*)cmin
write(*,1006)
1006 format('Do you want to fix the aperture mag size ?',
* ' (y/[n]) ')
read(*,1000)record
if(record.eq.'y'.or.record.eq.'Y')then
write(*,1007)
1007 format('Enter the size in pixels: ',$)
read(*,*)iapr
if(iapr.gt.0) then
arect(1)=iapr
i = iapr/asprat + 0.1
arect(2)=i
end if
endif
C
write(*,1008)
1008 format('Satisfied with other input parameters ? ([y]/n)?',$)
read(*,1000) yn
if(yn.eq.'n'.or.yn.eq.'N')then
yn='n'
else
yn='y'
end if
if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input
else
if ( ifit.ne.0 ) then
irect(1)=ifit
irect(2)=(ifit/asprat + 0.1)
endif
if ( iapr.ne.0 ) then
arect(1)=iapr
i = iapr/asprat + 0.1
arect(2)=i
endif
if ( itmn.ne.0 ) tmin = itmn
if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then
xcen = xc
ycen = yc
endif
endif
C
C--------------------------------
C
C
call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+nfast, nslow )
C
C if the uncrowded field option has been chosen, jump
C straight to the minimum threshold
C
if(nocrwd.eq.1)tmax=tmin
C
C Adjust tfac so that thresh ends precisely on Tmin.
if(tmin/tmax .gt. 0.999) then
thresh = tmin
tfac = 1.
else
thresh = tmax
xnum = alog10(tmax/tmin)/alog10(2.**tfac)
if(xnum.gt.1.5) then
xnum = float(nint(xnum))
else if(xnum.ge.1) then
xnum = 2.0
else
xnum = 1.0
endif
tfac = alog10(tmax/tmin)/alog10(2.)/xnum
endif
C
C------------------------------------------------------------------------
C
C This is the BIG LOOP which searches the frame for stars
C with intensities > thresh.
C
C-----------------------------------------------------------------------
C
loop = .true.
nstot = 0
do while ( loop )
loop = thresh/tmin .ge. 1.01
write(luout,1050) thresh
1050 format(/20('-')/'THRESHOLD: ', f10.3)
if(ludebg.eq.12)write(ludebg,1050) thresh
C
C Fit given model to sky values.
C
call varipar(nstot, nfast, nslow )
t1 = cputime(0.0)
C
C Identifies potential objects in cleaned array IMG
nstar = isearch( pseud2d, nfast, nslow , clinfo)
tsearch = cputime(t1) + tsearch
C
if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then
C
C Performs 7-parameter PSF fit and determines nature of object.
t1 = cputime(0.0)
call shape(pseud2d,pseud4d,nfast,nslow,clinfo)
tshape = cputime(t1) + tshape
C
C Computes average sky values etc from star list
call paravg
t1 = cputime(0.0)
C
C Computes 4-parameter fits for all stellar objects using
C new average shape parameters.
call improve(pseud2d,nfast,nslow,clinfo)
timprove = cputime(t1) + timprove
end if
C
C Calculate aperture photometry on last pass.
if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow )
C
totaltime = (tgetpar+tsearch+tshape+timprove)
write(3,1060) totaltime
write(4,1060) totaltime
write(luout,1060) totaltime
1060 format('Total CPU time consumed:',F10.2,' seconds.')
write(10,1070)infile,tgetpar,tsearch,tshape,timprove,
* totaltime
1070 format(a20,' T(getp/f)',f5.1,' T(search)',f5.1,
* ' T(shape)',f5.1,' T(improve)',f5.1,
* ' Total',f6.1)
call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums)
rewind(2)
rewind(3)
rewind(4)
C
call output ( line )
C
C Now reduce the threshold and loop back
C
thresh = thresh/2.**tfac
end do
C
C--------- END OF BIG LOOP ---------------------------------------
C
C If after-burner required, residuals from analytic PSF are computed
C and stored in RES.
C
20 if ( burn ) then
C
C If using a fixed (X,Y) coordinate list, read it.
if (fixed) then
C Read the image frame
call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line)
C
C Initialize arrays, open files etc.
call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+nfast, nslow )
C
C Read the XY list
write(luout,'(''Reading XY list ...'')')
call xylist(numf, nc, ios )
if(ios.ne.0) then
fixed = .false.
write(luout,'(''SXY file absent or incorrect...'')')
goto 15
endif
C
call htype(line,skyval,.false.,fitr,ngr,ncon)
C
C Remove good stars
write(luout,'(''Cleaning frame of stars: '',i8)') nstot
call clean ( pseud2d, nstot, nfast, nslow, -1)
C
C Calculate aperture photometry
C call aper ( pseud2d, nstot, nfast, nslow )
else
rewind(3)
rewind(4)
endif
C
C-----------------------
C Flag all stars close together in groups. Keep making the distance
C criterion FITR smaller until the maximum number in a group is less
C than NFMAX
C
fitr = amax1(arect(1),arect(2))
fitr = fitr + 2.0
nmax = 10000
write(*,'(''Regrouping ...'')')
C
do while ( nmax.gt.nfmax )
fitr = fitr - 1.0
write(luout,'(''Min distance ='',f8.1)') fitr
call regroup( fitr, ngr, nmax )
enddo
C
xlim = irect(1)/2
ylim = irect(2)/2
C
C Calculate normalized PSF residual from PSEUD2D
call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect,
+arect,ztot,nums)
if(nums.eq.0) then
write(luout,'(''No suitable PSF stars!'')')
goto 30
endif
C
write(luout,'(/''AFTERBURNER tuned ON!'')')
C
C Fit multiple stars in a group with enhanced PSF using box size IRECT.
call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect )
C
C Re-calculate aperture photometry
call aperm ( pseudmd, nstot, nfast, nslow )
C
call skyadj ( nstot )
C
call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums)
call output ( line )
endif
C---------------------
C
C----- This section skipped if PSF residual not written out ------
C
30 if( isub ) then
C
C Write final Cleaned array.
infile = 'x'//numf(1:nc)//'.fits'
call putfits(2,infile,header,nhead,nfast,nslow)
close(2)
C
C If afterburner used, then residual array also written out.
C Find suitable scale for writing residual PSF to FITS "R" file.
C
if ( wrtres ) then
scale=20000.0/(rmx-rmn)
zero=-scale*rmn
do j=-nres,nres
jj=nres+j+1
do i=-nres,nres
ii=nres+i+1
big(ii,jj)=scale*res(i,j)+zero
enddo
enddo
nx=2*nres+1
C
infile = 'r'//numf(1:nc)//'.fits'
zer=-zero/scale
scl=1.0/scale
C
C Create a FITS header for the normalized PSF residual image
call sethead(rhead,numf,nx,nx,zer,scl)
scale=1.0
zero=0.0
C Write the normalized PSF residual image
call putfits(2,infile,rhead,1,nx,nx)
close(2)
endif
C
end if
C
C
900 close(1)
close(3)
close(4)
if ( .not.screen ) close(luout)
if(comd) then
if(instr(5).eq.1)call system('rm shd.'//numf(1:nc))
if(instr(6).eq.1)call system('rm out.'//numf(1:nc))
n=1
do while(infile(n:n).ne.' ')
n=n+1
end do
if(instr(7).eq.1)call system('rm '//infile(1:n-1))
end if
fixed = fixedxy
goto 1
C
995 print 996
996 format(/'*** Fatal error ***'/
* 'You asked for batch processing but'/
* 'I cant open the "dophot.bat" file.'/
* 'Please make one (using batchdophot)'/
* 'and restart DoPHOT'/)
go to 999
C
997 print 998
998 format(/'*** Fatal error ***'/
* 'You asked for "windowed" processing'/
* 'but I cant open the "windows" file.'/
* 'Please make one and restart DoPHOT'/)
999 call exit(0)
end
* (gdb) r
* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O
* [...]
* Breakpoint 2, fancy_abort (
* file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399,
* function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010
* (gdb) up
* #1 0x8222fab in output_fp_cc0_set (insn=0x8382324)
* at ../../g77-e/gcc/config/i386/i386.c:4399
* (gdb) p insn
* $1 = 0x3a
* (gdb) up
* #2 0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60)
* at ../../g77-e/gcc/config/i386/i386.c:4205
* (gdb) p insn
* $2 = 0x8382324
* (gdb) whatis insn
* type = rtx
* (gdb) pr
* (insn 2181 2180 2191 (parallel[
* (set (cc0)
* (compare (reg:SF 8 %st(0))
* (mem:SF (plus:SI (reg:SI 6 %ebp)
* (const_int -9948 [0xffffd924])) 0)))
* (clobber (reg:HI 0 %ax))
* ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil)))
* (expr_list:REG_DEAD (reg:DF 8 %st(0))
* (expr_list:REG_UNUSED (reg:HI 0 %ax)
* (nil))))
* (gdb)
gcc/testsuite/g77.f-torture/noncompile/19990905-1.f deleted 100644 → 0
* =foo7.f in Burley's g77 test suite.
subroutine x
real a(n)
common /foo/n
continue
entry y(a)
call foo(a(1))
end
gcc/testsuite/g77.f-torture/noncompile/9263.f deleted 100644 → 0
PARAMETER (Q=1)
PARAMETER (P=10)
INTEGER C(10),D(10),E(10),F(10)
DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER
DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER
DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER
END
gcc/testsuite/g77.f-torture/noncompile/970626-2.f deleted 100644 → 0
SUBROUTINE A(A,ALPHA,IA)
COMPLEX A(IA,*), ALPHA(*)
ALPHA(I)=A(I,I).ZERO)
END
gcc/testsuite/g77.f-torture/noncompile/980615-0.f deleted 100644 → 0
* Fixed by JCB 1998-07-25 change to stc.c.
* Date: Thu, 11 Jun 1998 22:35:20 -0500
* From: Ian A Watson <WATSON_IAN_A@lilly.com>
* Subject: crash
*
CaLL foo(W)
END
SUBROUTINE foo(W)
yy(I)=A(I)Q(X)
gcc/testsuite/g77.f-torture/noncompile/980616-0.f deleted 100644 → 0
* Fixed by 1998-07-11 equiv.c change.
* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER'
* Date: Mon, 15 Jun 1998 21:54:32 -0500
* From: Ian A Watson <WATSON_IAN_A@lilly.com>
* Subject: Mangler Crash
EQUIVALENCE(I,glerf(P))
COMMON /foo/ glerf(3)
gcc/testsuite/g77.f-torture/noncompile/check0.f deleted 100644 → 0
CCC Abort fixed by:
CCC1998-04-21 Jim Wilson <wilson@cygnus.com>
CCC
CCC * stmt.c (check_seenlabel): When search for line number note for
CCC warning, handle case where there is no such note.
logical l(10)
integer i(10)
goto (10,20),l
goto (10,20),i
10 stop
20 end
gcc/testsuite/g77.f-torture/noncompile/noncompile.exp deleted 100644 → 0
# Copyright (C) 1988, 90, 91, 92, 97, 1998 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 2 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 this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# This file was written by Jeff Law. (law@cs.utah.edu)
#
# These tests come from Torbjorn Granlund (tege@cygnus.com)
# C torture test suite.
#
load_lib mike-g77.exp
# Test check0.f
prebase
set src_code check0.f
# Not really sure what the error should be here...
set compiler_output ".*:8.*:9"
set groups {passed gcc-noncompile}
postbase $src_code $run $groups
gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f deleted 100644 → 0
integer*1 one
integer*2 two
parameter (one=1)
parameter (two=2)
select case (I)
case (one)
case (two)
end select
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment