diff options
Diffstat (limited to 'gcc/testsuite/g77.f-torture/noncompile/19990826-4.f')
| -rw-r--r-- | gcc/testsuite/g77.f-torture/noncompile/19990826-4.f | 648 |
1 files changed, 648 insertions, 0 deletions
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) |