summaryrefslogtreecommitdiff
path: root/gcc/testsuite/g77.f-torture
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/g77.f-torture')
-rw-r--r--gcc/testsuite/g77.f-torture/execute/io1.f10
-rw-r--r--gcc/testsuite/g77.f-torture/execute/io1.x13
-rw-r--r--gcc/testsuite/g77.f-torture/execute/labug1.f57
-rw-r--r--gcc/testsuite/g77.f-torture/execute/large_vec.f3
-rw-r--r--gcc/testsuite/g77.f-torture/execute/le.f29
-rw-r--r--gcc/testsuite/g77.f-torture/execute/select.f173
-rw-r--r--gcc/testsuite/g77.f-torture/execute/short.f57
-rw-r--r--gcc/testsuite/g77.f-torture/execute/u77-test.f421
-rw-r--r--gcc/testsuite/g77.f-torture/execute/u77-test.x12
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/19981216-0.f89
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/19990218-1.f13
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/19990826-4.f648
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/19990905-1.f8
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/9263.f7
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/970626-2.f4
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/980615-0.f10
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/980616-0.f8
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/check0.f11
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/noncompile.exp36
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f10
20 files changed, 1619 insertions, 0 deletions
diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f
new file mode 100644
index 00000000000..c5242446a49
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/io1.f
@@ -0,0 +1,10 @@
+* Fixed by 1998-09-28 libI77/open.c change.
+ open(90,status='scratch')
+ write(90, '(1X, I1 / 1X, I1)') 1, 2
+ rewind 90
+ write(90, '(1X, I1)') 1
+ rewind 90 ! implicit ENDFILE expected
+ read(90, *) i
+ read(90, *, end=10) j
+ call abort()
+ 10 end
diff --git a/gcc/testsuite/g77.f-torture/execute/io1.x b/gcc/testsuite/g77.f-torture/execute/io1.x
new file mode 100644
index 00000000000..6a69a3aadab
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/io1.x
@@ -0,0 +1,13 @@
+# Scratch files aren't implemented for mmixware
+# (_stat is a stub and files can't be deleted).
+# Similar restrictions exist for most simulators.
+
+if { [istarget "mmix-knuth-mmixware"]
+ || [istarget "arm*-*-elf"]
+ || [istarget "strongarm*-*-elf"]
+ || [istarget "xscale*-*-elf"]
+ || [istarget "cris-*-elf"] } {
+ set torture_execute_xfail [istarget]
+}
+
+return 0
diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f
new file mode 100644
index 00000000000..032fa41f899
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/labug1.f
@@ -0,0 +1,57 @@
+ PROGRAM LABUG1
+
+* This program core dumps on mips-sgi-irix6.2 when compiled
+* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
+* with -O2
+*
+* Originally derived from LAPACK test suite.
+* Almost any change allows it to run.
+*
+* David Billinghurst, (David.Billinghurst@riotinto.com.au)
+* 25 November 1998
+*
+* .. Parameters ..
+ INTEGER LDA, LDE
+ PARAMETER ( LDA = 2500, LDE = 50 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+
+ INTEGER I, J, M, N
+ REAL V
+ COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)
+ COMPLEX Z
+
+ N=2
+ M=1
+*
+ do i = 1, m
+ do j = 1, n
+ e(i,j) = czero
+ f(i,j) = czero
+ end do
+ end do
+*
+ DO J = 1, N
+ DO I = 1, M
+ V = ABS( E(I,J) - F(I,J) )
+ END DO
+ END DO
+
+ CALL SUB2(M,Z)
+
+ END
+
+ subroutine SUB2(I,A)
+ integer i
+ complex a
+ end
+
+
+
+
+
+
+
+
+
+
diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f
new file mode 100644
index 00000000000..0af5b1b0b3f
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/large_vec.f
@@ -0,0 +1,3 @@
+ parameter (nmax=165000)
+ double precision x(nmax)
+ end
diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f
new file mode 100644
index 00000000000..74e42750d55
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/le.f
@@ -0,0 +1,29 @@
+ program fool
+
+ real foo
+ integer n
+ logical t
+
+ foo = 2.5
+ n = 5
+
+ t = (n > foo)
+ if (t .neqv. .true.) call abort
+ t = (n >= foo)
+ if (t .neqv. .true.) call abort
+ t = (n < foo)
+ if (t .neqv. .false.) call abort
+ t = (n <= 5)
+ if (t .neqv. .true.) call abort
+ t = (n >= 5 )
+ if (t .neqv. .true.) call abort
+ t = (n == 5)
+ if (t .neqv. .true.) call abort
+ t = (n /= 5)
+ if (t .neqv. .false.) call abort
+ t = (n /= foo)
+ if (t .neqv. .true.) call abort
+ t = (n == foo)
+ if (t .neqv. .false.) call abort
+
+ end
diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f
new file mode 100644
index 00000000000..f1024330a71
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/select.f
@@ -0,0 +1,173 @@
+C integer byte case with integer byte parameters as case(s)
+ subroutine ib
+ integer *1 a /1/
+ integer *1 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal ib'
+ end
+C integer halfword case with integer halfword parameters
+ subroutine ih
+ integer *2 a /1/
+ integer *2 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal ih'
+ end
+C integer case with integer parameters
+ subroutine iw
+ integer *4 a /1/
+ integer *4 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal iw'
+ end
+C integer double case with integer double parameters
+ subroutine id
+ integer *8 a /1/
+ integer *8 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal id'
+ end
+C integer byte select with integer case
+ subroutine ib_mixed
+ integer*1 s /1/
+ select case (s)
+ case (1)
+ case (2)
+ call abort
+ end select
+ print*,'ib ok'
+ end
+C integer halfword with integer case
+ subroutine ih_mixed
+ integer*2 s /1/
+ select case (s)
+ case (1)
+ case default
+ call abort
+ end select
+ print*,'ih ok'
+ end
+C integer word with integer case
+ subroutine iw_mixed
+ integer s /5/
+ select case (s)
+ case (1)
+ call abort
+ case (2)
+ call abort
+ case (3)
+ call abort
+ case (4)
+ call abort
+ case (5)
+C
+ case (6)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'iw ok'
+ end
+C integer doubleword with integer case
+ subroutine id_mixed
+ integer *8 s /1024/
+ select case (s)
+ case (1)
+ call abort
+ case (1023)
+ call abort
+ case (1025)
+ call abort
+ case (1024)
+C
+ end select
+ print*,'i8 ok'
+ end
+ subroutine l1_mixed
+ logical*1 s /.TRUE./
+ select case (s)
+ case (.TRUE.)
+ case (.FALSE.)
+ call abort
+ end select
+ print*,'l1 ok'
+ end
+ subroutine l2_mixed
+ logical*2 s /.FALSE./
+ select case (s)
+ case (.TRUE.)
+ call abort
+ case (.FALSE.)
+ end select
+ print*,'lh ok'
+ end
+ subroutine l4_mixed
+ logical*4 s /.TRUE./
+ select case (s)
+ case (.FALSE.)
+ call abort
+ case (.TRUE.)
+ end select
+ print*,'lw ok'
+ end
+ subroutine l8_mixed
+ logical*8 s /.TRUE./
+ select case (s)
+ case (.TRUE.)
+ case (.FALSE.)
+ call abort
+ end select
+ print*,'ld ok'
+ end
+C main
+C -- regression cases
+ call ib
+ call ih
+ call iw
+ call id
+C -- new functionality
+ call ib_mixed
+ call ih_mixed
+ call iw_mixed
+ call id_mixed
+ end
+
+
+
+
+
diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f
new file mode 100644
index 00000000000..89ae273891c
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/short.f
@@ -0,0 +1,57 @@
+ program short
+
+ parameter ( N=2 )
+ common /chb/ pi,sig(0:N)
+ common /parm/ h(2,2)
+
+c initialize some variables
+ h(2,2) = 1117
+ h(2,1) = 1178
+ h(1,2) = 1568
+ h(1,1) = 1621
+ sig(0) = -1.
+ sig(1) = 0.
+ sig(2) = 1.
+
+ call printout
+ stop
+ end
+
+c ******************************************************************
+
+ subroutine printout
+ parameter ( N=2 )
+ common /chb/ pi,sig(0:N)
+ common /parm/ h(2,2)
+ dimension yzin1(0:N), yzin2(0:N)
+
+c function subprograms
+ z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
+
+c a four-way average of rhobar
+ do 260 k=0,N
+ yzin1(k) = 0.25 *
+ & ( z(2,2,k) + z(1,2,k) +
+ & z(2,1,k) + z(1,1,k) )
+ 260 continue
+
+c another four-way average of rhobar
+ do 270 k=0,N
+ rtmp1 = z(2,2,k)
+ rtmp2 = z(1,2,k)
+ rtmp3 = z(2,1,k)
+ rtmp4 = z(1,1,k)
+ yzin2(k) = 0.25 *
+ & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
+ 270 continue
+
+ do k=0,N
+ if (yzin1(k) .ne. yzin2(k)) call abort
+ enddo
+ if (yzin1(0) .ne. -1371.) call abort
+ if (yzin1(1) .ne. -685.5) call abort
+ if (yzin1(2) .ne. 0.) call abort
+
+ return
+ end
+
diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f
new file mode 100644
index 00000000000..f502bc72833
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/u77-test.f
@@ -0,0 +1,421 @@
+*** Some random stuff for testing libU77. Should be done better. It's
+* hard to test things where you can't guarantee the result. Have a
+* good squint at what it prints, though detected errors will cause
+* starred messages.
+*
+* Currently not tested:
+* ALARM
+* CHDIR (func)
+* CHMOD (func)
+* FGET (func/subr)
+* FGETC (func)
+* FPUT (func/subr)
+* FPUTC (func)
+* FSTAT (subr)
+* GETCWD (subr)
+* HOSTNM (subr)
+* IRAND
+* KILL
+* LINK (func)
+* LSTAT (subr)
+* RENAME (func/subr)
+* SIGNAL (subr)
+* SRAND
+* STAT (subr)
+* SYMLNK (func/subr)
+* UMASK (func)
+* UNLINK (func)
+*
+* NOTE! This is the testsuite version, so it should compile and
+* execute on all targets, and either run to completion (with
+* success status) or fail (by calling abort). The *other* version,
+* which is a bit more interactive and tests a couple of things
+* this one cannot, should be generally the same, and is in
+* libf2c/libU77/u77-test.f. Please keep it up-to-date.
+
+ implicit none
+
+ external hostnm
+* intrinsic hostnm
+ integer hostnm
+
+ integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
+ + pid, mask
+ real tarray1(2), tarray2(2), r1, r2
+ double precision d1
+ integer(kind=2) bigi
+ logical issum
+ intrinsic getpid, getuid, getgid, ierrno, gerror, time8,
+ + fnum, isatty, getarg, access, unlink, fstat, iargc,
+ + stat, lstat, getcwd, gmtime, etime, chmod, itime, date,
+ + chdir, fgetc, fputc, system_clock, second, idate, secnds,
+ + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8,
+ + cpu_time, dtime, ftell, abort
+ external lenstr, ctrlc
+ integer lenstr
+ logical l
+ character gerr*80, c*1
+ character ctim*25, line*80, lognam*20, wd*1000, line2*80,
+ + ddate*8, ttime*10, zone*5, ctim2*25
+ integer fstatb (13), statb (13)
+ integer *2 i2zero
+ integer values(8)
+ integer(kind=7) sigret
+
+ i = time ()
+ ctim = ctime (i)
+ WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim))
+ write (6,'(A,I3,'', '',I3)')
+ + ' Logical units 5 and 6 correspond (FNUM) to'
+ + // ' Unix i/o units ', fnum(5), fnum(6)
+ if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
+ print *, 'LNBLNK or LEN_TRIM failed'
+ call abort
+ end if
+
+ bigi = time8 ()
+
+ call ctime (i, ctim2)
+ if (ctim .ne. ctim2) then
+ write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
+ + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
+ call doabort
+ end if
+
+ j = time ()
+ if (i .gt. bigi .or. bigi .gt. j) then
+ write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
+ + i, bigi, j
+ call doabort
+ end if
+
+ print *, 'Command-line arguments: ', iargc ()
+ do i = 0, iargc ()
+ call getarg (i, line)
+ print *, 'Arg ', i, ' is: ', line(:lenstr (line))
+ end do
+
+ l= isatty(6)
+ line2 = ttynam(6)
+ if (l) then
+ line = 'and 6 is a tty device (ISATTY) named '//line2
+ else
+ line = 'and 6 isn''t a tty device (ISATTY)'
+ end if
+ write (6,'(1X,A)') line(:lenstr(line))
+ call ttynam (6, line)
+ if (line .ne. line2) then
+ print *, '*** CALL TTYNAM disagrees with TTYNAM: ',
+ + line(:lenstr (line))
+ call doabort
+ end if
+
+* regression test for compiler crash fixed by JCB 1998-08-04 com.c
+ sigret = signal(2, ctrlc)
+
+ pid = getpid()
+ WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
+ WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
+ WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
+ WRITE (6, *) 'If you have the `id'' program, the following call'
+ write (6, *) 'of SYSTEM should agree with the above:'
+ call flush(6)
+ CALL SYSTEM ('echo " " `id`')
+ call flush
+
+ lognam = 'blahblahblah'
+ call getlog (lognam)
+ write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
+
+ wd = 'blahblahblah'
+ call getenv ('LOGNAME', wd)
+ write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
+
+ call umask(0, mask)
+ write(6,*) 'UMASK returns', mask
+ call umask(mask)
+
+ ctim = fdate()
+ write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
+ call fdate (ctim)
+ write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
+
+ j=time()
+ call ltime (j, ltarray)
+ write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
+ call gmtime (j, ltarray)
+ write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
+
+ call system_clock(count) ! omitting optional args
+ call system_clock(count, rate, count_max)
+ write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
+
+ call date_and_time(ddate) ! omitting optional args
+ call date_and_time(ddate, ttime, zone, values)
+ write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
+ + zone, ' ', values
+
+ write (6,*) 'Sleeping for 1 second (SLEEP) ...'
+ call sleep (1)
+
+c consistency-check etime vs. dtime for first call
+ r1 = etime (tarray1)
+ r2 = dtime (tarray2)
+ if (abs (r1-r2).gt.1.0) then
+ write (6,*)
+ + 'Results of ETIME and DTIME differ by more than a second:',
+ + r1, r2
+ call doabort
+ end if
+ if (.not. issum (r1, tarray1(1), tarray1(2))) then
+ write (6,*) '*** ETIME didn''t return sum of the array: ',
+ + r1, ' /= ', tarray1(1), '+', tarray1(2)
+ call doabort
+ end if
+ if (.not. issum (r2, tarray2(1), tarray2(2))) then
+ write (6,*) '*** DTIME didn''t return sum of the array: ',
+ + r2, ' /= ', tarray2(1), '+', tarray2(2)
+ call doabort
+ end if
+ write (6, '(A,3F10.3)')
+ + ' Elapsed total, user, system time (ETIME): ',
+ + r1, tarray1
+
+c now try to get times to change enough to see in etime/dtime
+ write (6,*) 'Looping until clock ticks at least once...'
+ do i = 1,1000
+ do j = 1,1000
+ end do
+ call dtime (tarray2, r2)
+ if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
+ end do
+ call etime (tarray1, r1)
+ if (.not. issum (r1, tarray1(1), tarray1(2))) then
+ write (6,*) '*** ETIME didn''t return sum of the array: ',
+ + r1, ' /= ', tarray1(1), '+', tarray1(2)
+ call doabort
+ end if
+ if (.not. issum (r2, tarray2(1), tarray2(2))) then
+ write (6,*) '*** DTIME didn''t return sum of the array: ',
+ + r2, ' /= ', tarray2(1), '+', tarray2(2)
+ call doabort
+ end if
+ write (6, '(A,3F10.3)')
+ + ' Differences in total, user, system time (DTIME): ',
+ + r2, tarray2
+ write (6, '(A,3F10.3)')
+ + ' Elapsed total, user, system time (ETIME): ',
+ + r1, tarray1
+ write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
+
+ call idate (i,j,k)
+ call idate (idat)
+ write (6,*) 'IDATE (date,month,year): ',idat
+ print *, '... and the VXT version (month,date,year): ', i,j,k
+ if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
+ print *, '*** VXT and U77 versions don''t agree'
+ call doabort
+ end if
+
+ call date (ctim)
+ write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
+
+ call itime (idat)
+ write (6,*) 'ITIME (hour,minutes,seconds): ', idat
+
+ call time(line(:8))
+ print *, 'TIME: ', line(:8)
+
+ write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
+
+ write (6,*) 'SECOND returns: ', second()
+ call dumdum(r1)
+ call second(r1)
+ write (6,*) 'CALL SECOND returns: ', r1
+
+* compiler crash fixed by 1998-10-01 com.c change
+ if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
+ write (6,*) '*** rand(0) error'
+ call doabort()
+ end if
+
+ i = getcwd(wd)
+ if (i.ne.0) then
+ call perror ('*** getcwd')
+ call doabort
+ else
+ write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
+ end if
+ call chdir ('.',i)
+ if (i.ne.0) then
+ write (6,*) '***CHDIR to ".": ', i
+ call doabort
+ end if
+
+ i=hostnm(wd)
+ if(i.ne.0) then
+ call perror ('*** hostnm')
+ call doabort
+ else
+ write (6,*) 'Host name is ', wd(:lenstr(wd))
+ end if
+
+ i = access('/dev/null ', 'rw')
+ if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
+ write (6,*) 'Creating file "foo" for testing...'
+ open (3,file='foo',status='UNKNOWN')
+ rewind 3
+ call fputc(3, 'c',i)
+ call fputc(3, 'd',j)
+ if (i+j.ne.0) write(6,*) '***FPUTC: ', i
+C why is it necessary to reopen? (who wrote this?)
+C the better to test with, my dear! (-- burley)
+ close(3)
+ open(3,file='foo',status='old')
+ call fseek(3,0,0,*10)
+ go to 20
+ 10 write(6,*) '***FSEEK failed'
+ call doabort
+ 20 call fgetc(3, c,i)
+ if (i.ne.0) then
+ write(6,*) '***FGETC: ', i
+ call doabort
+ end if
+ if (c.ne.'c') then
+ write(6,*) '***FGETC read the wrong thing: ', ichar(c)
+ call doabort
+ end if
+ i= ftell(3)
+ if (i.ne.1) then
+ write(6,*) '***FTELL offset: ', i
+ call doabort
+ end if
+ call ftell(3, i)
+ if (i.ne.1) then
+ write(6,*) '***CALL FTELL offset: ', i
+ call doabort
+ end if
+ call chmod ('foo', 'a+w',i)
+ if (i.ne.0) then
+ write (6,*) '***CHMOD of "foo": ', i
+ call doabort
+ end if
+ i = fstat (3, fstatb)
+ if (i.ne.0) then
+ write (6,*) '***FSTAT of "foo": ', i
+ call doabort
+ end if
+ i = stat ('foo', statb)
+ if (i.ne.0) then
+ write (6,*) '***STAT of "foo": ', i
+ call doabort
+ end if
+ write (6,*) ' with stat array ', statb
+ if (statb(6) .ne. getgid ()) then
+ write (6,*) 'Note: FSTAT gid wrong (happens on some systems).'
+ end if
+ if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
+ write (6,*) '*** FSTAT uid or nlink is wrong'
+ call doabort
+ end if
+ do i=1,13
+ if (fstatb (i) .ne. statb (i)) then
+ write (6,*) '*** FSTAT and STAT don''t agree on '// '
+ + array element ', i, ' value ', fstatb (i), statb (i)
+ call abort
+ end if
+ end do
+ i = lstat ('foo', fstatb)
+ do i=1,13
+ if (fstatb (i) .ne. statb (i)) then
+ write (6,*) '*** LSTAT and STAT don''t agree on '//
+ + 'array element ', i, ' value ', fstatb (i), statb (i)
+ call abort
+ end if
+ end do
+
+C in case it exists already:
+ call unlink ('bar',i)
+ call link ('foo ', 'bar ',i)
+ if (i.ne.0) then
+ write (6,*) '***LINK "foo" to "bar" failed: ', i
+ call doabort
+ end if
+ call unlink ('foo',i)
+ if (i.ne.0) then
+ write (6,*) '***UNLINK "foo" failed: ', i
+ call doabort
+ end if
+ call unlink ('foo',i)
+ if (i.eq.0) then
+ write (6,*) '***UNLINK "foo" again: ', i
+ call doabort
+ end if
+
+ call gerror (gerr)
+ i = ierrno()
+ write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
+ + i,
+ + ' and the corresponding message is:', gerr(:lenstr(gerr))
+ write (6,*) 'This is sent to stderr prefixed by the program name'
+ call getarg (0, line)
+ call perror (line (:lenstr (line)))
+ call unlink ('bar')
+
+ print *, 'MCLOCK returns ', mclock ()
+ print *, 'MCLOCK8 returns ', mclock8 ()
+
+ call cpu_time (d1)
+ print *, 'CPU_TIME returns ', d1
+
+C WRITE (6,*) 'You should see exit status 1'
+ CALL EXIT(0)
+ 99 END
+
+* Return length of STR not including trailing blanks, but always > 0.
+ integer function lenstr (str)
+ character*(*) str
+ if (str.eq.' ') then
+ lenstr=1
+ else
+ lenstr = lnblnk (str)
+ end if
+ end
+
+* Just make sure SECOND() doesn't "magically" work the second time.
+ subroutine dumdum(r)
+ r = 3.14159
+ end
+
+* Test whether sum is approximately left+right.
+ logical function issum (sum, left, right)
+ implicit none
+ real sum, left, right
+ real mysum, delta, width
+ mysum = left + right
+ delta = abs (mysum - sum)
+ width = abs (left) + abs (right)
+ issum = (delta .le. .0001 * width)
+ end
+
+* Signal handler
+ subroutine ctrlc
+ print *, 'Got ^C'
+ call doabort
+ end
+
+* A problem has been noticed, so maybe abort the test.
+ subroutine doabort
+* For this version, call the ABORT intrinsic.
+ intrinsic abort
+ call abort
+ end
+
+* Testsuite version only.
+* Don't actually reference the HOSTNM intrinsic, because some targets
+* need -lsocket, which we don't have a mechanism for supplying.
+ integer function hostnm(nm)
+ character*(*) nm
+ nm = 'not determined by this version of u77-test.f'
+ hostnm = 0
+ end
diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.x b/gcc/testsuite/g77.f-torture/execute/u77-test.x
new file mode 100644
index 00000000000..e4b89008c25
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/u77-test.x
@@ -0,0 +1,12 @@
+# Various intrinsics not implemented and not implementable; will fail at
+# link time.
+
+if { [istarget "mmix-knuth-mmixware"]
+ || [istarget "arm*-*-elf"]
+ || [istarget "strongarm*-*-elf"]
+ || [istarget "xscale*-*-elf"]
+ || [istarget "cris-*-elf"] } {
+ set torture_compile_xfail [istarget]
+}
+
+return 0
diff --git a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f
new file mode 100644
index 00000000000..0cc9087d6cb
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f
@@ -0,0 +1,89 @@
+* Resent-From: Craig Burley <burley@gnu.org>
+* Resent-To: craig@jcb-sc.com
+* X-Delivered: at request of burley on mescaline.gnu.org
+* Date: Wed, 16 Dec 1998 18:31:24 +0100
+* From: Dieter Stueken <stueken@conterra.de>
+* Organization: con terra GmbH
+* To: fortran@gnu.org
+* Subject: possible bug
+* Content-Type: text/plain; charset=iso-8859-1
+* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
+* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
+*
+* Hi,
+*
+* I'm about to compile a very old, very ugly Fortran program.
+* For one part I got:
+*
+* f77: Internal compiler error: program f771 got fatal signal 6
+*
+* instead of any detailed error message. I was able to break down the
+* problem to the following source fragment:
+*
+* -------------------------------------------
+ PROGRAM WAP
+
+ integer*2 ios
+ character*80 name
+
+ name = 'blah'
+ open(unit=8,status='unknown',file=name,form='formatted',
+ F iostat=ios)
+
+ END
+* -------------------------------------------
+*
+* The problem seems to be caused by the "integer*2 ios" declaration.
+* So far I solved it by simply using a plain integer instead.
+*
+* I'm running gcc on a Linux system compiled/installed
+* with no special options:
+*
+* -> g77 -v
+* g77 version 0.5.23
+* Driving: g77 -v -c -xf77-version /dev/null -xnone
+* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
+* gcc version 2.8.1
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
+* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
+* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
+* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
+* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
+* /dev/null
+* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
+* #include "..." search starts here:
+* #include <...> search starts here:
+* /usr/local/include
+* /usr/i686-pc-linux-gnulibc1/include
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
+* /usr/include
+* End of search list.
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
+* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
+* /dev/null
+* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
+* 2.8.1.
+* GNU Fortran Front End version 0.5.23
+* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
+* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
+* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
+* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
+* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
+* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
+* /usr/lib/crtn.o
+* /tmp/cca24911
+* __G77_LIBF77_VERSION__: 0.5.23
+* @(#)LIBF77 VERSION 19970919
+* __G77_LIBI77_VERSION__: 0.5.23
+* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
+* __G77_LIBU77_VERSION__: 0.5.23
+* @(#) LIBU77 VERSION 19970919
+*
+*
+* Regards, Dieter.
+* --
+* Dieter Stüken, con terra GmbH, Münster
+* stueken@conterra.de stueken@qgp.uni-muenster.de
+* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken
+* (0)251-980-2027 (0)251-83-334974
diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f
new file mode 100644
index 00000000000..25b7c5b2b52
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f
@@ -0,0 +1,13 @@
+ double precision function fun(a,b)
+ double precision a,b
+ print*,'in sub: a,b=',a,b
+ fun=a*b
+ print*,'in sub: fun=',fun
+ return
+ end
+ program test
+ double precision a,b,c
+ data a,b/1.0d-46,1.0d0/
+ c=fun(a,b)
+ print*,'in main: fun=',c
+ end
diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f
new file mode 100644
index 00000000000..86d2a939064
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f
@@ -0,0 +1,648 @@
+* Culled from 970528-1.f in Burley's g77 test suite. Copyright
+* status not clear. Feel free to chop down if the bug is still
+* reproducible (see end of test case for how bug shows up in gdb
+* run of f771). No particular reason it should be a noncompile
+* case, other than that I didn't want to spend time "fixing" it
+* to compile cleanly (with -O0, which works) while making sure the
+* ICE remained reproducible. -- burley 1999-08-26
+
+* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200)
+* From: "D. O'Donoghue" <dod@da.saao.ac.za>
+* To: Craig Burley <burley@gnu.ai.mit.edu>
+* Cc: fortran@gnu.ai.mit.edu
+* Subject: Re: g77 problems
+
+ program dophot
+ parameter (napple = 4)
+ common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50)
+ common/io/luout,ludebg
+ common/search/nstot,thresh
+ common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1,
+ + mfit2,ind(npmax)
+ common /starlist/ starpar(npmax,nsmax), imtype(nsmax),
+ 1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax)
+ common /aperlist/ apple(napple ,nsmax)
+ common /parpred / ava(npmax)
+ common /unitize / ufactor
+ common /undergnd/ nfast, nslow
+ common/bzero/ scale,zero
+ common /ctimes / chiimp, apertime, filltime, addtime
+ common / drfake / needit
+ common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim
+ common /vers/ version
+ logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy
+ logical fixed,piped,debug,ex,clinfo
+ character header*5760,rhead*2880
+ character yn*1,version*40,ccd*4,infile*20
+ character*30 numf,odir,record*80
+ integer*2 instr(8)
+ character*800 line
+ external pseud0d, pseud2d, pseud4d, pseudmd, shape
+C
+C Initialization
+ data burn, fixedxy,fixed, piped
+ + /.false.,.false.,.false.,.false./
+ data needit,screen,comd,isub
+ + /.true.,.false.,.true.,.false. /
+ data acc / .01, -.03, -.03, .01, .03, .1, .03 /
+ data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 /
+C
+ version = 'DoPHOT Version 1.0 LINUX May 97 '
+ debug=.false.
+ clinfo=.false.
+ line(1:800) = ' '
+ odir = ' '
+C
+C
+C Read default tuneable parameters
+ call tuneup ( nccd, ccd, piped, debug )
+ version(33:36) = ccd(1:4)
+C
+
+ ludebg=6
+ if(piped)then
+ yn='n'
+ else
+ write(*,'(''****************************************'')')
+ write(*,1000) version
+ write(*,'(''****************************************''//)')
+C
+ write(*,'(''Screen output (y/[n])? '',$)')
+ read(*,1000) yn
+ end if
+ if(yn.eq.'y'.or.yn.eq.'Y') then
+ screen=.true.
+ luout=6
+ else
+ luout=2
+ end if
+C
+ if(piped)then
+ yn='y'
+ else
+ write(*,'(''Batch mode ([y]/n)? '',$)')
+ read(*,1000) yn
+ end if
+ if(yn.eq.'n'.or.yn.eq.'N') comd = .false.
+C
+ if(.not.comd) then
+ write(*,
+ * '(''Do you want windowing ([y]/n)? '',$)')
+ read(*,1000)yn
+ iwindo=1
+ if(yn.eq.'n'.or.yn.eq.'N')then
+ nwindo=0
+ iwindo=0
+ end if
+C
+ write(*,
+ * '(''Star classification info (y/[n]) ?'',$)')
+ read(*,1000)yn
+ clinfo=.false.
+ if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true.
+C
+ write(*,
+ * '(''Create a star-subtracted frame (y/[n])? '',$)')
+ read(*,1000) yn
+ if(yn.eq.'y'.or.yn.eq.'Y') isub = .true.
+C
+ write(*,'(''Apply after-burner (y/[n])? '',$)')
+ read(*,1000) yn
+ if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true.
+ wrtres = burn
+C
+ write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
+ read(*,1000) yn
+ if ( yn.eq.'y'.or.yn.eq.'Y' ) then
+ fixedxy = .true.
+ fixed = .true.
+ burn = .true.
+ wrtres = .true.
+ endif
+ endif
+ iopen=0
+C
+C This is the start of the loop over the input files
+c
+ iframe=0
+ open(10,file='timing',status='unknown',access='append')
+
+1 ifit = 0
+ iapr = 0
+ itmn = 0
+ model = 1
+ xc = 0.0
+ yc = 0.0
+ rc = 0.0
+ ibr = 0
+ ixy = 0
+C
+ iframe=iframe+1
+ tgetpar=0.0
+ tsearch=0.0
+ tshape=0.0
+ timprove=0.0
+C
+C Batch mode ...
+
+ if ( comd ) then
+ if(iopen.eq.0)then
+ iopen=1
+ open(11,file='dophot.bat',status='old',err=995)
+ end if
+ read(11,1000,end=999)infile
+c now read in the parameter instructions. these are:
+c instr(1) : if 1, specifies uncrowded field, otherwise crowded
+c instr(2) : if 1, specifies sequential frames of same field
+c with a window around the stars of interest -
+c all other objects are ignored
+c instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
+c if>0, sets cmin=instr(3)
+c instr(4) : if 0, does nothing
+c if 1, then opens a file called classifications
+c sets clinfo to .true. and writes out the star
+c typing info to this file
+c instr(5) : Delete the shd.nnnnnnn file
+c instr(6) : Delete the out.nnnnnnn file
+c instr(7) : Delete the input frame
+c instr(8) : Create a star-subtracted frame
+ read(11,*)instr
+ read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy
+ nocrwd = instr(1)
+ iwindo=instr(2)
+ if(iwindo.eq.0)nwindo=0
+ itmn=tmn
+ if ( instr(3).gt.0 ) cmin=instr(3)
+ clinfo=.false.
+ if ( instr(4).gt.0 )then
+ clinfo=.true.
+ open(12,file='classifications',status='unknown')
+ ludebg=12
+ end if
+ if ( instr(8).ne.0 ) then
+ isub = .true.
+ else
+ isub = .false.
+ endif
+C
+ if(ibr.ne.0) burn = .true.
+ if(ixy.ne.0) then
+ fixedxy = .true.
+ fixed = .true.
+ burn = .true.
+ goto 20
+ endif
+ if(iwindo.eq.0)then
+ write(6,10)iframe,infile(1:15)
+ 10 format(' ***** DoPHOT-ing frame ',i4,': ',a)
+ if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15)
+ 11 format(////' ',62('*')/
+ * ' * DoPHOT-ing frame ',i4,': ',a,
+ * ' *'/' ',62('*'))
+ end if
+ if(iwindo.eq.1)then
+ write(6,12)iframe,infile(1:15)
+ 12 format(' ***** DoPHOT-ing frame ',i4,': ',a,
+ * ' - Windowed *****')
+ if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15)
+ 13 format(////' ',62('*')/
+ * ' * DoPHOT-ing frame ',i4,': ',a,
+ * ' - Windowed *'/2x,62('*'))
+ end if
+C
+C Interactive...
+ else
+ write(*,'(''Image name: '',$)')
+ read(*,1000) infile
+ if(infile(1:1).eq.' ') goto 999
+1000 format(a)
+ write(*,'(''Crowded field mode ([y]/n) ? '',$)')
+ read(*,1000)yn
+ nocrwd=0
+ if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1
+ if(.not.fixed) then
+ write(*,1001)
+1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$)
+ read(*,1000)record
+ if(record.ne.' ')then
+ read(record,*) model
+ else
+ model=1
+ end if
+ else
+ burn=.true.
+ goto 20
+ endif
+ endif
+C
+C if windowing, open the file and read the window
+ if(iwindo.eq.1)then
+ inquire(file='windows',exist=ex)
+ if(.not.ex)go to 997
+ if(iframe.eq.1)open(9,file='windows',status='old')
+ nwindo=0
+ 2 read(9,*,end=3)intype,inx,iny,inbox
+ nwindo=nwindo+1
+ if(nwindo.gt.50)then
+ print *,'too many windows - max = 50'
+ stop
+ end if
+ ixwin(nwindo)=inx
+ iywin(nwindo)=iny
+ iboxwin(nwindo)=inbox
+ itype(nwindo)=intype
+ go to 2
+
+ 3 rewind 9
+ if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j),
+ * j=1,nwindo)
+ 4 format(' Windows: Type X Y Size'/
+ * (I13,i6,i5,i5))
+ end if
+
+ t1 = cputime(0.0)
+C
+C Read FITS frame.
+ call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd)
+C
+C Ignore frame if not the correct chip
+ if(nc.lt.0) goto 900
+C
+C Estimate starting PSF parameters.
+ 15 call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax,
+ * iframe)
+ tgetpar = cputime(t1) + tgetpar
+ if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax
+ 16 format(' Getparams on frame ',i4,' sky ',f6.1,' gxwid ',f5.1,
+ * ' gywid ',f5.1,' tmin ',f5.1,' tmax ',f5.1)
+C
+C Initialize
+ do j=1,nsmax
+ imtype(j) = 0
+ do i=1,npmax
+ shadow(i,j)=0.
+ shaderr(i,j)=0.
+ enddo
+ enddo
+C
+ skyguess=skyval
+ tfac = 1.0
+C Use 4.5 X SD as fitting width
+ fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5
+ i=fitr
+ irect(1)=i
+ irect(2)=fitr/asprat
+C Use 4/3 X FitFac X SD as aperture width
+ gmax = asprat*gywid
+ if(gxwid.gt.gmax) gmax=gxwid
+ aprw = 1.33*fitfac*sqrt(gmax) + 0.5
+ i = aprw
+ arect(1) = i
+ i = aprw/asprat + 0.1
+ arect(2) = i
+C
+ if(irect(1).gt.50) irect(1)=50
+ if(irect(2).gt.50) irect(2)=50
+ if(arect(1).gt.45.) arect(1)=45.
+ if(arect(2).gt.45.) arect(2)=45.
+C
+ if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon)
+C
+C Prompt for further information
+ if ( .not.comd ) then
+ write(*,1002)
+ 1002 format(/'The above are the inital parameters DoPHOT'/
+ * 'has found. You can change them now or accept'/
+ * 'the values in [ ] by pressing enter'/)
+
+ write(*,1004)tmin
+ 1004 format('Enter Tmin: threshold for star detection',
+ * ' [',f5.1,'] ',$)
+ read(*,1000)record
+ if(record.ne.' ')read(record,*)tmin
+
+ write(*,1005)cmin
+ 1005 format('Enter Cmin: threshold for PSF stars',
+ * ' [',f5.1,'] ',$)
+ read(*,1000)record
+ if(record.ne.' ')read(record,*)cmin
+
+ write(*,1006)
+ 1006 format('Do you want to fix the aperture mag size ?',
+ * ' (y/[n]) ')
+ read(*,1000)record
+ if(record.eq.'y'.or.record.eq.'Y')then
+ write(*,1007)
+ 1007 format('Enter the size in pixels: ',$)
+ read(*,*)iapr
+ if(iapr.gt.0) then
+ arect(1)=iapr
+ i = iapr/asprat + 0.1
+ arect(2)=i
+ end if
+ endif
+C
+ write(*,1008)
+ 1008 format('Satisfied with other input parameters ? ([y]/n)?',$)
+ read(*,1000) yn
+ if(yn.eq.'n'.or.yn.eq.'N')then
+ yn='n'
+ else
+ yn='y'
+ end if
+ if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input
+ else
+ if ( ifit.ne.0 ) then
+ irect(1)=ifit
+ irect(2)=(ifit/asprat + 0.1)
+ endif
+ if ( iapr.ne.0 ) then
+ arect(1)=iapr
+ i = iapr/asprat + 0.1
+ arect(2)=i
+ endif
+ if ( itmn.ne.0 ) tmin = itmn
+ if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then
+ xcen = xc
+ ycen = yc
+ endif
+ endif
+C
+C--------------------------------
+C
+C
+ call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+ +nfast, nslow )
+C
+C if the uncrowded field option has been chosen, jump
+C straight to the minimum threshold
+C
+ if(nocrwd.eq.1)tmax=tmin
+C
+C Adjust tfac so that thresh ends precisely on Tmin.
+ if(tmin/tmax .gt. 0.999) then
+ thresh = tmin
+ tfac = 1.
+ else
+ thresh = tmax
+ xnum = alog10(tmax/tmin)/alog10(2.**tfac)
+ if(xnum.gt.1.5) then
+ xnum = float(nint(xnum))
+ else if(xnum.ge.1) then
+ xnum = 2.0
+ else
+ xnum = 1.0
+ endif
+ tfac = alog10(tmax/tmin)/alog10(2.)/xnum
+ endif
+C
+C------------------------------------------------------------------------
+C
+C This is the BIG LOOP which searches the frame for stars
+C with intensities > thresh.
+C
+C-----------------------------------------------------------------------
+C
+ loop = .true.
+ nstot = 0
+ do while ( loop )
+ loop = thresh/tmin .ge. 1.01
+ write(luout,1050) thresh
+1050 format(/20('-')/'THRESHOLD: ', f10.3)
+ if(ludebg.eq.12)write(ludebg,1050) thresh
+C
+C Fit given model to sky values.
+C
+ call varipar(nstot, nfast, nslow )
+ t1 = cputime(0.0)
+C
+C Identifies potential objects in cleaned array IMG
+ nstar = isearch( pseud2d, nfast, nslow , clinfo)
+ tsearch = cputime(t1) + tsearch
+C
+ if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then
+C
+C Performs 7-parameter PSF fit and determines nature of object.
+ t1 = cputime(0.0)
+ call shape(pseud2d,pseud4d,nfast,nslow,clinfo)
+ tshape = cputime(t1) + tshape
+C
+C Computes average sky values etc from star list
+ call paravg
+ t1 = cputime(0.0)
+C
+C Computes 4-parameter fits for all stellar objects using
+C new average shape parameters.
+ call improve(pseud2d,nfast,nslow,clinfo)
+ timprove = cputime(t1) + timprove
+ end if
+C
+C Calculate aperture photometry on last pass.
+ if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow )
+C
+ totaltime = (tgetpar+tsearch+tshape+timprove)
+ write(3,1060) totaltime
+ write(4,1060) totaltime
+ write(luout,1060) totaltime
+1060 format('Total CPU time consumed:',F10.2,' seconds.')
+ write(10,1070)infile,tgetpar,tsearch,tshape,timprove,
+ * totaltime
+1070 format(a20,' T(getp/f)',f5.1,' T(search)',f5.1,
+ * ' T(shape)',f5.1,' T(improve)',f5.1,
+ * ' Total',f6.1)
+ call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums)
+ rewind(2)
+ rewind(3)
+ rewind(4)
+C
+ call output ( line )
+C
+C Now reduce the threshold and loop back
+C
+ thresh = thresh/2.**tfac
+ end do
+C
+C--------- END OF BIG LOOP ---------------------------------------
+C
+C If after-burner required, residuals from analytic PSF are computed
+C and stored in RES.
+C
+20 if ( burn ) then
+C
+C If using a fixed (X,Y) coordinate list, read it.
+ if (fixed) then
+C Read the image frame
+ call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line)
+C
+C Initialize arrays, open files etc.
+ call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+ +nfast, nslow )
+C
+C Read the XY list
+ write(luout,'(''Reading XY list ...'')')
+ call xylist(numf, nc, ios )
+ if(ios.ne.0) then
+ fixed = .false.
+ write(luout,'(''SXY file absent or incorrect...'')')
+ goto 15
+ endif
+C
+ call htype(line,skyval,.false.,fitr,ngr,ncon)
+C
+C Remove good stars
+ write(luout,'(''Cleaning frame of stars: '',i8)') nstot
+ call clean ( pseud2d, nstot, nfast, nslow, -1)
+C
+C Calculate aperture photometry
+C call aper ( pseud2d, nstot, nfast, nslow )
+ else
+ rewind(3)
+ rewind(4)
+ endif
+C
+C-----------------------
+C Flag all stars close together in groups. Keep making the distance
+C criterion FITR smaller until the maximum number in a group is less
+C than NFMAX
+C
+ fitr = amax1(arect(1),arect(2))
+ fitr = fitr + 2.0
+ nmax = 10000
+ write(*,'(''Regrouping ...'')')
+C
+ do while ( nmax.gt.nfmax )
+ fitr = fitr - 1.0
+ write(luout,'(''Min distance ='',f8.1)') fitr
+ call regroup( fitr, ngr, nmax )
+ enddo
+C
+ xlim = irect(1)/2
+ ylim = irect(2)/2
+C
+C Calculate normalized PSF residual from PSEUD2D
+ call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect,
+ +arect,ztot,nums)
+ if(nums.eq.0) then
+ write(luout,'(''No suitable PSF stars!'')')
+ goto 30
+ endif
+C
+ write(luout,'(/''AFTERBURNER tuned ON!'')')
+C
+C Fit multiple stars in a group with enhanced PSF using box size IRECT.
+ call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect )
+C
+C Re-calculate aperture photometry
+ call aperm ( pseudmd, nstot, nfast, nslow )
+C
+ call skyadj ( nstot )
+C
+ call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums)
+ call output ( line )
+ endif
+C---------------------
+C
+C----- This section skipped if PSF residual not written out ------
+C
+30 if( isub ) then
+C
+C Write final Cleaned array.
+ infile = 'x'//numf(1:nc)//'.fits'
+ call putfits(2,infile,header,nhead,nfast,nslow)
+ close(2)
+C
+C If afterburner used, then residual array also written out.
+C Find suitable scale for writing residual PSF to FITS "R" file.
+C
+ if ( wrtres ) then
+ scale=20000.0/(rmx-rmn)
+ zero=-scale*rmn
+ do j=-nres,nres
+ jj=nres+j+1
+ do i=-nres,nres
+ ii=nres+i+1
+ big(ii,jj)=scale*res(i,j)+zero
+ enddo
+ enddo
+ nx=2*nres+1
+C
+ infile = 'r'//numf(1:nc)//'.fits'
+ zer=-zero/scale
+ scl=1.0/scale
+C
+C Create a FITS header for the normalized PSF residual image
+ call sethead(rhead,numf,nx,nx,zer,scl)
+ scale=1.0
+ zero=0.0
+C Write the normalized PSF residual image
+ call putfits(2,infile,rhead,1,nx,nx)
+ close(2)
+ endif
+C
+ end if
+C
+C
+900 close(1)
+ close(3)
+ close(4)
+ if ( .not.screen ) close(luout)
+ if(comd) then
+ if(instr(5).eq.1)call system('rm shd.'//numf(1:nc))
+ if(instr(6).eq.1)call system('rm out.'//numf(1:nc))
+ n=1
+ do while(infile(n:n).ne.' ')
+ n=n+1
+ end do
+ if(instr(7).eq.1)call system('rm '//infile(1:n-1))
+ end if
+ fixed = fixedxy
+ goto 1
+C
+995 print 996
+996 format(/'*** Fatal error ***'/
+ * 'You asked for batch processing but'/
+ * 'I cant open the "dophot.bat" file.'/
+ * 'Please make one (using batchdophot)'/
+ * 'and restart DoPHOT'/)
+ go to 999
+
+C
+997 print 998
+998 format(/'*** Fatal error ***'/
+ * 'You asked for "windowed" processing'/
+ * 'but I cant open the "windows" file.'/
+ * 'Please make one and restart DoPHOT'/)
+
+999 call exit(0)
+ end
+
+* (gdb) r
+* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O
+* [...]
+* Breakpoint 2, fancy_abort (
+* file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399,
+* function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010
+* (gdb) up
+* #1 0x8222fab in output_fp_cc0_set (insn=0x8382324)
+* at ../../g77-e/gcc/config/i386/i386.c:4399
+* (gdb) p insn
+* $1 = 0x3a
+* (gdb) up
+* #2 0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60)
+* at ../../g77-e/gcc/config/i386/i386.c:4205
+* (gdb) p insn
+* $2 = 0x8382324
+* (gdb) whatis insn
+* type = rtx
+* (gdb) pr
+* (insn 2181 2180 2191 (parallel[
+* (set (cc0)
+* (compare (reg:SF 8 %st(0))
+* (mem:SF (plus:SI (reg:SI 6 %ebp)
+* (const_int -9948 [0xffffd924])) 0)))
+* (clobber (reg:HI 0 %ax))
+* ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil)))
+* (expr_list:REG_DEAD (reg:DF 8 %st(0))
+* (expr_list:REG_UNUSED (reg:HI 0 %ax)
+* (nil))))
+* (gdb)
diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f
new file mode 100644
index 00000000000..026d05e4b3c
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f
@@ -0,0 +1,8 @@
+* =foo7.f in Burley's g77 test suite.
+ subroutine x
+ real a(n)
+ common /foo/n
+ continue
+ entry y(a)
+ call foo(a(1))
+ end
diff --git a/gcc/testsuite/g77.f-torture/noncompile/9263.f b/gcc/testsuite/g77.f-torture/noncompile/9263.f
new file mode 100644
index 00000000000..e68b3e0a65f
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/9263.f
@@ -0,0 +1,7 @@
+ PARAMETER (Q=1)
+ PARAMETER (P=10)
+ INTEGER C(10),D(10),E(10),F(10)
+ DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER
+ DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER
+ DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER
+ END
diff --git a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f
new file mode 100644
index 00000000000..c1e2348646f
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f
@@ -0,0 +1,4 @@
+ SUBROUTINE A(A,ALPHA,IA)
+ COMPLEX A(IA,*), ALPHA(*)
+ ALPHA(I)=A(I,I).ZERO)
+ END
diff --git a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f
new file mode 100644
index 00000000000..316969f6aa8
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f
@@ -0,0 +1,10 @@
+* Fixed by JCB 1998-07-25 change to stc.c.
+
+* Date: Thu, 11 Jun 1998 22:35:20 -0500
+* From: Ian A Watson <WATSON_IAN_A@lilly.com>
+* Subject: crash
+*
+ CaLL foo(W)
+ END
+ SUBROUTINE foo(W)
+ yy(I)=A(I)Q(X)
diff --git a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f
new file mode 100644
index 00000000000..bd5e74022a3
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f
@@ -0,0 +1,8 @@
+* Fixed by 1998-07-11 equiv.c change.
+* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER'
+
+* Date: Mon, 15 Jun 1998 21:54:32 -0500
+* From: Ian A Watson <WATSON_IAN_A@lilly.com>
+* Subject: Mangler Crash
+ EQUIVALENCE(I,glerf(P))
+ COMMON /foo/ glerf(3)
diff --git a/gcc/testsuite/g77.f-torture/noncompile/check0.f b/gcc/testsuite/g77.f-torture/noncompile/check0.f
new file mode 100644
index 00000000000..fc3c6ca730e
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/check0.f
@@ -0,0 +1,11 @@
+CCC Abort fixed by:
+CCC1998-04-21 Jim Wilson <wilson@cygnus.com>
+CCC
+CCC * stmt.c (check_seenlabel): When search for line number note for
+CCC warning, handle case where there is no such note.
+ logical l(10)
+ integer i(10)
+ goto (10,20),l
+ goto (10,20),i
+ 10 stop
+ 20 end
diff --git a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp
new file mode 100644
index 00000000000..fadd1fbbe5a
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp
@@ -0,0 +1,36 @@
+# Copyright (C) 1988, 90, 91, 92, 97, 1998 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# This file was written by Jeff Law. (law@cs.utah.edu)
+
+#
+# These tests come from Torbjorn Granlund (tege@cygnus.com)
+# C torture test suite.
+#
+
+load_lib mike-g77.exp
+
+# Test check0.f
+prebase
+
+set src_code check0.f
+# Not really sure what the error should be here...
+set compiler_output ".*:8.*:9"
+
+set groups {passed gcc-noncompile}
+
+postbase $src_code $run $groups
+
diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
new file mode 100644
index 00000000000..f7dad339a81
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
@@ -0,0 +1,10 @@
+ integer*1 one
+ integer*2 two
+ parameter (one=1)
+ parameter (two=2)
+ select case (I)
+ case (one)
+ case (two)
+ end select
+ end
+