← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to contrib/invent/libsrc/search.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/invent/libsrc/search.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or 
 
5
C modify it under the terms of the GNU General Public License as 
 
6
C published by the Free Software Foundation; either version 2 of 
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public 
 
15
C License along with this program; if not, write to the Free 
 
16
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division 
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen 
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
29
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
30
C                                        all rights reserved
 
31
C.IDENTIFICATION: SEARCH.FOR
 
32
C.PURPOSE:        Searches image frame for objects and write found
 
33
C                 objects into array ACAT.
 
34
C
 
35
C.ALGORITHM:      Described in additional documentation.
 
36
C
 
37
C.LANGUAGE:       ESO-FOR
 
38
C.AUTHOR:         A. Kruszewski
 
39
C.KEYWORDS:       GALAXIES, IMAGES, SEARCH, STARS
 
40
C.ENVIRONMENT:    Portable MIDAS
 
41
C.COMMENTS:       Subroutines SEARCH and SEAREG used by program INVSEARCH
 
42
C.VERSION:        1.0     JUL 1981  Creation                  ESO-Garching
 
43
C.VERSION:        1.1  16 AUG 1983  Modification              ESO-Garching
 
44
C.VERSION:        2.0   6 SEP 1983  Modified by Ch. Ounnas    ESO-Garching
 
45
C.VERSION:             22 MAY 1984  Modified by Ch. Ounnas    ESO-Garching
 
46
C.VERSION:        2.1  19 FEB 1987  Modified for FX           Obs. de Geneve
 
47
C.VERSION:        3.0     JUN 1987  Indirect pixel addresing and SEAREG
 
48
C                                   added                     ESO-Garching
 
49
C.VERSION:        4.0  18 OCT 1988  Modified for portability  Warsaw U. Obs.
 
50
C.VERSION:              2 MAY 1989  Few minor changes         ESO-Garching
 
51
C-----------------------------------------------------------------------
 
52
      SUBROUTINE SEARCH(IMF, A, JAPY, NX, NY,
 
53
     &                  ACAT, IDET, IDA, IARR, RARR, MM)
 
54
C
 
55
      IMPLICIT NONE
 
56
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
 
57
C
 
58
      INTEGER   IMF                ! IN:  Image file
 
59
      REAL      A(1)               ! LOC: Image data buffer
 
60
      INTEGER   JAPY(1)            ! LOC: Pointers to image lines
 
61
      INTEGER   NX                 ! IN:  Image X-dimension
 
62
      INTEGER   NY                 ! IN:  Image Y-dimension
 
63
      REAL      ACAT(5,MAXCNT)     ! OUT: Catalog of objects
 
64
      INTEGER   IDET(1)            ! LOC: Detection mapping array
 
65
      INTEGER   IDA(1)             ! LOC: Multiple detections limits
 
66
      INTEGER   IARR(32)           ! IN:  Integer INVENTORY keywords
 
67
      REAL      RARR(64)           ! IN:  Real INVENTORY keywords
 
68
      INTEGER   MM                 ! OUT: Number of detected objects
 
69
C
 
70
      INTEGER   IBUF(4)
 
71
      INTEGER   IHED, ILIM, ISTAT
 
72
CKB      INTEGER   INET(0:MAXNET)
 
73
      INTEGER   INET0,INET(MAXNET)
 
74
      INTEGER   ITMP
 
75
      INTEGER   IUSD(4), IXYU(4)
 
76
      INTEGER   JEND, JMSG, JS, JSRCHD
 
77
      INTEGER   JSTART, K, M
 
78
      INTEGER   NC, NH1, NHED, NL
 
79
      INTEGER   MCAT(4,MAXDET)
 
80
C     INTEGER   MMB
 
81
      INTEGER   NHSEG, NLPB, NVSEG
 
82
      INTEGER   NXS, NXU, NYS, NYU
 
83
C
 
84
      REAL      SKYNET0(2)
 
85
      REAL      BCAT(2,MAXDET), CRMD(3), DLIM, SKYNET(2,MAXNET)
 
86
C
 
87
      CHARACTER*80 TEXT
 
88
C
 
89
C *** Recall keywords.
 
90
C
 
91
      NC = MAXCNT
 
92
      NL = MAXDET
 
93
      CRMD(1) = RARR(39)
 
94
      CRMD(2) = RARR(40)
 
95
      CRMD(3) = RARR(41)
 
96
      IHED = IARR(8)
 
97
      NHED = IARR(23)
 
98
      SKYNET0(1) = 0.0
 
99
      SKYNET0(2) = 0.0
 
100
      INET0 = 0
 
101
      do 99 m = 1,MAXNET
 
102
         SKYNET(1,M) = 0.0
 
103
         SKYNET(2,M) = 0.0
 
104
         INET(M) = 0
 
105
99    continue
 
106
C
 
107
C *** Define used part of frame IXYU.
 
108
C
 
109
      IXYU(1) = MAX( 1 , IARR(12)-IHED )
 
110
      IXYU(2) = MAX( 1 , IARR(13)-IHED )
 
111
      IXYU(3) = MIN( NX , IARR(14)+IHED )
 
112
      IXYU(4) = MIN( NY , IARR(15)+IHED )
 
113
C
 
114
C *** Part of frame in buffer is limited by IBUF.
 
115
C
 
116
c      IBUF(1) = IXYU(1)
 
117
c      IBUF(3) = IXYU(3)
 
118
C
 
119
C *** Presently buffer is identical with the frame.
 
120
C
 
121
      IBUF(1) = 1
 
122
      IBUF(2) = 1
 
123
      IBUF(3) = NX
 
124
      IBUF(4) = NY
 
125
C
 
126
C *** Analysed part of frame shall be divided onto vertical
 
127
C *** segments. Borders of actual segment are set by IUSD.
 
128
C
 
129
      IUSD(1) = IXYU(1)
 
130
      IUSD(3) = IXYU(3)
 
131
cC
 
132
cC *** Find number of lines in buffer.
 
133
cC
 
134
c      NPPL = IXYU(3) - IXYU(1) + 1
 
135
c      NLPB = MIN ( NYBUF , NIBUF/NPPL )
 
136
      NLPB = NY
 
137
C
 
138
C *** Searched part of frame is defined by IARR(12)-IARR(15)
 
139
C
 
140
      NXU = IXYU(3) - IXYU(1) + 1
 
141
      NYU = IXYU(4) - IXYU(2) + 1
 
142
      NXS = IARR(14) - IARR(12) + 1
 
143
      NYS = IARR(15) - IARR(13) + 1
 
144
C
 
145
C *** Set array for combining detections.
 
146
C
 
147
      DLIM = RARR(43)
 
148
      ILIM = INT( DLIM )
 
149
      CALL LMTDET( ILIM , DLIM , IDA )
 
150
C
 
151
C *** Initialize detection array.
 
152
C
 
153
      ITMP = (ILIM+1) * NXS
 
154
      DO 40 K = 1 , ITMP
 
155
          IDET(K) = 0
 
156
   40 CONTINUE
 
157
C
 
158
C *** Calculate number of vertical segments.
 
159
C
 
160
      NVSEG = INT( RARR(48) * FLOAT(NYS) / FLOAT(2*NHED+1) ) + 1
 
161
cC
 
162
cC *** Make segments small enough to fit buffer.
 
163
cC
 
164
c      IF ( (NYS/NVSEG+1+2*IHED)*NXU .GT. NIBUF .OR.
 
165
c     &                  NYS/NVSEG+1+2*IHED .GT. NYBUF ) THEN
 
166
c            NLPB = NIBUF / NXU
 
167
c            IF ( NLPB-2*IHED .GT. IHED .AND. NLPB .LE.
 
168
c     &                        NYBUF ) THEN
 
169
c                  NVSEG = NYS / (NLPB-2*IHED) + 1
 
170
c            ELSE
 
171
c               CALL STTPUT('Check connection and include files',ISTAT)
 
172
c                  RETURN
 
173
c            ENDIF
 
174
c      ENDIF
 
175
C
 
176
C *** Divide searched part of a frame into horizontal segments.
 
177
C
 
178
      NHSEG = MIN ( INT( RARR(48)*FLOAT(NXS) / FLOAT(2*NHED+1) ) + 1 ,
 
179
     &                                                MAXNET )
 
180
      INET0 = IARR(12)
 
181
      INET(NHSEG) = IARR(14)
 
182
      NH1 = NHSEG-1
 
183
      DO 10 K = 1 , NH1
 
184
          INET(K) = INET0 + ( K*NXS ) / NHSEG
 
185
   10 CONTINUE
 
186
C
 
187
C *** Initialize counters.
 
188
C
 
189
      M = 0
 
190
      MM = 0
 
191
C
 
192
C ***  Start loop over vertical segments
 
193
C
 
194
c      IBUF(2) = 0
 
195
c      JBS = 0
 
196
c      IBUF(4) = 0
 
197
c      JBE = 0
 
198
      JSRCHD = IARR(13) - 1
 
199
      CALL STTPUT( 'Search started' , ISTAT )
 
200
      DO 20 JS = 1 , NVSEG
 
201
C
 
202
C *** Find vertical limits of searched area.
 
203
C
 
204
          JSTART = JSRCHD + 1
 
205
          IF ( JS .LT. NVSEG ) THEN
 
206
              JEND = IARR(13) + ( JS*NYS ) / NVSEG
 
207
          ELSE
 
208
              JEND = IARR(15)
 
209
          ENDIF
 
210
cC
 
211
cC ***     Find vertical limits of used area.
 
212
cC
 
213
c          IEXT = ( NLPB - JEND + JSTART ) / 2
 
214
c          IEXT = MAX( NHED , IEXT ) 
 
215
c          JUS = MAX( JSTART-IEXT , IXYU(2) )
 
216
c          JUE = MIN( JEND+IEXT , IXYU(4) , JUS+NLPB-1 )
 
217
C
 
218
C ***     Take care of image buffers.
 
219
C
 
220
c          IF ( JBE .LT. JUE ) THEN
 
221
c              IUSD(2) = JUS
 
222
c              IUSD(4) = JUE
 
223
          IF ( JS .EQ. 1 ) THEN
 
224
              CALL FILBUF( IMF , A , JAPY , NX , IXYU , IUSD , IBUF )
 
225
          ENDIF
 
226
c          JBS = IBUF(2)
 
227
c          JBE = IBUF(4)
 
228
c          ENDIF
 
229
C
 
230
C ***     Update sky background net.
 
231
C
 
232
          CALL SBGNET ( A , JAPY , IBUF , IXYU , JS ,
 
233
     &                  JSTART , JEND , inet0, INET , skynet0,
 
234
     +                  SKYNET , NHSEG ,
 
235
     &                  CRMD , NHED )
 
236
 
 
237
C
 
238
C ***     Search JS-th vertical segment.
 
239
C
 
240
          CALL SEAREG ( A , JAPY , IBUF , IXYU , JSTART ,
 
241
     &                  JEND , NHSEG , inet0, INET , skynet0,
 
242
     +                  SKYNET , ACAT ,
 
243
     &                  BCAT , MCAT , IDET , IDA , IARR ,
 
244
     &                  RARR , M , MM )
 
245
C
 
246
C ***     Mark last searched line.
 
247
C
 
248
          JSRCHD = JEND
 
249
          JMSG = ( 100 * (JSRCHD-IARR(13)+1) ) / NYS
 
250
C
 
251
C ***     Write message.
 
252
C
 
253
          WRITE(TEXT,'(I4,A,I8,A)')
 
254
     &              JMSG,'% of frame searched ',MM,' objects detected'
 
255
          CALL STTPUT( TEXT , ISTAT )
 
256
 
 
257
  20      CONTINUE
 
258
cC
 
259
cC ******      Write down objects left in ACAT.
 
260
cC
 
261
c      MMB = MOD( MM-1 , NC ) + 1
 
262
c      IF ( MMB .GT. 0 ) THEN
 
263
c          CALL CTLG( ITF , ACAT , NC , START , STEP , MM , MMB )
 
264
c      END IF
 
265
C
 
266
 
 
267
      RETURN
 
268
C
 
269
      END
 
270
C
 
271
 
 
272
 
 
273
 
 
274
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
275
C
 
276
C.PURPOSE:        Searches horizontal image segment
 
277
C
 
278
C.ALGORITHM:      Described in additional documentation
 
279
C
 
280
C.REMARKS:
 
281
C-----------------------------------------------------------------------
 
282
      SUBROUTINE SEAREG(A, JAPY, IBUF, IXYU, JSTART,
 
283
     &                  JEND, NHSEG, inet0, INET, skynet0,SKYNET, ACAT,
 
284
     &                  BCAT, MCAT, IDET, IDA, IARR,
 
285
     &                  RARR, M, MM)
 
286
C
 
287
      IMPLICIT NONE
 
288
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
 
289
C
 
290
      REAL      A(1)                ! IN:  Image buffer
 
291
      INTEGER   JAPY(1)             ! IN:  Pointers to image lines
 
292
      INTEGER   IBUF(4)             ! IN:  Limits of image buffer
 
293
      INTEGER   IXYU(4)             ! IN:  Limits of investigated area
 
294
      INTEGER   JSTART              ! IN:  First searched line
 
295
      INTEGER   JEND                ! IN:  Last searched line
 
296
      INTEGER   NHSEG               ! IN:  Number of horizontal segments
 
297
      INTEGER   INET0  
 
298
      INTEGER   INET(NHSEG)       ! IN:  Horizontal segments limits
 
299
      REAL      SKYNET0(2)
 
300
      REAL      SKYNET(2,NHSEG)   ! IN:  Net of sky values
 
301
      REAL      ACAT(5,MAXCNT)      ! MOD: Array with objects data
 
302
      REAL      BCAT(2,MAXDET)      ! MOD: Real detection data
 
303
      INTEGER   MCAT(4,MAXDET)      ! MOD: Integer detection data
 
304
      INTEGER   IDET(1)             ! MOD: Rolling array with detections
 
305
      INTEGER   IDA(1)              ! MOD: Definition of nearby pixels
 
306
      INTEGER   IARR(32)            ! IN:  Integer INVENTORY keywords
 
307
      REAL      RARR(64)            ! IN:  Real INVENTORY keywords
 
308
      INTEGER   M                   ! MOD: Number of actual detections
 
309
      INTEGER   MM                  ! MOD: Number of actual objects
 
310
C
 
311
      INTEGER   I , IARG , IB
 
312
      INTEGER   IEND , IFLD , IFULL , IHED
 
313
      INTEGER   IL , ILIM
 
314
      INTEGER   IOF , IOFF
 
315
      INTEGER   IP , IPLIM(MAXNET)
 
316
      INTEGER   IS , ISDET , ISTART, ISTAT
 
317
      INTEGER   IUNIT
 
318
      INTEGER   J , JBS , JBE , JXY(4)
 
319
      INTEGER   JOF , JOFF
 
320
C     INTEGER   KREC, KCOR
 
321
      INTEGER   MINCR , MK
 
322
      INTEGER   NC , NL , NXS
 
323
C
 
324
      REAL   AVER
 
325
C     REAL   AR
 
326
      REAL   BGRD , BLIM , BLIME , BLIMS
 
327
      REAL   CRMD(3)
 
328
      REAL   FLTR , FRCTI1 , FRCTI2 , FRCTJ1 , FRCTJ2
 
329
      REAL   HCUT , LCUT
 
330
      REAL   PLIM , PLIML , PRLIM(MAXNET)
 
331
      REAL   RTRSH
 
332
      REAL   SB2 , SKYMIN , SKYMAX
 
333
      REAL   TRSH
 
334
C     REAL   TRLM
 
335
C
 
336
      LOGICAL   DETECT , OBJECT
 
337
C
 
338
C
 
339
      NC = MAXCNT
 
340
      NL = MAXDET
 
341
      JBS = IBUF(2)
 
342
      JBE = IBUF(4)
 
343
C
 
344
C ******      Recall keywords. Sky variations are additive,
 
345
C ******      limiting threshold RTRSH=RARR(3) is in
 
346
C ******      measurement units: IFLD=1. Sky variations are
 
347
C ******      multiplicative, limiting threshold RTRSH=RARR(3)
 
348
C ******      is expressed in units of local sky: IFLD=0.
 
349
C
 
350
      BLIME = 0.0
 
351
      BLIMS = 0.0
 
352
      IHED = IARR(8)
 
353
      IFLD = IARR(9)
 
354
      IUNIT = IARR(10)
 
355
      NXS = IARR(14) - IARR(12) + 1
 
356
      MINCR = IARR(22)
 
357
      LCUT = RARR(1)
 
358
      HCUT = RARR(2)
 
359
      RTRSH = RARR(3)
 
360
      FLTR = RARR(4)
 
361
      CRMD(1) = RARR(39)
 
362
      CRMD(2) = RARR(40)
 
363
      CRMD(3) = RARR(41)
 
364
      ILIM = INT( RARR(43) )
 
365
C
 
366
C *** Local sky determination is less accurate when ISDET=0,
 
367
C *** more accurate when ISDET=1, and most accurate when ISDET=2.
 
368
C
 
369
      ISDET = IARR(16)
 
370
C
 
371
C *** Calculate offsets.
 
372
C
 
373
      JOFF = JBS - 1
 
374
      IOFF = IBUF(1) - 1
 
375
      IOF = IARR(12) - 1
 
376
C
 
377
C *** Find preliminary detection limits.
 
378
C
 
379
          SKYMIN = MIN( SKYNET0(1) , SKYNET0(2) ,
 
380
     &                        SKYNET(1,1) , SKYNET(2,1) )
 
381
          SKYMAX = MAX( SKYNET0(1) , SKYNET0(2) ,
 
382
     &                        SKYNET(1,1) , SKYNET(2,1) )
 
383
          IF ( IFLD .EQ. 1 ) THEN
 
384
              PRLIM(1) = SKYMIN + RTRSH
 
385
              TRSH = RTRSH
 
386
          ELSE
 
387
              PRLIM(1) = SKYMIN * (1.0+RTRSH)
 
388
              TRSH = PRLIM(1) - SKYMIN
 
389
          ENDIF
 
390
C
 
391
C ***     Mark segments with disprepant sky determinations.
 
392
C
 
393
          IF ( SKYMAX-SKYMIN .GT. TRSH ) THEN
 
394
              IPLIM(1) = 1
 
395
          ELSE
 
396
              IPLIM(1) = 0
 
397
          ENDIF
 
398
 
 
399
 
 
400
      DO 5 IS = 2 , NHSEG
 
401
          SKYMIN = MIN( SKYNET(1,IS-1) , SKYNET(2,IS-1) ,
 
402
     &                        SKYNET(1,IS) , SKYNET(2,IS) )
 
403
          SKYMAX = MAX( SKYNET(1,IS-1) , SKYNET(2,IS-1) ,
 
404
     &                        SKYNET(1,IS) , SKYNET(2,IS) )
 
405
          IF ( IFLD .EQ. 1 ) THEN
 
406
              PRLIM(IS) = SKYMIN + RTRSH
 
407
              TRSH = RTRSH
 
408
          ELSE
 
409
              PRLIM(IS) = SKYMIN * (1.0+RTRSH)
 
410
              TRSH = PRLIM(IS) - SKYMIN
 
411
          ENDIF
 
412
C
 
413
C ***     Mark segments with disprepant sky determinations.
 
414
C
 
415
          IF ( SKYMAX-SKYMIN .GT. TRSH ) THEN
 
416
              IPLIM(IS) = 1
 
417
          ELSE
 
418
              IPLIM(IS) = 0
 
419
          ENDIF
 
420
    5 CONTINUE
 
421
C
 
422
C *** Search by lines.
 
423
C
 
424
      DO 10 J = JSTART , JEND
 
425
          JOF = JAPY(J-JOFF)
 
426
          FRCTJ1 = FLOAT(JEND-J) / FLOAT(JEND-JSTART)
 
427
          FRCTJ2 = 1.0 - FRCTJ1
 
428
C
 
429
C ***     Search by horizontal segments.
 
430
C
 
431
          DO 20 IS = 1 , NHSEG
 
432
              IP = IPLIM(IS)
 
433
              IF ( IS .GT. 1 ) THEN
 
434
                  ISTART = INET(IS-1) + 1
 
435
              ELSE
 
436
CKB                  ISTART = INET(IS-1)
 
437
                  ISTART = INET0
 
438
              ENDIF
 
439
              IEND = INET(IS)
 
440
C
 
441
C ***         Find preliminary detection limit.
 
442
C
 
443
              PLIM = PRLIM(IS)
 
444
              PLIML = MAX( LCUT , PLIM - 4.0*TRSH )
 
445
              IF ( ISDET .EQ. 2 ) THEN
 
446
                  PLIM = PLIM - 0.3 * TRSH
 
447
              ENDIF
 
448
              IB = 0
 
449
C
 
450
C ***         Search by pixels.
 
451
C
 
452
              DO 30 I = ISTART , IEND
 
453
                  DETECT = .FALSE.
 
454
                  OBJECT = .FALSE.
 
455
                  IARG = JOF + I
 
456
                  AVER = A(IARG)
 
457
C
 
458
C ***             Pixel lower than preliminary
 
459
C ***             limit is no longer considered.
 
460
C
 
461
                  IF ( AVER .LT. PLIM ) THEN
 
462
c                      IF ( AVER .LT. PLIML ) THEN
 
463
c                          MA(IARG) = 0
 
464
c                      ENDIF
 
465
                      GOTO 30
 
466
                  ENDIF
 
467
C
 
468
C ***             Pixels higher than HCUT get special treatment. 
 
469
C
 
470
                  IF ( AVER .GE. HCUT ) THEN
 
471
c                      MA(IARG) = 2
 
472
                      CALL SATOBJ( A , JAPY , JOFF , I , J ,
 
473
     &                             HCUT , AVER )
 
474
                      IF ( ISDET .EQ. 2 ) THEN
 
475
                          BGRD = PLIM - 0.7 * TRSH
 
476
                      ELSE
 
477
                          BGRD = PLIM - TRSH
 
478
                      ENDIF                      
 
479
                      CALL FLTRBP( A , JAPY , IBUF , I , J ,
 
480
     &                             BGRD , FLTR , AVER )
 
481
                      IF ( AVER .GT. 0.9*HCUT ) THEN
 
482
                          GOTO 55
 
483
                      ELSE
 
484
                          GOTO 56
 
485
                      ENDIF
 
486
                  ENDIF
 
487
C
 
488
C***********************************************************************
 
489
C
 
490
C ******                This part of code depends on
 
491
C ******                the detection criterium used.
 
492
C
 
493
                  CALL SRHOBJ( A , JAPY , JOFF , I , J ,
 
494
     &                                          DETECT , AVER )
 
495
                  IF ( .NOT. DETECT ) GOTO 30
 
496
C
 
497
C ******                Pixel is higher than 8 neighbours.
 
498
C
 
499
C***********************************************************************
 
500
C
 
501
   56             CONTINUE
 
502
                  IF ( IB .EQ. 0 ) THEN
 
503
C
 
504
C ******                  Find background on borders.
 
505
C
 
506
                      if (is .eq. 1) then
 
507
                      BLIMS = SKYNET0(1)*FRCTJ1 +
 
508
     &                              SKYNET0(2)*FRCTJ2 + TRSH
 
509
                      BLIME = SKYNET(1,1)*FRCTJ1 +
 
510
     &                              SKYNET(2,1)*FRCTJ2 + TRSH
 
511
                      else
 
512
                      BLIMS = SKYNET(1,IS-1)*FRCTJ1 +
 
513
     &                              SKYNET(2,IS-1)*FRCTJ2 + TRSH
 
514
                      BLIME = SKYNET(1,IS)*FRCTJ1 +
 
515
     &                              SKYNET(2,IS)*FRCTJ2 + TRSH
 
516
                      endif
 
517
                      IB = 1
 
518
                  ENDIF
 
519
C
 
520
C ******                        Calculate interpolated background.
 
521
C
 
522
                  FRCTI1 = FLOAT(I-ISTART) / FLOAT(IEND-ISTART)
 
523
                  FRCTI2 = 1.0 - FRCTI1
 
524
                  BLIM = BLIMS*FRCTI1 + BLIME*FRCTI2
 
525
                  IF ( ISDET .EQ. 2 ) THEN
 
526
                      BLIM = BLIM - 0.3 * TRSH
 
527
                  ENDIF
 
528
                  IF ( AVER .GT. BLIM ) THEN
 
529
                      IF ( ISDET .EQ. 2 ) THEN
 
530
                          BGRD = BLIM - 0.7 * TRSH
 
531
                      ELSE
 
532
                          BGRD = BLIM - TRSH
 
533
                      ENDIF
 
534
                      GOTO 40
 
535
                  ENDIF
 
536
C
 
537
C ******                Calculate approximate background.
 
538
C
 
539
                  JXY(1) = MAX( IBUF(1) , I-IHED )
 
540
                  JXY(2) = MAX( IBUF(2) , J-IHED )
 
541
                  JXY(3) = MIN( IBUF(3) , I+IHED )
 
542
                  JXY(4) = MIN( IBUF(4) , J+IHED )
 
543
                  CALL APRBGR ( A , JAPY , JOFF , JXY , SB2 )
 
544
                  IF ( AVER .LT. SB2+TRSH ) THEN
 
545
                      GOTO 30
 
546
                  ELSE
 
547
                      BGRD = SB2
 
548
                  ENDIF
 
549
   40         CONTINUE
 
550
C
 
551
C ******                The pixel has passed approximate
 
552
C ******                criteria. Now the final criterium
 
553
C ******                will be applied if necessary.
 
554
C
 
555
                IF ( IP .EQ. 1 .OR. ISDET .EQ. 1 ) THEN
 
556
                  IFULL = 0
 
557
                  CALL SKYMOD( A , JAPY , IBUF , I , J , CRMD ,
 
558
     &                                    IHED , IFULL , BGRD )
 
559
                     IF ( AVER .LE. BGRD+TRSH ) GOTO 30
 
560
                     IF ( A(JAPY(J-JOFF)+I) .GT.
 
561
     &                                 BGRD + (FLTR-1.0)*TRSH ) THEN
 
562
                         CALL FLTRBP( A , JAPY , IBUF , I , J ,
 
563
     &                                    BGRD , FLTR , AVER )
 
564
                     ENDIF
 
565
                     IF ( AVER .LE. BGRD+TRSH ) GOTO 30
 
566
                 ENDIF
 
567
C  50            CONTINUE
 
568
C
 
569
C ***            One more check.
 
570
C
 
571
c                 TRLM = BGRD + TRSH
 
572
c                 CALL RADDET( A , JAPY , IBUF , I , J ,
 
573
c     &                        MINCR , TRLM , AVER , TRSH , AR )
 
574
c                 IF ( AR .LT. 0.0 .AND. AVER .LT. 0.9*HCUT ) GOTO 30
 
575
   55            CONTINUE
 
576
C
 
577
C ******                This is a detection.
 
578
C
 
579
                  M = M + 1
 
580
                  IF (M.GE.NL) THEN
 
581
                     CALL STTPUT
 
582
     +               ('*** FATAL: Internal buffer overflow; ',ISTAT)
 
583
                     CALL STTPUT
 
584
     +               ('    Restrict our search to smaller subframe',
 
585
     +               ISTAT)
 
586
                     CALL STTPUT
 
587
     +               ('    or modify parameter setup fro detection',
 
588
     +               ISTAT)
 
589
                    CALL STSEPI
 
590
                  ENDIF
 
591
C
 
592
C ******                Save arrays MCAT and BCAT
 
593
C ******                if they are full of new data.
 
594
C
 
595
c                 IF ( MOD( M , NL ) .EQ. 1 .AND. M .GT. NL ) THEN
 
596
c                     KCOR = M - NL - 1 
 
597
c                     DO 60 K = 1 , NL
 
598
c                         KREC = K + KCOR
 
599
c                         WRITE ( ISF , REC=KREC ) MCAT(1,K) ,
 
600
c     &                            MCAT(2,K) , MCAT(3,K) , MCAT(4,K) ,
 
601
c     &                                    BCAT(1,K) , BCAT(2,K)
 
602
c   60                CONTINUE
 
603
c                 ENDIF
 
604
C
 
605
C ***             Record data for new detection.
 
606
C
 
607
                  MK = MOD( M-1 , NL ) + 1
 
608
                  MCAT(1,MK) = I
 
609
                  MCAT(2,MK) = J
 
610
                  MCAT(3,MK) = 0
 
611
                  MCAT(4,MK) = 0
 
612
                  BCAT(1,MK) = BGRD
 
613
                  BCAT(2,MK) = AVER
 
614
                  IP = I - IOF
 
615
C
 
616
C ***             Update linked list of detections.
 
617
C
 
618
                  CALL UPDTLL( MCAT , NL , IDET ,
 
619
     &                              NXS , ILIM , IDA , IP , M )
 
620
 
 
621
   30         CONTINUE
 
622
   20     CONTINUE
 
623
C
 
624
C ***     Join multiple detections and update array IDET.
 
625
C
 
626
          CALL JOINMD( A , JAPY , IBUF , IXYU , ACAT ,
 
627
     &                 NC , BCAT , MCAT , NL , IDET ,
 
628
     &                 NXS , ILIM , IARR , RARR , M ,
 
629
     &                 MM )
 
630
          IF ( J .EQ. IARR(15) ) THEN
 
631
              DO 70 IL = 1 , ILIM
 
632
                  CALL JOINMD( A , JAPY , IBUF , IXYU , ACAT ,
 
633
     &                         NC , BCAT , MCAT , NL , IDET ,
 
634
     &                         NXS , ILIM , IARR , RARR , M ,
 
635
     &                         MM )
 
636
   70         CONTINUE
 
637
 
 
638
          ENDIF
 
639
   10 CONTINUE
 
640
C
 
641
      RETURN
 
642
C
 
643
      END