1 * Culled from
970528-1.f in Burley
's g77 test suite. Copyright
2 * status not clear. Feel free to chop down if the bug is still
3 * reproducible (see end of test case for how bug shows up in gdb
4 * run of f771). No particular reason it should be a noncompile
5 * case, other than that I didn't want
to spend time
"fixing" it
6 * to compile cleanly
(with
-O0
, which works
) while making sure the
7 * ICE remained reproducible
. -- burley
1999-08-26
9 * Date: Mon
, 26 May
1997 13:00:19 +0200 (GMT
+0200)
10 * From
: "D. O'Donoghue" <dod@da
.saao
.ac
.za
>
11 * To: Craig Burley
<burley@gnu
.ai
.mit
.edu
>
12 * Cc
: fortran@gnu
.ai
.mit
.edu
13 * Subject
: Re
: g77 problems
16 parameter (napple
= 4)
17 common /window
/nwindo
,ixwin
(50),iywin
(50),iboxwin
(50),itype
(50)
18 common/io
/luout
,ludebg
19 common/search
/nstot
,thresh
20 common /fitparms
/ acc
(npmax
),alim
(npmax
),mit
,mpar
,mfit1
,
22 common /starlist
/ starpar
(npmax
,nsmax
), imtype
(nsmax
),
23 1shadow
(npmax
,nsmax
),shaderr
(npmax
,nsmax
),idstr
(nsmax
)
24 common /aperlist
/ apple
(napple
,nsmax
)
25 common /parpred
/ ava
(npmax
)
26 common /unitize
/ ufactor
27 common /undergnd
/ nfast
, nslow
28 common/bzero
/ scale
,zero
29 common /ctimes
/ chiimp
, apertime
, filltime
, addtime
30 common / drfake
/ needit
31 common /mfit
/ psfpar
(npmax
),starx
(nfmax
),stary
(nfmax
),xlim
,ylim
33 logical needit
,screen
,isub
,loop
,comd
,burn
,wrtres
,fixedxy
34 logical fixed
,piped
,debug
,ex
,clinfo
35 character header*5760
,rhead*2880
36 character yn*1
,version*40
,ccd*4
,infile*20
37 character*30 numf
,odir
,record*80
40 external pseud0d
, pseud2d
, pseud4d
, pseudmd
, shape
43 data burn
, fixedxy
,fixed
, piped
44 + /.false
.,.false
.,.false
.,.false
./
45 data needit
,screen
,comd
,isub
46 + /.true
.,.false
.,.true
.,.false
. /
47 data acc
/ .01, -.03, -.03, .01, .03, .1, .03 /
48 data alim
/ -1.0e8
, 2*-1.0e3
, -1.0e8
, 3*-1.0e3
/
50 version
= 'DoPHOT Version 1.0 LINUX May 97 '
57 C Read default tuneable parameters
58 call tuneup
( nccd
, ccd
, piped
, debug
)
59 version
(33:36) = ccd
(1:4)
66 write(*,'(''****************************************'')')
68 write(*,'(''****************************************''//)')
70 write(*,'(''Screen output (y/[n])? '',$)')
73 if(yn
.eq
.'y'.or
.yn
.eq
.'Y') then
83 write(*,'(''Batch mode ([y]/n)? '',$)')
86 if(yn
.eq
.'n'.or
.yn
.eq
.'N') comd
= .false
.
90 * '(''Do you want windowing ([y]/n)? '',$)')
93 if(yn
.eq
.'n'.or
.yn
.eq
.'N')then
99 * '(''Star classification info (y/[n]) ?'',$)')
102 if(yn
.eq
.'y'.or
.yn
.eq
.'Y')clinfo
=.true
.
105 * '(''Create a star-subtracted frame (y/[n])? '',$)')
107 if(yn
.eq
.'y'.or
.yn
.eq
.'Y') isub
= .true
.
109 write(*,'(''Apply after-burner (y/[n])? '',$)')
111 if ( yn
.eq
.'y'.or
.yn
.eq
.'Y' ) burn
= .true
.
114 write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
116 if ( yn
.eq
.'y'.or
.yn
.eq
.'Y' ) then
125 C This is the start of the loop over the input files
128 open
(10,file
='timing',status
='unknown',access
='append')
151 open
(11,file
='dophot.bat',status
='old',err
=995)
153 read(11,1000,end=999)infile
154 c now read in the parameter instructions. these are:
155 c instr(1) : if 1, specifies uncrowded field, otherwise crowded
156 c instr(2) : if 1, specifies sequential frames of same field
157 c with a window around the stars of interest -
158 c all other objects are ignored
159 c instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
160 c if>0, sets cmin=instr(3)
161 c instr(4) : if 0, does nothing
162 c if 1, then opens a file called classifications
163 c sets clinfo to .true. and writes out the star
164 c typing info to this file
165 c instr(5) : Delete the shd.nnnnnnn file
166 c instr(6) : Delete the out.nnnnnnn file
167 c instr(7) : Delete the input frame
168 c instr(8) : Create a star-subtracted frame
170 read(11,*)ifit
,iapr
,tmn
,model
,xc
,yc
,rc
,ibr
,ixy
173 if(iwindo
.eq
.0)nwindo
=0
175 if ( instr
(3).gt
.0 ) cmin
=instr
(3)
177 if ( instr
(4).gt
.0 )then
179 open
(12,file
='classifications',status
='unknown')
182 if ( instr
(8).ne
.0 ) then
188 if(ibr
.ne
.0) burn
= .true
.
196 write(6,10)iframe
,infile
(1:15)
197 10 format(' ***** DoPHOT-ing frame ',i4
,': ',a
)
198 if(ludebg
.eq
.12)write(ludebg
,11)iframe
,infile
(1:15)
199 11 format(////' ',62('*')/
200 * ' * DoPHOT-ing frame ',i4
,': ',a
,
204 write(6,12)iframe
,infile
(1:15)
205 12 format(' ***** DoPHOT-ing frame ',i4
,': ',a
,
206 * ' - Windowed *****')
207 if(ludebg
.eq
.12)write(ludebg
,13)iframe
,infile
(1:15)
208 13 format(////' ',62('*')/
209 * ' * DoPHOT-ing frame ',i4
,': ',a
,
210 * ' - Windowed *'/2x
,62('*'))
215 write(*,'(''Image name: '',$)')
217 if(infile
(1:1).eq
.' ') goto 999
219 write(*,'(''Crowded field mode ([y]/n) ? '',$)')
222 if(yn
.eq
.'n'.or
.yn
.eq
.'N')nocrwd
=1
225 1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$
)
227 if(record
.ne
.' ')then
238 C if windowing, open the file and read the window
240 inquire
(file
='windows',exist
=ex
)
242 if(iframe
.eq
.1)open
(9,file
='windows',status
='old')
244 2 read(9,*,end=3)intype
,inx
,iny
,inbox
247 print
*,'too many windows - max = 50'
252 iboxwin
(nwindo
)=inbox
257 if(screen
)print
4,(itype
(j
),ixwin
(j
),iywin
(j
),iboxwin
(j
),
259 4 format(' Windows: Type X Y Size'/
266 call getfits
(1,infile
,header
,nhead
,nfast
,nslow
,numf
,nc
,line
,ccd
)
268 C Ignore frame if not the correct chip
271 C Estimate starting PSF parameters.
272 15 call getparams
(nfast
,nslow
,gxwid
,gywid
,skyval
,tmin
,tmax
,
274 tgetpar
= cputime
(t1
) + tgetpar
275 if(debug
)write(ludebg
,16)iframe
,skyval
,gxwid
,gywid
,tmin
,tmax
276 16 format(' Getparams on frame ',i4
,' sky ',f6
.1
,' gxwid ',f5
.1
,
277 * ' gywid ',f5
.1
,' tmin ',f5
.1
,' tmax ',f5
.1
)
290 C Use 4.5 X SD as fitting width
291 fitr
=fitfac*
(gxwid*asprat*gywid
)**0.25 + 0.5
295 C Use 4/3 X FitFac X SD as aperture width
297 if(gxwid
.gt
.gmax
) gmax
=gxwid
298 aprw
= 1.33*fitfac*sqrt
(gmax
) + 0.5
301 i
= aprw
/asprat
+ 0.1
304 if(irect
(1).gt
.50) irect
(1)=50
305 if(irect
(2).gt
.50) irect
(2)=50
306 if(arect
(1).gt
.45.) arect
(1)=45.
307 if(arect
(2).gt
.45.) arect
(2)=45.
309 if (screen
) call htype
(line
,skyval
,.false
.,fitr
,ngr
,ncon
)
311 C Prompt for further information
312 if ( .not
.comd
) then
314 1002 format(/'The above are the inital parameters DoPHOT'/
315 * 'has found. You can change them now or accept'/
316 * 'the values in [ ] by pressing enter'/)
319 1004 format('Enter Tmin: threshold for star detection',
322 if(record
.ne
.' ')read(record
,*)tmin
325 1005 format('Enter Cmin: threshold for PSF stars',
328 if(record
.ne
.' ')read(record
,*)cmin
331 1006 format('Do you want to fix the aperture mag size ?',
334 if(record
.eq
.'y'.or
.record
.eq
.'Y')then
336 1007 format('Enter the size in pixels: ',$
)
340 i
= iapr
/asprat
+ 0.1
346 1008 format('Satisfied with other input parameters ? ([y]/n)?',$
)
348 if(yn
.eq
.'n'.or
.yn
.eq
.'N')then
353 if(.not
.(yn
.eq
.'y'.or
.yn
.eq
.'Y') ) call input
355 if ( ifit
.ne
.0 ) then
357 irect
(2)=(ifit
/asprat
+ 0.1)
359 if ( iapr
.ne
.0 ) then
361 i
= iapr
/asprat
+ 0.1
364 if ( itmn
.ne
.0 ) tmin
= itmn
365 if ( .not
.(xc
.eq
.0.0.and
.yc
.eq
.0.0) ) then
371 C--------------------------------
374 call setup
( numf
,nc
,screen
,line
,skyval
,fitr
,ngr
,ncon
,
377 C if the uncrowded field option has been chosen, jump
378 C straight to the minimum threshold
380 if(nocrwd
.eq
.1)tmax
=tmin
382 C Adjust tfac so that thresh ends precisely on Tmin.
383 if(tmin
/tmax
.gt
. 0.999) then
388 xnum
= alog10
(tmax
/tmin
)/alog10
(2.**tfac
)
390 xnum
= float
(nint
(xnum
))
391 else if(xnum
.ge
.1) then
396 tfac
= alog10
(tmax
/tmin
)/alog10
(2.)/xnum
399 C------------------------------------------------------------------------
401 C This is the BIG LOOP which searches the frame for stars
402 C with intensities > thresh.
404 C-----------------------------------------------------------------------
409 loop
= thresh
/tmin
.ge
. 1.01
410 write(luout
,1050) thresh
411 1050 format(/20('-')/'THRESHOLD: ', f10
.3
)
412 if(ludebg
.eq
.12)write(ludebg
,1050) thresh
414 C Fit given model to sky values.
416 call varipar
(nstot
, nfast
, nslow
)
419 C Identifies potential objects in cleaned array IMG
420 nstar
= isearch
( pseud2d
, nfast
, nslow
, clinfo
)
421 tsearch
= cputime
(t1
) + tsearch
423 if ( (nstar
.ne
. 0).or
.(xnum
.lt
.1.5) ) then
425 C Performs 7-parameter PSF fit and determines nature of object.
427 call shape
(pseud2d
,pseud4d
,nfast
,nslow
,clinfo
)
428 tshape
= cputime
(t1
) + tshape
430 C Computes average sky values etc from star list
434 C Computes 4-parameter fits for all stellar objects using
435 C new average shape parameters.
436 call improve
(pseud2d
,nfast
,nslow
,clinfo
)
437 timprove
= cputime
(t1
) + timprove
440 C Calculate aperture photometry on last pass.
441 if(.not
.loop
) call aper
( pseud2d
, nstot
, nfast
, nslow
)
443 totaltime
= (tgetpar
+tsearch
+tshape
+timprove
)
444 write(3,1060) totaltime
445 write(4,1060) totaltime
446 write(luout
,1060) totaltime
447 1060 format('Total CPU time consumed:',F10
.2
,' seconds.')
448 write(10,1070)infile
,tgetpar
,tsearch
,tshape
,timprove
,
450 1070 format(a20
,' T(getp/f)',f5
.1
,' T(search)',f5
.1
,
451 * ' T(shape)',f5
.1
,' T(improve)',f5
.1
,
453 call title
(line
,skyval
,.false
.,fitr
,ngr
,ncon
,strint
,ztot
,nums
)
460 C Now reduce the threshold and loop back
462 thresh
= thresh
/2.**tfac
465 C--------- END OF BIG LOOP ---------------------------------------
467 C If after-burner required, residuals from analytic PSF are computed
472 C If using a fixed (X,Y) coordinate list, read it.
474 C Read the image frame
475 call getfits
(1,infile
,header
,nhead
,nfast
,nslow
,numf
,nc
,line
)
477 C Initialize arrays, open files etc.
478 call setup
( numf
,nc
,screen
,line
,skyval
,fitr
,ngr
,ncon
,
482 write(luout
,'(''Reading XY list ...'')')
483 call xylist
(numf
, nc
, ios
)
486 write(luout
,'(''SXY file absent or incorrect...'')')
490 call htype
(line
,skyval
,.false
.,fitr
,ngr
,ncon
)
493 write(luout
,'(''Cleaning frame of stars: '',i8)') nstot
494 call clean
( pseud2d
, nstot
, nfast
, nslow
, -1)
496 C Calculate aperture photometry
497 C call aper ( pseud2d, nstot, nfast, nslow )
503 C-----------------------
504 C Flag all stars close together in groups. Keep making the distance
505 C criterion FITR smaller until the maximum number in a group is less
508 fitr
= amax1
(arect
(1),arect
(2))
511 write(*,'(''Regrouping ...'')')
513 do while ( nmax
.gt
.nfmax
)
515 write(luout
,'(''Min distance ='',f8.1)') fitr
516 call regroup
( fitr
, ngr
, nmax
)
522 C Calculate normalized PSF residual from PSEUD2D
523 call getres
(pseud0d
,pseud2d
,strint
,rmn
,rmx
,nfast
,nslow
,irect
,
526 write(luout
,'(''No suitable PSF stars!'')')
530 write(luout
,'(/''AFTERBURNER tuned ON!'')')
532 C Fit multiple stars in a group with enhanced PSF using box size IRECT.
533 call mulfit
( pseud2d
,pseudmd
,ngr
,ncon
,nfast
,nslow
,irect
)
535 C Re-calculate aperture photometry
536 call aperm
( pseudmd
, nstot
, nfast
, nslow
)
538 call skyadj
( nstot
)
540 call title
(line
,skyval
,.true
.,fitr
,ngr
,ncon
,strint
,ztot
,nums
)
543 C---------------------
545 C----- This section skipped if PSF residual not written out ------
549 C Write final Cleaned array.
550 infile
= 'x'//numf
(1:nc
)//'.fits'
551 call putfits
(2,infile
,header
,nhead
,nfast
,nslow
)
554 C If afterburner used, then residual array also written out.
555 C Find suitable scale for writing residual PSF to FITS "R" file.
558 scale
=20000.0/(rmx
-rmn
)
564 big
(ii
,jj
)=scale*res
(i
,j
)+zero
569 infile
= 'r'//numf
(1:nc
)//'.fits'
573 C Create a FITS header for the normalized PSF residual image
574 call sethead
(rhead
,numf
,nx
,nx
,zer
,scl
)
577 C Write the normalized PSF residual image
578 call putfits
(2,infile
,rhead
,1,nx
,nx
)
588 if ( .not
.screen
) close
(luout
)
590 if(instr
(5).eq
.1)call system
('rm shd.'//numf
(1:nc
))
591 if(instr
(6).eq
.1)call system
('rm out.'//numf
(1:nc
))
593 do while(infile
(n
:n
).ne
.' ')
596 if(instr
(7).eq
.1)call system
('rm '//infile
(1:n
-1))
602 996 format(/'*** Fatal error ***'/
603 * 'You asked for batch processing but'/
604 * 'I cant open the "dophot.bat" file.'/
605 * 'Please make one (using batchdophot)'/
606 * 'and restart DoPHOT'/)
611 998 format(/'*** Fatal error ***'/
612 * 'You asked for "windowed" processing'/
613 * 'but I cant open the "windows" file.'/
614 * 'Please make one and restart DoPHOT'/)
620 * Starting
program: /home3
/craig
/gnu
/f77
-e
/gcc
/f771
-quiet
< ../../play
/19990826-4.f
-O
622 * Breakpoint
2, fancy_abort
(
623 * file
=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line
=4399,
624 * function=0x82860df "output_fp_cc0_set") at
../../g77
-e
/gcc
/rtl
.c
:1010
626 * #
1 0x8222fab in output_fp_cc0_set
(insn
=0x8382324)
627 * at
../../g77
-e
/gcc
/config
/i386
/i386
.c
:4399
631 * #
2 0x8222b81 in output_float_compare
(insn
=0x8382324, operands
=0x82acc60)
632 * at
../../g77
-e
/gcc
/config
/i386
/i386
.c
:4205
638 * (insn
2181 2180 2191 (parallel
[
640 * (compare
(reg
:SF
8 %st
(0))
641 * (mem
:SF
(plus
:SI
(reg
:SI
6 %ebp
)
642 * (const_int
-9948 [0xffffd924])) 0)))
643 * (clobber
(reg
:HI
0 %ax
))
644 * ] ) 29 {*cmpsf_cc_1
} (insn_list
2173 (insn_list
2173 (nil
)))
645 * (expr_list
:REG_DEAD
(reg
:DF
8 %st
(0))
646 * (expr_list
:REG_UNUSED
(reg
:HI
0 %ax
)