Skip to content

R
riscv-gcc-1
Commit d417dba9 by David Billinghurst Committed by David Billinghurst
Options

Copy cases from g77.f-torture/execute and add dg-run directive. 

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

From-SVN: r84980
parent 78773322
Showing with 1827 additions and 0 deletions
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/g77/13037.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/1832.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/19981119-0.f 0 → 100644
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!
gcc/testsuite/gfortran.dg/g77/19990313-0.f 0 → 100644
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.
gcc/testsuite/gfortran.dg/g77/19990313-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/19990313-2.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/19990313-3.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/19990419-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/19990826-0.f 0 → 100644
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.
gcc/testsuite/gfortran.dg/g77/19990826-2.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/20000503-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/20001111.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/20010116.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/20010426-1.f 0 → 100644
c { dg-do run }
print*,cos(1.0)
end
gcc/testsuite/gfortran.dg/g77/20010430.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/6177.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/947.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/970816-3.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/971102-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980520-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-0.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-10.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-2.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-3.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-7.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-8.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980628-9.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980701-0.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/980701-1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/cabs.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/claus.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/complex_1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/cpp3.F 0 → 100755
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
gcc/testsuite/gfortran.dg/g77/dcomplex.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/dnrm2.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/int8421.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/labug1.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/large_vec.f 0 → 100644
c { dg-do run }
parameter (nmax=165000)
double precision x(nmax)
end
gcc/testsuite/gfortran.dg/g77/le.f 0 → 100644
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
gcc/testsuite/gfortran.dg/g77/short.f 0 → 100644
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment