+2004-07-21 David Billinghurst (David.Billinghurst@riotinto.com)
+
+ Copy cases from g77.f-torture/execute and add dg-run
+ directive. Other changes as noted.
+ * gfortran.dg/g77/13037.f
+ * gfortran.dg/g77/1832.f
+ * gfortran.dg/g77/19981119-0.f
+ * gfortran.dg/g77/19990313-0.f
+ * gfortran.dg/g77/19990313-1.f
+ * gfortran.dg/g77/19990313-2.f
+ * gfortran.dg/g77/19990313-3.f
+ * gfortran.dg/g77/19990419-1.f
+ * gfortran.dg/g77/19990826-0.f
+ * gfortran.dg/g77/19990826-2.f
+ * gfortran.dg/g77/20000503-1.f
+ * gfortran.dg/g77/20001111.f
+ * gfortran.dg/g77/20010116.f
+ * gfortran.dg/g77/20010426-1.f: Renamed from 20010426-1.f
+ * gfortran.dg/g77/20010430.f
+ * gfortran.dg/g77/6177.f
+ * gfortran.dg/g77/947.f
+ * gfortran.dg/g77/970816-3.f
+ * gfortran.dg/g77/971102-1.f
+ * gfortran.dg/g77/980520-1.f
+ * gfortran.dg/g77/980628-0.f
+ * gfortran.dg/g77/980628-1.f
+ * gfortran.dg/g77/980628-10.f
+ * gfortran.dg/g77/980628-2.f
+ * gfortran.dg/g77/980628-3.f
+ * gfortran.dg/g77/980628-7.f
+ * gfortran.dg/g77/980628-8.f
+ * gfortran.dg/g77/980628-9.f
+ * gfortran.dg/g77/980701-0.f
+ * gfortran.dg/g77/980701-1.f
+ * gfortran.dg/g77/cabs.f
+ * gfortran.dg/g77/claus.f
+ * gfortran.dg/g77/complex_1.f
+ * gfortran.dg/g77/cpp3.F: Renamed from cpp3.F
+ * gfortran.dg/g77/dcomplex.f
+ * gfortran.dg/g77/dnrm2.f: Add dg-warnings as required.
+ * gfortran.dg/g77/f90-intrinsic-mathematical.f
+ * gfortran.dg/g77/f90-intrinsic-numeric.f
+ * gfortran.dg/g77/int8421.f
+ * gfortran.dg/g77/labug1.f
+ * gfortran.dg/g77/large_vec.f
+ * gfortran.dg/g77/le.f
+ * gfortran.dg/g77/short.f
+ * gfortran.dg/g77/README: Update
+
2004-07-20 Mark Mitchell <mark@codesourcery.com>
PR c++/16637
--- /dev/null
+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
+
--- /dev/null
+c { dg-do run }
+ character*120 file
+ character*5 string
+ file = "c:/dos/adir/bdir/cdir/text.doc"
+ write(string, *) "a ", file
+ if (string .ne. ' a') call abort
+C-- The leading space is normal for list-directed output
+C-- "file" is not printed because it would overflow "string".
+ end
--- /dev/null
+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!
--- /dev/null
+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*8 (on x86):
+*
+* $ cat x.f
+*[modified for test suite]
+ integer *8 foo, bar
+ data r/4e10/
+ foo = 4e10
+ bar = r
+ if (foo .ne. bar) call abort
+ end
+* $ g77 x.f && ./a.out
+* 1345294336
+* 123
+* $ f2c x.f && g77 x.c && ./a.out
+* x.f:
+* MAIN:
+* 40000000000
+* 123
+* $
+*
+* Gdb shows the upper half of the buffer passed to do_lio is zeroed in
+* the g77 case.
+*
+* I've forgotten how the code generation happens.
--- /dev/null
+c { dg-do run }
+ integer *8 foo, bar
+ double precision r
+ data r/4d10/
+ foo = 4d10
+ bar = r
+ if (foo .ne. bar) call abort
+ end
--- /dev/null
+c { dg-do run }
+ integer *8 foo, bar
+ complex c
+ data c/(4e10,0)/
+ foo = 4e10
+ bar = c
+ if (foo .ne. bar) call abort
+ end
--- /dev/null
+c { dg-do run }
+ integer *8 foo, bar
+ double complex c
+ data c/(4d10,0)/
+ foo = 4d10
+ bar = c
+ if (foo .ne. bar) call abort
+ end
--- /dev/null
+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
--- /dev/null
+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.
--- /dev/null
+c { dg-do run }
+* 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do run }
+*
+* 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
--- /dev/null
+c { dg-do run }
+ print*,cos(1.0)
+ end
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do run }
+ DIMENSION A(-5:5)
+ INTEGER*1 IM5, IZ, IP5
+ INTEGER*2 IM1, IP1
+ PARAMETER (IM5=-5, IM1=-1, IZ=0, IP1=1, IP5=5)
+ DATA A(IM5) /-5./, A(IM1) /-1./
+ DATA A(IZ) /0./
+ DATA A(IP5) /+5./, A(IP1) /+1./
+ IF (A(IM5) .NE. -5. .OR. A(IM1) .NE. -1. .OR.
+ , A(IZ) .NE. 0. .OR.
+ , A(IP5) .NE. +5. .OR. A(IP1) .NE. +1. )
+ , CALL ABORT
+ END
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do run }
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
+ 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
+
--- /dev/null
+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
+
+ 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
--- /dev/null
+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
+
+ 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
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
+
+ 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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+c { dg-do run }
+ program cabs_1
+ complex z0
+ real r0
+ complex*16 z1
+ real*8 r1
+
+ z0 = cmplx(3.,4.)
+ r0 = cabs(z0)
+ if (r0 .ne. 5.) call abort
+
+ z1 = dcmplx(3.d0,4.d0)
+ r1 = zabs(z1)
+ if (r1 .ne. 5.d0) call abort
+ end
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+c { dg-do run }
+! 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
--- /dev/null
+c { dg-do run }
+ program foo
+ complex*16 z0, z1, z2
+
+ z0 = dcmplx(0.,.5)
+ z1 = 1./z0
+ if (z1 .ne. dcmplx(0.,-2)) call abort
+
+ z0 = 10.*z0
+ if (z0 .ne. dcmplx(0.,5.)) call abort
+
+ z2 = cmplx(1.,2.)
+ z1 = z0/z2
+ if (z1 .ne. dcmplx(2.,1.)) call abort
+
+ z1 = z0*z2
+ if (z1 .ne. dcmplx(-10.,5.)) call abort
+ end
+
--- /dev/null
+c { dg-do run }
+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
--- /dev/null
+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(double complex)')
+
+c COSH - Section 13.13.23
+ call c_r(COSH(1.0),1.5430806,'COSH(real)')
+ call c_d(COSH(1.d0),1.5430806d0,'COSH(double)')
+
+c EXP - Section 13.13.34
+ call c_r(EXP(1.0),2.7182818,'EXP(real)')
+ call c_d(EXP(1.d0),2.7182818d0,'EXP(double)')
+ call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)')
+ call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0),
+ $ 'EXP(double complex)')
+
+c LOG - Section 13.13.59
+ call c_r(LOG(10.0),2.3025851,'LOG(real)')
+ call c_d(LOG(10.d0),2.3025851d0,'LOG(double)')
+ call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)')
+ call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0),
+ $ 'LOG(double complex)')
+
+c LOG10 - Section 13.13.60
+ call c_r(LOG10(10.0),1.0,'LOG10(real)')
+ call c_d(LOG10(10.d0),1.d0,'LOG10(double)')
+
+c SIN - Section 13.13.97
+ call c_r(SIN(1.0),0.84147098,'SIN(real)')
+ call c_d(SIN(1.d0),0.84147098d0,'SIN(double)')
+ call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)')
+ call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0),
+ $ 'SIN(double complex)')
+
+c SINH - Section 13.13.98
+ call c_r(SINH(1.0),1.175201,'SINH(real)')
+ call c_d(SINH(1.d0),1.175201d0,'SINH(double)')
+
+c SQRT - Section 13.13.102
+ call c_r(SQRT(4.0),2.0,'SQRT(real)')
+ call c_d(SQRT(4.d0),2.d0,'SQRT(double)')
+ call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)')
+ call c_z(SQRT((4.d0,0.)),(2.d0,0.),
+ $ 'SQRT(double complex)')
+
+c TAN - Section 13.13.105
+ call c_r(TAN(1.0),1.5574077,'TAN(real)')
+ call c_d(TAN(1.d0),1.5574077d0,'TAN(double)')
+
+c TANH - Section 13.13.106
+ call c_r(TANH(1.0),0.76159416,'TANH(real)')
+ call c_d(TANH(1.d0),0.76159416d0,'TANH(double)')
+
+ if ( fail ) call abort()
+ end
+
+ subroutine failure(label)
+c Report failure and set flag
+ character*(*) label
+ logical fail
+ common /flags/ fail
+ write(6,'(a,a,a)') 'Test ',label,' FAILED'
+ fail = .true.
+ end
+
+ subroutine c_r(a,b,label)
+c Check if REAL a equals b, and fail otherwise
+ real a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0e-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_d(a,b,label)
+c Check if DOUBLE PRECISION a equals b, and fail otherwise
+ double precision a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0d-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_c(a,b,label)
+c Check if COMPLEX a equals b, and fail otherwise
+ complex a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0e-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_z(a,b,label)
+c Check if COMPLEX a equals b, and fail otherwise
+ double complex a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0d-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
--- /dev/null
+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*2 j, j2, ja
+ integer*1 k, k2, ka
+
+ common /flags/ fail
+ fail = .false.
+
+c ABS - Section 13.13.1
+ j = -9
+ ja = 9
+ k = j
+ ka = ja
+ call c_i(ABS(-7),7,'ABS(integer)')
+ call c_i2(ABS(j),ja,'ABS(integer*2)')
+ call c_i1(ABS(k),ka,'ABS(integer*1)')
+ call c_r(ABS(-7.),7.,'ABS(real)')
+ call c_d(ABS(-7.d0),7.d0,'ABS(double)')
+ call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
+ call c_d(ABS((3.d0,-4.d0)),5.0d0,'ABS(double complex)')
+
+c AIMAG - Section 13.13.6
+ call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
+c g77: AIMAG(double complex) does not comply with F90
+c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(double complex)')
+
+c AINT - Section 13.13.7
+ call c_r(AINT(2.783),2.0,'AINT(real) 1')
+ call c_r(AINT(-2.783),-2.0,'AINT(real) 2')
+ call c_d(AINT(2.783d0),2.0d0,'AINT(double precision) 1')
+ call c_d(AINT(-2.783d0),-2.0d0,'AINT(double precision) 2')
+c Note: g77 does not support optional argument KIND
+
+c ANINT - Section 13.13.10
+ call c_r(ANINT(2.783),3.0,'ANINT(real) 1')
+ call c_r(ANINT(-2.783),-3.0,'ANINT(real) 2')
+ call c_d(ANINT(2.783d0),3.0d0,'ANINT(double precision) 1')
+ call c_d(ANINT(-2.783d0),-3.0d0,'ANINT(double precision) 2')
+c Note: g77 does not support optional argument KIND
+
+c CEILING - Section 13.13.18
+c Not implemented
+
+c CMPLX - Section 13.13.20
+ j = 1
+ ja = 2
+ k = 1
+ ka = 2
+ call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
+ call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
+ call c_c(CMPLX(j),(1.,0.),'CMPLX(integer*2)')
+ call c_c(CMPLX(j,ja),(1.,2.),'CMPLX(integer*2, integer*2)')
+ call c_c(CMPLX(k),(1.,0.),'CMPLX(integer*1)')
+ call c_c(CMPLX(k,ka),(1.,2.),'CMPLX(integer*1, integer*1)')
+ call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
+ call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
+ call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
+ call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
+ call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double complex)')
+c NOTE: g77 does not support optional argument KIND
+
+c CONJG - Section 13.13.21
+ call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
+ call c_z(CONJG((2.d0,-7.d0)),(2.d0,7.d0),'CONJG(double complex)')
+
+c DBLE - Section 13.13.27
+ j = 5
+ k = 5
+ call c_d(DBLE(5),5.0d0,'DBLE(integer)')
+ call c_d(DBLE(j),5.0d0,'DBLE(integer*2)')
+ call c_d(DBLE(k),5.0d0,'DBLE(integer*1)')
+ call c_d(DBLE(5.),5.0d0,'DBLE(real)')
+ call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
+ call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
+ call c_d(DBLE((5.0d0,0.5d0)),5.0d0,'DBLE(double complex)')
+
+c DIM - Section 13.13.29
+ j = -8
+ j2 = -3
+ ja = 0
+ k = -8
+ k2 = -3
+ ka = 0
+ call c_i(DIM(-8,-3),0,'DIM(integer)')
+ call c_i2(DIM(j,j2),ja,'DIM(integer*2)')
+ call c_i1(DIM(k,k2),ka,'DIM(integer*1)')
+ call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
+ call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
+
+c DPROD - Section 13.13.31
+ call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
+
+c FLOOR - Section 13.13.36
+c Not implemented
+
+c INT - Section 13.13.47
+ j = 5
+ k = 5
+ call c_i(INT(5),5,'INT(integer)')
+ call c_i(INT(j),5,'INT(integer*2)')
+ call c_i(INT(k),5,'INT(integer*1)')
+ call c_i(INT(5.01),5,'INT(real)')
+ call c_i(INT(5.01d0),5,'INT(double)')
+c Note: Does not accept optional second argument KIND
+
+c MAX - Section 13.13.63
+ j = 1
+ j2 = 2
+ ja = 2
+ k = 1
+ k2 = 2
+ ka = 2
+ call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
+ call c_i2(MAX(j,j2),ja,'MAX(integer*2,integer*2)')
+ call c_i1(MAX(k,k2),ka,'MAX(integer*1,integer*1)')
+ call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
+ call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
+
+c MIN - Section 13.13.68
+ j = 1
+ j2 = 2
+ ja = 1
+ k = 1
+ k2 = 2
+ ka = 1
+ call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
+ call c_i2(MIN(j,j2),ja,'MIN(integer*2,integer*2)')
+ call c_i1(MIN(k,k2),ka,'MIN(integer*1,integer*1)')
+ call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
+ call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
+
+c MOD - Section 13.13.72
+ call c_i(MOD(8,5),3,'MOD(integer,integer) 1')
+ call c_i(MOD(-8,5),-3,'MOD(integer,integer) 2')
+ call c_i(MOD(8,-5),3,'MOD(integer,integer) 3')
+ call c_i(MOD(-8,-5),-3,'MOD(integer,integer) 4')
+ j = 8
+ j2 = 5
+ ja = 3
+ call c_i2(MOD(j,j2),ja,'MOD(integer*2,integer*2) 1')
+ call c_i2(MOD(-j,j2),-ja,'MOD(integer*2,integer*2) 2')
+ call c_i2(MOD(j,-j2),ja,'MOD(integer*2,integer*2) 3')
+ call c_i2(MOD(-j,-j2),-ja,'MOD(integer*2,integer*2) 4')
+ k = 8
+ k2 = 5
+ ka = 3
+ call c_i1(MOD(k,k2),ka,'MOD(integer*1,integer*1) 1')
+ call c_i1(MOD(-k,k2),-ka,'MOD(integer*1,integer*1) 2')
+ call c_i1(MOD(k,-k2),ka,'MOD(integer*1,integer*1) 3')
+ call c_i1(MOD(-k,-k2),-ka,'MOD(integer*1,integer*1) 4')
+ call c_r(MOD(8.,5.),3.,'MOD(real,real) 1')
+ call c_r(MOD(-8.,5.),-3.,'MOD(real,real) 2')
+ call c_r(MOD(8.,-5.),3.,'MOD(real,real) 3')
+ call c_r(MOD(-8.,-5.),-3.,'MOD(real,real) 4')
+ call c_d(MOD(8.d0,5.d0),3.d0,'MOD(double,double) 1')
+ call c_d(MOD(-8.d0,5.d0),-3.d0,'MOD(double,double) 2')
+ call c_d(MOD(8.d0,-5.d0),3.d0,'MOD(double,double) 3')
+ call c_d(MOD(-8.d0,-5.d0),-3.d0,'MOD(double,double) 4')
+
+c MODULO - Section 13.13.73
+c Not implemented
+
+c NINT - Section 13.13.76
+ call c_i(NINT(2.783),3,'NINT(real)')
+ call c_i(NINT(2.783d0),3,'NINT(double)')
+c Optional second argument KIND not implemented
+
+c REAL - Section 13.13.86
+ j = -2
+ k = -2
+ call c_r(REAL(-2),-2.0,'REAL(integer)')
+ call c_r(REAL(j),-2.0,'REAL(integer*2)')
+ call c_r(REAL(k),-2.0,'REAL(integer*1)')
+ call c_r(REAL(-2.0),-2.0,'REAL(real)')
+ call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
+ call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
+c REAL(double complex) not implemented
+c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(double complex)')
+
+c SIGN - Section 13.13.96
+ j = -3
+ j2 = 2
+ ja = 3
+ k = -3
+ k2 = 2
+ ka = 3
+ call c_i(SIGN(-3,2),3,'SIGN(integer)')
+ call c_i2(SIGN(j,j2),ja,'SIGN(integer*2)')
+ call c_i1(SIGN(k,k2),ka,'SIGN(integer*1)')
+ call c_r(SIGN(-3.0,2.),3.,'SIGN(real,real)')
+ call c_d(SIGN(-3.d0,2.d0),3.d0,'SIGN(double,double)')
+
+ if ( fail ) call abort()
+ end
+
+ subroutine failure(label)
+c Report failure and set flag
+ character*(*) label
+ logical fail
+ common /flags/ fail
+ write(6,'(a,a,a)') 'Test ',label,' FAILED'
+ fail = .true.
+ end
+
+ subroutine c_i(i,j,label)
+c Check if INTEGER i equals j, and fail otherwise
+ integer i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i2(i,j,label)
+c Check if INTEGER*2 i equals j, and fail otherwise
+ integer*2 i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i1(i,j,label)
+c Check if INTEGER*1 i equals j, and fail otherwise
+ integer*1 i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_r(a,b,label)
+c Check if REAL a equals b, and fail otherwise
+ real a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0e-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_d(a,b,label)
+c Check if DOUBLE PRECISION a equals b, and fail otherwise
+ double precision a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0d-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_c(a,b,label)
+c Check if COMPLEX a equals b, and fail otherwise
+ complex a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0e-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
+
+ subroutine c_z(a,b,label)
+c Check if COMPLEX a equals b, and fail otherwise
+ double complex a, b
+ character*(*) label
+ if ( abs(a-b) .gt. 1.0d-5 ) then
+ call failure(label)
+ write(6,*) 'Got ',a,' expected ', b
+ end if
+ end
--- /dev/null
+c { dg-do run }
+ integer*1 i1, i11
+ integer*2 i2, i22
+ integer i, ii
+ integer*4 i4, i44
+ integer*8 i8, i88
+ real r, rr
+ real*4 r4, r44
+ double precision d, dd
+ real*8 r8, r88
+ parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1)
+ parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1)
+ if (i8 .ne. 15 ) call abort
+ if (d .ne. 61.d0) call abort
+ i11 = 1; i22 = 2; i44 = 4; ii = 5
+ i88 = i + i4*i2 + i2*i1
+ if (i88 .ne. i8) call abort
+ rr = 3.0; r44 = 4.0; r88 = 8.0d0
+ dd = i88*rr + r44*i22 + r88*i11
+ if (dd .ne. d) call abort
+ end
--- /dev/null
+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
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+c { dg-do run }
+ parameter (nmax=165000)
+ double precision x(nmax)
+ end
--- /dev/null
+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
--- /dev/null
+c { dg-do run }
+ 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
+
projects / gcc.git / commitdiff