+2004-07-12 David Billinghurst (David.Billinghurst@riotinto.com)
+
+ * gfortran.dg/g77/12002.f: Copy from g77.f-torture/compile .
+ Add {dg-do compile} directive.
+ * gfortran.dg/g77/13060.f: Likewise
+ * gfortran.dg/g77/19990218-0.f: Likewise
+ * gfortran.dg/g77/19990305-0.f: Likewise
+ * gfortran.dg/g77/19990419-0.f: Likewise
+ * gfortran.dg/g77/19990502-0.f: Likewise
+ * gfortran.dg/g77/19990502-1.f: Likewise
+ * gfortran.dg/g77/19990525-0.f: Likewise
+ * gfortran.dg/g77/19990826-1.f: Likewise
+ * gfortran.dg/g77/19990826-3.f: Likewise
+ * gfortran.dg/g77/19990905-2.f: Likewise
+ * gfortran.dg/g77/20000412-1.f: Likewise
+ * gfortran.dg/g77/20000511-1.f: Likewise
+ * gfortran.dg/g77/20000511-2.f: Likewise
+ * gfortran.dg/g77/20000518.f: Likewise
+ * gfortran.dg/g77/20000601-1.f: Likewise
+ * gfortran.dg/g77/20000601-2.f: Likewise
+ * gfortran.dg/g77/20000629-1.f: Likewise
+ * gfortran.dg/g77/20000630-2.f: Likewise
+ * gfortran.dg/g77/20010115.f: Likewise
+ * gfortran.dg/g77/20010321-1.f: Likewise
+ * gfortran.dg/g77/20010426.f: Likewise
+ * gfortran.dg/g77/20020307-1.f: Likewise
+ * gfortran.dg/g77/8485.f: Likewise
+ * gfortran.dg/g77/960317-1.f: Likewise
+ * gfortran.dg/g77/970915-0.f: Likewise
+ * gfortran.dg/g77/980310-1.f: Likewise
+ * gfortran.dg/g77/980310-2.f: Likewise
+ * gfortran.dg/g77/980310-3.f: Likewise
+ * gfortran.dg/g77/980310-4.f: Likewise
+ * gfortran.dg/g77/980310-6.f: Likewise
+ * gfortran.dg/g77/980310-7.f: Likewise
+ * gfortran.dg/g77/980310-8.f: Likewise
+ * gfortran.dg/g77/980419-2.f: Likewise
+ * gfortran.dg/g77/980424-0.f: Likewise
+ * gfortran.dg/g77/980427-0.f: Likewise
+ * gfortran.dg/g77/980729-0.f: Likewise
+ * gfortran.dg/g77/981117-1.f: Likewise
+ * gfortran.dg/g77/toon_1.f: Likewise
+
2004-07-12 Giovanni Bajo <giovannibajo@gcc.gnu.org>
PR c++/2204
--- /dev/null
+C PR middle-end/12002
+C {dg-do compile }
+ COMPLEX TE1
+ TE1=-2.
+ TE1=TE1+TE1
+ END
--- /dev/null
+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
--- /dev/null
+c { dg-do compile }
+ program test
+ double precision a,b,c
+ data a,b/1.0d-46,1.0d0/
+ c=fun(a,b)
+ print*,'in main: fun=',c
+ end
+ double precision function fun(a,b)
+ double precision a,b
+ print*,'in sub: a,b=',a,b
+ fun=a*b
+ print*,'in sub: fun=',fun
+ return
+ end
--- /dev/null
+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
+ DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
+ DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
+ EXTERNAL HWULI2
+ COMMON/SMALL/EPSI
+ PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
+ IF(B.EQ.ZERO)THEN
+ HWUCI2=CMPLX(ZERO,ZERO)
+ ELSE
+ Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
+ Y2=ONE-Y1
+ Z1=Y0/(Y0-Y1)
+ Z2=(Y0-ONE)/(Y0-Y1)
+ Z3=Y0/(Y0-Y2)
+ Z4=(Y0-ONE)/(Y0-Y2)
+ HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
+ ENDIF
+ RETURN
+ END
+*
+* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do compile }
+ SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY)
+ INTEGER*2 IGAMS(2,NADC)
+ in = 1
+ do while (in.le.nadc.and.IGAMS(2,in).le.in)
+ enddo
+ END
--- /dev/null
+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: "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
--- /dev/null
+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
--- /dev/null
+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
+ N10=2**NUN
+ N20=2**NDE
+ NDIF=(N10-N20)
+ NDIF=IABS(NDIF)
+C POUR AVOIR CES RESULTATS FAIRE TOURNER LE PROGRAMME VEFFT1
+ TCFFTU=0.
+ IF(N10.EQ.128.AND.N20.EQ.128)TCFFTU=3.35
+ IF(N10.EQ.64.AND.N20.EQ.64)TCFFTU=.70
+ IF(N10.EQ.32.AND.N20.EQ.32)TCFFTU=.138
+ IF(N10.EQ.16.AND.N20.EQ.16)TCFFTU=.0332
+ IF(N10.EQ.8.AND.N20.EQ.8)TCFFTU=.00688
+ IF(NDIF.EQ.64)TCFFTU=1.566
+ IF(NDIF.EQ.96)TCFFTU=.709
+ IF(NDIF.EQ.112)TCFFTU=.349
+ IF(NDIF.EQ.120)TCFFTU=.160
+ IF(NDIF.EQ.32)TCFFTU=.315
+ IF(NDIF.EQ.48)TCFFTU=.154
+ IF(NDIF.EQ.56)TCFFTU=.07
+ IF(NDIF.EQ.16)TCFFTU=.067
+ IF(NDIF.EQ.24)TCFFTU=.030
+ IF(NDIF.EQ.8)TCFFTU=.016
+ N30=N10-L1+1
+ N40=N20-L2+1
+ WW=VY1+N30*VY2
+ NDOU=2*N10*N20
+ IF((N10.LT.L1).OR.(N20.LT.L2)) GOTO 3
+ NB=NMEM-NDOU-N20*(L1-1)
+ NVC=2*N10*(N20-1)+M1
+ IF(NB.LT.(NVC)) GOTO 3
+ CALL VALENT(M1,N30,K1)
+ CALL VALENT(M2,N40,K2)
+ IS=K1/2
+ IF((2*IS).NE.K1)K1=K1+1
+ TFF=TCFFTU*K1*K2
+ CALL VALENT(M2,N40,JOFI)
+ IF(NB.GE.(K1*N20*N30+2*N20*(L1-1))) GOTO 4
+ TIOOP=1.E+10
+ IC=1
+18 IB1=2*IC
+ MAX=(NB-2*N20*(L1-1))/(N20*N30)
+ IN=MAX/2
+ IF(MAX.NE.2*IN) MAX=MAX-1
+ K3=K1/IB1
+ IBB1=K1-K3*IB1
+ IOFI=M1/(IB1*N30)
+ IRZ=0
+ IF(IOFI*IB1*N30.EQ.M1) GOTO1234
+ IRZ=1
+ IOFI=IOFI+1
+ IF(IBB1.EQ.0) GOTO 1234
+ IF(M1.EQ.((IOFI-1)*IB1*N30+IBB1*N30)) GOTO 1233
+ IRZ=2
+ GOTO 1234
+1233 IRZ=3
+1234 IBX1=IBB1
+ IF(IBX1.EQ.0)IBX1=IB1
+ AR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1-(IOFI-1)*IB1*N30)*2*(REQ+RAD))
+ %+M2*(3*(REQ+RMU+RAD)+4*RMI+(M1-(IOFI-1)*IB1*N30)*(2*RAD+REQ)
+ %+(IOFI-1)*IB1*N30*(2*RMI+REQ+RAD))
+ AR5=(JOFI-1)*(N20-L2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU)+REQ)
+ %*IOFI+(M2-(JOFI-1)*N40+L2-2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU
+ %)+REQ)*IOFI
+ WQ=((IOFI-1)*IB1+IBX1)*JOFI*WW
+ AT1=N20*WQ
+ AT2=N40*WQ
+ QW=JOFI*(VY1+VY2*IB1*N30)
+ AT3=IOFI*N40*QW
+ AT4=(IOFI-1)*N40*QW
+ AT5=JOFI*((IOFI-1)*N40*(IB1/IBX1)*(VY1+IBX1*N30*VY2)
+ %+N40*((IB1/IBX1)*(IOFI-1)+1)*(VY1+IBX1*N30*VY2))
+ AT6=JOFI*((IOFI-1)*N40*(IB1/2)*(VY1+2*N30*VY2)+N40*(
+ %IB1*(IOFI-1)/2+IBX1/2)*(VY1+2*N30*VY2))
+ T1=JOFI*N20*(L1-1)*REQ
+ T2=M1*(L2-1)*REQ
+ T3=JOFI*N20*IBX1*N30*(RAD+REQ)
+ T4=JOFI*((IOFI-1)*IB1*N30*N20*(2*RMI+REQ)+IBX1*N30*N20*(2*RMI+R
+ %EQ))
+ T5=JOFI*((IOFI-1)*IB1/2+IBX1/2)*N20*N30*(2*RAD+REQ)
+ T6=2*JOFI*(((IOFI-1)*IB1+IBX1)*N20)*((5*(RMI+RMU)+4*RAD
+ %)+(L1-1)*(2*RAD+REQ)+N30*(2*RAD+REQ))
+ T7=JOFI*2*((IOFI-1)*IB1+IBX1)*(L1-1)*(2*RAD+REQ)
+ T8=JOFI*N10*N20*((IOFI-1)*IB1/2+IBX1/2)*(3*REQ+9*RAD+4*RMU+RMI)
+ T9=N10*N20*JOFI*((IOFI-1)*IB1/2+IBX1/2)*(REQ+RMI)+M1*M2*(REQ+R
+ %DI+2*RAD)
+ T10=JOFI*((IOFI-1)*IB1/2+IBX1/2)*2*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
+ %+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
+ POI=JOFI
+ IF(POI.LE.2)POI=2
+ TNRAN=(N40+(POI-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMI+RMU+RAD
+ %+REQ+N30*(2*RAD+2*REQ)*(IB1*(IOFI-1)+IBX1))
+ IF(TNRAN.LT.0.)TNRAN=0.
+ TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10+TNRAN
+ NVA(1)=N40
+ NVA(2)=N40
+ NVA(3)=N20
+ NVA(4)=N20
+ NVA(5)=M2-(JOFI-1)*N40
+ NVA(6)=NVA(5)
+ C(1)=FLOAT(IB1*N30)/FLOAT(M1)
+ C(2)=FLOAT(M1-(IOFI-1)*IB1*N30)/FLOAT(M1)
+ C(3)=C(1)
+ C(4)=C(2)
+ C(5)=C(1)
+ C(6)=C(2)
+ K=1
+ P1=FLOAT(NB)/FLOAT(M1)
+10 IP1=P1
+ I(K)=1
+ IF(IP1.GE.NVA(K)) GOTO 7
+ P2=P1
+ IP2=P2
+8 P2=P2-FLOAT(IP2)*C(K)
+ IP2=P2
+ IF(IP2.EQ.0) GOTO 3
+ IP1=IP1+IP2
+ I(K)=I(K)+1
+ IF(IP1.GE.NVA(K))GOTO 7
+ GOTO 8
+7 IF(K.EQ.6) GOTO 11
+ K=K+1
+ GOTO 10
+11 IP1=0
+ IP2=0
+ IP3=0
+ POFI=JOFI
+ IF(POFI.LE.2)POFI=2
+ TIOL=(I(2)+(IOFI-1)*I(1)+(POFI-2)*(IOFI-1)*I(3)+(POFI-
+ %2)*I(4)+(IOFI-1)*I(5)+I(6))*TACC+(IOFI*M1*N40+(POFI-2)*IOFI*
+ %M1*N20+(M2-(JOFI-1)*N40+L2-1)*M1*IOFI)*TTRANS
+ IF(IBB1.EQ.0) GOTO 33
+ IF(IB1.EQ.IBB1) GOTO 33
+ IF(IBB1.EQ.2)GOTO 34
+ IP3=1
+ INL=NMEM/((IOFI-1)*IB1*N30+IBB1*N30)
+55 IF(INL.GT.N40)INL=N40
+ GOTO 35
+33 IF(IB1.GT.2) GOTO 36
+ IF((M1-(IOFI-1)*IB1*N30).GE.N30) GOTO 36
+34 IP1=1
+ INL=NMEM/(2*M1-(IOFI-1)*IB1*N30)
+ GOTO 55
+36 IP2=1
+ INL=NMEM/(IOFI*IB1*N30)
+ IF(INL.GT.N40)INL=N40
+35 CALL VALENT(N40,INL,KN1)
+ CALL VALENT(M2-(JOFI-1)*N40,INL,KN2)
+ CALL VALENT(INL*IBB1,IB1,KN3)
+ CALL VALENT((N40-(KN1-1)*INL)*IBB1,IB1,KN4)
+ IF((IP1+IP2+IP3).NE.1) CALL ERMESF(14)
+ TIO1=0.
+ IF(IP3.EQ.1)TIO1=N30*M2*TTRANS*(IB1*(IOFI-1)+IBB1)
+ IF(IP1.EQ.1)TIO1=M1*M2*TTRANS
+ IF(IP2.EQ.1) TIO1=(IB1*N30*M2*IOFI*TTRANS)
+ TTIO=2.*TIO1+(KN1*IOFI*(JOFI-1)+KN2*IOFI+(KN1-1)*(
+ %JOFI-1)+IOFI*(JOFI-1)+KN2-1.+IOFI+(KN1*(JOFI-1)+KN2))*TACC
+ %+M1*M2*TTRANS+TIOL
+ IF((IP1.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
+ IF((IP1.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT4+AR1
+ IF((IP2.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
+ IF((IP2.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT3+AR2
+ IFOIS=IB1/IBX1
+ IF((IP3.EQ.1).AND.(IFOIS*IBX1.EQ.IB1))TCPU=TCPU+AT1+AT2+AT5+AR2
+ IF((IP3.EQ.1).AND.(IFOIS*IBX1.NE.IB1))TCPU=TCPU+AT1+AT2+AT6+AR2
+ IF((IP1.EQ.1).AND.(IRZ.EQ.1))TCPU=TCPU+AR5
+ IF((IP1.EQ.1).AND.(IRZ.EQ.2))TCPU=TCPU+AR5
+ TTIOG=TTIO+TCPU
+ IF(TTIOG.LE.0.) GOTO 99
+ IF(TTIOG.GE.TIOOP) GOTO 99
+ IBOP=IB1
+ IBBOP=IBB1
+ K3OP=K3
+ TIOOP=TTIOG
+ TIOOP1=TTIO
+ TIOOP2=TCPU
+99 IF(IB1.GE.MAX)GOTO17
+ IC=IC+1
+ GOTO 18
+4 T1=JOFI*N20*(L1-1)*REQ
+ T2=M1*(L2-1)*REQ
+ T3=JOFI*N20*N30*(RAD+REQ)*K1
+ T4=JOFI*(K1*N30*N20*(2*RMI+REQ))
+ T5=JOFI*N20*N30*(2*RAD+REQ)*K1/2
+ T6=2*JOFI*(K1*N20)*((5*RMI+RMU)+4*RAD+(L1-1)*(2*RAD+REQ)+N30*2*
+ %RAD+REQ)
+ T7=JOFI*2*K1*(L1-1)*(2*RAD+REQ)
+ T9=JOFI*N10*N20*K1*(REQ+RMI)/2+M1*M2*(REQ+RDI+2*RAD)
+ T8=JOFI*N10*N20*K1*(3*REQ+9*RAD+4*RMU+RMI)/2
+ T10=JOFI*K1*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
+ %+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
+ PIO=JOFI
+ IF(PIO.LE.2)PIO=2
+ TNR=(N40+(PIO-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMU+RMI+RAD+REQ+
+ %N30*(2*RAD+2*REQ)*K1)
+ IF(TNR.LE.0.)TNR=0.
+ BT1=JOFI*N20*WW*K1
+ BT2=JOFI*N40*WW*K1
+ BT3=JOFI*N40*(VY1+K1*N30*VY2)
+ BR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1*2*(REQ+RAD)))+M2*(3*(
+ $REQ+RAD+RMU)+4*(RMI)+M1*(2*(RAD)+REQ))
+ BR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ))
+ TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10
+ TCPU=TCPU+TNR+BT1+BT2
+ LIOF=M1/(N30)
+ IRZ=0
+ IF(LIOF*N30.EQ.M1) GOTO 2344
+ IRZ=1
+2344 IF(IRZ.EQ.0)TCPU=TCPU+BT3
+ IF(IRZ.NE.0)TCPU=TCPU+BT3+BR2
+ TIOOP=2.*FLOAT(M1)*FLOAT(M2)*TTRANS+2.*FLOAT(K2)*TACC+TCPU
+ IBOP=1
+ IBBOP=0
+ K3OP=1
+ TIOOP2=TCPU
+ TIOOP1=TIOOP-TCPU
+17 TTOT=TIOOP+TFF
+ IF(TTOT.LE.0.) GOTO 3
+ IF(TTOT.GE.TTOTOP)GOTO3
+ N1CO=N10
+ N2CO=N20
+ IBCO=IBOP
+ IBBCO=IBBOP
+ K3CO=K3OP
+ TTOTOP=TTOT
+ TESOP=TIOOP1
+ TCOP=TIOOP2
+ TFOP=TFF
+3 CONTINUE
+
+C
+ N1=N1CO
+ N2=N2CO
+ TTO=TTOTOP
+ IB=IBCO
+ IBB=IBBCO
+ K3=K3CO
+ TC=TCOP
+ TS=TESOP
+ TF=TFOP
+ TT=TCOP+TFOP
+ TWER=TTO-TT
+ IF(N1.EQ.0.OR.N2.EQ.0) CALL OUTSTR(0,'PAS DE PLACE MEMOIRE SUFFISA
+ $NTE POUR UNE MISE EN OEUVRE PAR BLOCS$')
+ IF(IB.NE.1)RETURN
+ IHJ=(M1/(N1-L1+1))
+ IF(IHJ*(N1-L1+1).NE.M1)IHJ=IHJ+1
+ IHJ1=IHJ/2
+ IF(IHJ1*2.NE.IHJ)GOTO7778
+ IB=IHJ
+ IBB=0
+ RETURN
+7778 IB=IHJ+1
+ IBB=0
+ RETURN
+ END
--- /dev/null
+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*8(A-H,O-Z),INTEGER*4(I-N)
+ COMMON/ARRAYS/Z(64,8),AB(30,30),PAIRS(9,9),T(9,9),TEMP(9,9),C1(3),
+ > C2(3),AA(30),BB(30)
+ EQUIVALENCE (X1,C1(1)),(Y1,C1(2)),(Z1,C1(3))
+ EQUIVALENCE (X2,C2(1)),(Y2,C2(2)),(Z2,C2(3))
+ COMMON /CONTRL/
+ > SHIFT,CONV,SCION,DIVERG,
+ > IOPT,KCNDO,KINDO,KMINDO,I2EINT,KOHNO,KSLATE,
+ > N,NG,NUMAT,NSEK,NELECS,NIT,OCCA,OCCB,NOLDAT,NOLDFN
+ INTEGER*4 OCCA,OCCB
+ DIMENSION W(N),A(N,N),B(N,N)
+ DIMENSION BUF(100)
+ occb=5
+ ENTRY INDNS (A,B)
+ 40 READ(IREAD) BUF
+ STOP
+ END
--- /dev/null
+c { dg-do compile }
+ subroutine aap(k)
+ equivalence (i,r)
+ i = k
+ print*,r
+ end
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do compile }
+ SUBROUTINE MIST(N, BETA)
+ IMPLICIT REAL*8 (A-H,O-Z)
+ INTEGER IA, IQ, M1
+ DIMENSION BETA(N)
+ DO 80 IQ=1,M1
+ IF (BETA(IQ).EQ.0.0D0) GO TO 120
+ 80 CONTINUE
+ 120 IF (IQ.NE.1) GO TO 160
+ 160 M1 = IA(IQ)
+ RETURN
+ END
--- /dev/null
+c { dg-do compile }
+ 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do compile }
+ function f(c)
+ implicit none
+ real*8 c, f
+ f = sqrt(c)
+ return
+ end
--- /dev/null
+c { dg-do compile }
+ SUBROUTINE SWEEP
+ PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20)
+ REAL*8 B,W1,W2,BNORM,BINV,WT,W0,C1,C2,R1,R2
+ DIMENSION B(MAXVEC,0:3),W1(MAXVEC,0:3),W2(MAXVEC,0:3)
+ DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC)
+ DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC)
+ DO 200 ILAT=1,2**IDIM
+ DO 200 I1=1,IDIM
+ DO 220 I2=1,IDIM
+ CALL INTACT(ILAT,I1,I1,W1)
+220 CONTINUE
+ DO 310 IATT=1,IDIM
+ DO 311 I=1,100
+ WT(I)=ONE + C1(I)*LOG(EPS+R1(I))
+ IF( R2(I)**2 .LE. (ONE-WT(I)**2) )THEN
+ W0(I)=WT(I)
+ ENDIF
+311 CONTINUE
+310 CONTINUE
+200 CONTINUE
+ END
--- /dev/null
+c { dg-do compile }
+C Extracted from PR fortran/8485
+ PARAMETER (PPMULT = 1.0E5)
+ INTEGER*8 NWRONG
+ PARAMETER (NWRONG = 8)
+ PARAMETER (DDMULT = PPMULT * NWRONG)
+ PRINT 10, DDMULT
+10 FORMAT (F10.3)
+ END
--- /dev/null
+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 "Obsolete: 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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+ tb = b(i,j)
+ ta = a(i,j)
+ if (ta .eq. 0.0d0) go to 220
+ ta = dlog10(dabs(ta)) / basl
+ 220 continue
+ if (tb .eq. 0.0d0) go to 230
+ tb = dlog10(dabs(tb)) / basl
+ 230 continue
+ wk(i,5) = wk(i,5) - ta - tb
+ wk(j,6) = wk(j,6) - ta - tb
+ 240 continue
+ nr = igh-low+1
+ coef = 1.0d0/float(2*nr)
+ coef2 = coef*coef
+ coef5 = 0.5d0*coef2
+ nrp2 = nr+2
+ beta = 0.0d0
+ it = 1
+c
+c start generalized conjugate gradient iteration
+c
+ 250 continue
+ ew = 0.0d0
+ ewc = 0.0d0
+ gamma = 0.0d0
+ do 260 i = low,igh
+ gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
+ ew = ew + wk(i,5)
+ ewc = ewc + wk(i,6)
+ 260 continue
+ gamma = coef*gamma - coef2*(ew**2 + ewc**2)
+ + - coef5*(ew - ewc)**2
+ if (it .ne. 1) beta = gamma / pgamma
+ t = coef5*(ewc - 3.0d0*ew)
+ tc = coef5*(ew - 3.0d0*ewc)
+ do 270 i = low,igh
+ wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
+ cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
+ 270 continue
+c
+c apply matrix to vector
+c
+ do 300 i = low,igh
+ kount = 0
+ sum = 0.0d0
+ do 290 j = low,igh
+ if (a(i,j) .eq. 0.0d0) go to 280
+ kount = kount+1
+ sum = sum + cperm(j)
+ 280 continue
+ if (b(i,j) .eq. 0.0d0) go to 290
+ kount = kount+1
+ sum = sum + cperm(j)
+ 290 continue
+ wk(i,3) = float(kount)*wk(i,2) + sum
+ 300 continue
+ do 330 j = low,igh
+ kount = 0
+ sum = 0.0d0
+ do 320 i = low,igh
+ if (a(i,j) .eq. 0.0d0) go to 310
+ kount = kount+1
+ sum = sum + wk(i,2)
+ 310 continue
+ if (b(i,j) .eq. 0.0d0) go to 320
+ kount = kount+1
+ sum = sum + wk(i,2)
+ 320 continue
+ wk(j,4) = float(kount)*cperm(j) + sum
+ 330 continue
+ sum = 0.0d0
+ do 340 i = low,igh
+ sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
+ 340 continue
+ if(sum.eq.0.0d0) return
+ alpha = gamma / sum
+c
+c determine correction to current iterate
+c
+ cmax = 0.0d0
+ do 350 i = low,igh
+ cor = alpha * wk(i,2)
+ if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+ wk(i,1) = wk(i,1) + cor
+ cor = alpha * cperm(i)
+ if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+ cscale(i) = cscale(i) + cor
+ 350 continue
+ if (cmax .lt. 0.5d0) go to 370
+ do 360 i = low,igh
+ wk(i,5) = wk(i,5) - alpha*wk(i,3)
+ wk(i,6) = wk(i,6) - alpha*wk(i,4)
+ 360 continue
+ pgamma = gamma
+ it = it+1
+ if (it .le. nrp2) go to 250
+c
+c end generalized conjugate gradient iteration
+c
+ 370 continue
+ do 380 i = low,igh
+ ir = wk(i,1) + dsign(0.5d0,wk(i,1))
+ wk(i,1) = ir
+ jc = cscale(i) + dsign(0.5d0,cscale(i))
+ cscale(i) = jc
+ 380 continue
+c
+c scale a and b
+c
+ do 400 i = 1,igh
+ ir = wk(i,1)
+ fi = 2.0d0**ir
+ if (i .lt. low) fi = 1.0d0
+ do 400 j =low,n
+ jc = cscale(j)
+ fj = 2.0d0**jc
+ if (j .le. igh) go to 390
+ if (i .lt. low) go to 400
+ fj = 1.0d0
+ 390 continue
+ a(i,j) = a(i,j)*fi*fj
+ b(i,j) = b(i,j)*fi*fj
+ 400 continue
+ 410 continue
+ return
+c
+c last line of scaleg
+c
+ end
--- /dev/null
+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
--- /dev/null
+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 '*'.
+
--- /dev/null
+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.
--- /dev/null
+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 alphaev56-unknown-linux-gnu):
+C
+C foo.f: In subroutine `foobar':
+C foo.f:11:
+C subroutine foobar(norb,nnorb)
+C ^
+C Array `norb' at (^) is too large to handle
+
+ program foo
+ implicit integer(A-Z)
+ dimension norb(6)
+ nnorb=6
+
+ call foobar(norb,nnorb)
+
+ stop
+ end
+
+ subroutine foobar(norb,nnorb)
+ implicit integer(A-Z)
+ dimension norb(-1:*)
+
+ do 10 i=-1,nnorb-2
+ norb(i) = i+999
+ 10 continue
+
+ return
+ end
--- /dev/null
+c { dg-do compile }
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do compile }
+ SUBROUTINE AAP(NOOT)
+ DIMENSION NOOT(*)
+ END
projects / gcc.git / commitdiff