← Back to branch summary

~ubuntu-branches/ubuntu/wily/eso-midas/wily-proposed

« back to all changes in this revision

Viewing changes to prim/general/libsrc/avarea.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/libsrc/avarea.for
 
1
C @(#)avarea.for        19.1 (ES0-DMD) 02/25/03 14:01:03
 
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
      REAL FUNCTION AVAREA(METHOD,A,NPIX,SUBPIX,NDIM,O)
 
30
C
 
31
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
32
C       
 
33
C.IDENTIFICATION
 
34
C  real function AVAREA         version 2.80    880630
 
35
C  K. Banse                     ESO - Garching
 
36
C 
 
37
C.KEYWORDS
 
38
C  median filter, average
 
39
C 
 
40
C.PURPOSE
 
41
C  find median value or average
 
42
C 
 
43
C.ALGORITHM
 
44
C  as in [MIDAS.PRIM.SUB1]AVERAGE.FOR
 
45
C       
 
46
C.INPUT/OUTPUT
 
47
C  use as VALUE = AV_AREA(METHOD,A,NPIX,SUBPIX,NDIM,O)
 
48
C  
 
49
C input par:
 
50
C  METHOD:      char. exp.      A for average, M for median
 
51
C  A:           R*4 array       input array
 
52
C  NPIX:        I*4             no. of pixels per line
 
53
C  SUBPIX:      I*4 array       start pixels of area
 
54
C  NDIM:        I*4 array       no. of pixels in subarea
 
55
C  O:           R*4 array       working buffer
 
56
C       
 
57
C  AVAREA:      R*4             median value to be returned
 
58
C       
 
59
C --------------------------------------------------------------------
 
60
C
 
61
      IMPLICIT NONE
 
62
C 
 
63
      INTEGER      NPIX,NDIM(*),SUBPIX(*)
 
64
      INTEGER      INDX,NH,NN,NNN,NTOT,NX,NY,OFF,TOP
 
65
C 
 
66
      REAL         A(*),O(*)
 
67
C 
 
68
      CHARACTER*(*)  METHOD
 
69
C 
 
70
      DOUBLE PRECISION   SUM
 
71
C      
 
72
C  point to first pixel (in lower left corner)
 
73
      OFF = (SUBPIX(2)-1)*NPIX + SUBPIX(1)
 
74
      NTOT = NDIM(1) * NDIM(2)
 
75
C      
 
76
C  branch according to method
 
77
      IF (METHOD(1:1).EQ.'A') GOTO 5000
 
78
C      
 
79
C  here for median finding
 
80
C      
 
81
      O(1) = A(OFF)
 
82
      TOP = 1
 
83
      NH = (NTOT + 1)/2             !index of median
 
84
C
 
85
C  move through rest of first line
 
86
      DO 1200 NX=1,NDIM(1)-1
 
87
         INDX = OFF + NX                  !point to "first" pixel in row
 
88
C      
 
89
C  fill array O only from 1 to NH
 
90
         DO 800 NN=1,TOP                  !loop through already ordered set
 
91
            IF (A(INDX).LT.O(NN)) THEN
 
92
               DO 600 NNN=TOP,NN,-1
 
93
                  O(NNN+1) = O(NNN)       !shift up ...
 
94
600            CONTINUE
 
95
             O(NN) = A(INDX)              !merge value into array O
 
96
             GOTO 1000
 
97
            ENDIF
 
98
800      CONTINUE
 
99
C 
 
100
         O(TOP+1) = A(INDX)               !add value on top
 
101
1000     IF (TOP.LT.NH) TOP = TOP + 1
 
102
C      
 
103
1200  CONTINUE
 
104
C      
 
105
C  test, if we are only handling single line
 
106
      IF (NDIM(2).LE.1) THEN
 
107
         AVAREA = O(NH)
 
108
         RETURN
 
109
      ELSE
 
110
         OFF = OFF + NPIX - 1             !point to next line (start value - 1)
 
111
      ENDIF
 
112
C      
 
113
C  handle remaining lines
 
114
      DO 2300 NY=1,NDIM(2)-1
 
115
         DO 2200 NX=1,NDIM(1)
 
116
            INDX = OFF + NX               !point to "first" pixel in row
 
117
C      
 
118
C  fill array O only from 1 to NH
 
119
            DO 1800 NN=1,TOP              !loop through already ordered set
 
120
               IF (A(INDX).LT.O(NN)) THEN
 
121
                  DO 1600 NNN=TOP,NN,-1
 
122
                     O(NNN+1) = O(NNN)    !shift up ...
 
123
1600              CONTINUE
 
124
                  O(NN) = A(INDX)         !merge value into array O
 
125
                  GOTO 2000
 
126
               ENDIF
 
127
1800        CONTINUE
 
128
C 
 
129
            O(TOP+1) = A(INDX)            !add value on top
 
130
2000        IF (TOP.LT.NH) TOP = TOP + 1
 
131
2200     CONTINUE
 
132
         OFF = OFF + NPIX
 
133
2300  CONTINUE
 
134
C      
 
135
C  return median value
 
136
      AVAREA = O(NH)
 
137
      RETURN
 
138
C      
 
139
C  here for simple averaging
 
140
C      
 
141
5000  OFF = OFF - 1
 
142
      SUM = 0.D0
 
143
      DO 6000 NY=1,NDIM(2)
 
144
         DO 5500 NX=1,NDIM(1)
 
145
            SUM = SUM + A(OFF+NX)
 
146
5500     CONTINUE
 
147
         OFF = OFF + NPIX
 
148
6000  CONTINUE
 
149
C      
 
150
C  return average value
 
151
      AVAREA = SNGL(SUM/DBLE(NTOT))
 
152
      RETURN
 
153
C      
 
154
      END