← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/invent/src/invanalys.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/src/invanalys.for
 
1
C @(#)invanalys.for     19.1 (ES0-DMD) 02/25/03 13:26:20
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
31
C                                         all rights reserved
 
32
C
 
33
C.IDENTIFICATION: ANALYS       VERSION 2.0           840522
 
34
C.PURPOSE:        For an input list of objects, calcul of classifying 
 
35
C                 parameters,  magnitudes, positions, gradients, profiles
 
36
c                 (see inventory user's manual from a. kruszewski)
 
37
C.AUTHOR:         A. Kruszewski
 
38
C.LANGUAGE:       F77+ESOext
 
39
C.KEYWORDS:       classifying parameters, magnitudes, positions, profiles
 
40
C.VERSION:        1.0  ESO-FORTRAN Conversion, AA  8:56 - 23 NOV 1987
 
41
C.VERSION:        Ch O, ESO - Garching  850115
 
42
C.VERSION:        AK, Obs. de Geneva    870303  changes for the Alliant FX
 
43
C.VERSION:        AK, ESO Garching      870702  new table column names
 
44
C.VERSION         MP, ESO Garching      890216  change length of TYPE
 
45
C-----------------------------------------------------------------------
 
46
      PROGRAM ANALYS
 
47
C
 
48
      IMPLICIT NONE
 
49
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
 
50
C
 
51
      INTEGER   IACOL, IACT, IAROW, IARR(32)
 
52
      INTEGER*8  ICOLP, IPNTR, JPNTR, KPNTR, LPNTR
 
53
      INTEGER   ICOL(6), IHED, IMF
 
54
      INTEGER   ISTAT, ITF, ITOB(4), IXYU(4)
 
55
      INTEGER   JSIZE
 
56
      INTEGER   KNUL, KSIZE, KUN
 
57
      INTEGER   LPXL, LSBP, LSIZE
 
58
      INTEGER   MADRID(1)
 
59
      INTEGER   NAXIS, NBYTE, NCOLI, NEL
 
60
      INTEGER   NCAT(NIPAR,MAXCNT), NPIX(2), NROWI
 
61
      INTEGER   NX, NY, NSC
 
62
      INTEGER   IMAX, INIP
 
63
C
 
64
      REAL      PMTR(NRPAR,MAXCNT)
 
65
      REAL      PRCT(0:MAXSUB,MAXCNT)
 
66
      REAL      RARR(64)
 
67
C
 
68
      DOUBLE PRECISION  START(2)
 
69
      DOUBLE PRECISION  STEP(2)
 
70
      DOUBLE PRECISION  DBLONE
 
71
C
 
72
      CHARACTER*1    TYPE
 
73
      CHARACTER*16   COLAR, COLAV9, COLBGD
 
74
      CHARACTER*16   COLID, COLISO, COLX, COLY
 
75
      CHARACTER*48   CUNIT
 
76
      CHARACTER*60   FRAME, INTABL, OUTABL , OUTPSF
 
77
      CHARACTER*40   OPTION 
 
78
      CHARACTER*72   IDENT
 
79
      CHARACTER*80   OUTPUT
 
80
C
 
81
C     INCLUDE  'MID_INCLUDE:TABLES.INC/NOLIST'
 
82
      INCLUDE  'MID_INCLUDE:ST_DEF.INC/NOLIST'
 
83
      COMMON   /VMR/MADRID
 
84
C     INCLUDE  'MID_INCLUDE:TABLED.INC/NOLIST'
 
85
      INCLUDE  'MID_INCLUDE:ST_DAT.INC/NOLIST'
 
86
C
 
87
C *** Start Midas.
 
88
C
 
89
      CALL STSPRO('ANALYSE')
 
90
C
 
91
C *** Initialisation of column labels.
 
92
C
 
93
      DO IMAX = 1, MAXCNT
 
94
         DO INIP = 1, NIPAR
 
95
            NCAT(INIP,IMAX) = 0
 
96
         ENDDO 
 
97
      ENDDO
 
98
 
 
99
      DBLONE = 1.0
 
100
      COLID  = 'IDENT'
 
101
      COLX   = 'X'
 
102
      COLY   = 'Y'
 
103
      COLISO = 'RAD_ISO'
 
104
      COLBGD = 'BG'
 
105
      COLAV9 = 'INT'
 
106
      COLAR  = 'AR'
 
107
C
 
108
C *** Read arrays IARR and RARR.
 
109
C
 
110
      CALL RDKINV(IARR, RARR, ISTAT)
 
111
C
 
112
C *** Read image and tables names.
 
113
C
 
114
      CALL STKRDC('IN_A', 1, 1, 60, IACT, FRAME, KUN, KNUL, ISTAT)
 
115
      CALL STKRDC('IN_B', 1, 1, 60, IACT, INTABL, KUN, KNUL, ISTAT)
 
116
      CALL STKRDC('OUT_A', 1, 1, 60, IACT, OUTABL, KUN, KNUL, ISTAT)
 
117
      CALL STKRDC('INPUTC', 1, 1, 10, IACT, OPTION, KUN, KNUL, ISTAT)
 
118
      CALL STKRDC('OUT_B', 1, 1, 60, IACT, OUTPSF, KUN, KNUL, ISTAT)
 
119
C
 
120
C *** Open image frame.
 
121
C
 
122
      CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,2,
 
123
     &            NAXIS, NPIX, START, STEP, IDENT, CUNIT, IPNTR,
 
124
     &            IMF, ISTAT)
 
125
      NX = NPIX(1)
 
126
      NY = NPIX(2)
 
127
C
 
128
C *** Check if descriptor STARS is present if needed.
 
129
C
 
130
      IF (IARR(11) .LT. 0) THEN
 
131
         CALL STDFND(IMF, 'STARS', TYPE, NEL, NBYTE, ISTAT)
 
132
         IF (TYPE .EQ. ' ' .OR. NEL .LE. 0) THEN
 
133
            OUTPUT = '*** FATAL: '//
 
134
     2               'Descriptor STARS is missing in your frame'
 
135
            CALL STTPUT(OUTPUT, ISTAT)
 
136
            OUTPUT = '    Create it via GET/CURS STARS/DES or'
 
137
            CALL STTPUT(OUTPUT, ISTAT)
 
138
            OUTPUT = '    set keyword PRFLCTRL to non-negative value.'
 
139
            CALL STTPUT(OUTPUT, ISTAT)
 
140
            CALL STSEPI
 
141
         ENDIF
 
142
      ENDIF
 
143
C
 
144
C *** Read descriptor DPROFILE after testing its presence.
 
145
C
 
146
      CALL STDFND(IMF, 'DPROFILE', TYPE, NEL, NBYTE, ISTAT)
 
147
      IF (.NOT. (TYPE .EQ. ' ' .OR. NEL .LE. 0)) THEN
 
148
         CALL STDRDR(IMF, 'DPROFILE', 1, 25, IACT, RARR(14),
 
149
     &               KUN, KNUL, ISTAT)
 
150
      ENDIF
 
151
C
 
152
C *** Find borders of an area on which the search
 
153
C *** shall be made. It has the form of rectangle.
 
154
C *** The keyword PHYSICAL = IARR(7) tells if the
 
155
C *** search rectangle is defined by physical coordinates
 
156
C *** RARR(54) - RARR(57) (IARR(7)=1), or by pixel
 
157
C *** coordinates IARR(12) - IARR(15) (IARR(7)=0).
 
158
C
 
159
      IF (IARR(7) .EQ. 1) THEN
 
160
         IARR(12) = 1 + NINT((DBLE(RARR(54)) - START(1))/STEP(1))
 
161
         IARR(13) = 1 + NINT((DBLE(RARR(55)) - START(2))/STEP(2))
 
162
         IARR(14) = 1 + NINT((DBLE(RARR(56)) - START(1))/STEP(1))
 
163
         IARR(15) = 1 + NINT((DBLE(RARR(57)) - START(2))/STEP(2))
 
164
      ENDIF
 
165
C
 
166
C *** Default is whole frame.
 
167
C
 
168
      IF (IARR(14) .LE. MAX(IARR(12), 0)) THEN
 
169
         IARR(12) = 1
 
170
         IARR(14) = NX
 
171
      ENDIF
 
172
      IF (IARR(15) .LE. MAX(IARR(13), 0)) THEN
 
173
         IARR(13) = 1
 
174
         IARR(15) = NY
 
175
      ENDIF
 
176
C
 
177
C *** Check if searched region overlaps with the frame.
 
178
C
 
179
      IF (IARR(12).GE.NX-IARR(19) .OR. IARR(13).GE.
 
180
     &             NY-IARR(19) .OR. IARR(14).LE.1+IARR(19)
 
181
     &             .OR. IARR(15).LE.1+IARR(19)) THEN
 
182
          OUTPUT = '*** FATAL: '//
 
183
     &             'Frame and searched region do not overlap'
 
184
          CALL STTPUT(OUTPUT, ISTAT)
 
185
      ENDIF
 
186
C
 
187
C *** Frame margins IARR(19)-pixels wide are not used.
 
188
C
 
189
      IARR(12) = MAX(IARR(12), IARR(19)+1)
 
190
      IARR(13) = MAX(IARR(13), IARR(19)+1)
 
191
      IARR(14) = MIN(IARR(14), NX-IARR(19))
 
192
      IARR(15) = MIN(IARR(15), NY-IARR(19))
 
193
C
 
194
C *** IARR(12) to IARR(15) give limits of searched region.
 
195
C *** Temporary objects can be detected in little larger
 
196
C *** region bounded by array ITOB.
 
197
C
 
198
      IHED = IARR(8)
 
199
      ITOB(1) = MAX( IARR(12)-IHED , IARR(19)+1 )
 
200
      ITOB(2) = MAX( IARR(13)-IHED , IARR(19)+1 )
 
201
      ITOB(3) = MIN( IARR(14)+IHED , NX-IARR(19) )
 
202
      ITOB(4) = MIN( IARR(15)+IHED , NY-IARR(19) )
 
203
C
 
204
C *** Data in still larger region is used. It is limited by array IXYU.
 
205
C
 
206
      IXYU(1) = MAX(ITOB(1)-IHED, 1)
 
207
      IXYU(2) = MAX(ITOB(2)-IHED, 1)
 
208
      IXYU(3) = MIN(ITOB(3)+IHED, NX)
 
209
      IXYU(4) = MIN(ITOB(4)+IHED, NY)
 
210
C
 
211
C *** Allocate memory for line pointers array.
 
212
C
 
213
      JSIZE = 4 * NY
 
214
      CALL TDMGET(JSIZE, JPNTR, ISTAT)
 
215
C
 
216
C *** Allocate memory for two dimensional p.s.f.
 
217
C
 
218
      LPXL  = IARR(20)
 
219
      LSBP  = IARR(21)
 
220
      KSIZE = 4 * ( (7+NOSP) * (2*LPXL+1)**2 + 1) * (2*LSBP+1)**2
 
221
      CALL TDMGET(KSIZE, KPNTR, ISTAT)
 
222
      LSIZE = 4 * ( (2*LSBP+1)**2 + NOSP + 1 )
 
223
      CALL TDMGET(LSIZE, LPNTR, ISTAT)
 
224
C
 
225
C *** Open input table.
 
226
C
 
227
      CALL TBTOPN(INTABL,F_I_MODE,ITF,ISTAT)
 
228
C
 
229
C *** Read number of input table rows NROWI and columns NCOLI.
 
230
C
 
231
      CALL TBIGET(ITF, NCOLI, NROWI, NSC, IACOL, IAROW, ISTAT)
 
232
C
 
233
C *** Find columns X and Y and read them into array NCAT.
 
234
C
 
235
      CALL TBLSER(ITF, COLX, ICOL(1), ISTAT)
 
236
      IF (ICOL(1) .LE. 0 .OR. ISTAT .NE. 0) THEN
 
237
         OUTPUT = '*** FATAL: The column label X is not present.'
 
238
         CALL STTPUT(OUTPUT, ISTAT)
 
239
         CALL STSEPI
 
240
      ELSE
 
241
         CALL TBCMAP(ITF, ICOL(1), ICOLP, ISTAT)
 
242
         CALL TBLAI(MADRID(ICOLP), NROWI, START(1), STEP(1),
 
243
     &              NCAT, NIPAR, 1)
 
244
         CALL TBLAR(MADRID(ICOLP), NROWI, START(1), STEP(1),
 
245
     &              PMTR, NRPAR, 10)
 
246
      ENDIF
 
247
C
 
248
      CALL TBLSER(ITF, COLY, ICOL(2), ISTAT)
 
249
      IF (ICOL(2) .LE. 0 .OR. ISTAT .NE. 0) THEN
 
250
         OUTPUT = '*** FATAL: The column label Y is not present'
 
251
         CALL STTPUT(OUTPUT, ISTAT)
 
252
         CALL STSEPI
 
253
      ELSE
 
254
         CALL TBCMAP(ITF, ICOL(2), ICOLP, ISTAT)
 
255
         CALL TBLAI(MADRID(ICOLP), NROWI, START(2), STEP(2),
 
256
     &              NCAT, NIPAR, 2)
 
257
         CALL TBLAR(MADRID(ICOLP), NROWI, START(2), STEP(2),
 
258
     &              PMTR, NRPAR, 11)
 
259
      ENDIF
 
260
C
 
261
C *** Find column RAD_ISO if IARR(5) = 1.
 
262
C
 
263
      IF (IARR(5) .EQ. 1) THEN
 
264
         CALL TBLSER(ITF, COLISO, ICOL(5), ISTAT)
 
265
         IF (ICOL(5) .LE. 0 .OR. ISTAT .NE. 0) THEN
 
266
            OUTPUT = '*** WARNING: '//
 
267
     2               'The column label RAD_ISO is not present'
 
268
            CALL STTPUT(OUTPUT, ISTAT)
 
269
            ICOL(5) = 0
 
270
         ELSE
 
271
         CALL TBCMAP(ITF, ICOL(5), ICOLP, ISTAT)
 
272
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
 
273
     &              NRPAR, 5)
 
274
         ENDIF
 
275
      ELSE
 
276
         ICOL(5) = 0
 
277
      ENDIF
 
278
C
 
279
C *** Find columns LOC_BGD and AVER_9.
 
280
C
 
281
      CALL TBLSER(ITF, COLBGD, ICOL(3), ISTAT)
 
282
      IF (ICOL(3) .LE. 0 .OR. ISTAT .NE. 0) THEN
 
283
         ICOL(3) = 0
 
284
      ELSE
 
285
         CALL TBCMAP(ITF, ICOL(3), ICOLP, ISTAT)
 
286
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
 
287
     &              NRPAR, 1)
 
288
      ENDIF
 
289
      CALL TBLSER(ITF, COLAV9, ICOL(4), ISTAT)
 
290
      IF (ICOL(4) .LE. 0 .OR. ISTAT .NE. 0) THEN
 
291
         ICOL(4) = 0
 
292
      ELSE
 
293
         CALL TBCMAP(ITF, ICOL(4), ICOLP, ISTAT)
 
294
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
 
295
     &              NRPAR, 2)
 
296
      ENDIF
 
297
C
 
298
C ***  Find column ID or create its values if absent.
 
299
C
 
300
C      CALL TXLSER(INTABL,COLID,ICOL(6),ISTAT)
 
301
C      IF (ICOL(6).LE.0) THEN
 
302
C          DO 10 L = 1,NROWI
 
303
C              IDCAT(L) = L
 
304
C   10     CONTINUE
 
305
C      ELSE
 
306
C          CALL TXCMAP(INTABL,ICOL(6),ICOLP,ISTAT)
 
307
C          CALL TBLAI(MADRID(ICOLP),NROWI,DBLONE,DBLONE,IDCAT,1,1)
 
308
C      END IF
 
309
C
 
310
C ***  Perform calculations.
 
311
C
 
312
      CALL CALCUL(IMF, MADRID(IPNTR), MADRID(JPNTR), NX, NY,
 
313
     &            ITOB, IXYU, IARR, RARR, ICOL, NROWI, NCAT,
 
314
     &            PMTR, PRCT, MADRID(KPNTR), MADRID(LPNTR), OUTPSF)
 
315
C
 
316
C *** Free resources.
 
317
C
 
318
      CALL TDMFRE(LSIZE, LPNTR, ISTAT)
 
319
      CALL TDMFRE(KSIZE, KPNTR, ISTAT)
 
320
      CALL TDMFRE(JSIZE, JPNTR, ISTAT)
 
321
      CALL TBTCLO(ITF, ISTAT)
 
322
C
 
323
      CALL STSEPI
 
324
      END
 
325
C
 
326
C **********************************************************************
 
327
C
 
328
      SUBROUTINE TBLAI(ARR, N, START, STEP, NARR, NCOL, ICOL)
 
329
C
 
330
      IMPLICIT  NONE
 
331
C
 
332
      REAL       ARR(1)
 
333
      INTEGER    N
 
334
      INTEGER    NCOL
 
335
      DOUBLE PRECISION START
 
336
      DOUBLE PRECISION STEP
 
337
      INTEGER    NARR(NCOL,N)
 
338
      INTEGER    ICOL
 
339
C
 
340
      INTEGER   L
 
341
      DOUBLE PRECISION FCTR
 
342
C
 
343
      IF (START .EQ. 1.0 .AND. STEP .EQ. 1.0) THEN
 
344
         DO 10 L = 1, N
 
345
            NARR(ICOL,L) = NINT(ARR(L))
 
346
   10    CONTINUE
 
347
      ELSE
 
348
         FCTR = 1.0 / STEP
 
349
         DO 20 L = 1, N
 
350
           NARR(ICOL,L) = NINT((ARR(L) - REAL(START))*FCTR) + 1
 
351
   20    CONTINUE
 
352
      ENDIF
 
353
C
 
354
      RETURN
 
355
      END
 
356
C
 
357
C **********************************************************************
 
358
C
 
359
      SUBROUTINE TBLAR(ARR, N, START, STEP, AARR, NCOL, ICOL)
 
360
C
 
361
      IMPLICIT       NONE
 
362
      INTEGER        N
 
363
      INTEGER        NCOL
 
364
      REAL           ARR(1)
 
365
      DOUBLE PRECISION  START
 
366
      DOUBLE PRECISION  STEP
 
367
      REAL           AARR(NCOL,N)
 
368
      INTEGER        ICOL
 
369
C
 
370
      INTEGER        L
 
371
      REAL           FCTR
 
372
C
 
373
      IF (START .EQ. 1.0 .AND. STEP .EQ. 1.0) THEN
 
374
         DO 10 L = 1, N
 
375
            AARR(ICOL,L) = ARR(L)
 
376
   10    CONTINUE
 
377
      ELSE
 
378
         FCTR = 1.0 / REAL(STEP)
 
379
         DO 20 L = 1, N
 
380
            AARR(ICOL,L) = (ARR(L) - REAL(START))*FCTR + 1.0
 
381
   20    CONTINUE
 
382
      ENDIF
 
383
C
 
384
      RETURN
 
385
      END