← Back to branch summary

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

« back to all changes in this revision

Viewing changes to prim/general/src/averow.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:
prim/general/src/averow.for
 
1
C @(#)averow.for        19.1 (ESO-DMD) 02/25/03 14:01:40
 
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 Massachusetts Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Correspondence 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
      PROGRAM AVEROW
 
30
C --------------------------------------------------------------------
 
31
C
 
32
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
33
C                                         all rights reserved
 
34
C
 
35
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  13:37 - 5 JAN 1988
 
36
C
 
37
C.LANGUAGE: F77+ESOext
 
38
C
 
39
C.AUTHOR: J.D.Ponz
 
40
C         900202   KB  take care of options in lower case
 
41
C
 
42
C.IDENTIFICATION
 
43
C
 
44
C AVEROW.FOR
 
45
C
 
46
C.KEYWORDS
 
47
C
 
48
C  average
 
49
C
 
50
C.PURPOSE
 
51
C
 
52
C  produce a 1d image from a 2d by averaging over rows or columns
 
53
C
 
54
C  COMMAND
 
55
C  AVERAGE/ROW    output = input start,end [SUM]
 
56
C  AVERAGE/COLUMN output = input start,end [SUM]
 
57
C
 
58
C.ALGORITHM
 
59
C
 
60
C  add rows/columns
 
61
C
 
62
C.INPUT/OUTPUT
 
63
C
 
64
C KEYWORDS out_a, in_a, p4, p5, action
 
65
C
 
66
C 001207                        last modif
 
67
C 
 
68
C ------------------------------------------------------------------
 
69
C
 
70
      IMPLICIT NONE
 
71
C
 
72
      INTEGER MADRID(1)
 
73
      INTEGER NDIM,KUN,KNUL
 
74
      INTEGER I1,I2,II1,II2
 
75
      INTEGER I,IFIRST,INUM,SUBLO(3)
 
76
      INTEGER NAXISA,NAXISB,NN,IMNOA,IMNOB
 
77
      INTEGER NPIXA(2),NPIXB(2),STATUS
 
78
      INTEGER*8 PNTRA,PNTRB
 
79
C
 
80
      REAL IAV,LHCUTS(4),FACT
 
81
C
 
82
      DOUBLE PRECISION STEPA(2),STEPB(2)
 
83
      DOUBLE PRECISION STARTA(2),STARTB(2)
 
84
C
 
85
      CHARACTER*80    FRAMEA, FRAMEB
 
86
      CHARACTER*72    IDENT,CUNITA,RANGE
 
87
      CHARACTER*72    CUNITB 
 
88
      CHARACTER*1     IOP,COMLIN
 
89
      CHARACTER       NEWSTR*80
 
90
C
 
91
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
92
C
 
93
      COMMON  /VMR/ MADRID
 
94
C
 
95
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
96
C
 
97
      DATA   NDIM    /2/
 
98
      DATA   IDENT   /' '/,   CUNITA  /' '/
 
99
      DATA   CUNITB  /' '/
 
100
      DATA   LHCUTS  /0.,0.,0.,0./
 
101
C
 
102
C  connect to Midas environment
 
103
C
 
104
      CALL STSPRO('AVEROW')
 
105
C
 
106
C  read params
 
107
C
 
108
      CALL STKRDC('OUT_A',1,1,80,IAV,FRAMEB,KUN,KNUL,STATUS)
 
109
      CALL STKRDC('IN_A',1,1,80,IAV,FRAMEA,KUN,KNUL,STATUS)
 
110
      CALL STKRDC('P4',1,1,72,IAV,RANGE,KUN,KNUL,STATUS)
 
111
      CALL STKRDC('P5',1,1,1,IAV,IOP,KUN,KNUL,STATUS)
 
112
      CALL STKRDC('ACTION',1,2,1,IAV,COMLIN,KUN,KNUL,STATUS)
 
113
C
 
114
C  open input frame and read descriptors
 
115
C
 
116
      CALL STFOPN(FRAMEA,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,IMNOA,STATUS)
 
117
      CALL STDRDI(IMNOA,'NAXIS',1,1,IAV,NAXISA,KUN,KNUL,STATUS)
 
118
      CALL STDRDI(IMNOA,'NPIX',1,2,IAV,NPIXA,KUN,KNUL,STATUS)
 
119
      CALL STDRDD(IMNOA,'START',1,2,IAV,STARTA,KUN,KNUL,STATUS)
 
120
      CALL STDRDD(IMNOA,'STEP',1,2,IAV,STEPA,KUN,KNUL,STATUS)
 
121
      CALL STDRDC(IMNOA,'IDENT',1,1,72,IAV,IDENT,KUN,KNUL,STATUS)
 
122
      CALL STDRDC(IMNOA,'CUNIT',1,1,72,IAV,CUNITA,KUN,KNUL,STATUS)    
 
123
C
 
124
C  setup descriptors of result frame
 
125
C
 
126
      NAXISB = 1
 
127
      NPIXB(2) = 1
 
128
      STARTB(2) = 1.D0
 
129
      STEPB(2) = 0.D0
 
130
      IF (RANGE(1:1).EQ.'[') THEN
 
131
         II1 = 2
 
132
      ELSE
 
133
         II1 = 1
 
134
      ENDIF
 
135
      II2 = INDEX(RANGE,',')
 
136
      IF (II2.LT.2) CALL STETER(22,'missing comma in range spec.')
 
137
C
 
138
C  get range of pixels I1,I2
 
139
C
 
140
      IF (COMLIN.EQ.'R') THEN
 
141
         NPIXB(1) = NPIXA(1)
 
142
         STARTB(1) = STARTA(1)
 
143
         STEPB(1) = STEPA(1)
 
144
         CUNITB(1:16) = CUNITA(1:16)
 
145
         CUNITB(17:32) = CUNITA(17:32)
 
146
         NEWSTR(1:) = '[@1, '
 
147
         NEWSTR(5:) = RANGE(II1:II2-1)
 
148
         NN = INDEX(NEWSTR,' ')
 
149
         NEWSTR(NN:) = '] '
 
150
         CALL EXTCO1(IMNOA,NEWSTR,2,NN,SUBLO,STATUS)
 
151
         IF (STATUS.NE.0) CALL STSEPI
 
152
         I1 = SUBLO(2)
 
153
         NEWSTR(1:) = '[@1, '
 
154
         NEWSTR(5:) = RANGE(II2+1:)
 
155
         IF (II1.EQ.2) THEN
 
156
            NN = INDEX(NEWSTR,']')
 
157
         ELSE
 
158
            NN = INDEX(NEWSTR,' ')
 
159
         ENDIF
 
160
         NEWSTR(NN:) = '] '
 
161
         CALL EXTCO1(IMNOA,NEWSTR,2,NN,SUBLO,STATUS)
 
162
         IF (STATUS.NE.0) CALL STSEPI
 
163
         I2 = SUBLO(2)
 
164
      ELSE
 
165
         NPIXB(1) = NPIXA(2)
 
166
         STARTB(1) = STARTA(2)
 
167
         STEPB(1)= STEPA(2)
 
168
         CUNITB(1:16) = CUNITA(1:16)
 
169
         CUNITB(17:32) = CUNITA(33:49)   
 
170
         NEWSTR(1:) = '[ '
 
171
         NEWSTR(2:) = RANGE(II1:II2-1)
 
172
         NN = INDEX(NEWSTR,' ')
 
173
         NEWSTR(NN:) = ',@1] '
 
174
         CALL EXTCO1(IMNOA,NEWSTR,2,NN,SUBLO,STATUS)
 
175
         IF (STATUS.NE.0) CALL STSEPI
 
176
         I1 = SUBLO(1)
 
177
         NEWSTR(1:) = '[ '
 
178
         NEWSTR(2:) = RANGE(II2+1:)
 
179
         IF (II1.EQ.2) THEN
 
180
            NN = INDEX(NEWSTR,']')
 
181
         ELSE
 
182
            NN = INDEX(NEWSTR,' ')
 
183
         ENDIF
 
184
         NEWSTR(NN:) = ',@1] '
 
185
         CALL EXTCO1(IMNOA,NEWSTR,2,NN,SUBLO,STATUS)
 
186
         IF (STATUS.NE.0) CALL STSEPI
 
187
         I2 = SUBLO(1)
 
188
      ENDIF
 
189
      IF (I1.GT.I2) CALL STETER(22,'Invalid range')
 
190
C
 
191
C  map output frame + initialize data
 
192
C
 
193
      CALL STIPUT(FRAMEB,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,NAXISB,
 
194
     +            NPIXB,STARTB,STEPB,IDENT,CUNITA,PNTRB,IMNOB,STATUS)
 
195
      CALL WORK(0,MADRID(PNTRB),NPIXB,0.0,LHCUTS(3))
 
196
C
 
197
C  do it
 
198
C
 
199
      IF (COMLIN.EQ.'R') THEN
 
200
         CALL STFXMP(NPIXB(1),D_R4_FORMAT,PNTRA,STATUS)
 
201
         IFIRST = (I1-1)*NPIXA(1)+1
 
202
         DO 100, I=I1,I2
 
203
C
 
204
C read row after row and sum up
 
205
            CALL STFGET(IMNOA,IFIRST,NPIXA(1),IAV,MADRID(PNTRA),STATUS)
 
206
            CALL AVER1(MADRID(PNTRB),MADRID(PNTRA),NPIXB(1))
 
207
            IFIRST = IFIRST + NPIXA(1)
 
208
100      CONTINUE
 
209
C 
 
210
      ELSE
 
211
         INUM = I2-I1+1
 
212
         CALL STFXMP(INUM,D_R4_FORMAT,PNTRA,STATUS)
 
213
         IFIRST = I1
 
214
         DO 200, I=1,NPIXA(2)
 
215
C
 
216
C read the columns which are to be  summed up
 
217
            CALL STFGET(IMNOA,IFIRST,INUM,IAV,MADRID(PNTRA),STATUS)
 
218
            CALL AVER2(MADRID(PNTRB),MADRID(PNTRA),
 
219
     +           I,INUM,NPIXA(1),NPIXA(2))
 
220
            IFIRST = IFIRST + NPIXA(1)
 
221
200      CONTINUE
 
222
      ENDIF
 
223
      FACT = 1.0/(I2-I1+1)
 
224
      IF ((IOP.NE.'S').AND.(IOP.NE.'s')) THEN
 
225
         CALL WORK(1,MADRID(PNTRB),NPIXB(1),FACT,
 
226
     +             LHCUTS(3))                      !average + find minmax
 
227
      ELSE
 
228
         CALL WORK(2,MADRID(PNTRB),NPIXB(1),FACT,
 
229
     +             LHCUTS(3))                      !find minmax only
 
230
      ENDIF
 
231
      CALL STDWRR(IMNOB,'LHCUTS',LHCUTS,1,4,KUN,STATUS)
 
232
      CALL STDWRC(IMNOB,'CUNIT',1,CUNITB,1,72,KUN,STATUS)
 
233
      CALL DSCUPT(IMNOA,IMNOB,' ',STATUS)
 
234
C
 
235
      CALL STSEPI
 
236
      END
 
237
 
 
238
      SUBROUTINE WORK(FLAG,Y,NPIX,FACT,AUX)
 
239
C
 
240
      IMPLICIT NONE
 
241
C 
 
242
      INTEGER  FLAG,NPIX,J
 
243
C 
 
244
      REAL     Y(NPIX),FACT,AUX(2)
 
245
C
 
246
      IF (FLAG.EQ.0) THEN
 
247
         DO 20, J=1,NPIX
 
248
            Y(J) = 0.
 
249
20       CONTINUE
 
250
      ELSE IF (FLAG.EQ.1) THEN
 
251
         AUX(1) = Y(1)*FACT
 
252
         AUX(2) = AUX(1)
 
253
         DO 30, J=1,NPIX
 
254
            Y(J) = Y(J)*FACT
 
255
            IF (Y(J).LT.AUX(1)) AUX(1) = Y(J)
 
256
            IF (Y(J).GT.AUX(2)) AUX(2) = Y(J)
 
257
30       CONTINUE
 
258
      ELSE
 
259
         AUX(1) = Y(1)
 
260
         AUX(2) = AUX(1)
 
261
         DO 40, J=1,NPIX
 
262
            IF (Y(J).LT.AUX(1)) AUX(1) = Y(J)
 
263
            IF (Y(J).GT.AUX(2)) AUX(2) = Y(J)
 
264
40       CONTINUE
 
265
      ENDIF
 
266
C
 
267
      RETURN
 
268
      END
 
269
 
 
270
      SUBROUTINE AVER1(Y,Y1,NPIX1)
 
271
C
 
272
C sum over rows
 
273
C
 
274
      IMPLICIT NONE
 
275
      INTEGER  NPIX1,J
 
276
      REAL     Y(NPIX1), Y1(NPIX1)
 
277
C
 
278
      DO 20, J=1,NPIX1
 
279
         Y(J) = Y(J) + Y1(J)
 
280
20    CONTINUE
 
281
C
 
282
      RETURN
 
283
      END
 
284
 
 
285
      SUBROUTINE AVER2(Y,Y1,ICOL,INUM,NPXA,NPXB)
 
286
C
 
287
C sum over columns
 
288
C
 
289
      IMPLICIT NONE
 
290
      INTEGER  ICOL,J,INUM,NPXA,NPXB
 
291
      REAL     Y(NPXA), Y1(NPXB)
 
292
C
 
293
      DO 20, J=1,INUM
 
294
         Y(ICOL) = Y(ICOL)+Y1(J)
 
295
20    CONTINUE
 
296
C    
 
297
      RETURN
 
298
      END
 
299