--- /dev/null
+* 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
+
+* 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
+
+ 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)
projects / gcc.git / commitdiff