diff options
| author | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
|---|---|---|
| committer | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
| commit | 1bc5aee63eb72b341f506ad058502cd0361f0d10 (patch) | |
| tree | c607e8252f3405424ff15bc2d00aa38dadbb2518 /gcc-4.9/gcc/testsuite/gfortran.dg/g77 | |
| parent | 283a0bf58fcf333c58a2a92c3ebbc41fb9eb1fdb (diff) | |
| download | toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.gz toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.bz2 toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.zip | |
Initial checkin of GCC 4.9.0 from trunk (r208799).
Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba
Diffstat (limited to 'gcc-4.9/gcc/testsuite/gfortran.dg/g77')
137 files changed, 7080 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12002.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12002.f new file mode 100644 index 000000000..0cb29c754 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12002.f @@ -0,0 +1,6 @@ +C PR middle-end/12002 +C { dg-do compile } + COMPLEX TE1 + TE1=-2. + TE1=TE1+TE1 + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12632.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12632.f new file mode 100644 index 000000000..398333926 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/12632.f @@ -0,0 +1,6 @@ +C { dg-do compile } +C { dg-options "-fbounds-check" } + INTEGER I(1) + I(2) = 0 ! { dg-warning "out of bounds" "out of bounds" } + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/13037.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/13037.f new file mode 100644 index 000000000..01c2bab19 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/13037.f @@ -0,0 +1,59 @@ +c { dg-do run } +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-4.9/gcc/testsuite/gfortran.dg/g77/13060.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/13060.f new file mode 100644 index 000000000..4c1b3e723 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/13060.f @@ -0,0 +1,14 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/1832.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/1832.f new file mode 100644 index 000000000..6b7617d62 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/1832.f @@ -0,0 +1,9 @@ +c { dg-do run } +! { dg-options "-std=legacy" } +! + character*5 string + write(string, *) "a " + if (string .ne. ' a') call abort +C-- The leading space is normal for list-directed output + + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981119-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981119-0.f new file mode 100644 index 000000000..17c6e0640 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981119-0.f @@ -0,0 +1,41 @@ +c { dg-do run } +* X-Delivered: at request of burley on mescaline.gnu.org +* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET) +* From: "B. Yanchitsky" <yan@im.imag.kiev.ua> +* To: fortran@gnu.org +* Subject: Bug report +* MIME-Version: 1.0 +* Content-Type: TEXT/PLAIN; charset=US-ASCII +* +* There is a trouble with g77 on Alpha. +* My configuration: +* Digital Personal Workstation 433au, +* Digital Unix 4.0D, +* GNU Fortran 0.5.23 and GNU C 2.8.1. +* +* The following program treated successfully but crashed when running. +* +* C --- PROGRAM BEGIN ------- +* + subroutine sub(N,u) + integer N + double precision u(-N:N,-N:N) + +C vvvv CRASH HERE vvvvv + u(-N,N)=0d0 + return + end + + + program bug + integer N + double precision a(-10:10,-10:10) + data a/441*1d0/ + N=10 + call sub(N,a) + if (a(-N,N) .ne. 0d0) call abort + end +* +* C --- PROGRAM END ------- +* +* Good luck! diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981216-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981216-0.f new file mode 100644 index 000000000..82d259d3c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19981216-0.f @@ -0,0 +1,92 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +* Resent-From: Craig Burley <burley@gnu.org> +* Resent-To: craig@jcb-sc.com +* X-Delivered: at request of burley on mescaline.gnu.org +* Date: Wed, 16 Dec 1998 18:31:24 +0100 +* From: Dieter Stueken <stueken@conterra.de> +* Organization: con terra GmbH +* To: fortran@gnu.org +* Subject: possible bug +* Content-Type: text/plain; charset=iso-8859-1 +* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085 +* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2 +* +* Hi, +* +* I'm about to compile a very old, very ugly Fortran program. +* For one part I got: +* +* f77: Internal compiler error: program f771 got fatal signal 6 +* +* instead of any detailed error message. I was able to break down the +* problem to the following source fragment: +* +* ------------------------------------------- + PROGRAM WAP + + integer(kind=8) 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(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/19990218-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990218-0.f new file mode 100644 index 000000000..57bb63841 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990218-0.f @@ -0,0 +1,14 @@ +c { dg-do compile } + program test + double precision a,b,c + data a,b/1.0d-46,1.0d0/ + c=fun(a,b) ! { dg-error "Return type mismatch of function" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/19990218-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990218-1.f new file mode 100644 index 000000000..8506e4fe1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990218-1.f @@ -0,0 +1,25 @@ +c { dg-do compile } +c +c g77 used to warn for this case +c 19990218-1.f: In program `test': +c 19990218-1.f:13: +c double precision function fun(a,b) +c 1 +c 19990218-1.f:23: (continued): +c c=fun(a,b) +c 2 +c Global name `fun' at (2) has different type at (1) [info -f g77 M GLOBALS] +c + 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) ! { dg-error "Return type mismatch of function" } + print*,'in main: fun=',c + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990305-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990305-0.f new file mode 100644 index 000000000..056d2b7a3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990305-0.f @@ -0,0 +1,56 @@ +c { dg-do compile } +* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST) +* From: Denes Molnar <molnard@phys.columbia.edu> +* To: fortran@gnu.org +* Subject: f771 gets fatal signal 6 +* Content-Type: TEXT/PLAIN; charset=US-ASCII +* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f +* +* Hi, +* +* +* Comiling object from the source code below WORKS FINE with +* 'g77 -o hwuci2 -c hwuci2.F' +* but FAILS with fatal signal 6 +* 'g77 -o hwuci2 -O -c hwuci2.F' +* +* Any explanations? +* +* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1). +* +* +* Denes Molnar +* +* %%%%%%%%%%%%%%%%%%%%%%%%% +* %the source: +* %%%%%%%%%%%%%%%%%%%%%%%%% +* +CDECK ID>, HWUCI2. +*CMZ :- -23/08/94 13.22.29 by Mike Seymour +*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles +C----------------------------------------------------------------------- + FUNCTION HWUCI2(A,B,Y0) +C----------------------------------------------------------------------- +C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0) +C----------------------------------------------------------------------- + IMPLICIT NONE + complex(kind=8) 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-4.9/gcc/testsuite/gfortran.dg/g77/19990313-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-0.f new file mode 100644 index 000000000..fd74351d2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-0.f @@ -0,0 +1,34 @@ +c { dg-do run } +* To: craig@jcb-sc.com +* Subject: Re: G77 and KIND=2 +* Content-Type: text/plain; charset=us-ascii +* From: Dave Love <d.love@dl.ac.uk> +* Date: 03 Mar 1999 18:20:11 +0000 +* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000" +* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3 +* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0 +* +* ISTM that there is a real problem printing integer(kind=8) (on x86): +* +* $ cat x.f +*[modified for test suite] + integer(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/19990313-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-1.f new file mode 100644 index 000000000..a73ec4ea7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-1.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + double precision r + data r/4d10/ + foo = 4d10 + bar = r + if (foo .ne. bar) call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-2.f new file mode 100644 index 000000000..51f16685e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-2.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + complex c + data c/(4e10,0)/ + foo = 4e10 + bar = c + if (foo .ne. bar) call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-3.f new file mode 100644 index 000000000..782f39568 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990313-3.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + complex(kind=8) c + data c/(4d10,0)/ + foo = 4d10 + bar = c + if (foo .ne. bar) call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990419-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990419-0.f new file mode 100644 index 000000000..68f4ddabe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990419-0.f @@ -0,0 +1,8 @@ +c { dg-do compile } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/19990419-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990419-1.f new file mode 100644 index 000000000..e6a4a9bc0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990419-1.f @@ -0,0 +1,22 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/19990502-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990502-0.f new file mode 100644 index 000000000..a82f8838d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990502-0.f @@ -0,0 +1,67 @@ +c { dg-do compile } +* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm +* Precedence: bulk +* Sender: owner-egcs-bugs@egcs.cygnus.com +* From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de> +* Subject: egcs g77 19990524pre Internal compiler error in `print_operand' +* To: egcs-bugs@egcs.cygnus.com +* Date: Mon, 31 May 1999 11:46:52 +0200 (CET) +* Content-Type: text/plain; charset=US-ASCII +* X-UIDL: 9a00095a5fe4d774b7223de071157374 +* +* Hi, +* +* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524 +* on an i686-pc-linux-gnu. The program below gives an internal compiler error. +* +* +* Script started on Mon May 31 11:30:01 1999 +* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f +* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515) +* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs +* gcc version gcc-2.95 19990524 (prerelease) +* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s +* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease). +* GNU Fortran Front End version 0.5.24-19990515 +* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405 +* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'. +* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for details. +* lx{g010}:/tmp>cat e3.f + SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 ) + DOUBLE PRECISION SMALL2, TOL2 + DOUBLE PRECISION EE( * ), QQ( * ) + INTEGER ICONV, N, OFF + DOUBLE PRECISION QEMAX, XINF + EXTERNAL DLASQ3 + INTRINSIC MAX, SQRT + XINF = 0.0D0 + ICONV = 0 + IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN + END IF + IF( EE( N-2 ).LE.MAX( XINF, SMALL2, + $ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN + QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) + END IF + IF( N.EQ.0 ) THEN + IF( OFF.EQ.0 ) THEN + RETURN + ELSE + XINF =0.0D0 + END IF + ELSE IF( N.EQ.2 ) THEN + END IF + CALL DLASQ3(ICONV) + END +* lx{g010}:/tmp>exit +* +* Script done on Mon May 31 11:30:23 1999 +* +* Best regards, +* +* Norbert. +* -- +* Norbert Conrad phone: ++49 641 9913021 +* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de +* Heinrich-Buff-Ring 44 +* 35392 Giessen +* Germany diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990502-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990502-1.f new file mode 100644 index 000000000..dde2769f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990502-1.f @@ -0,0 +1,7 @@ +c { dg-do compile } + SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY) + INTEGER(kind=2) IGAMS(2,NADC) + in = 1 + do while (in.le.nadc.and.IGAMS(2,in).le.in) + enddo + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990525-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990525-0.f new file mode 100644 index 000000000..4eb104cdb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990525-0.f @@ -0,0 +1,53 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm +* Precedence: bulk +* Sender: owner-egcs-bugs@egcs.cygnus.com +* From: "Bjorn R. Bjornsson" <brb@halo.hi.is> +* Subject: g77 char expr. as arg to subroutine bug +* To: egcs-bugs@egcs.cygnus.com +* Date: Tue, 25 May 1999 14:45:56 +0000 (GMT) +* Content-Type: text/plain; charset=US-ASCII +* X-UIDL: 06000c94269ed6dfe826493e52a818b9 +* +* The following bug is in all snapshots starting +* from April 18. I have only tested this on Alpha linux, +* and with FFECOM_FASTER_ARRAY_REFS set to 1. +* +* Run the following through g77: +* + subroutine a + character*2 string1 + character*2 string2 + character*4 string3 + string1 = 's1' + string2 = 's2' +c +c the next 2 lines are ok. + string3 = (string1 // string2) + call b(string1//string2) +c +c this line gives gcc/f/com.c:10660: failed assertion `hook' + call b((string1//string2)) + end +* +* the output from: +* +* /usr/local/egcs-19990418/bin/g77 --verbose -c D.f +* +* is: +* +* on egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (from FSF-g77 version 0.5.24-19990418) +* Reading specs from /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/specs +* gcc version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) +* /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/f771 D.f -quiet -dumpbase D.f -version -fversion -o /tmp/ccNpaaaa.s +* GNU F77 version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (alphaev56-unknown-linux-gnu) compiled by GNU C version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental). +* GNU Fortran Front End version 0.5.24-19990418 +* ../../../egcs-19990418/gcc/f/com.c:10351: failed assertion `hook' +* g77: Internal compiler error: program f771 got fatal signal 6 +* +* Yours, +* +* Bjorn R. Bjornsson +* brb@halo.hi.is diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-0.f new file mode 100644 index 000000000..bc471f0bf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-0.f @@ -0,0 +1,20 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/19990826-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-1.f new file mode 100644 index 000000000..d9dd70b88 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-1.f @@ -0,0 +1,287 @@ +c { dg-do compile } +* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST) +* From: Jonathan Ravens <ravens@whio.gns.cri.nz> +* To: gcc-bugs@gcc.gnu.org +* Subject: g77 bug report +* X-UIDL: a0bf5ecc21487cde48d9104983ab04d6 + +! This fortran source will not compile - if the penultimate elseif block is 0 +! included then the message appears : +! +! /usr/src/egcs//gcc-2.95.1/gcc/f/stw.c:308: failed assertion `b->uses_ > 0' +! g77: Internal compiler error: program f771 got fatal signal 6 +! +! The command was : g77 -c <prog.f> +! +! The OS is Red Hat 6, and the output from uname -a is +! Linux grfw1452.gns.cri.nz 2.2.5-15 #1 Mon Apr 19 23:00:46 EDT 1999 i686 unknown +! +! The configure script I used was +! /usr/src/egcs/gcc/gcc-2.95.1/configure --enable-languages=f77 i585-unknown-linux +! +! I was installing 2.95 because under EGCS 2.1.1 none of my code was working +! with optimisation turned on, and there were still bugs with no optimisation +! (all of which code works fine under g77 0.5.21 and Sun/IBM/Dec/HP fortrans). +! +! The version of g77 is : +! +!g77 version 2.95.1 19990816 (release) (from FSF-g77 version 0.5.25 19990816 (release)) + + program main + if (i.eq.1) then + call abc(1) + else if (i.eq. 1) then + call abc( 1) + else if (i.eq. 2) then + call abc( 2) + else if (i.eq. 3) then + call abc( 3) + else if (i.eq. 4) then + call abc( 4) + else if (i.eq. 5) then + call abc( 5) + else if (i.eq. 6) then + call abc( 6) + else if (i.eq. 7) then + call abc( 7) + else if (i.eq. 8) then + call abc( 8) + else if (i.eq. 9) then + call abc( 9) + else if (i.eq. 10) then + call abc( 10) + else if (i.eq. 11) then + call abc( 11) + else if (i.eq. 12) then + call abc( 12) + else if (i.eq. 13) then + call abc( 13) + else if (i.eq. 14) then + call abc( 14) + else if (i.eq. 15) then + call abc( 15) + else if (i.eq. 16) then + call abc( 16) + else if (i.eq. 17) then + call abc( 17) + else if (i.eq. 18) then + call abc( 18) + else if (i.eq. 19) then + call abc( 19) + else if (i.eq. 20) then + call abc( 20) + else if (i.eq. 21) then + call abc( 21) + else if (i.eq. 22) then + call abc( 22) + else if (i.eq. 23) then + call abc( 23) + else if (i.eq. 24) then + call abc( 24) + else if (i.eq. 25) then + call abc( 25) + else if (i.eq. 26) then + call abc( 26) + else if (i.eq. 27) then + call abc( 27) + else if (i.eq. 28) then + call abc( 28) + else if (i.eq. 29) then + call abc( 29) + else if (i.eq. 30) then + call abc( 30) + else if (i.eq. 31) then + call abc( 31) + else if (i.eq. 32) then + call abc( 32) + else if (i.eq. 33) then + call abc( 33) + else if (i.eq. 34) then + call abc( 34) + else if (i.eq. 35) then + call abc( 35) + else if (i.eq. 36) then + call abc( 36) + else if (i.eq. 37) then + call abc( 37) + else if (i.eq. 38) then + call abc( 38) + else if (i.eq. 39) then + call abc( 39) + else if (i.eq. 40) then + call abc( 40) + else if (i.eq. 41) then + call abc( 41) + else if (i.eq. 42) then + call abc( 42) + else if (i.eq. 43) then + call abc( 43) + else if (i.eq. 44) then + call abc( 44) + else if (i.eq. 45) then + call abc( 45) + else if (i.eq. 46) then + call abc( 46) + else if (i.eq. 47) then + call abc( 47) + else if (i.eq. 48) then + call abc( 48) + else if (i.eq. 49) then + call abc( 49) + else if (i.eq. 50) then + call abc( 50) + else if (i.eq. 51) then + call abc( 51) + else if (i.eq. 52) then + call abc( 52) + else if (i.eq. 53) then + call abc( 53) + else if (i.eq. 54) then + call abc( 54) + else if (i.eq. 55) then + call abc( 55) + else if (i.eq. 56) then + call abc( 56) + else if (i.eq. 57) then + call abc( 57) + else if (i.eq. 58) then + call abc( 58) + else if (i.eq. 59) then + call abc( 59) + else if (i.eq. 60) then + call abc( 60) + else if (i.eq. 61) then + call abc( 61) + else if (i.eq. 62) then + call abc( 62) + else if (i.eq. 63) then + call abc( 63) + else if (i.eq. 64) then + call abc( 64) + else if (i.eq. 65) then + call abc( 65) + else if (i.eq. 66) then + call abc( 66) + else if (i.eq. 67) then + call abc( 67) + else if (i.eq. 68) then + call abc( 68) + else if (i.eq. 69) then + call abc( 69) + else if (i.eq. 70) then + call abc( 70) + else if (i.eq. 71) then + call abc( 71) + else if (i.eq. 72) then + call abc( 72) + else if (i.eq. 73) then + call abc( 73) + else if (i.eq. 74) then + call abc( 74) + else if (i.eq. 75) then + call abc( 75) + else if (i.eq. 76) then + call abc( 76) + else if (i.eq. 77) then + call abc( 77) + else if (i.eq. 78) then + call abc( 78) + else if (i.eq. 79) then + call abc( 79) + else if (i.eq. 80) then + call abc( 80) + else if (i.eq. 81) then + call abc( 81) + else if (i.eq. 82) then + call abc( 82) + else if (i.eq. 83) then + call abc( 83) + else if (i.eq. 84) then + call abc( 84) + else if (i.eq. 85) then + call abc( 85) + else if (i.eq. 86) then + call abc( 86) + else if (i.eq. 87) then + call abc( 87) + else if (i.eq. 88) then + call abc( 88) + else if (i.eq. 89) then + call abc( 89) + else if (i.eq. 90) then + call abc( 90) + else if (i.eq. 91) then + call abc( 91) + else if (i.eq. 92) then + call abc( 92) + else if (i.eq. 93) then + call abc( 93) + else if (i.eq. 94) then + call abc( 94) + else if (i.eq. 95) then + call abc( 95) + else if (i.eq. 96) then + call abc( 96) + else if (i.eq. 97) then + call abc( 97) + else if (i.eq. 98) then + call abc( 98) + else if (i.eq. 99) then + call abc( 99) + else if (i.eq. 100) then + call abc( 100) + else if (i.eq. 101) then + call abc( 101) + else if (i.eq. 102) then + call abc( 102) + else if (i.eq. 103) then + call abc( 103) + else if (i.eq. 104) then + call abc( 104) + else if (i.eq. 105) then + call abc( 105) + else if (i.eq. 106) then + call abc( 106) + else if (i.eq. 107) then + call abc( 107) + else if (i.eq. 108) then + call abc( 108) + else if (i.eq. 109) then + call abc( 109) + else if (i.eq. 110) then + call abc( 110) + else if (i.eq. 111) then + call abc( 111) + else if (i.eq. 112) then + call abc( 112) + else if (i.eq. 113) then + call abc( 113) + else if (i.eq. 114) then + call abc( 114) + else if (i.eq. 115) then + call abc( 115) + else if (i.eq. 116) then + call abc( 116) + else if (i.eq. 117) then + call abc( 117) + else if (i.eq. 118) then + call abc( 118) + else if (i.eq. 119) then + call abc( 119) + else if (i.eq. 120) then + call abc( 120) + else if (i.eq. 121) then + call abc( 121) + else if (i.eq. 122) then + call abc( 122) + else if (i.eq. 123) then + call abc( 123) + else if (i.eq. 124) then + call abc( 124) + else if (i.eq. 125) then !< Miscompiles if present + call abc( 125) !< + +c else if (i.eq. 126) then +c call abc( 126) + endif + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-2.f new file mode 100644 index 000000000..8870c2588 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-2.f @@ -0,0 +1,36 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +* From: "Billinghurst, David (RTD)" <David.Billinghurst@riotinto.com.au> +* Subject: RE: single precision complex bug in g77 - was Testing g77 with LA +* PACK 3.0 +* Date: Thu, 8 Jul 1999 00:55:11 +0100 +* X-UIDL: b00d9d8081a36fef561b827d255dd4a5 + +* Here is a slightly simpler and neater test case + + program labug3 + implicit none + +* This program gives the wrong answer on mips-sgi-irix6.5 +* when compiled with g77 from egcs-19990629 (gcc 2.95 prerelease) +* Get a = 0.0 when it should be 1.0 +* +* Works with: -femulate-complex +* egcs-1.1.2 +* +* Originally derived from LAPACK 3.0 test suite. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 8 July 1999 +* + complex one, z + real a, f1 + f1(z) = real(z) + one = (1.,0.) + a = f1(one) + if ( abs(a-1.0) .gt. 1.0e-5 ) then + write(6,*) 'A should be 1.0 but it is',a + call abort() + end if + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-3.f new file mode 100644 index 000000000..374c5538e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990826-3.f @@ -0,0 +1,320 @@ +c { dg-do compile } +* Date: Thu, 19 Aug 1999 10:02:32 +0200 +* From: Frederic Devernay <devernay@istar.fr> +* Organization: ISTAR +* X-Accept-Language: French, fr, en +* To: gcc-bugs@gcc.gnu.org +* Subject: g77 2.95 bug (Internal compiler error in `final_scan_insn') +* X-UIDL: 08443f5c374ffa382a05573281482f4f + +* Here's a bug that happens only when I compile with -O (disappears with +* -O2) + +* > g77 -v --save-temps -O -c pcapop.f +* g77 version 2.95 19990728 (release) (from FSF-g77 version 0.5.25 +* 19990728 (release)) +* Reading specs from +* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/specs +* gcc version 2.95 19990728 (release) +* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/f771 pcapop.f -quiet +* -dumpbase pcapop.f -O -version -fversion -o pcapop.s +* GNU F77 version 2.95 19990728 (release) (sparc-sun-solaris2.6) compiled +* by GNU C version 2.95 19990728 (release). +* GNU Fortran Front End version 0.5.25 19990728 (release) +* pcapop.f: In subroutine `pcapop': +* pcapop.f:291: Internal compiler error in `final_scan_insn', at +* final.c:2920 +* Please submit a full bug report. +* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for instructions. + +C* PCAPOP + SUBROUTINE PCAPOP(M1,M2,L1,L2,NMEM,N1,N2,IB,IBB,K3,TF,TS,TC,TTO) + DIMENSION NVA(6),C(6),I(6) +C +C CALCUL DES PARAMETRES OPTIMAUX N1 N2 IB IBB +C + TACC=.035 + TTRANS=.000004 + RAD=.000001 + RMI=.000001 + RMU=.0000015 + RDI=.000003 + RTE=.000003 + REQ=.000005 + VY1=3*RTE+RDI+8*REQ+3*(RAD+RMI+RMU) + VY2=REQ+2*RAD + AR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ)) +C VARIATION DE L1,L2, +C + TTOTOP=1.E+10 + N1CO=0 + N2CO=0 + IBCO=0 + IBBCO=0 + K3CO=0 + TESOP=0. + TCOP=0. + TFOP=0. + INUN=7 + INDE=7 + IF(M1.LT.128)INUN=6 + IF(M1.LT.64)INUN=5 + IF(M1.LT.32)INUN=4 + IF(M2.LT.128)INDE=6 + IF(M2.LT.64)INDE=5 + IF(M2.LT.32)INDE=4 + DO 3 NUN =3,INUN + DO 3 NDE=3,INDE ! { dg-warning "Obsolescent feature: Shared DO termination" } + 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 + + 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-4.9/gcc/testsuite/gfortran.dg/g77/19990905-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-0.f new file mode 100644 index 000000000..8e81d43df --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-0.f @@ -0,0 +1,12 @@ +c { dg-do compile } +* =foo0.f in Burley's g77 test suite. +! Used to give "Variable 'm' cannot appear" "Variable 'm' cannot appear" +! after REAL a(m,n), as described in PR 16511. +! + subroutine sub(a) + equivalence (m,iarray(100)) + common /info/ iarray(1000) + equivalence (n,iarray(200)) + real a(m,n) + a(1,1) = a(2,2) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-1.f new file mode 100644 index 000000000..b69d66ed2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-1.f @@ -0,0 +1,19 @@ +c { dg-do compile } +c +c g77 gave error +c 19990905-1.f: In subroutine `x': +c 19990905-1.f:15: +c common /foo/n +c 1 +c 19990905-1.f:18: (continued): +c call foo(a(1)) +c 2 +c Invalid declaration of or reference to symbol `foo' at (2) [initially seen at (1)] +* =foo7.f in Burley's g77 test suite. + subroutine x + real a(n) + common /foo/n ! { dg-error "is already being used as a COMMON" } + continue + entry y(a) + call foo(a(1)) ! { dg-error "is already being used as a COMMON" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-2.f new file mode 100644 index 000000000..e0cc07397 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/19990905-2.f @@ -0,0 +1,23 @@ +c { dg-do compile } +* =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(kind=8) (A-H,O-Z),INTEGER(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 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-4.9/gcc/testsuite/gfortran.dg/g77/20000412-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000412-1.f new file mode 100644 index 000000000..af403ef9b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000412-1.f @@ -0,0 +1,6 @@ +c { dg-do compile } + subroutine aap(k) + equivalence (i,r) + i = k + print*,r + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000503-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000503-1.f new file mode 100644 index 000000000..2a48a3533 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000503-1.f @@ -0,0 +1,25 @@ +c { dg-do run } +* +* 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-4.9/gcc/testsuite/gfortran.dg/g77/20000511-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000511-1.f new file mode 100644 index 000000000..261b6a0e2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000511-1.f @@ -0,0 +1,22 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20000511-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000511-2.f new file mode 100644 index 000000000..1ae24ae5b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000511-2.f @@ -0,0 +1,62 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20000518.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000518.f new file mode 100644 index 000000000..ac25f25ac --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000518.f @@ -0,0 +1,17 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20000601-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000601-1.f new file mode 100644 index 000000000..d0c05ec2e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000601-1.f @@ -0,0 +1,29 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20000601-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000601-2.f new file mode 100644 index 000000000..e5b9db70d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000601-2.f @@ -0,0 +1,28 @@ +c { dg-do compile } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20000629-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000629-1.f new file mode 100644 index 000000000..e369efb4d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000629-1.f @@ -0,0 +1,12 @@ +c { dg-do compile } + SUBROUTINE MIST(N, BETA) + IMPLICIT REAL(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/20000630-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000630-2.f new file mode 100644 index 000000000..4948c49e4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20000630-2.f @@ -0,0 +1,12 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c + 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-4.9/gcc/testsuite/gfortran.dg/g77/20001111.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20001111.f new file mode 100644 index 000000000..366956a66 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20001111.f @@ -0,0 +1,13 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20010115.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010115.f new file mode 100644 index 000000000..cce8dbce7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010115.f @@ -0,0 +1,10 @@ +c { dg-do compile } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/20010116.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010116.f new file mode 100644 index 000000000..ca7375d0f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010116.f @@ -0,0 +1,41 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +* +* 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-4.9/gcc/testsuite/gfortran.dg/g77/20010216-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010216-1.f new file mode 100644 index 000000000..af2c03a05 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010216-1.f @@ -0,0 +1,52 @@ +C Test for bug in reg-stack handling conditional moves. +C Reported by Tim Prince <tprince@computer.org> +C +C { dg-do run { target { { i[6789]86-*-* x86_64-*-* } && ia32 } } } +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), b(ntests), x(ntests) + data a /1, -23, -1, 1, 9, 10, -9/ + data b /1, -23, 12, -12, 10, 9, -10/ + data x /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-4.9/gcc/testsuite/gfortran.dg/g77/20010321-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010321-1.f new file mode 100644 index 000000000..df003190c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010321-1.f @@ -0,0 +1,9 @@ +c { dg-do compile } +# 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-4.9/gcc/testsuite/gfortran.dg/g77/20010426-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010426-1.f new file mode 100644 index 000000000..ce8cc4d10 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010426-1.f @@ -0,0 +1,3 @@ +c { dg-do run } + print*,cos(1.0) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010426.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010426.f new file mode 100644 index 000000000..07bc7ea41 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010426.f @@ -0,0 +1,7 @@ +c { dg-do compile } + function f(c) + implicit none + real(kind=8) c, f + f = sqrt(c) + return + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010430.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010430.f new file mode 100644 index 000000000..c6af4968d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010430.f @@ -0,0 +1,21 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20010519-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010519-1.f new file mode 100644 index 000000000..c268bf03e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010519-1.f @@ -0,0 +1,1327 @@ +c { dg-do compile } +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(KIND=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(KIND=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(KIND=8) MINONE, MINTWO, MINSIX + PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0) + REAL(KIND=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(KIND=8) ANUM,FMARK + REAL(KIND=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(KIND=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(KIND=8) PI,RADDEG,DEGRAD,TWOPI + PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI) + PARAMETER (RADDEG=180.0D0/PI) + PARAMETER (DEGRAD=PI/180.0D0) + REAL(KIND=8) COSMAX + PARAMETER (COSMAX=0.9999999999D0) + REAL(KIND=8) TIMFAC + PARAMETER (TIMFAC=4.88882129D-02) + REAL(KIND=8) KBOLTZ + PARAMETER (KBOLTZ=1.987191D-03) + REAL(KIND=8) CCELEC +C..##IF AMBER +C..##ELIF DISCOVER +C..##ELSE + PARAMETER (CCELEC=332.0716D0) +C..##ENDIF + REAL(KIND=8) CNVFRQ + PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0)) + REAL(KIND=8) SPEEDL + PARAMETER (SPEEDL=2.99793D-02) + REAL(KIND=8) ATMOSP + PARAMETER (ATMOSP=1.4584007D-05) + REAL(KIND=8) PATMOS + PARAMETER (PATMOS = 1.D0 / ATMOSP ) + REAL(KIND=8) BOHRR + PARAMETER (BOHRR = 0.529177249D0 ) + REAL(KIND=8) TOKCAL + PARAMETER (TOKCAL = 627.5095D0 ) +C..##IF MMFF + REAL(KIND=8) MDAKCAL + parameter(MDAKCAL=143.9325D0) +C..##ENDIF + REAL(KIND=8) DEBYEC + PARAMETER ( DEBYEC = 2.541766D0 / BOHRR ) + REAL(KIND=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(KIND=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(KIND=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(KIND=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(KIND=8) EPROP, ETERM, EPRESS + COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV) +C..##IF SAVEFCM +C..##ENDIF + REAL(KIND=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(KIND=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(KIND=8) TSMTRM(LENENT),TSMTMP(LENENT) + COMMON /TSMENG/ TSMTRM,TSMTMP +C...##IF SAVEFCM +C...##ENDIF +C..##ENDIF + REAL(KIND=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(KIND=8) X(*),Y(*),Z(*),AMASS(*),DDSCR(*) + REAL(KIND=8) DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*) + REAL(KIND=8) DDF(*),PARDDF(*),DDEV(*),PARDDE(*) + REAL(KIND=8) DD1BLK(*),DD1BLL(*),DD1CMP(*) + REAL(KIND=8) TOLDIM,DDVALM + REAL(KIND=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(KIND=8) CVGMX,TOLER + LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG +C Begin + QCALC=.TRUE. + LWDINI=.FALSE. + INIDS=0 + IS3=0 + IS4=0 + LPURG=.TRUE. + ITER=0 + NADD=0 + NFSAV=0 + TOLER=TENM5 + QDIAG=.TRUE. + CVGMX=HUNDRD + QMIX=.FALSE. + NATOM=NAT3/3 + NFREG6=(NFREG-6)/NPAR + NFREG2=NFREG/2 + NFRRES=(NFREG+6)/2 + IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', + 1 'NFREG IS LARGER THAN PARDIM*3') +C +C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS + ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 800 + 801 CONTINUE +C ALLOCATE-SPACE-FOR-DIAGONALIZATION + ASSIGN 721 TO I720 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 720 + 721 CONTINUE +C ALLOCATE-SPACE-FOR-REDUCED-BASIS + ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 760 + 761 CONTINUE +C ALLOCATE-SPACE-FOR-OTHER-ARRAYS + ASSIGN 921 TO I920 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 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 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 840 + 841 CONTINUE + ELSE +C ALLOCATE-DUMMY-SPACE-FOR-LSCI + ASSIGN 881 TO I880 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 880 + 881 CONTINUE + ENDIF + QMASWT=(.NOT.LNOMA) + IF(.NOT. QDISK) THEN + LENCM=INBCMP(NATOM-1)*9+NATOM*6 + DO I=1,LENCM + DD1CMP(I)=0.0 + ENDDO + OLDFAS=LFAST + QCMPCT=.TRUE. + LFAST = -1 + CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1) + LFAST=OLDFAS + QCMPCT=.FALSE. +C +C Mass weight DD1CMP matrix +C + CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM) + ELSE + CALL WRNDIE(-3,'<NMDIMB>','QDISK OPTION NOT SUPPORTED YET') +C DO I=1,LENDSK +C DD1CMP(I)=0.0 +C ENDDO +C OLDFAS=LFAST +C LFAST = -1 + ENDIF +C +C Fill DDV with six translation-rotation vectors +C + CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM) + CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1) + NTR=6 + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) + PRNLEV=OLDPRN + IF(IUNRMD .LT. 0) THEN +C +C If no previous basis is read +C + IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR + 502 FORMAT(/' NMDIMB: Calculating initial basis from block ', + 1 'diagonals'/' NMDIMB: The number of blocks is ',I5/) + NFRET = 6 + DO I=1,NPAR + IS1=ATMPAR(1,I) + IS2=ATMPAR(2,I) + NDIM=(IS2-IS1+1)*3 + NFRE=NDIM + IF(NFRE.GT.NFREG6) NFRE=NFREG6 + IF(NFREG6.EQ.0) NFRE=1 + CALL FILUPT(HEAP(IUPD),NDIM) + CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD), + 1 IS1,IS2,NATOM) + IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR', + 1 'ENR',.TRUE.,1,ZERO,ZERO) +C +C Generate the lower section of the matrix and diagonalize +C +C..##IF EISPACK +C..##ENDIF + IH1=1 + NATP=NDIM+1 + IH2=IH1+NATP + IH3=IH2+NATP + IH4=IH3+NATP + IH5=IH4+NATP + IH6=IH5+NATP + IH7=IH6+NATP + IH8=IH7+NATP + CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3), + 1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD) +C..##IF EISPACK +C..##ENDIF +C +C Put the PARDDV vectors into DDV and replace the elements which do +C not belong to the considered partitioned region by zeros. +C + CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2) + IF(LSCI) THEN + DO J=1,NFRE + PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) + IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) + ENDDO + ELSE + DO J=1,NFRE + PARDDE(J)=DDS(J) + PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) + IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) + ENDDO + ENDIF + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,512) I + WRITE(OUTU,514) + WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE) + ENDIF + NFRET=NFRET+NFRE + IF(NFRET .GE. NFREG) GOTO 10 + ENDDO + 512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed') + 514 FORMAT(' NMDIMB: Frequencies'/) + 516 FORMAT(5(I4,F12.6)) + 10 CONTINUE +C +C Orthonormalize the eigenvectors +C + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN +C +C Do reduced basis diagonalization using the DDV vectors +C and get eigenvectors of zero iteration +C + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,521) ITER + WRITE(OUTU,523) NFRET + ENDIF + 521 FORMAT(/' NMDIMB: Iteration number = ',I5) + 523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5) + IF(LBIG) THEN + IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD + 525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5) + REWIND (UNIT=IUNMOD) + LCARD=.FALSE. + CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS) + CALL SAVEIT(IUNMOD) + ELSE + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1) + ENDIF + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4, + 3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) +C +C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS +C + ASSIGN 621 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 620 + 621 CONTINUE +C SAVE-MODES + ASSIGN 701 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 700 + 701 CONTINUE + IF(ITER.EQ.ITMX) THEN + CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, + 1 DDVAL,JSPACE,TRAROT, + 2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6, + 3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF, + 4 ATMCOR,SUBLIS,LSCI,QDW,LBIG) + RETURN + ENDIF + ELSE +C +C Read in existing basis +C + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,531) + 531 FORMAT(/' NMDIMB: Calculations restarted') + ENDIF +C READ-MODES + ISTRT=1 + ISTOP=99999999 + LCARD=.FALSE. + LAPPE=.FALSE. + CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM, + 1 DDV,DDSCR,DDF,DDEV, + 2 IUNRMD,LAPPE,ISTRT,ISTOP) + NFRET=NDIM + IF(NFRET.GT.NFREG) THEN + NFRET=NFREG + CALL WRNDIE(-1,'<NMDIMB>', + 1 'Not enough space to hold the basis. Increase NMODes') + ENDIF +C PRINT-MODES + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,533) NFRET,IUNRMD + WRITE(OUTU,514) + WRITE(OUTU,516) (J,DDF(J),J=1,NFRET) + ENDIF + 533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5) + NFRRES=NFRET + ENDIF +C +C ------------------------------------------------- +C Here starts the mixed-basis diagonalization part. +C ------------------------------------------------- +C +C +C Check cut-off frequency +C + CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) +C TEST-NFCUT1 + IF(IUNRMD.LT.0) THEN + IF(NFCUT1*2-6.GT.NFREG) THEN + IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES) + NFCUT1=NFRRES + CUTF1=DDF(NFRRES) + ENDIF + ELSE + CUTF1=DDF(NFRRES) + ENDIF + 537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency' + 1 /' Cutoff frequency is decreased to',F9.3) +C +C Compute the new partioning of the molecule +C + CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES, + 1 PARDIM) + NPARS=NPARC + DO I=1,NPARC + ATMPAS(1,I)=ATMPAR(1,I) + ATMPAS(2,I)=ATMPAR(2,I) + ENDDO + IF(QDW) THEN + IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE. + IF(IPAR1.GE.IPAR2) LWDINI=.TRUE. + IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE. + IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE. + IF(ITER.EQ.0) LWDINI=.TRUE. + ENDIF + ITMX=ITMX+ITER + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,543) ITER,ITMX + IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2 + ENDIF + 543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/ + 1 ' NMDIMB: Iteration number to reach = ',I8) + 545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5) +C + IF(SAVF.LE.0) SAVF=NPARC + IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF + 547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5, + 1 ' iterations') +C +C If double windowing is defined, the original block sizes are divided +C in two. +C + IF(QDW) THEN + NSUBP=1 + CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX) + ATMPAF=ALLHP(INTEG4(NPARD*NPARD)) + ATMCOR=ALLHP(INTEG4(NATOM)) + DDVAL=ALLHP(IREAL8(NPARD*NPARD)) + CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM) + CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD, + 2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM) + SUBLIS=ALLHP(INTEG4(NSUBP*2)) + CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP) + CALL INIPAF(HEAP(ATMPAF),NPARD) +C +C Find out with which block to continue (double window method only) +C + IPA1=IPAR1 + IPA2=IPAR2 + IRESF=0 + IF(LWDINI) THEN + ITER=0 + LWDINI=.FALSE. + GOTO 500 + ENDIF + DO II=1,NSUBP + CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF), + 1 NPARD,QCALC) + IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500 + ENDDO + ENDIF + 500 CONTINUE +C +C Main loop. +C + DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX)) + IF(.NOT.QDW) THEN + ITER=ITER+1 + IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER + 553 FORMAT(/' NMDIMB: Iteration number = ',I8) + IF(INIDS.EQ.0) THEN + INIDS=1 + ELSE + INIDS=0 + ENDIF + CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX, + 1 DDF,NFREG,CUTF1,PARDIM,NFCUT1) +C DO-THE-DIAGONALISATIONS + ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 640 + 641 CONTINUE + QDIAG=.FALSE. +C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS + ASSIGN 622 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 620 + 622 CONTINUE + QDIAG=.TRUE. +C SAVE-MODES + ASSIGN 702 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 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 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 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 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 620 + 623 CONTINUE + QDIAG=.TRUE. + IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600 +C SAVE-MODES + ASSIGN 703 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 700 + 703 CONTINUE + ENDIF + ENDDO + ENDIF + ENDDO + 600 CONTINUE +C +C SAVE-MODES + ASSIGN 704 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +C +C----------------------------------------------------------------------- +C TO DO-THE-DIAGONALISATIONS + 640 CONTINUE + DO I=1,NPARC + NFCUT1=NFRRES + IS1=ATMPAR(1,I) + IS2=ATMPAR(2,I) + NDIM=(IS2-IS1+1)*3 + IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2 + 573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/ + 1 ' NMDIMB: Block limits: ',I5,2X,I5) + IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', + 1 'Error in dimension of block') + NFRET=NFCUT1 + IF(NFRET.GT.NFREG) NFRET=NFREG + CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) + NFCUT1=NFCUT + CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2) + NFSAV=NFCUT1 + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) + NFRET=NDIM+NFCUT + QMIX=.TRUE. + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, + 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) + QMIX=.FALSE. + IF(NFCUT.GT.NFRRES) NFCUT=NFRRES + NFCUT1=NFCUT + NFRET=NFCUT + ENDDO + GOTO I640 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +C +C----------------------------------------------------------------------- +C TO DO-THE-DWIN-DIAGONALISATIONS + 660 CONTINUE +C +C Store the DDV vectors into DDVBAS +C + NFCUT1=NFRRES + IS1=ATMPAD(1,IPAR1) + IS2=ATMPAD(2,IPAR1) + IS3=ATMPAD(1,IPAR2) + IS4=ATMPAD(2,IPAR2) + NDIM=(IS2-IS1+IS4-IS3+2)*3 + IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4 + 577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ', + 1 2I5/ + 2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5) + IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', + 1 'Error in dimension of block') + NFRET=NFCUT1 + IF(NFRET.GT.NFREG) NFRET=NFREG +C +C Prepare the DDV vectors consisting of 6 translations-rotations +C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors +C spanning the atoms from IS1 to IS2 +C + CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) + NFCUT1=NFCUT + NFSAV=NFCUT1 + CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4) + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) +C + NFRET=NDIM+NFCUT + QMIX=.TRUE. + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, + 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) + QMIX=.FALSE. +C + IF(NFCUT.GT.NFRRES) NFCUT=NFRRES + NFCUT1=NFCUT + NFRET=NFCUT + GOTO I660 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS + 800 CONTINUE + TRAROT=ALLHP(IREAL8(6*NAT3)) + GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +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 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS + 920 CONTINUE + IUPD=ALLHP(INTEG4(PARDIM+3)) + GOTO I920 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } +C.##ELSE +C.##ENDIF + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010610.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010610.f new file mode 100644 index 000000000..5adbcd672 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20010610.f @@ -0,0 +1,5 @@ +c { dg-do run } + DO I = 0, 255 + IF (ICHAR(CHAR(I)) .NE. I) CALL ABORT + ENDDO + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20020307-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20020307-1.f new file mode 100644 index 000000000..73585434c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20020307-1.f @@ -0,0 +1,22 @@ +c { dg-do compile } + SUBROUTINE SWEEP + PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20) + REAL(KIND=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 ! { dg-warning "Obsolescent feature: Shared DO termination" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/20030326-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20030326-1.f new file mode 100644 index 000000000..6efc5d9a6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/20030326-1.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options -pedantic } +! PR fortran/9793 +! larson@w6yx.stanford.edu +! +! For gfortran, see PR 13490 +! + integer c + c = -2147483648_4 / (-1) ! { dg-error "too big for its kind" "" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/6177.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/6177.f new file mode 100644 index 000000000..d708652a6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/6177.f @@ -0,0 +1,15 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/7388.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/7388.f new file mode 100644 index 000000000..0b8374646 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/7388.f @@ -0,0 +1,12 @@ +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-4.9/gcc/testsuite/gfortran.dg/g77/8485.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/8485.f new file mode 100644 index 000000000..ae5f03451 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/8485.f @@ -0,0 +1,9 @@ +c { dg-do compile } +C Extracted from PR fortran/8485 + PARAMETER (PPMULT = 1.0E5) + INTEGER(kind=8) NWRONG + PARAMETER (NWRONG = 8) + PARAMETER (DDMULT = PPMULT * NWRONG) + PRINT 10, DDMULT +10 FORMAT (F10.3) + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/9263.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/9263.f new file mode 100644 index 000000000..77ce98575 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/9263.f @@ -0,0 +1,11 @@ +C { dg-do compile } + PARAMETER (Q=1) + PARAMETER (P=10) + INTEGER C(10),D(10),E(10),F(10) +C TERMINAL NOT INTEGER + DATA (C(I),I=1,P) /10*10/ ! { dg-error "End expression in DO loop" "" } +C START NOT INTEGER + DATA (D(I),I=Q,10) /10*10/ ! { dg-error "Start expression in DO loop" "" } +C INCREMENT NOT INTEGER + DATA (E(I),I=1,10,Q) /10*10/ ! { dg-error "Step expression in DO loop" "" } + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/947.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/947.f new file mode 100644 index 000000000..247c1a09e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/947.f @@ -0,0 +1,13 @@ +c { dg-do run } + DIMENSION A(-5:5) + INTEGER(kind=1) IM5, IZ, IP5 + INTEGER(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/960317-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/960317-1.f new file mode 100644 index 000000000..c8b3b69ba --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/960317-1.f @@ -0,0 +1,104 @@ +c { dg-do compile } +* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST) +* From: Kate Hedstrom <kate@ahab.Rutgers.EDU> +* To: burley@gnu.ai.mit.edu +* Subject: g77 bug in assign +* +* I found some files in the NCAR graphics source code which used to +* compile with g77 and now don't. All contain the following combination +* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a +* Sun running SunOS 5.5 (slightly older g77), but compiles on an +* IBM/RS6000: +* +C + SUBROUTINE QUICK + SAVE +C + ASSIGN 101 TO JUMP ! { dg-warning "Deleted feature: ASSIGN" "" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/970125-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970125-0.f new file mode 100644 index 000000000..656c4750a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970125-0.f @@ -0,0 +1,45 @@ +c { dg-do compile } +c +c Following line added on transfer to gfortran testsuite +c { dg-excess-errors "" } +c +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 i4 + integer(kind=8) i8 + integer(kind=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(kind=8) i8 + print *, i4, i4a + print *, i8, i8a + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970625-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970625-2.f new file mode 100644 index 000000000..7f8a46448 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970625-2.f @@ -0,0 +1,84 @@ +* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST) +* MIME-Version: 1.0 +* From: R.Hooft@EuroMail.com (Rob Hooft) +* To: g77-alpha@gnu.ai.mit.edu +* Subject: Re: testing 970624. +* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu> +* References: <199706251018.MAA21538@nu> +* <199706251027.GAA07892@churchy.gnu.ai.mit.edu> +* X-Mailer: VM 6.30 under Emacs 19.34.1 +* Content-Type: text/plain; charset=US-ASCII +* +* >>>>> "CB" == Craig Burley <burley@gnu.ai.mit.edu> writes: +* +* CB> but OTOH I'd like to see more problems like this on other +* CB> applications, and especially other systems +* +* How about this one: An application that prints "112." on all +* compilers/platforms I have tested, except with the new g77 on ALPHA (I +* don't have the new g77 on any other platform here to test)? +* +* Application Appended. Source code courtesy of my boss..... +* Disclaimer: I do not know the right answer, or even whether there is a +* single right answer..... +* +* Regards, +* -- +* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ == +* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/ +* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ==== +* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! ============= +* +* nu[152]for% cat humor.f + PROGRAM SUBROUTINE + LOGICAL ELSE IF + INTEGER REAL, GO TO PROGRAM, WHILE, THEN, END DO + 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) ! { dg-error "Type mismatch in argument" } + 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 ! { dg-warning "ASSIGN" "" } + ASSIGN = 9 + LOGICAL + ASSIGN 7 TO RETURN ! { dg-warning "ASSIGN" "" } + ASSIGN 9 TO GO TO ! { dg-warning "ASSIGN" "" } + GO TO = 5 + STOP = 8 + IF (.NOT.REAL) GOTO STOP ! { dg-warning "Assigned GOTO" "" } + IF (LOGICAL.GT.INTEGER) THEN + IF = LOGICAL +5 + IF (LOGICAL.EQ.5) ASSIGN 5 TO IF ! { dg-warning "ASSIGN" "" } + INTEGER=IF + ELSE + IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO ! { dg-warning "ASSIGN" "" } + ELSE = GO TO + END IF = ELSE + GO TO + IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN ! { dg-warning "Assigned GOTO" "" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/970816-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970816-3.f new file mode 100644 index 000000000..690438646 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970816-3.f @@ -0,0 +1,21 @@ +c { dg-do run } +* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) +* From: Claus Denk <denk@cica.es> +* To: g77-alpha@gnu.ai.mit.edu +* Subject: 970811 report - segfault bug on alpha still there +*[...] +* Now, the bug that I reported some weeks ago is still there, I'll post +* the test program again: +* + PROGRAM TEST +C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with +C NSTART=1 on the second write. + PARAMETER (NSTART=1,NADD=NSTART+1) + REAL AB(NSTART:NSTART) + AB(NSTART)=1.0 + I=1 + J=2 + IND=I-J+NADD + write(*,*) AB(IND) + write(*,*) AB(I-J+NADD) + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970915-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970915-0.f new file mode 100644 index 000000000..228248e2a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/970915-0.f @@ -0,0 +1,21 @@ +c { dg-do compile } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/971102-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/971102-1.f new file mode 100644 index 000000000..6181a1771 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/971102-1.f @@ -0,0 +1,12 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/980310-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-1.f new file mode 100644 index 000000000..303013337 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-1.f @@ -0,0 +1,29 @@ +c { dg-do compile } +C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4 +C To: egcs-bugs@cygnus.com +C Subject: backend case range problem/fix +C From: Dave Love <d.love@dl.ac.uk> +C Date: 02 Dec 1997 18:11:35 +0000 +C Message-ID: <rzqpvnfboo8.fsf@djlvig.dl.ac.uk> +C +C The following Fortran test case aborts the compiler because +C tree_int_cst_lt dereferences a null tree; this is a regression from +C gcc 2.7. + + INTEGER N + READ(*,*) N + SELECT CASE (N) + CASE (1:) + WRITE(*,*) 'case 1' + CASE (0) + WRITE(*,*) 'case 0' + END SELECT + END + +C The relevant change to cure this is: +C +C Thu Dec 4 06:34:40 1997 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> +C +C * stmt.c (pushcase_range): Clean up handling of "infinite" values. +C + diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-2.f new file mode 100644 index 000000000..1ed5efc59 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-2.f @@ -0,0 +1,44 @@ +c { dg-do compile } +C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl +C +C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT) +C From: David Bristow <dbristow@lynx.dac.neu.edu> +C To: egcs-bugs@cygnus.com +C Subject: g77 crashes compiling Dungeon +C Message-ID: <Pine.OSF.3.91.970823003521.11281A-100000@lynx.dac.neu.edu> +C +C The following small segment of Dungeon (the adventure that became the +C commercial hit Zork) causes an internal error in f771. The platform is +C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran +C 0.5.21-19970811) +C +C --cut here--cut here--cut here--cut here--cut here--cut here-- +C g77 --verbose -fugly -fvxt -c subr_.f +C g77 version 0.5.21-19970811 +C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm +C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs +C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental) +C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s +C f771: warning: -fugly is overloaded with meanings and likely to be removed; +C f771: warning: use only the specific -fugly-* options you need +C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental). +C GNU Fortran Front End version 0.5.21-19970811 +C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))' +C gcc: Internal compiler error: program f771 got fatal signal 6 +C --cut here--cut here--cut here--cut here--cut here--cut here-- +C +C Here's the FORTRAN code, it's basically a single subroutine from subr.f +C in the Dungeon source, slightly altered (the original calls RAN(), which +C doesn't exist in the g77 runtime) +C +C RND - Return a random integer mod n +C + INTEGER FUNCTION RND (N) + IMPLICIT INTEGER (A-Z) + REAL RAND + COMMON /SEED/ RNSEED + + RND = RAND(RNSEED)*FLOAT(N) + RETURN + + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-3.f new file mode 100644 index 000000000..098e22c68 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-3.f @@ -0,0 +1,260 @@ +c { dg-do compile } +c +c This demonstrates a problem with g77 and pic on x86 where +c egcs 1.0.1 and earlier will generate bogus assembler output. +c unfortunately, gas accepts the bogus acssembler output and +c generates code that almost works. +c + + +C Date: Wed, 17 Dec 1997 23:20:29 +0000 +C From: Joao Cardoso <jcardoso@inescn.pt> +C To: egcs-bugs@cygnus.com +C Subject: egcs-1.0 f77 bug on OSR5 +C When trying to compile the Fortran file that I enclose bellow, +C I got an assembler error: +C +C ./g77 -B./ -fpic -O -c scaleg.f +C /usr/tmp/cca002D8.s:123:syntax error at ( +C +C ./g77 -B./ -fpic -O0 -c scaleg.f +C /usr/tmp/cca002EW.s:246:invalid operand combination: leal +C +C Compiling without the -fpic flag runs OK. + + subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk) +c +c *****parameters: + integer igh,low,ma,mb,n + double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6) +c +c *****local variables: + integer i,ir,it,j,jc,kount,nr,nrp2 + double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor, + * ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc +c +c *****fortran functions: + double precision dabs, dlog10, dsign +c float +c +c *****subroutines called: +c none +c +c --------------------------------------------------------------- +c +c *****purpose: +c scales the matrices a and b in the generalized eigenvalue +c problem a*x = (lambda)*b*x such that the magnitudes of the +c elements of the submatrices of a and b (as specified by low +c and igh) are close to unity in the least squares sense. +c ref.: ward, r. c., balancing the generalized eigenvalue +c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981, +c 141-152. +c +c *****parameter description: +c +c on input: +c +c ma,mb integer +c row dimensions of the arrays containing matrices +c a and b respectively, as declared in the main calling +c program dimension statement; +c +c n integer +c order of the matrices a and b; +c +c a real(ma,n) +c contains the a matrix of the generalized eigenproblem +c defined above; +c +c b real(mb,n) +c contains the b matrix of the generalized eigenproblem +c defined above; +c +c low integer +c specifies the beginning -1 for the rows and +c columns of a and b to be scaled; +c +c igh integer +c specifies the ending -1 for the rows and columns +c of a and b to be scaled; +c +c cperm real(n) +c work array. only locations low through igh are +c referenced and altered by this subroutine; +c +c wk real(n,6) +c work array that must contain at least 6*n locations. +c only locations low through igh, n+low through n+igh, +c ..., 5*n+low through 5*n+igh are referenced and +c altered by this subroutine. +c +c on output: +c +c a,b contain the scaled a and b matrices; +c +c cscale real(n) +c contains in its low through igh locations the integer +c exponents of 2 used for the column scaling factors. +c the other locations are not referenced; +c +c wk contains in its low through igh locations the integer +c exponents of 2 used for the row scaling factors. +c +c *****algorithm notes: +c none. +c +c *****history: +c written by r. c. ward....... +c modified 8/86 by bobby bodenheimer so that if +c sum = 0 (corresponding to the case where the matrix +c doesn't need to be scaled) the routine returns. +c +c --------------------------------------------------------------- +c + if (low .eq. igh) go to 410 + do 210 i = low,igh + wk(i,1) = 0.0d0 + wk(i,2) = 0.0d0 + wk(i,3) = 0.0d0 + wk(i,4) = 0.0d0 + wk(i,5) = 0.0d0 + wk(i,6) = 0.0d0 + cscale(i) = 0.0d0 + cperm(i) = 0.0d0 + 210 continue +c +c compute right side vector in resulting linear equations +c + basl = dlog10(2.0d0) + do 240 i = low,igh + do 240 j = low,igh ! { dg-warning "Obsolescent feature: Shared DO termination" } + 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 ! { dg-warning "Obsolescent feature: Shared DO termination" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/980310-4.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-4.f new file mode 100644 index 000000000..ee50bc6b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-4.f @@ -0,0 +1,348 @@ +c { dg-do compile } +C To: egcs-bugs@cygnus.com +C Subject: -fPIC problem showing up with fortran on x86 +C From: Dave Love <d.love@dl.ac.uk> +C Date: 19 Dec 1997 19:31:41 +0000 +C +C +C This illustrates a long-standing problem noted at the end of the g77 +C `Actual Bugs' info node and thought to be in the back end. Although +C the report is against gcc 2.7 I can reproduce it (specifically on +C redhat 4.2) with the 971216 egcs snapshot. +C +C g77 version 0.5.21 +C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone +C -lf2c -lm +C + +C ------------ + subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr, + * neval,ier,alist,blist,rlist,elist,iord,last) +C -------------------------------------------------- +C +C Modified Feb 1989 by Barry W. Brown to eliminate key +C as argument (use key=1) and to eliminate all Fortran +C output. +C +C Purpose: to make this routine usable from within S. +C +C -------------------------------------------------- +c***begin prologue dqage +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c integrand examinator, globally adaptive, +c gauss-kronrod +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-reslt).le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c key - integer +c key for choice of local integration rule +c a gauss-kronrod pair is used with +c 7 - 15 points if key.lt.2, +c 10 - 21 points if key = 2, +c 15 - 31 points if key = 3, +c 20 - 41 points if key = 4, +c 25 - 51 points if key = 5, +c 30 - 61 points if key.gt.5. +c +c limit - integer +c gives an upperbound on the number of subintervals +c in the partition of (a,b), limit.ge.1. +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for result and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value +c of limit. +c however, if this yields no improvement it +c is rather advised to analyze the integrand +c in order to determine the integration +c difficulties. if the position of a local +c difficulty can be determined(e.g. +c singularity, discontinuity within the +c interval) one will probably gain from +c splitting up the interval at this point +c and calling the integrator on the +c subranges. if possible, an appropriate +c special-purpose integrator should be used +c which is designed for handling the type of +c difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c = 3 extremely bad integrand behavior occurs +c at some points of the integration +c interval. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c result, abserr, neval, last, rlist(1) , +c elist(1) and iord(1) are set to zero. +c alist(1) and blist(1) are set to a and b +c respectively. +c +c alist - double precision +c vector of dimension at least limit, the first +c last elements of which are the left +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c blist - double precision +c vector of dimension at least limit, the first +c last elements of which are the right +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c rlist - double precision +c vector of dimension at least limit, the first +c last elements of which are the +c integral approximations on the subintervals +c +c elist - double precision +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension at least limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., +c elist(iord(k)) form a decreasing sequence, +c with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c last - integer +c number of subintervals actually produced in the +c subdivision process +c +c***references (none) +c***routines called d1mach,dqk15,dqk21,dqk31, +c dqk41,dqk51,dqk61,dqpsrt +c***end prologue dqage +c + double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b, + * blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach, + * epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, + * resabs,result,rlist,uflow + integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval, + * nrmax +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * rlist(limit) +c + external f +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest +c error estimate +c errmax - elist(maxerr) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqage + epmach = d1mach(4) + uflow = d1mach(1) +c +c test on validity of parameters +c ------------------------------ +c + ier = 0 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0d+00 + elist(1) = 0.0d+00 + iord(1) = 0 + if(epsabs.le.0.0d+00.and. + * epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6 + if(ier.eq.6) go to 999 +c +c first approximation to the integral +c ----------------------------------- +c + neval = 0 + call dqk15(f,a,b,result,abserr,defabs,resabs) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 +c +c test on accuracy. +c + errbnd = dmax1(epsabs,epsrel*dabs(result)) + if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs) + * .or.abserr.eq.0.0d+00) go to 60 +c +c initialization +c -------------- +c +c + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 +c +c main do-loop +c ------------ +c + do 30 last = 2,limit +c +c bisect the subinterval with the largest error estimate. +c + a1 = alist(maxerr) + b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + call dqk15(f,a1,b1,area1,error1,resabs,defab1) + call dqk15(f,a2,b2,area2,error2,resabs,defab2) +c +c improve previous approximations to integral +c and error and test for accuracy. +c + neval = neval+1 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 5 + if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) + * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 + 5 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) + if(errsum.le.errbnd) go to 8 +c +c test for roundoff error and eventually set error flag. +c + if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 +c +c set error flag in the case that the number of subintervals +c equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behavior +c at a point of the integration range. +c + if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03* + * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3 +c +c append the newly-created intervals to the list. +c + 8 if(error2.gt.error1) go to 10 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 20 + 10 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine dqpsrt to maintain the descending ordering +c in the list of error estimates and select the subinterval +c with the largest error estimate (to be bisected next). +c + 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +c ***jump out of do-loop + if(ier.ne.0.or.errsum.le.errbnd) go to 40 + 30 continue +c +c compute final result. +c --------------------- +c + 40 result = 0.0d+00 + do 50 k=1,last + result = result+rlist(k) + 50 continue + abserr = errsum + 60 neval = 30*neval+15 + 999 return + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-6.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-6.f new file mode 100644 index 000000000..b4b2f1d1e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-6.f @@ -0,0 +1,22 @@ +c { dg-do compile } +C From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de> +C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de> +C Subject: 971105 g77 bug +C To: egcs-bugs@cygnus.com +C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET) + +C I found a bug in g77 in snapshot 971105 + + subroutine ai (a) + dimension a(-1:*) + return + end +C ai.f: In subroutine `ai': +C ai.f:1: +C subroutine ai (a) +C ^ +C Array `a' at (^) is too large to handle +C +C This happens whenever the lower index boundary is negative and the upper index +C boundary is '*'. + diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-7.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-7.f new file mode 100644 index 000000000..3cbcbe9ca --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-7.f @@ -0,0 +1,51 @@ +c { dg-do compile } +C From: "David C. Doherty" <doherty@networkcs.com> +C Message-Id: <199711171846.MAA27947@uh.msc.edu> +C Subject: g77: auto arrays + goto = no go +C To: egcs-bugs@cygnus.com +C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST) + +C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love +C replied that he was able to reproduce it on rs6000-aix; not on +C others. He suggested that I send it to egcs-bugs. + +C Hi - I've observed the following behavior regarding +C automatic arrays and gotos. Seems similar to what I found +C in the docs about computed gotos (but not exactly the same). +C +C I suspect from the nature of the error msg that it's in the GBE. +C +C I'm using egcs-971105, under linux-ppc. +C +C I also observed the same in g77-0.5.19 (and gcc 2.7.2?). +C +C I'd appreciate any advice on this. thanks for the great work. +C -- +C >cat testg77.f + subroutine testg77(n, a) +c + implicit none +c + integer n + real a(n) + real b(n) + integer i +c + do i = 1, 10 + if (i .gt. 4) goto 100 + write(0, '(i2)')i + enddo +c + goto 200 +100 continue +200 continue +c + return + end +C >g77 -c testg77.f +C testg77.f: In subroutine `testg77': +C testg77.f:19: label `200' used before containing binding contour +C testg77.f:18: label `100' used before containing binding contour +C -- +C If I comment out the b(n) line or replace it with, e.g., b(10), +C it compiles fine. diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-8.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-8.f new file mode 100644 index 000000000..c20f2d720 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980310-8.f @@ -0,0 +1,41 @@ +c { dg-do compile } +C To: egcs-bugs@cygnus.com +C Subject: egcs-g77 and array indexing +C Reply-To: etseidl@jutland.ca.sandia.gov +C Date: Wed, 26 Nov 1997 10:38:27 -0800 +C From: Edward Seidl <etseidl@jutland.ca.sandia.gov> +C +C I have some horrible spaghetti code I'm trying compile with egcs-g77, +C but it's puking on code like the example below. I have no idea if it's +C legal fortran or not, and I'm in no position to change it. All I do know +C is it compiles with a number of other compilers, including f2c and +C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122 +C I get the following (on both i686-pc-linux-gnu and +C alphaev56-unknown-linux-gnu): +C +Cfoo.f: In subroutine `foobar': +Cfoo.f:11: +C subroutine foobar(norb,nnorb) +C ^ +CArray `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-4.9/gcc/testsuite/gfortran.dg/g77/980419-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980419-2.f new file mode 100644 index 000000000..bb02862e3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980419-2.f @@ -0,0 +1,51 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +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-4.9/gcc/testsuite/gfortran.dg/g77/980424-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980424-0.f new file mode 100644 index 000000000..dd6e7a858 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980424-0.f @@ -0,0 +1,7 @@ +c { dg-do compile } +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-4.9/gcc/testsuite/gfortran.dg/g77/980427-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980427-0.f new file mode 100644 index 000000000..c5c3ade00 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980427-0.f @@ -0,0 +1,9 @@ +c { dg-do compile } +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-4.9/gcc/testsuite/gfortran.dg/g77/980519-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980519-2.f new file mode 100644 index 000000000..3134a00b5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980519-2.f @@ -0,0 +1,51 @@ +c { dg-do compile } +* Date: Fri, 17 Apr 1998 14:12:51 +0200 +* From: Jean-Paul Jeannot <jeannot@gx-tech.fr> +* Organization: GX Technology France +* To: egcs-bugs@cygnus.com +* Subject: identified bug in g77 on Alpha +* +* Dear Sir, +* +* You will find below the assembly code of a simple Fortran routine which +* crashes with segmentation fault when storing the first element +* in( jT_f-hd_T ) = Xsp +* whereas everything is fine when commenting this line. +* +* The assembly code (generated with +* -ffast-math -fexpensive-optimizations -fomit-frame-pointer -fno-inline +* or with -O5) +* uses a zapnot instruction to copy an address. +* BUT the zapnot parameter is 15 (copuing 4 bytes) instead of 255 (to copy +* 8 bytes). +* +* I guess this is typically a 64 bit issue. As, from my understanding, +* zapnots are used a lot to copy registers, this may create problems +* elsewhere. +* +* Thanks for your help +* +* Jean-Paul Jeannot +* + subroutine simul_trace( in, Xsp, Ysp, Xrcv, Yrcv ) + +c Next declaration added on transfer to gfortran testsuite + integer hd_S, hd_Z, hd_T + + 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-4.9/gcc/testsuite/gfortran.dg/g77/980520-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980520-1.f new file mode 100644 index 000000000..855b9a442 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980520-1.f @@ -0,0 +1,9 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +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-4.9/gcc/testsuite/gfortran.dg/g77/980615-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980615-0.f new file mode 100644 index 000000000..5107f4f79 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980615-0.f @@ -0,0 +1,12 @@ +c { dg-do compile } +* Fixed by JCB 1998-07-25 change to stc.c. + +* Date: Thu, 11 Jun 1998 22:35:20 -0500 +* From: Ian A Watson <WATSON_IAN_A@lilly.com> +* Subject: crash +* + CaLL foo(W) + END + SUBROUTINE foo(W) + yy(I)=A(I)Q(X) ! { dg-error "Unclassifiable statement" "" } +c { dg-error "end of file" "end of file" { target *-*-* } 0 } diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980616-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980616-0.f new file mode 100644 index 000000000..069b611eb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980616-0.f @@ -0,0 +1,10 @@ +c { dg-do compile } +* Fixed by 1998-07-11 equiv.c change. +* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER' + +* Date: Mon, 15 Jun 1998 21:54:32 -0500 +* From: Ian A Watson <WATSON_IAN_A@lilly.com> +* Subject: Mangler Crash + EQUIVALENCE(I,glerf(P)) ! { dg-error "is a variable" "is a variable" } + COMMON /foo/ glerf(3) +c { dg-error "end of file" "end of file" { target *-*-* } 0 } diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-0.f new file mode 100644 index 000000000..9943e3c21 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-0.f @@ -0,0 +1,62 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-1.f new file mode 100644 index 000000000..7524a3f8a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-1.f @@ -0,0 +1,63 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-10.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-10.f new file mode 100644 index 000000000..b7429e4c9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-10.f @@ -0,0 +1,59 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-2.f new file mode 100644 index 000000000..89a9e2354 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-2.f @@ -0,0 +1,57 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-3.f new file mode 100644 index 000000000..dea368d02 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-3.f @@ -0,0 +1,59 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +c +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-7.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-7.f new file mode 100644 index 000000000..22ef08a47 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-7.f @@ -0,0 +1,63 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-8.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-8.f new file mode 100644 index 000000000..3b4a4a3fc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-8.f @@ -0,0 +1,64 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980628-9.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-9.f new file mode 100644 index 000000000..7e2f2279f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980628-9.f @@ -0,0 +1,58 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980701-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980701-0.f new file mode 100644 index 000000000..2820d2e1d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980701-0.f @@ -0,0 +1,73 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980701-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980701-1.f new file mode 100644 index 000000000..0f07de3f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980701-1.f @@ -0,0 +1,73 @@ +c { dg-do run } +* 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-4.9/gcc/testsuite/gfortran.dg/g77/980729-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980729-0.f new file mode 100644 index 000000000..f0ca9da66 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/980729-0.f @@ -0,0 +1,6 @@ +c { dg-do compile } +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-4.9/gcc/testsuite/gfortran.dg/g77/981117-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/981117-1.f new file mode 100644 index 000000000..705a5da40 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/981117-1.f @@ -0,0 +1,24 @@ +c { dg-do compile } +* egcs-bugs: +* From: Martin Kahlert <martin.kahlert@mchp.siemens.de> +* Subject: ICE in g77 from egcs-19981109 +* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de> + +* As of 1998-11-17, fails -O2 -fomit-frame-pointer with +* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints: +* (insn 31 83 32 (set (reg:SF 8 %st(0)) +* (mult:SF (reg:SF 8 %st(0)) +* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil) +* (nil)) +* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn + +* Fixed sometime before 1998-11-21 -- don't know by which change. + + SUBROUTINE SSPTRD + PARAMETER (HALF = 0.5 ) + DO I = 1, N + CALL SSPMV(TAUI) + ALPHA = -HALF*TAUI + CALL SAXPY(ALPHA) + ENDDO + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/990115-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/990115-1.f new file mode 100644 index 000000000..b38d55adf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/990115-1.f @@ -0,0 +1,12 @@ +c { dg-do compile } +C Derived from lapack + SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, RWORK, INFO ) + COMPLEX(kind=8) WORK( * ) +c Following declaration added on transfer to gfortran testsuite. +c It is present in original lapack source + integer rank + DO 20 I = 1, RANK + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/README b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/README new file mode 100644 index 000000000..f0c34c0fe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/README @@ -0,0 +1,208 @@ +The g77 testsuite is being transferred to the gfortran testsuite. +This file documents the status of each test case. + + Y Test has been transferred. + Y XFAIL This test has been transferred but fails + N This feature will not be supported by gfortran. + F This test fails with gfortran. Not transferred (yet). + ? We looked at this case, but haven't decided. + +Directory g77.dg + +12632.f Y +20010216-1.f Y +7388.f Y +f77-edit-apostrophe-out.f Y +f77-edit-colon-out.f Y +f77-edit-h-out.f Y +f77-edit-i-in.f Y +f77-edit-i-out.f Y +f77-edit-s-out.f Y XFAIL PR 16434 +f77-edit-slash-out.f Y +f77-edit-t-in.f Y XFAIL PR 16436 +f77-edit-t-out.f Y +f77-edit-x-out.f Y XFAIL PR 16435 +fbackslash.f ? +fcase-preserve.f ? +ff90-1.f ? +ffixed-form-1.f Y +ffixed-form-2.f Y +ffixed-line-length-0.f Y +ffixed-line-length-132.f Y +ffixed-line-length-7.f F PR 16465 +ffixed-line-length-72.f Y +ffixed-line-length-none.f Y +ffree-form-1.f Y +ffree-form-2.f Y +ffree-form-3.f Y +fno-backslash.f ? +fno-f90-1.f ? +fno-fixed-form-1.f ? +fno-onetrip.f ? +fno-typeless-boz.f ? +fno-underscoring.f Y +fno-vxt-1.f ? +fonetrip.f ? +ftypeless-boz.f ? +fugly-assumed.f ? +funderscoring.f Y +fvxt-1.f ? +pr3743-1.f ? +pr3743-2.f ? +pr3743-3.f ? +pr3743-4.f ? +pr5473.f ? +pr9258.f Y +strlen0.f Y + + +Directory g77.dg/bprob +g77-bprob-1.f + + +Directory g77.dg/gcov +gcov-1.f + +Directory g77.f-torture/compile +12002.f Y +13060.f Y +19990218-0.f Y +19990305-0.f Y +19990419-0.f Y +19990502-0.f Y +19990502-1.f Y +19990525-0.f Y +19990826-1.f Y +19990826-3.f Y +19990905-0.f Y XFAIL PR 16511 +19990905-2.f Y +20000412-1.f Y +20000511-1.f Y +20000511-2.f Y +20000518.f Y +20000601-1.f Y +20000601-2.f Y +20000629-1.f Y +20000630-2.f Y +20010115.f Y +20010321-1.f Y +20010426.f Y +20010519-1.f Y Add dg-warnings for ASSIGN +20020307-1.f Y +20030115-1.f Y Add dg-warnings for ASSIGN +20030326-1.f Y +8485.f Y +960317-1.f Y +970125-0.f Y Add dg-excess-errors. Investigate.later. +970915-0.f Y +980310-1.f Y +980310-2.f Y +980310-3.f Y +980310-4.f Y +980310-6.f Y +980310-7.f Y +980310-8.f Y +980419-2.f Y +980424-0.f Y +980427-0.f Y +980519-2.f Y Modify slightly +980729-0.f Y +981117-1.f Y +990115-1.f Y Declare variable RANK +alpha1.f Y Work around PR 16508 and PR 16509 +toon_1.f Y +xformat.f Y Add dg-warning for extension +cpp.F Y +cpp2.F Y + +g77.f-torture/execute +10197.f & 10197.x +13037.f Y +1832.f Y +19981119-0.f Y +19990313-0.f Y +19990313-1.f Y +19990313-2.f Y +19990313-3.f Y +19990325-0.f F Execution failure +19990325-1.f F Execution failure +19990419-1.f Y +19990826-0.f Y +19990826-2.f Y +20000503-1.f Y +20001111.f Y +20001201.f & 20001201.x +20010116.f Y +20010426.f renamed 20010426-1.f Y +20010430.f Y +20010610.f Y +5122.f - Assembler failure +6177.f Y +6367.f & 6367.x +947.f Y +970625-2.f Y Add dg-warnings and declare variables +970816-3.f Y +971102-1.f Y +980520-1.f Y +980628-0.f Y +980628-1.f Y +980628-10.f Y +980628-2.f Y +980628-3.f Y +980628-4.f & 980628-4.x +980628-5.f & 980628-5.x +980628-6.f & 980628-6.x +980628-7.f Y +980628-8.f Y +980628-9.f Y +980701-0.f Y +980701-1.f Y +alpha2.f & alpha2.x +auto0.f & auto0.x +auto1.f & auto1.x +cabs.f Y +claus.f Y +complex_1.f Y +cpp.F (Renamed cpp3.F) Y +cpp2.F - Compiler warnings +dcomplex.f Y +dnrm2.f Y Add dg-warning as required +erfc.f Y +exp.f Compiler warnings and fails +f90-intrinsic-bit.f F 16581 Compile errors +f90-intrinsic-mathematical.f Y +f90-intrinsic-numeric.f Y +int8421.f Y +intrinsic-f2c-z.f F Execution fail +intrinsic-unix-bessel.f Y +intrinsic-unix-erf.f Y +intrinsic-vax-cd.f F Execution fail +intrinsic77.f F PR 16580 Compiler ICE +io0.f & io0.x +io1.f & io1.x +labug1.f Y +large_vec.f Y +le.f Y +select.f Lots of compiler warnings +short.f Y +u77-test.f & u77-test.x + + +Directory g77.f-torture/noncompile +19981216-0.f Y Accepted by gfortran +19990218-1.f Y g77 issued warning. +19990826-4.f ? +19990905-1.f Y XFAIL 16520 gfortran ICE on invalid +9263.f Y +970626-2.f ? +980615-0.f Y +980616-0.f Y +check0.f Y +select_no_compile.f Y + + +Copyright (C) 2004-2014 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/alpha1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/alpha1.f new file mode 100644 index 000000000..68947692d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/alpha1.f @@ -0,0 +1,27 @@ +c { dg-do compile } + REAL(kind=8) A,B,C + REAL(kind=4) RARRAY(19) + DATA RARRAY /19*-1/ + INTEGER BOTTOM,RIGHT + INTEGER IARRAY(19) + DATA IARRAY /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 + +! previously g77.ftorture/compile/alpha1.f with following alpha1.x +! +!# 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-4.9/gcc/testsuite/gfortran.dg/g77/cabs.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cabs.f new file mode 100644 index 000000000..eafe92c8f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cabs.f @@ -0,0 +1,15 @@ +c { dg-do run } + program cabs_1 + complex z0 + real r0 + complex(kind=8) z1 + real(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/check0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/check0.f new file mode 100644 index 000000000..f0a14f826 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/check0.f @@ -0,0 +1,14 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +CCC Abort fixed by: +CCC1998-04-21 Jim Wilson <wilson@cygnus.com> +CCC +CCC * stmt.c (check_seenlabel): When search for line number note for +CCC warning, handle case where there is no such note. + logical l(10) + integer i(10) + goto (10,20),l ! { dg-error "Selection expression in computed GOTO" "" } + goto (10,20),i ! { dg-error "Selection expression in computed GOTO" "" } + 10 stop + 20 end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/claus.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/claus.f new file mode 100644 index 000000000..391d1cb9a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/claus.f @@ -0,0 +1,14 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/complex_1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/complex_1.f new file mode 100644 index 000000000..ddfbeff3f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/complex_1.f @@ -0,0 +1,19 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/cpp.F b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp.F new file mode 100644 index 000000000..42c4735c9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp.F @@ -0,0 +1,10 @@ +c { dg-do compile } +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-4.9/gcc/testsuite/gfortran.dg/g77/cpp2.F b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp2.F new file mode 100644 index 000000000..a1ee05afd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp2.F @@ -0,0 +1,8 @@ +c { dg-do compile } +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-4.9/gcc/testsuite/gfortran.dg/g77/cpp3.F b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp3.F new file mode 100644 index 000000000..ab25b5329 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp3.F @@ -0,0 +1,8 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +! 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-4.9/gcc/testsuite/gfortran.dg/g77/cpp4.F b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp4.F new file mode 100644 index 000000000..bc14e0469 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp4.F @@ -0,0 +1,12 @@ +c { dg-do run } +C The preprocessor must not mangle Hollerith constants +C which contain apostrophes. + integer i + character(4) j + data i /4hbla'/ + write (j, '(4a)') i + if (j .ne. "bla'") call abort + end + + ! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 } + ! { dg-warning "Conversion" "conversion" { target *-*-* } 6 } diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.F b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.F new file mode 100644 index 000000000..9b8d15bd7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.F @@ -0,0 +1,4 @@ + ! { dg-do run } +#include "cpp5.h" + IF (FOO().NE.1) CALL ABORT () + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.h b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.h new file mode 100644 index 000000000..bb6d1927c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5.h @@ -0,0 +1,3 @@ + FUNCTION FOO() +#include "cpp5inc.h" + END FUNCTION diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5inc.h b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5inc.h new file mode 100644 index 000000000..9a2a15885 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp5inc.h @@ -0,0 +1 @@ + FOO = 1 diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp6.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp6.f new file mode 100644 index 000000000..4160cfea1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/cpp6.f @@ -0,0 +1,20 @@ +# 1 "test.F" +# 1 "<built-in>" +# 1 "<command line>" +# 1 "test.F" +! { dg-do compile } + +# 1 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "D234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + PARAMETER (I=1) + +# 2 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 2 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 2 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 3 "test.F" 2 + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/dcomplex.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/dcomplex.f new file mode 100644 index 000000000..f25e7c570 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/dcomplex.f @@ -0,0 +1,19 @@ +c { dg-do run } + program foo + complex(kind=8) 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-4.9/gcc/testsuite/gfortran.dg/g77/dnrm2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/dnrm2.f new file mode 100644 index 000000000..dbf9f0d05 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/dnrm2.f @@ -0,0 +1,76 @@ +c { dg-do run } +c { dg-options "-fno-bounds-check" } +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 ! { dg-warning "ASSIGN" "" } + sum = zero + i = 1 + ix = 1 + 20 go to next,(30, 50, 70, 110) ! { dg-warning "Assigned GOTO" "" } + 30 if( dabs(dx(i)) .gt. cutlo) go to 85 + assign 50 to next ! { dg-warning "ASSIGN" "" } + xmax = zero + 50 if( dx(i) .eq. zero) go to 200 + if( dabs(dx(i)) .gt. cutlo) go to 85 + assign 70 to next ! { dg-warning "ASSIGN" "" } + go to 105 + 100 continue + ix = j + assign 110 to next ! { dg-warning "ASSIGN" "" } + 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-4.9/gcc/testsuite/gfortran.dg/g77/erfc.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/erfc.f new file mode 100644 index 000000000..9897162af --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/erfc.f @@ -0,0 +1,39 @@ +c { dg-do run } +c============================================== test.f + real x, y + real(kind=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 + +c 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-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-apostrophe-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-apostrophe-out.f new file mode 100644 index 000000000..aa51bc05c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-apostrophe-out.f @@ -0,0 +1,21 @@ +C Test Fortran 77 apostrophe edit descriptor +C (ANSI X3.9-1978 Section 13.5.1) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + 10 format('abcde') + 20 format('and an apostrophe -''-') + 30 format('''a leading apostrophe') + 40 format('a trailing apostrophe''') + 50 format('''and all of the above -''-''') + + write(*,10) ! { dg-output "abcde(\n|\r\n|\r)" } + write(*,20) ! { dg-output "and an apostrophe -'-(\n|\r\n|\r)" } + write(*,30) ! { dg-output "'a leading apostrophe(\n|\r\n|\r)" } + write(*,40) ! { dg-output "a trailing apostrophe'(\n|\r\n|\r)" } + write(*,50) ! { dg-output "'and all of the above -'-'(\n|\r\n|\r)" } + +C { dg-output "\$" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-colon-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-colon-out.f new file mode 100644 index 000000000..4feef755f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-colon-out.f @@ -0,0 +1,9 @@ +C Test Fortran 77 colon edit descriptor +C (ANSI X3.9-1978 Section 13.5.5) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" } + write(*,'((3(I1:)))') (I,I=1,5) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f new file mode 100644 index 000000000..78e6f017b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f @@ -0,0 +1,14 @@ +C Test Fortran 77 H edit descriptor +C (ANSI X3.9-1978 Section 13.5.2) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + 10 format(1H1) + 20 format(6H 6) + write(*,10) ! { dg-output "1(\n|\r\n|\r)" } + write(*,20) ! { dg-output " 6(\n|\r\n|\r)" } + write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\n|\r\n|\r)" } +C { dg-output "\$" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-in.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-in.f new file mode 100644 index 000000000..0369b79db --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-in.f @@ -0,0 +1,24 @@ +C Test Fortran 77 I edit descriptor for input +C (ANSI X3.9-1978 Section 13.5.9.1) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-options "-std=legacy" } +C + + integer i,j + character*10 buf + + write(buf,'(A)') '1 -1' + + read(buf,'(I1)') i + if ( i.ne.1 ) call abort() + + read(buf,'(1X,I1)') i + if ( i.ne.0 ) call abort() + + read(buf,'(1X,I1,1X,I2)') i,j + if ( i.ne.0 .and. j.ne.-1 ) call abort() + + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-out.f new file mode 100644 index 000000000..9887704c7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-i-out.f @@ -0,0 +1,26 @@ +C Test Fortran 77 I edit descriptor for output +C (ANSI X3.9-1978 Section 13.5.9.1) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + + write(*,'(I1)') 1 ! { dg-output "1(\n|\r\n|\r)" } + write(*,'(I1)') -1 ! { dg-output "\\*(\n|\r\n|\r)" } + write(*,'(I2)') 2 ! { dg-output " 2(\n|\r\n|\r)" } + write(*,'(I2)') -2 ! { dg-output "-2(\n|\r\n|\r)" } + write(*,'(I3)') 3 ! { dg-output " 3(\n|\r\n|\r)" } + write(*,'(I3)') -3 ! { dg-output " -3(\n|\r\n|\r)" } + + write(*,'(I2.0)') 0 ! { dg-output " (\n|\r\n|\r)" } + write(*,'(I1.1)') 4 ! { dg-output "4(\n|\r\n|\r)" } + write(*,'(I1.1)') -4 ! { dg-output "\\*(\n|\r\n|\r)" } + write(*,'(I2.1)') 5 ! { dg-output " 5(\n|\r\n|\r)" } + write(*,'(I2.1)') -5 ! { dg-output "-5(\n|\r\n|\r)" } + write(*,'(I2.2)') 6 ! { dg-output "06(\n|\r\n|\r)" } + write(*,'(I2.2)') -6 ! { dg-output "\\*\\*(\n|\r\n|\r)" } + write(*,'(I3.2)') 7 ! { dg-output " 07(\n|\r\n|\r)" } + write(*,'(I3.2)') -7 ! { dg-output "-07(\n|\r\n|\r)" } + + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-s-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-s-out.f new file mode 100644 index 000000000..7a22ae6b8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-s-out.f @@ -0,0 +1,20 @@ +C Test Fortran 77 S, SS and SP edit descriptors +C (ANSI X3.9-1978 Section 13.5.6) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + 10 format(SP,I3,1X,SS,I3) + 20 format(SP,I3,1X,SS,I3,SP,I3) + 30 format(SP,I3,1X,SS,I3,S,I3) + 40 format(SP,I3) + 50 format(SP,I2) + write(*,10) 10, 20 ! { dg-output "\\+10 20(\n|\r\n|\r)" } + write(*,20) 10, 20, 30 ! { dg-output "\\+10 20\\+30(\n|\r\n|\r)" } + write(*,30) 10, 20, 30 ! { dg-output "\\+10 20 30(\n|\r\n|\r)" } + write(*,40) 0 ! { dg-output " \\+0(\n|\r\n|\r)" } +C 15.5.9 - Note 5: When SP editing is in effect, the plus sign is not optional + write(*,50) 11 ! { dg-output "\\*\\*(\n|\r\n|\r)" } +C { dg-output "\$" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-slash-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-slash-out.f new file mode 100644 index 000000000..6cc9a8842 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-slash-out.f @@ -0,0 +1,9 @@ +C Test Fortran 77 colon slash descriptor +C (ANSI X3.9-1978 Section 13.5.4) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" } + write(*,'(3(I1)/2(I1))') (I,I=1,5) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-in.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-in.f new file mode 100644 index 000000000..524b18e31 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-in.f @@ -0,0 +1,33 @@ +C Test Fortran 77 T edit descriptor for input +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-options "-std=legacy" } +C + 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-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-out.f new file mode 100644 index 000000000..b47b74776 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-t-out.f @@ -0,0 +1,12 @@ +C Test Fortran 77 T edit descriptor +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + write(*,'(I4,T8,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } + write(*,'(I4,TR3,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } + write(*,'(I4,5X,TL2,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } +C { dg-output "\$" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f new file mode 100644 index 000000000..13a9d7a93 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f @@ -0,0 +1,12 @@ +C Test Fortran 77 X descriptor +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do run } +C { dg-output "^" } + write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" } +C Section 13.5.3 explains why there are no trailing blanks + write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" } +C { dg-output "\$" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f new file mode 100644 index 000000000..01436d197 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f @@ -0,0 +1,468 @@ +c { dg-do run } +c f90-intrinsic-bit.f +c +c Test Fortran 90 +c * intrinsic bit manipulation functions - Section 13.10.10 +c * bitcopy subroutine - Section 13.9.3 +c David Billinghurst <David.Billinghurst@riotinto.com> +c +c Notes: +c * g77 only supports scalar arguments +c * third argument of ISHFTC is not optional in g77 + + logical fail + integer i, i2, ia, i3 + integer(kind=2) j, j2, j3, ja + integer(kind=1) k, k2, k3, ka + integer(kind=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(kind=2) i equals j, and fail otherwise + integer(kind=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(kind=1) i equals j, and fail otherwise + integer(kind=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(kind=8) i equals j, and fail otherwise + integer(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f new file mode 100644 index 000000000..bb9849994 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f @@ -0,0 +1,138 @@ +c { dg-do run } +c f90-intrinsic-mathematical.f +c +c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and +c 13.13 +c David Billinghurst <David.Billinghurst@riotinto.com> +c +c Notes: +c * g77 does not fully comply with F90. Noncompliances noted in comments. +c * Section 13.12: Specific names for intrinsic functions tested in +c intrinsic77.f + + logical fail + common /flags/ fail + fail = .false. + +c ACOS - Section 13.13.3 + call c_r(ACOS(0.54030231),1.0,'ACOS(real)') + call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)') + +c ASIN - Section 13.13.12 + call c_r(ASIN(0.84147098),1.0,'ASIN(real)') + call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)') + +c ATAN - Section 13.13.14 + call c_r(ATAN(1.5574077),1.0,'ATAN(real)') + call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)') + +c ATAN2 - Section 13.13.15 + call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)') + call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)') + +c COS - Section 13.13.22 + call c_r(COS(1.0),0.54030231,'COS(real)') + call c_d(COS(1.d0),0.54030231d0,'COS(double)') + call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)') + call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0), + $ 'COS(complex(kind=8))') + +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(complex(kind=8))') + +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(complex(kind=8))') + +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(complex(kind=8))') + +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(complex(kind=8))') + +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 + complex(kind=8) 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-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f new file mode 100644 index 000000000..41bf59694 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f @@ -0,0 +1,283 @@ +c { dg-do run } +c f90-intrinsic-numeric.f +c +c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13 +c David Billinghurst <David.Billinghurst@riotinto.com> +c +c Notes: +c * g77 does not fully comply with F90. Noncompliances noted in comments. +c * Section 13.12: Specific names for intrinsic functions tested in +c intrinsic77.f + + logical fail + integer(kind=2) j, j2, ja + integer(kind=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(complex(kind=8))') + +c AIMAG - Section 13.13.6 + call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)') +c g77: AIMAG(complex(kind=8)) does not comply with F90 +c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(complex(kind=8))') + +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(complex(kind=8))') +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(complex(kind=8))') + +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(complex(kind=8))') + +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(complex(kind=8)) not implemented +c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(complex(kind=8))') + +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(kind=2) i equals j, and fail otherwise + integer(kind=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(kind=1) i equals j, and fail otherwise + integer(kind=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 + complex(kind=8) 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-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-1.f new file mode 100644 index 000000000..4b5f72301 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-1.f @@ -0,0 +1,6 @@ +! Test compiler flags: -ffixed-form +! Origin: David Billinghurst <David.Billinghurst@riotinto.com> +! +! { dg-do compile } +! { dg-options "-ffixed-form" } + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-2.f new file mode 100644 index 000000000..5f6980ca0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-form-2.f @@ -0,0 +1,12 @@ +! PR fortran/10843 +! Origin: Brad Davis <bdavis9659@comcast.net> +! +! { dg-do compile } +! { dg-options "-ffixed-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + GO TO = 55 + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-0.f new file mode 100644 index 000000000..80c4f3f56 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-0.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-0 +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-0" } +C The next line has length 257 + en d diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-132.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-132.f new file mode 100644 index 000000000..610169675 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-132.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-132 +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-132" } +c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 + en d* diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-72.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-72.f new file mode 100644 index 000000000..8a2fad1fa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-72.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-72 +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-72" } +c2345678901234567890123456789012345678901234567890123456789012345678901234567890 + en d* diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-none.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-none.f new file mode 100644 index 000000000..b4a50147f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffixed-line-length-none.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-none +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-none" } +C The next line has length 257 + en d diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-1.f new file mode 100644 index 000000000..88ddeefb3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-1.f @@ -0,0 +1,6 @@ +! Test compiler flags: -ffree-form +! Origin: David Billinghurst <David.Billinghurst@riotinto.com> +! +! { dg-do compile } +! { dg-options "-ffree-form" } +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-2.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-2.f new file mode 100644 index 000000000..b07db2187 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-2.f @@ -0,0 +1,11 @@ +! PR fortran/10843 +! Origin: Brad Davis <bdavis9659@comcast.net> +! +! { dg-do compile } +! { dg-options "-ffree-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-3.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-3.f new file mode 100644 index 000000000..a30d60460 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/ffree-form-3.f @@ -0,0 +1,20 @@ +! Test acceptance of keywords in free format +! Origin: David Billinghurst <David.Billinghurst@riotinto.com> +! +! { dg-do compile } +! { dg-options "-ffree-form" } + integer i, j + i = 1 + if ( i .eq. 1 ) then + go = 2 + endif + if ( i .eq. 3 ) then + i = 4 + end if + do i = 1, 3 + j = i + end do + do j = 1, 3 + i = j + enddo + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/fno-underscoring.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/fno-underscoring.f new file mode 100644 index 000000000..b91320b4c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/fno-underscoring.f @@ -0,0 +1,8 @@ +C Test compiler flags: -fno-underscoring +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-fno-underscoring" } + call aaabbbccc + end +C { dg-final { scan-assembler-not "aaabbbccc_" } } diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/funderscoring.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/funderscoring.f new file mode 100644 index 000000000..720b3a7e3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/funderscoring.f @@ -0,0 +1,8 @@ +C Test compiler flags: -funderscoring +C Origin: David Billinghurst <David.Billinghurst@riotinto.com> +C +C { dg-do compile } +C { dg-options "-funderscoring" } + call aaabbbccc + end +C { dg-final { scan-assembler "aaabbbccc_" } } diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/int8421.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/int8421.f new file mode 100644 index 000000000..0eb152002 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/int8421.f @@ -0,0 +1,21 @@ +c { dg-do run } + integer(kind=1) i1, i11 + integer(kind=2) i2, i22 + integer i, ii + integer(kind=4) i4, i44 + integer(kind=8) i8, i88 + real r, rr + real(kind=4) r4, r44 + double precision d, dd + real(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f new file mode 100644 index 000000000..696392ffa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f @@ -0,0 +1,109 @@ +c { dg-do run } +c intrinsic-unix-bessel.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst <David.Billinghurst@riotinto.com> +c + real x, a + double precision dx, da + integer i + integer(kind=2) j + integer(kind=1) k + integer(kind=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-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f new file mode 100644 index 000000000..460ddeea4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f @@ -0,0 +1,61 @@ +c { dg-do run } +c intrinsic-unix-erf.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst <David.Billinghurst@riotinto.com> +c + real x, a + double precision dx, da + logical fail + common /flags/ fail + fail = .false. + + x = 0.6 + dx = x +c ERF - error function + a = 0.6038561 + da = a + call c_r(ERF(x),a,'ERF(real)') + call c_d(ERF(dx),da,'ERF(double)') + call c_d(DERF(dx),da,'DERF(double)') + +c ERFC - complementary error function + a = 1.0 - a + da = a + call c_r(ERFC(x),a,'ERFC(real)') + call c_d(ERFC(dx),da,'ERFC(double)') + call c_d(DERFC(dx),da,'DERFC(double)') + + if ( fail ) call abort() + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/labug1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/labug1.f new file mode 100644 index 000000000..d004f760e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/labug1.f @@ -0,0 +1,58 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/large_vec.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/large_vec.f new file mode 100644 index 000000000..f5ff87d0d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/large_vec.f @@ -0,0 +1,4 @@ +c { dg-do run } + parameter (nmax=165000) + double precision x(nmax) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/le.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/le.f new file mode 100644 index 000000000..c62ac46cd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/le.f @@ -0,0 +1,30 @@ +c { dg-do run } + 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-4.9/gcc/testsuite/gfortran.dg/g77/pr9258.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/pr9258.f new file mode 100644 index 000000000..621324556 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/pr9258.f @@ -0,0 +1,18 @@ +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 !{ dg-warning "Deleted feature: ASSIGN" "" } + IF (100.LT.A) GOTO 10 + GOTO 40 +C + 20 IF (B.LT.ABS(A)) GOTO 10 + ASSIGN 30 TO M !{ dg-warning "Deleted feature: ASSIGN" "" } + GOTO 40 +C + 30 ASSIGN 10 TO M !{ dg-warning "Deleted feature: ASSIGN" "" } + 40 GOTO M,(10,20,30) !{ dg-warning "Deleted feature: Assigned GOTO" "" } + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/short.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/short.f new file mode 100644 index 000000000..330f0ac52 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/short.f @@ -0,0 +1,60 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c + 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-4.9/gcc/testsuite/gfortran.dg/g77/strlen0.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/strlen0.f new file mode 100644 index 000000000..765c8b611 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/strlen0.f @@ -0,0 +1,95 @@ +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-4.9/gcc/testsuite/gfortran.dg/g77/toon_1.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/toon_1.f new file mode 100644 index 000000000..fcdeb427d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/toon_1.f @@ -0,0 +1,4 @@ +c { dg-do compile } + SUBROUTINE AAP(NOOT) + DIMENSION NOOT(*) + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/g77/xformat.f b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/xformat.f new file mode 100644 index 000000000..9b2769a03 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/g77/xformat.f @@ -0,0 +1,4 @@ +c { dg-do compile } + PRINT 10, 2, 3 +10 FORMAT (I1, X, I1) ! { dg-warning "Extension: X descriptor" "Extension: X descriptor" } + END |