From: Toon Moene Date: Sat, 17 Jul 2004 11:18:05 +0000 (+0200) Subject: g77.dg: Removed. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=649067c3624a25712b0668f0c48060cca0faf030;p=gcc.git g77.dg: Removed. 2004-07-17 Toon Moene * g77.dg: Removed. * g77.f-torture: Ditto. From-SVN: r84865 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d2c90e29f99..1e62636ce87 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-07-17 Toon Moene + + * g77.dg: Removed. + * g77.f-torture: Ditto. + 2004-07-17 Joseph S. Myers * gcc.dg/Wparentheses-2.c, gcc.dg/Wparentheses-3.c, diff --git a/gcc/testsuite/g77.dg/12632.f b/gcc/testsuite/g77.dg/12632.f deleted file mode 100644 index 6801229eace..00000000000 --- a/gcc/testsuite/g77.dg/12632.f +++ /dev/null @@ -1,6 +0,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 - diff --git a/gcc/testsuite/g77.dg/20010216-1.f b/gcc/testsuite/g77.dg/20010216-1.f deleted file mode 100644 index 150dc9f016a..00000000000 --- a/gcc/testsuite/g77.dg/20010216-1.f +++ /dev/null @@ -1,51 +0,0 @@ -C Test for bug in reg-stack handling conditional moves. -C Reported by Tim Prince -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 diff --git a/gcc/testsuite/g77.dg/7388.f b/gcc/testsuite/g77.dg/7388.f deleted file mode 100644 index 0b8374646b0..00000000000 --- a/gcc/testsuite/g77.dg/7388.f +++ /dev/null @@ -1,12 +0,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 diff --git a/gcc/testsuite/g77.dg/bprob/bprob.exp b/gcc/testsuite/g77.dg/bprob/bprob.exp deleted file mode 100644 index e453f4e66f8..00000000000 --- a/gcc/testsuite/g77.dg/bprob/bprob.exp +++ /dev/null @@ -1,59 +0,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 -} diff --git a/gcc/testsuite/g77.dg/bprob/g77-bprob-1.f b/gcc/testsuite/g77.dg/bprob/g77-bprob-1.f deleted file mode 100644 index 73f04405b9b..00000000000 --- a/gcc/testsuite/g77.dg/bprob/g77-bprob-1.f +++ /dev/null @@ -1,330 +0,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 diff --git a/gcc/testsuite/g77.dg/dg.exp b/gcc/testsuite/g77.dg/dg.exp deleted file mode 100644 index 446166c49db..00000000000 --- a/gcc/testsuite/g77.dg/dg.exp +++ /dev/null @@ -1,36 +0,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 diff --git a/gcc/testsuite/g77.dg/f77-edit-apostrophe-out.f b/gcc/testsuite/g77.dg/f77-edit-apostrophe-out.f deleted file mode 100644 index aa51bc05c25..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-apostrophe-out.f +++ /dev/null @@ -1,21 +0,0 @@ -C Test Fortran 77 apostrophe edit descriptor -C (ANSI X3.9-1978 Section 13.5.1) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-colon-out.f b/gcc/testsuite/g77.dg/f77-edit-colon-out.f deleted file mode 100644 index 4feef755f57..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-colon-out.f +++ /dev/null @@ -1,9 +0,0 @@ -C Test Fortran 77 colon edit descriptor -C (ANSI X3.9-1978 Section 13.5.5) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-h-out.f b/gcc/testsuite/g77.dg/f77-edit-h-out.f deleted file mode 100644 index 78e6f017b7e..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-h-out.f +++ /dev/null @@ -1,14 +0,0 @@ -C Test Fortran 77 H edit descriptor -C (ANSI X3.9-1978 Section 13.5.2) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-i-in.f b/gcc/testsuite/g77.dg/f77-edit-i-in.f deleted file mode 100644 index 9040a4fcae2..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-i-in.f +++ /dev/null @@ -1,22 +0,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 -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-i-out.f b/gcc/testsuite/g77.dg/f77-edit-i-out.f deleted file mode 100644 index 9887704c716..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-i-out.f +++ /dev/null @@ -1,26 +0,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 -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-s-out.f b/gcc/testsuite/g77.dg/f77-edit-s-out.f deleted file mode 100644 index 89a8df2caff..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-s-out.f +++ /dev/null @@ -1,20 +0,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 -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-slash-out.f b/gcc/testsuite/g77.dg/f77-edit-slash-out.f deleted file mode 100644 index 6cc9a8842d6..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-slash-out.f +++ /dev/null @@ -1,9 +0,0 @@ -C Test Fortran 77 colon slash descriptor -C (ANSI X3.9-1978 Section 13.5.4) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-t-in.f b/gcc/testsuite/g77.dg/f77-edit-t-in.f deleted file mode 100644 index 2314080d708..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-t-in.f +++ /dev/null @@ -1,31 +0,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 -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-t-out.f b/gcc/testsuite/g77.dg/f77-edit-t-out.f deleted file mode 100644 index 8e411888f2b..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-t-out.f +++ /dev/null @@ -1,12 +0,0 @@ -C Test Fortran 77 T edit descriptor -C (ANSI X3.9-1978 Section 13.5.3.2) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/f77-edit-x-out.f b/gcc/testsuite/g77.dg/f77-edit-x-out.f deleted file mode 100644 index 76049fa0fdf..00000000000 --- a/gcc/testsuite/g77.dg/f77-edit-x-out.f +++ /dev/null @@ -1,12 +0,0 @@ -C Test Fortran 77 X descriptor -C (ANSI X3.9-1978 Section 13.5.3.2) -C -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/fbackslash.f b/gcc/testsuite/g77.dg/fbackslash.f deleted file mode 100644 index d2227adb67b..00000000000 --- a/gcc/testsuite/g77.dg/fbackslash.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -fbackslash -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fbackslash" } - if ( len('A\nB') .ne. 3 ) call abort - end diff --git a/gcc/testsuite/g77.dg/fcase-preserve.f b/gcc/testsuite/g77.dg/fcase-preserve.f deleted file mode 100644 index f1d1eab6fd4..00000000000 --- a/gcc/testsuite/g77.dg/fcase-preserve.f +++ /dev/null @@ -1,9 +0,0 @@ -C Test compiler flags: -fcase-preserve -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fcase-preserve" } - i = 3 - I = 4 - if ( i .ne. 3 ) call abort - end diff --git a/gcc/testsuite/g77.dg/ff90-1.f b/gcc/testsuite/g77.dg/ff90-1.f deleted file mode 100644 index f33eb28b21b..00000000000 --- a/gcc/testsuite/g77.dg/ff90-1.f +++ /dev/null @@ -1,15 +0,0 @@ -C Test compiler flags: -ff90 -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/ffixed-form-1.f b/gcc/testsuite/g77.dg/ffixed-form-1.f deleted file mode 100644 index 4b5f72301da..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-form-1.f +++ /dev/null @@ -1,6 +0,0 @@ -! Test compiler flags: -ffixed-form -! Origin: David Billinghurst -! -! { dg-do compile } -! { dg-options "-ffixed-form" } - end diff --git a/gcc/testsuite/g77.dg/ffixed-form-2.f b/gcc/testsuite/g77.dg/ffixed-form-2.f deleted file mode 100644 index 5f6980ca0ac..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-form-2.f +++ /dev/null @@ -1,12 +0,0 @@ -! PR fortran/10843 -! Origin: Brad Davis -! -! { dg-do compile } -! { dg-options "-ffixed-form" } - GO TO 3 - GOTO 3 - 3 CONTINUE - GOTO = 55 - GO TO = 55 - END - diff --git a/gcc/testsuite/g77.dg/ffixed-line-length-0.f b/gcc/testsuite/g77.dg/ffixed-line-length-0.f deleted file mode 100644 index 80c4f3f56ca..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-line-length-0.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -ffixed-line-length-0 -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-ffixed-line-length-0" } -C The next line has length 257 - en d diff --git a/gcc/testsuite/g77.dg/ffixed-line-length-132.f b/gcc/testsuite/g77.dg/ffixed-line-length-132.f deleted file mode 100644 index 6101696758c..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-line-length-132.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -ffixed-line-length-132 -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-ffixed-line-length-132" } -c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 - en d* diff --git a/gcc/testsuite/g77.dg/ffixed-line-length-7.f b/gcc/testsuite/g77.dg/ffixed-line-length-7.f deleted file mode 100644 index 8a9abf48050..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-line-length-7.f +++ /dev/null @@ -1,8 +0,0 @@ -C Test compiler flags: -ffixed-line-length-7 -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-ffixed-line-length-7" } - e* - $n* - $d* diff --git a/gcc/testsuite/g77.dg/ffixed-line-length-72.f b/gcc/testsuite/g77.dg/ffixed-line-length-72.f deleted file mode 100644 index 8a2fad1fad2..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-line-length-72.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -ffixed-line-length-72 -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-ffixed-line-length-72" } -c2345678901234567890123456789012345678901234567890123456789012345678901234567890 - en d* diff --git a/gcc/testsuite/g77.dg/ffixed-line-length-none.f b/gcc/testsuite/g77.dg/ffixed-line-length-none.f deleted file mode 100644 index b4a50147f12..00000000000 --- a/gcc/testsuite/g77.dg/ffixed-line-length-none.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -ffixed-line-length-none -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-ffixed-line-length-none" } -C The next line has length 257 - en d diff --git a/gcc/testsuite/g77.dg/ffree-form-1.f b/gcc/testsuite/g77.dg/ffree-form-1.f deleted file mode 100644 index 88ddeefb32c..00000000000 --- a/gcc/testsuite/g77.dg/ffree-form-1.f +++ /dev/null @@ -1,6 +0,0 @@ -! Test compiler flags: -ffree-form -! Origin: David Billinghurst -! -! { dg-do compile } -! { dg-options "-ffree-form" } -end diff --git a/gcc/testsuite/g77.dg/ffree-form-2.f b/gcc/testsuite/g77.dg/ffree-form-2.f deleted file mode 100644 index b07db218789..00000000000 --- a/gcc/testsuite/g77.dg/ffree-form-2.f +++ /dev/null @@ -1,11 +0,0 @@ -! PR fortran/10843 -! Origin: Brad Davis -! -! { dg-do compile } -! { dg-options "-ffree-form" } - GO TO 3 - GOTO 3 - 3 CONTINUE - GOTO = 55 - END - diff --git a/gcc/testsuite/g77.dg/ffree-form-3.f b/gcc/testsuite/g77.dg/ffree-form-3.f deleted file mode 100644 index a30d6046081..00000000000 --- a/gcc/testsuite/g77.dg/ffree-form-3.f +++ /dev/null @@ -1,20 +0,0 @@ -! Test acceptance of keywords in free format -! Origin: David Billinghurst -! -! { 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 diff --git a/gcc/testsuite/g77.dg/fno-backslash.f b/gcc/testsuite/g77.dg/fno-backslash.f deleted file mode 100644 index 7488cb6e98e..00000000000 --- a/gcc/testsuite/g77.dg/fno-backslash.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test compiler flags: -fno-backslash -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fno-backslash" } - if ( len('A\nB') .ne. 4 ) call abort - end diff --git a/gcc/testsuite/g77.dg/fno-f90-1.f b/gcc/testsuite/g77.dg/fno-f90-1.f deleted file mode 100644 index ac0f967505b..00000000000 --- a/gcc/testsuite/g77.dg/fno-f90-1.f +++ /dev/null @@ -1,15 +0,0 @@ -C Test compiler flags: -fno-f90 -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/fno-fixed-form-1.f b/gcc/testsuite/g77.dg/fno-fixed-form-1.f deleted file mode 100644 index df2dd1d70e5..00000000000 --- a/gcc/testsuite/g77.dg/fno-fixed-form-1.f +++ /dev/null @@ -1,6 +0,0 @@ -! Test compiler flags: -fno-fixed-form -! Origin: David Billinghurst -! -! { dg-do compile } -! { dg-options "-fno-fixed-form" } -end diff --git a/gcc/testsuite/g77.dg/fno-onetrip.f b/gcc/testsuite/g77.dg/fno-onetrip.f deleted file mode 100644 index 781e272f972..00000000000 --- a/gcc/testsuite/g77.dg/fno-onetrip.f +++ /dev/null @@ -1,9 +0,0 @@ -C Test compiler flags: -fno-onetrip -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fno-onetrip -w" } - do i = 1, 0 - call abort - end do - end diff --git a/gcc/testsuite/g77.dg/fno-typeless-boz.f b/gcc/testsuite/g77.dg/fno-typeless-boz.f deleted file mode 100644 index 3faa550cce8..00000000000 --- a/gcc/testsuite/g77.dg/fno-typeless-boz.f +++ /dev/null @@ -1,10 +0,0 @@ -C Test compiler flags: -fno-typeless-boz -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/fno-underscoring.f b/gcc/testsuite/g77.dg/fno-underscoring.f deleted file mode 100644 index b91320b4c0b..00000000000 --- a/gcc/testsuite/g77.dg/fno-underscoring.f +++ /dev/null @@ -1,8 +0,0 @@ -C Test compiler flags: -fno-underscoring -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-fno-underscoring" } - call aaabbbccc - end -C { dg-final { scan-assembler-not "aaabbbccc_" } } diff --git a/gcc/testsuite/g77.dg/fno-vxt-1.f b/gcc/testsuite/g77.dg/fno-vxt-1.f deleted file mode 100644 index 1277fb50c6b..00000000000 --- a/gcc/testsuite/g77.dg/fno-vxt-1.f +++ /dev/null @@ -1,10 +0,0 @@ -C Test compiler flags: -fno-vxt -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fno-vxt" } - i = 0 - !1 - if ( i .ne. 0 ) call exit - call abort - END diff --git a/gcc/testsuite/g77.dg/fonetrip.f b/gcc/testsuite/g77.dg/fonetrip.f deleted file mode 100644 index dec61bcb364..00000000000 --- a/gcc/testsuite/g77.dg/fonetrip.f +++ /dev/null @@ -1,10 +0,0 @@ -C Test compiler flags: -fonetrip -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fonetrip -w" } - do i = 1, 0 - call exit - end do - call abort - end diff --git a/gcc/testsuite/g77.dg/ftypeless-boz.f b/gcc/testsuite/g77.dg/ftypeless-boz.f deleted file mode 100644 index b72cb177546..00000000000 --- a/gcc/testsuite/g77.dg/ftypeless-boz.f +++ /dev/null @@ -1,10 +0,0 @@ -C Test compiler flags: -ftypeless-boz -C Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/fugly-assumed.f b/gcc/testsuite/g77.dg/fugly-assumed.f deleted file mode 100644 index a45e9c8e2b7..00000000000 --- a/gcc/testsuite/g77.dg/fugly-assumed.f +++ /dev/null @@ -1,9 +0,0 @@ -C Test compiler flags: -fugly-assumed -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-fugly-assumed" } - function f(i) - integer i(1) - f = i(1)+i(2) - end diff --git a/gcc/testsuite/g77.dg/funderscoring.f b/gcc/testsuite/g77.dg/funderscoring.f deleted file mode 100644 index 720b3a7e3e1..00000000000 --- a/gcc/testsuite/g77.dg/funderscoring.f +++ /dev/null @@ -1,8 +0,0 @@ -C Test compiler flags: -funderscoring -C Origin: David Billinghurst -C -C { dg-do compile } -C { dg-options "-funderscoring" } - call aaabbbccc - end -C { dg-final { scan-assembler "aaabbbccc_" } } diff --git a/gcc/testsuite/g77.dg/fvxt-1.f b/gcc/testsuite/g77.dg/fvxt-1.f deleted file mode 100644 index 0cde4f8a36f..00000000000 --- a/gcc/testsuite/g77.dg/fvxt-1.f +++ /dev/null @@ -1,10 +0,0 @@ -C Test compiler flags: -fvxt -C Origin: David Billinghurst -C -C { dg-do run } -C { dg-options "-fvxt" } - i = 0 - !1 - if ( i .eq. 0 ) call exit - call abort - END diff --git a/gcc/testsuite/g77.dg/gcov/gcov-1.f b/gcc/testsuite/g77.dg/gcov/gcov-1.f deleted file mode 100644 index fa0ce55f8f8..00000000000 --- a/gcc/testsuite/g77.dg/gcov/gcov-1.f +++ /dev/null @@ -1,419 +0,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 } } } diff --git a/gcc/testsuite/g77.dg/gcov/gcov.exp b/gcc/testsuite/g77.dg/gcov/gcov.exp deleted file mode 100644 index a99a5723c39..00000000000 --- a/gcc/testsuite/g77.dg/gcov/gcov.exp +++ /dev/null @@ -1,44 +0,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 diff --git a/gcc/testsuite/g77.dg/pr3743-1.f b/gcc/testsuite/g77.dg/pr3743-1.f deleted file mode 100644 index fd5fb0c426d..00000000000 --- a/gcc/testsuite/g77.dg/pr3743-1.f +++ /dev/null @@ -1,7 +0,0 @@ -C Test case for PR fortran/3743 -C Origin: David Billinghurst -C -C { dg-do link } - integer i - i = bit_size(i) - end diff --git a/gcc/testsuite/g77.dg/pr3743-2.f b/gcc/testsuite/g77.dg/pr3743-2.f deleted file mode 100644 index 3e0eabc15f7..00000000000 --- a/gcc/testsuite/g77.dg/pr3743-2.f +++ /dev/null @@ -1,8 +0,0 @@ -C Test case for PR fortran/3743 -C Origin: David Billinghurst -C -C { dg-do link } -C { dg-options "-fcase-preserve -fintrin-case-upper" } - integer i - i = BIT_SIZE(i) - end diff --git a/gcc/testsuite/g77.dg/pr3743-3.f b/gcc/testsuite/g77.dg/pr3743-3.f deleted file mode 100644 index 77964341506..00000000000 --- a/gcc/testsuite/g77.dg/pr3743-3.f +++ /dev/null @@ -1,8 +0,0 @@ -c Test case for PR fortran/3743 -c Origin: David Billinghurst -c -c { dg-do link } -c { dg-options "-fcase-preserve -fintrin-case-lower" } - integer i - i = bit_size(i) - end diff --git a/gcc/testsuite/g77.dg/pr3743-4.f b/gcc/testsuite/g77.dg/pr3743-4.f deleted file mode 100644 index 0cb94f62d21..00000000000 --- a/gcc/testsuite/g77.dg/pr3743-4.f +++ /dev/null @@ -1,8 +0,0 @@ -C Test case for PR fortran/3743 -C Origin: David Billinghurst -C -C { dg-do link } -C { dg-options "-fcase-preserve -fintrin-case-initcap" } - integer i - i = Bit_Size(i) - end diff --git a/gcc/testsuite/g77.dg/pr5473.f b/gcc/testsuite/g77.dg/pr5473.f deleted file mode 100644 index 41a6bdb9cdc..00000000000 --- a/gcc/testsuite/g77.dg/pr5473.f +++ /dev/null @@ -1,15 +0,0 @@ - program pr5473 -c Derived from g77.f-torture/execute/intrinsic-unix-bessel.f -c Origin: David Billinghurst -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 diff --git a/gcc/testsuite/g77.dg/pr9258.f b/gcc/testsuite/g77.dg/pr9258.f deleted file mode 100644 index 9961b72b7f6..00000000000 --- a/gcc/testsuite/g77.dg/pr9258.f +++ /dev/null @@ -1,18 +0,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 diff --git a/gcc/testsuite/g77.dg/strlen0.f b/gcc/testsuite/g77.dg/strlen0.f deleted file mode 100644 index 765c8b61190..00000000000 --- a/gcc/testsuite/g77.dg/strlen0.f +++ /dev/null @@ -1,95 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/12002.f b/gcc/testsuite/g77.f-torture/compile/12002.f deleted file mode 100644 index cd661459f93..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/12002.f +++ /dev/null @@ -1,5 +0,0 @@ -C PR middle-end/12002 - COMPLEX TE1 - TE1=-2. - TE1=TE1+TE1 - END diff --git a/gcc/testsuite/g77.f-torture/compile/13060.f b/gcc/testsuite/g77.f-torture/compile/13060.f deleted file mode 100644 index 200117b0271..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/13060.f +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990218-0.f b/gcc/testsuite/g77.f-torture/compile/19990218-0.f deleted file mode 100644 index 3e34117ec69..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990218-0.f +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990305-0.f b/gcc/testsuite/g77.f-torture/compile/19990305-0.f deleted file mode 100644 index 32c656d90a6..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990305-0.f +++ /dev/null @@ -1,55 +0,0 @@ -* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST) -* From: Denes Molnar -* 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 -* -* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/gcc/testsuite/g77.f-torture/compile/19990419-0.f b/gcc/testsuite/g77.f-torture/compile/19990419-0.f deleted file mode 100644 index 084e7a254bf..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990419-0.f +++ /dev/null @@ -1,7 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990502-0.f b/gcc/testsuite/g77.f-torture/compile/19990502-0.f deleted file mode 100644 index 4f5d6859138..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990502-0.f +++ /dev/null @@ -1,66 +0,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 -* 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 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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990502-1.f b/gcc/testsuite/g77.f-torture/compile/19990502-1.f deleted file mode 100644 index b7238fcd881..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990502-1.f +++ /dev/null @@ -1,6 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990525-0.f b/gcc/testsuite/g77.f-torture/compile/19990525-0.f deleted file mode 100644 index 5b8d466e40d..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990525-0.f +++ /dev/null @@ -1,50 +0,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" -* 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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990826-1.f b/gcc/testsuite/g77.f-torture/compile/19990826-1.f deleted file mode 100644 index e8daafc990a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990826-1.f +++ /dev/null @@ -1,286 +0,0 @@ -* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST) -* From: Jonathan Ravens -* 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 -! -! 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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990826-3.f b/gcc/testsuite/g77.f-torture/compile/19990826-3.f deleted file mode 100644 index a0f5fd17544..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990826-3.f +++ /dev/null @@ -1,320 +0,0 @@ -* Date: Thu, 19 Aug 1999 10:02:32 +0200 -* From: Frederic Devernay -* 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 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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990905-0.f b/gcc/testsuite/g77.f-torture/compile/19990905-0.f deleted file mode 100644 index b945b2eb1bd..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990905-0.f +++ /dev/null @@ -1,7 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/19990905-2.f b/gcc/testsuite/g77.f-torture/compile/19990905-2.f deleted file mode 100644 index af82f65d288..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990905-2.f +++ /dev/null @@ -1,22 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000412-1.f b/gcc/testsuite/g77.f-torture/compile/20000412-1.f deleted file mode 100644 index e4c6511fa3b..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000412-1.f +++ /dev/null @@ -1,5 +0,0 @@ - subroutine aap(k) - equivalence (i,r) - i = k - print*,r - end diff --git a/gcc/testsuite/g77.f-torture/compile/20000511-1.f b/gcc/testsuite/g77.f-torture/compile/20000511-1.f deleted file mode 100644 index ff95214351e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000511-1.f +++ /dev/null @@ -1,21 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000511-2.f b/gcc/testsuite/g77.f-torture/compile/20000511-2.f deleted file mode 100644 index 84542c578ae..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000511-2.f +++ /dev/null @@ -1,61 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000518.f b/gcc/testsuite/g77.f-torture/compile/20000518.f deleted file mode 100644 index 200a1ebcf2c..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000518.f +++ /dev/null @@ -1,16 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000601-1.f b/gcc/testsuite/g77.f-torture/compile/20000601-1.f deleted file mode 100644 index 86144a1aa09..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000601-1.f +++ /dev/null @@ -1,28 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000601-2.f b/gcc/testsuite/g77.f-torture/compile/20000601-2.f deleted file mode 100644 index 06c68d22ba0..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000601-2.f +++ /dev/null @@ -1,27 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000629-1.f b/gcc/testsuite/g77.f-torture/compile/20000629-1.f deleted file mode 100644 index c14021c4fa3..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000629-1.f +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20000630-2.f b/gcc/testsuite/g77.f-torture/compile/20000630-2.f deleted file mode 100644 index 623a29a9679..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20000630-2.f +++ /dev/null @@ -1,9 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20010115.f b/gcc/testsuite/g77.f-torture/compile/20010115.f deleted file mode 100644 index 8cf85a80abe..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20010115.f +++ /dev/null @@ -1,9 +0,0 @@ -* GNATS PR Fortran/1636 - PRINT 42, 'HELLO' - 42 FORMAT(A) - CALL WORLD - END - SUBROUTINE WORLD - PRINT 42, 'WORLD' - 42 FORMAT(A) - END diff --git a/gcc/testsuite/g77.f-torture/compile/20010321-1.f b/gcc/testsuite/g77.f-torture/compile/20010321-1.f deleted file mode 100644 index 3f3b5602737..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20010321-1.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20010426.f b/gcc/testsuite/g77.f-torture/compile/20010426.f deleted file mode 100644 index b22b02907a6..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20010426.f +++ /dev/null @@ -1,6 +0,0 @@ - function f(c) - implicit none - real*8 c, f - f = sqrt(c) - return - end diff --git a/gcc/testsuite/g77.f-torture/compile/20010519-1.f b/gcc/testsuite/g77.f-torture/compile/20010519-1.f deleted file mode 100644 index efe6b34ad9e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20010519-1.f +++ /dev/null @@ -1,1326 +0,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,'', - 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,'','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,'', - 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,'', - 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,'', - 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 diff --git a/gcc/testsuite/g77.f-torture/compile/20020307-1.f b/gcc/testsuite/g77.f-torture/compile/20020307-1.f deleted file mode 100644 index cfea25bee6a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20020307-1.f +++ /dev/null @@ -1,21 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20030115-1.c b/gcc/testsuite/g77.f-torture/compile/20030115-1.c deleted file mode 100644 index ec6f79c718e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20030115-1.c +++ /dev/null @@ -1,14 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/20030326-1.f b/gcc/testsuite/g77.f-torture/compile/20030326-1.f deleted file mode 100644 index bcbc73c179b..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/20030326-1.f +++ /dev/null @@ -1,14 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/8485.f b/gcc/testsuite/g77.f-torture/compile/8485.f deleted file mode 100644 index 95e58fbfc18..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/8485.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/960317-1.f b/gcc/testsuite/g77.f-torture/compile/960317-1.f deleted file mode 100644 index 4bb0a37278e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/960317-1.f +++ /dev/null @@ -1,103 +0,0 @@ -* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST) -* From: Kate Hedstrom -* 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 diff --git a/gcc/testsuite/g77.f-torture/compile/970125-0.f b/gcc/testsuite/g77.f-torture/compile/970125-0.f deleted file mode 100644 index 004f5584f3e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/970125-0.f +++ /dev/null @@ -1,40 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/970915-0.f b/gcc/testsuite/g77.f-torture/compile/970915-0.f deleted file mode 100644 index 9ac3cf8aa97..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/970915-0.f +++ /dev/null @@ -1,20 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/980310-1.f b/gcc/testsuite/g77.f-torture/compile/980310-1.f deleted file mode 100644 index bc8aa85c14a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-1.f +++ /dev/null @@ -1,28 +0,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 -C Date: 02 Dec 1997 18:11:35 +0000 -C Message-ID: -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 -C -C * stmt.c (pushcase_range): Clean up handling of "infinite" values. -C - diff --git a/gcc/testsuite/g77.f-torture/compile/980310-2.f b/gcc/testsuite/g77.f-torture/compile/980310-2.f deleted file mode 100644 index 5077c552da8..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-2.f +++ /dev/null @@ -1,43 +0,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 -C To: egcs-bugs@cygnus.com -C Subject: g77 crashes compiling Dungeon -C Message-ID: -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 diff --git a/gcc/testsuite/g77.f-torture/compile/980310-3.f b/gcc/testsuite/g77.f-torture/compile/980310-3.f deleted file mode 100644 index ddfb4c4bb9f..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-3.f +++ /dev/null @@ -1,259 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/compile/980310-4.f b/gcc/testsuite/g77.f-torture/compile/980310-4.f deleted file mode 100644 index 802e3031f86..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-4.f +++ /dev/null @@ -1,348 +0,0 @@ - -C To: egcs-bugs@cygnus.com -C Subject: -fPIC problem showing up with fortran on x86 -C From: Dave Love -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 diff --git a/gcc/testsuite/g77.f-torture/compile/980310-6.f b/gcc/testsuite/g77.f-torture/compile/980310-6.f deleted file mode 100644 index fd91500eea8..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-6.f +++ /dev/null @@ -1,21 +0,0 @@ -C From: Norbert Conrad -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 '*'. - diff --git a/gcc/testsuite/g77.f-torture/compile/980310-7.f b/gcc/testsuite/g77.f-torture/compile/980310-7.f deleted file mode 100644 index 9cfbaed692a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-7.f +++ /dev/null @@ -1,50 +0,0 @@ -C From: "David C. Doherty" -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. diff --git a/gcc/testsuite/g77.f-torture/compile/980310-8.f b/gcc/testsuite/g77.f-torture/compile/980310-8.f deleted file mode 100644 index 9501012f60a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-8.f +++ /dev/null @@ -1,39 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/compile/980419-2.f b/gcc/testsuite/g77.f-torture/compile/980419-2.f deleted file mode 100644 index ac9134dc8a7..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980419-2.f +++ /dev/null @@ -1,48 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/980424-0.f b/gcc/testsuite/g77.f-torture/compile/980424-0.f deleted file mode 100644 index 5df45bb79a9..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980424-0.f +++ /dev/null @@ -1,6 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/980427-0.f b/gcc/testsuite/g77.f-torture/compile/980427-0.f deleted file mode 100644 index d5d7d74c57b..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980427-0.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/980519-2.f b/gcc/testsuite/g77.f-torture/compile/980519-2.f deleted file mode 100644 index 4e708a17e60..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980519-2.f +++ /dev/null @@ -1,47 +0,0 @@ -* Date: Fri, 17 Apr 1998 14:12:51 +0200 -* From: Jean-Paul Jeannot -* 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 diff --git a/gcc/testsuite/g77.f-torture/compile/980729-0.f b/gcc/testsuite/g77.f-torture/compile/980729-0.f deleted file mode 100644 index 07789441d41..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980729-0.f +++ /dev/null @@ -1,5 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/981117-1.f b/gcc/testsuite/g77.f-torture/compile/981117-1.f deleted file mode 100644 index 019167064fa..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/981117-1.f +++ /dev/null @@ -1,23 +0,0 @@ -* egcs-bugs: -* From: Martin Kahlert -* 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 diff --git a/gcc/testsuite/g77.f-torture/compile/990115-1.f b/gcc/testsuite/g77.f-torture/compile/990115-1.f deleted file mode 100644 index 187e1b463b5..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/990115-1.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/alpha1.f b/gcc/testsuite/g77.f-torture/compile/alpha1.f deleted file mode 100644 index 7cda74ebd45..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/alpha1.f +++ /dev/null @@ -1,10 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/alpha1.x b/gcc/testsuite/g77.f-torture/compile/alpha1.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/alpha1.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/compile.exp b/gcc/testsuite/g77.f-torture/compile/compile.exp deleted file mode 100644 index b76741a8d48..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/compile.exp +++ /dev/null @@ -1,44 +0,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 -} diff --git a/gcc/testsuite/g77.f-torture/compile/cpp.F b/gcc/testsuite/g77.f-torture/compile/cpp.F deleted file mode 100644 index bdf10d7fbde..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/cpp.F +++ /dev/null @@ -1,9 +0,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 diff --git a/gcc/testsuite/g77.f-torture/compile/cpp2.F b/gcc/testsuite/g77.f-torture/compile/cpp2.F deleted file mode 100644 index 968d9f666ef..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/cpp2.F +++ /dev/null @@ -1,7 +0,0 @@ -C The preprocessor must not introduce a newline after -C the "a" when ARGUMENTS is expanded. - -#define ARGUMENTS a\ - - subroutine yada (ARGUMENTS) - end diff --git a/gcc/testsuite/g77.f-torture/compile/toon_1.f b/gcc/testsuite/g77.f-torture/compile/toon_1.f deleted file mode 100644 index 6b6847c4de5..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/toon_1.f +++ /dev/null @@ -1,3 +0,0 @@ - SUBROUTINE AAP(NOOT) - DIMENSION NOOT(*) - END diff --git a/gcc/testsuite/g77.f-torture/compile/xformat.f b/gcc/testsuite/g77.f-torture/compile/xformat.f deleted file mode 100644 index 7e9001c4bc1..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/xformat.f +++ /dev/null @@ -1,3 +0,0 @@ - PRINT 10, 2, 3 -10 FORMAT (I1, X, I1) - END diff --git a/gcc/testsuite/g77.f-torture/execute/10197.f b/gcc/testsuite/g77.f-torture/execute/10197.f deleted file mode 100644 index 0fa81f67809..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/10197.f +++ /dev/null @@ -1,15 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/10197.x b/gcc/testsuite/g77.f-torture/execute/10197.x deleted file mode 100644 index 6a69a3aadab..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/10197.x +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/13037.f b/gcc/testsuite/g77.f-torture/execute/13037.f deleted file mode 100644 index daafc528754..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/13037.f +++ /dev/null @@ -1,58 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/1832.f b/gcc/testsuite/g77.f-torture/execute/1832.f deleted file mode 100644 index 9ae1ca9fb27..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/1832.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/19981119-0.f b/gcc/testsuite/g77.f-torture/execute/19981119-0.f deleted file mode 100644 index 5cfab57a5fc..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19981119-0.f +++ /dev/null @@ -1,40 +0,0 @@ -* X-Delivered: at request of burley on mescaline.gnu.org -* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET) -* From: "B. Yanchitsky" -* 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! diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-0.f b/gcc/testsuite/g77.f-torture/execute/19990313-0.f deleted file mode 100644 index abf898fb793..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-0.f +++ /dev/null @@ -1,33 +0,0 @@ -* To: craig@jcb-sc.com -* Subject: Re: G77 and KIND=2 -* Content-Type: text/plain; charset=us-ascii -* From: Dave Love -* 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. diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-1.f b/gcc/testsuite/g77.f-torture/execute/19990313-1.f deleted file mode 100644 index d99c72f2fde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-1.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double precision r - data r/4d10/ - foo = 4d10 - bar = r - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-2.f b/gcc/testsuite/g77.f-torture/execute/19990313-2.f deleted file mode 100644 index ffb7549d413..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-2.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - complex c - data c/(4e10,0)/ - foo = 4e10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-3.f b/gcc/testsuite/g77.f-torture/execute/19990313-3.f deleted file mode 100644 index 6366dccd890..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-3.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double complex c - data c/(4d10,0)/ - foo = 4d10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-0.f b/gcc/testsuite/g77.f-torture/execute/19990325-0.f deleted file mode 100644 index a230362fdde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-0.f +++ /dev/null @@ -1,313 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-1.f b/gcc/testsuite/g77.f-torture/execute/19990325-1.f deleted file mode 100644 index 802f375b33d..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-1.f +++ /dev/null @@ -1,313 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/19990419-1.f b/gcc/testsuite/g77.f-torture/execute/19990419-1.f deleted file mode 100644 index 7449bac2b95..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990419-1.f +++ /dev/null @@ -1,21 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/19990826-0.f b/gcc/testsuite/g77.f-torture/execute/19990826-0.f deleted file mode 100644 index 975efdce61e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990826-0.f +++ /dev/null @@ -1,19 +0,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. diff --git a/gcc/testsuite/g77.f-torture/execute/19990826-2.f b/gcc/testsuite/g77.f-torture/execute/19990826-2.f deleted file mode 100644 index 30bdb30fd57..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990826-2.f +++ /dev/null @@ -1,33 +0,0 @@ -* From: "Billinghurst, David (RTD)" -* 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 diff --git a/gcc/testsuite/g77.f-torture/execute/20000503-1.f b/gcc/testsuite/g77.f-torture/execute/20000503-1.f deleted file mode 100644 index 027c9fc6fbb..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20000503-1.f +++ /dev/null @@ -1,24 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20001111.f b/gcc/testsuite/g77.f-torture/execute/20001111.f deleted file mode 100644 index db342bbd42b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20001111.f +++ /dev/null @@ -1,12 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20001201.f b/gcc/testsuite/g77.f-torture/execute/20001201.f deleted file mode 100644 index e80c2a8bcf8..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20001201.f +++ /dev/null @@ -1,12 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20001201.x b/gcc/testsuite/g77.f-torture/execute/20001201.x deleted file mode 100644 index 6a69a3aadab..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20001201.x +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20010116.f b/gcc/testsuite/g77.f-torture/execute/20010116.f deleted file mode 100644 index 7c72a085a79..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20010116.f +++ /dev/null @@ -1,38 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20010426.f b/gcc/testsuite/g77.f-torture/execute/20010426.f deleted file mode 100644 index dd1b5bdd0e8..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20010426.f +++ /dev/null @@ -1,2 +0,0 @@ - print*,cos(1.0) - end diff --git a/gcc/testsuite/g77.f-torture/execute/20010430.f b/gcc/testsuite/g77.f-torture/execute/20010430.f deleted file mode 100644 index 58dca834004..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20010430.f +++ /dev/null @@ -1,20 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/20010610.f b/gcc/testsuite/g77.f-torture/execute/20010610.f deleted file mode 100644 index 4ce2d22147a..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/20010610.f +++ /dev/null @@ -1,4 +0,0 @@ - DO I = 0, 255 - IF (ICHAR(CHAR(I)) .NE. I) CALL ABORT - ENDDO - END diff --git a/gcc/testsuite/g77.f-torture/execute/5122.f b/gcc/testsuite/g77.f-torture/execute/5122.f deleted file mode 100644 index bdf955acac9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/5122.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/6177.f b/gcc/testsuite/g77.f-torture/execute/6177.f deleted file mode 100644 index f40029cf52c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/6177.f +++ /dev/null @@ -1,14 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/6367.f b/gcc/testsuite/g77.f-torture/execute/6367.f deleted file mode 100644 index 158bddf8f47..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/6367.f +++ /dev/null @@ -1,16 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/6367.x b/gcc/testsuite/g77.f-torture/execute/6367.x deleted file mode 100644 index 42fc7da02ae..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/6367.x +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/947.f b/gcc/testsuite/g77.f-torture/execute/947.f deleted file mode 100644 index 7efa204d5be..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/947.f +++ /dev/null @@ -1,12 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/970625-2.f b/gcc/testsuite/g77.f-torture/execute/970625-2.f deleted file mode 100644 index 3ef6f46cb79..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970625-2.f +++ /dev/null @@ -1,84 +0,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 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. diff --git a/gcc/testsuite/g77.f-torture/execute/970816-3.f b/gcc/testsuite/g77.f-torture/execute/970816-3.f deleted file mode 100644 index 6398600f059..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970816-3.f +++ /dev/null @@ -1,20 +0,0 @@ -* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) -* From: Claus Denk -* 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 diff --git a/gcc/testsuite/g77.f-torture/execute/971102-1.f b/gcc/testsuite/g77.f-torture/execute/971102-1.f deleted file mode 100644 index 6b0c2f3b3a9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/971102-1.f +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980520-1.f b/gcc/testsuite/g77.f-torture/execute/980520-1.f deleted file mode 100644 index 6d05c6767fd..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980520-1.f +++ /dev/null @@ -1,6 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-0.f b/gcc/testsuite/g77.f-torture/execute/980628-0.f deleted file mode 100644 index c36b1efc052..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-0.f +++ /dev/null @@ -1,61 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-1.f b/gcc/testsuite/g77.f-torture/execute/980628-1.f deleted file mode 100644 index 6ab0a0a81a8..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-1.f +++ /dev/null @@ -1,62 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-10.f b/gcc/testsuite/g77.f-torture/execute/980628-10.f deleted file mode 100644 index 427f635add9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-10.f +++ /dev/null @@ -1,57 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-2.f b/gcc/testsuite/g77.f-torture/execute/980628-2.f deleted file mode 100644 index a140e7db611..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-2.f +++ /dev/null @@ -1,55 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-3.f b/gcc/testsuite/g77.f-torture/execute/980628-3.f deleted file mode 100644 index 47e6ea57301..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-3.f +++ /dev/null @@ -1,56 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-4.f b/gcc/testsuite/g77.f-torture/execute/980628-4.f deleted file mode 100644 index 40bd6e6df51..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-4.f +++ /dev/null @@ -1,27 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-4.x b/gcc/testsuite/g77.f-torture/execute/980628-4.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-4.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-5.f b/gcc/testsuite/g77.f-torture/execute/980628-5.f deleted file mode 100644 index 14f39e3c51e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-5.f +++ /dev/null @@ -1,27 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-5.x b/gcc/testsuite/g77.f-torture/execute/980628-5.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-5.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-6.f b/gcc/testsuite/g77.f-torture/execute/980628-6.f deleted file mode 100644 index c5ade65ed39..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-6.f +++ /dev/null @@ -1,26 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-6.x b/gcc/testsuite/g77.f-torture/execute/980628-6.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-6.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980628-7.f b/gcc/testsuite/g77.f-torture/execute/980628-7.f deleted file mode 100644 index c81ba31fc26..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-7.f +++ /dev/null @@ -1,62 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-8.f b/gcc/testsuite/g77.f-torture/execute/980628-8.f deleted file mode 100644 index 8940d009954..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-8.f +++ /dev/null @@ -1,63 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-9.f b/gcc/testsuite/g77.f-torture/execute/980628-9.f deleted file mode 100644 index 54e6552d628..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-9.f +++ /dev/null @@ -1,56 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/980701-0.f b/gcc/testsuite/g77.f-torture/execute/980701-0.f deleted file mode 100644 index a3ddd55473a..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-0.f +++ /dev/null @@ -1,72 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/980701-1.f b/gcc/testsuite/g77.f-torture/execute/980701-1.f deleted file mode 100644 index fba78564572..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-1.f +++ /dev/null @@ -1,72 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/alpha2.f b/gcc/testsuite/g77.f-torture/execute/alpha2.f deleted file mode 100644 index d7b9d39da4b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/alpha2.f +++ /dev/null @@ -1,19 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/alpha2.x b/gcc/testsuite/g77.f-torture/execute/alpha2.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/alpha2.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/auto0.f b/gcc/testsuite/g77.f-torture/execute/auto0.f deleted file mode 100644 index 4b6b2f51a8e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto0.f +++ /dev/null @@ -1,80 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/auto0.x b/gcc/testsuite/g77.f-torture/execute/auto0.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto0.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/auto1.f b/gcc/testsuite/g77.f-torture/execute/auto1.f deleted file mode 100644 index ab9044ceca5..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto1.f +++ /dev/null @@ -1,88 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/auto1.x b/gcc/testsuite/g77.f-torture/execute/auto1.x deleted file mode 100644 index 8f6fe7faf80..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto1.x +++ /dev/null @@ -1,11 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/cabs.f b/gcc/testsuite/g77.f-torture/execute/cabs.f deleted file mode 100644 index 61fd263620b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cabs.f +++ /dev/null @@ -1,14 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/claus.f b/gcc/testsuite/g77.f-torture/execute/claus.f deleted file mode 100644 index bccef7f4090..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/claus.f +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/complex_1.f b/gcc/testsuite/g77.f-torture/execute/complex_1.f deleted file mode 100644 index 77da6359f72..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/complex_1.f +++ /dev/null @@ -1,18 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/cpp.F b/gcc/testsuite/g77.f-torture/execute/cpp.F deleted file mode 100644 index fc9386b5c92..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cpp.F +++ /dev/null @@ -1,5 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/cpp2.F b/gcc/testsuite/g77.f-torture/execute/cpp2.F deleted file mode 100644 index 88f5644d8b5..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cpp2.F +++ /dev/null @@ -1,7 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/dcomplex.f b/gcc/testsuite/g77.f-torture/execute/dcomplex.f deleted file mode 100644 index a46f03aabef..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dcomplex.f +++ /dev/null @@ -1,18 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/dnrm2.f b/gcc/testsuite/g77.f-torture/execute/dnrm2.f deleted file mode 100644 index c69608786b9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dnrm2.f +++ /dev/null @@ -1,74 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/erfc.f b/gcc/testsuite/g77.f-torture/execute/erfc.f deleted file mode 100644 index e5e0412f587..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/erfc.f +++ /dev/null @@ -1,38 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/execute.exp b/gcc/testsuite/g77.f-torture/execute/execute.exp deleted file mode 100644 index 00126ff21a3..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/execute.exp +++ /dev/null @@ -1,52 +0,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 -} diff --git a/gcc/testsuite/g77.f-torture/execute/exp.f b/gcc/testsuite/g77.f-torture/execute/exp.f deleted file mode 100644 index de388f181b0..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/exp.f +++ /dev/null @@ -1,3 +0,0 @@ - a = 2**-2*1. - if (a .ne. .25) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-bit.f b/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-bit.f deleted file mode 100644 index a5f876e14ba..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-bit.f +++ /dev/null @@ -1,458 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-mathematical.f b/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-mathematical.f deleted file mode 100644 index 400e3fa6796..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-mathematical.f +++ /dev/null @@ -1,137 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-numeric.f b/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-numeric.f deleted file mode 100644 index 4428ca042d7..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/f90-intrinsic-numeric.f +++ /dev/null @@ -1,282 +0,0 @@ -c f90-intrinsic-numeric.f -c -c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13 -c David Billinghurst -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 diff --git a/gcc/testsuite/g77.f-torture/execute/int8421.f b/gcc/testsuite/g77.f-torture/execute/int8421.f deleted file mode 100644 index 1fcc3bc4c9f..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/int8421.f +++ /dev/null @@ -1,20 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f deleted file mode 100644 index ec7b3324379..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/intrinsic-f2c-z.f +++ /dev/null @@ -1,94 +0,0 @@ -c intrinsic-f2c-z.f -c -c Test double complex intrinsics Z*. -c These functions are f2c extensions -c -c David Billinghurst -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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f deleted file mode 100644 index 53c97fd92fd..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-bessel.f +++ /dev/null @@ -1,108 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f deleted file mode 100644 index 5ab48d65036..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f +++ /dev/null @@ -1,60 +0,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 -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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f b/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f deleted file mode 100644 index 93f1c43b0f5..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/intrinsic-vax-cd.f +++ /dev/null @@ -1,94 +0,0 @@ -c intrinsic-vax-cd.f -c -c Test double complex intrinsics CD*. -c These functions are VAX extensions -c -c David Billinghurst -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 diff --git a/gcc/testsuite/g77.f-torture/execute/intrinsic77.f b/gcc/testsuite/g77.f-torture/execute/intrinsic77.f deleted file mode 100644 index 19073196885..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/intrinsic77.f +++ /dev/null @@ -1,586 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/io0.f b/gcc/testsuite/g77.f-torture/execute/io0.f deleted file mode 100644 index c56c9919077..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io0.f +++ /dev/null @@ -1,46 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/io0.x b/gcc/testsuite/g77.f-torture/execute/io0.x deleted file mode 100644 index 6a69a3aadab..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io0.x +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f deleted file mode 100644 index c5242446a49..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.f +++ /dev/null @@ -1,10 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/io1.x b/gcc/testsuite/g77.f-torture/execute/io1.x deleted file mode 100644 index 6a69a3aadab..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.x +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f deleted file mode 100644 index 032fa41f899..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/labug1.f +++ /dev/null @@ -1,57 +0,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 - - - - - - - - - - diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f deleted file mode 100644 index 0af5b1b0b3f..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/large_vec.f +++ /dev/null @@ -1,3 +0,0 @@ - parameter (nmax=165000) - double precision x(nmax) - end diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f deleted file mode 100644 index 74e42750d55..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/le.f +++ /dev/null @@ -1,29 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f deleted file mode 100644 index f1024330a71..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/select.f +++ /dev/null @@ -1,173 +0,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 - - - - - diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f deleted file mode 100644 index 89ae273891c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/short.f +++ /dev/null @@ -1,57 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f deleted file mode 100644 index f502bc72833..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.f +++ /dev/null @@ -1,421 +0,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 diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.x b/gcc/testsuite/g77.f-torture/execute/u77-test.x deleted file mode 100644 index e4b89008c25..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.x +++ /dev/null @@ -1,12 +0,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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f deleted file mode 100644 index 0cc9087d6cb..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f +++ /dev/null @@ -1,89 +0,0 @@ -* Resent-From: Craig Burley -* 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 -* 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 Stüken, con terra GmbH, Münster -* 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f deleted file mode 100644 index 25b7c5b2b52..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f +++ /dev/null @@ -1,13 +0,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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f deleted file mode 100644 index 86d2a939064..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f +++ /dev/null @@ -1,648 +0,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" -* To: Craig Burley -* 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) diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f deleted file mode 100644 index 026d05e4b3c..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f +++ /dev/null @@ -1,8 +0,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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/9263.f b/gcc/testsuite/g77.f-torture/noncompile/9263.f deleted file mode 100644 index e68b3e0a65f..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/9263.f +++ /dev/null @@ -1,7 +0,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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f deleted file mode 100644 index c1e2348646f..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f +++ /dev/null @@ -1,4 +0,0 @@ - SUBROUTINE A(A,ALPHA,IA) - COMPLEX A(IA,*), ALPHA(*) - ALPHA(I)=A(I,I).ZERO) - END diff --git a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f deleted file mode 100644 index 316969f6aa8..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f +++ /dev/null @@ -1,10 +0,0 @@ -* Fixed by JCB 1998-07-25 change to stc.c. - -* Date: Thu, 11 Jun 1998 22:35:20 -0500 -* From: Ian A Watson -* Subject: crash -* - CaLL foo(W) - END - SUBROUTINE foo(W) - yy(I)=A(I)Q(X) diff --git a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f deleted file mode 100644 index bd5e74022a3..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f +++ /dev/null @@ -1,8 +0,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 -* Subject: Mangler Crash - EQUIVALENCE(I,glerf(P)) - COMMON /foo/ glerf(3) diff --git a/gcc/testsuite/g77.f-torture/noncompile/check0.f b/gcc/testsuite/g77.f-torture/noncompile/check0.f deleted file mode 100644 index fc3c6ca730e..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/check0.f +++ /dev/null @@ -1,11 +0,0 @@ -CCC Abort fixed by: -CCC1998-04-21 Jim Wilson -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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp deleted file mode 100644 index fadd1fbbe5a..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp +++ /dev/null @@ -1,36 +0,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 - diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f deleted file mode 100644 index f7dad339a81..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f +++ /dev/null @@ -1,10 +0,0 @@ - integer*1 one - integer*2 two - parameter (one=1) - parameter (two=2) - select case (I) - case (one) - case (two) - end select - end -