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