← Back to branch summary

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

« back to all changes in this revision

Viewing changes to prim/table/libsrc/tdfreq.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/table/libsrc/tdfreq.for
 
1
C @(#)tdfreq.for        19.1 (ESO-DMD) 02/25/03 14:11:17
 
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
31
C                                         all rights reserved
 
32
C
 
33
C.VERSION: 1.1  ESO-FORTRAN Conversion, AA  14:13 - 19 NOV 1987
 
34
C
 
35
C.LANGUAGE: F77+ESOext
 
36
C
 
37
C.AUTHOR: J.D.PONZ
 
38
C
 
39
C.IDENTIFICATION:
 
40
C               TDFREQ.FOR
 
41
C
 
42
C.KEYWORDS
 
43
C    HISTOGRAM, TABLES
 
44
C
 
45
C.PURPOSE
 
46
C
 
47
C  EXECUTE THE COMMAND
 
48
C  COMP/HIST OUTPUT = TABLE COLUMN-REF [STEP [MIN-VAL  [MAX-VAL]]]
 
49
C  WHERE 'OUTPUT' CAN BE EITHER 'frame' OR 'name/TABLE'
 
50
C
 
51
C.ALGORITHM
 
52
C
 
53
C  USE TABLE INTERFACE ROUTINES
 
54
C
 
55
C-----------------------------------------------------------
 
56
C
 
57
 
 
58
      SUBROUTINE RFREQU(NROW,X,M,NPIX,F,START,STEP,RMIN,RMAX)
 
59
C
 
60
C COMPUTE THE FREQUENCY
 
61
C SINGLE PRECISION VERSION
 
62
C
 
63
      IMPLICIT NONE
 
64
      INTEGER  NROW, NPIX
 
65
      REAL X(NROW),M(NROW),F(NPIX)
 
66
      REAL START, STEP, RMIN, RMAX
 
67
C
 
68
      INTEGER  I, J
 
69
C 
 
70
      INTEGER TINULL
 
71
      REAL    TRNULL, TBLSEL
 
72
      DOUBLE PRECISION TDNULL, TDTRUE, TDFALS
 
73
C
 
74
C ... GET MACHINE CONSTANTS
 
75
C
 
76
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
77
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
78
C
 
79
C
 
80
      DO 10 I = 1,NPIX
 
81
          F(I)   = 0.
 
82
   10 CONTINUE
 
83
      RMIN   = 0.
 
84
      RMAX   = 0.
 
85
      DO 20 I = 1,NROW
 
86
          IF (M(I).EQ.TBLSEL .AND. X(I).NE.TRNULL) THEN
 
87
              J      = (X(I)-START)/STEP + 1
 
88
              IF (J.GE.1 .AND. J.LE.NPIX) THEN
 
89
                  F(J)   = F(J) + 1
 
90
                  RMAX   = AMAX1(RMAX,F(J))
 
91
              END IF
 
92
          END IF
 
93
   20 CONTINUE
 
94
      RETURN
 
95
      END
 
96
 
 
97
      SUBROUTINE DFREQU(NROW,X,M,NPIX,F,START,STEP,RMIN,RMAX)
 
98
C
 
99
C COMPUTE THE FREQUENCY
 
100
C DOUBLE PRECISION VERSION
 
101
C
 
102
      IMPLICIT NONE
 
103
      INTEGER          NROW, NPIX
 
104
      REAL             M(NROW),F(NPIX)
 
105
      DOUBLE PRECISION X(NROW)
 
106
      REAL             START, STEP, RMIN, RMAX
 
107
C
 
108
      INTEGER          I, J
 
109
C 
 
110
      INTEGER TINULL
 
111
      REAL    TRNULL, TBLSEL
 
112
      DOUBLE PRECISION TDNULL, TDTRUE, TDFALS
 
113
C
 
114
C ... GET MACHINE CONSTANTS
 
115
C
 
116
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
117
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
118
C
 
119
C
 
120
      DO 10 I = 1,NPIX
 
121
          F(I)   = 0.
 
122
   10 CONTINUE
 
123
      RMIN   = 0.
 
124
      RMAX   = 0.
 
125
      DO 20 I = 1,NROW
 
126
          IF (M(I).EQ.TBLSEL .AND. X(I).NE.TDNULL) THEN
 
127
              J      = (X(I)-START)/STEP + 1
 
128
              IF (J.GE.1 .AND. J.LE.NPIX) THEN
 
129
                  F(J)   = F(J) + 1
 
130
                  RMAX   = AMAX1(RMAX,F(J))
 
131
              END IF
 
132
          END IF
 
133
   20 CONTINUE
 
134
      RETURN
 
135
      END
 
136
 
 
137
      SUBROUTINE TDHSTM(TID,ICOL,NROW,NPIX,F,START,STEP,RMIN,RMAX)
 
138
C
 
139
C COMPUTE HISTOGRAM FOR A TABLE COLUMN
 
140
C
 
141
      IMPLICIT NONE
 
142
      INTEGER  TID, ICOL, NROW, NPIX
 
143
      REAL     F(NPIX)
 
144
      REAL     START, STEP, RMIN, RMAX, XX
 
145
C
 
146
      LOGICAL  ISEL, NULL
 
147
      INTEGER  I, J, STATUS
 
148
C 
 
149
      DO 10 I = 1, NPIX
 
150
          F(I)   = 0.
 
151
   10 CONTINUE
 
152
      RMIN   = 0.
 
153
      RMAX   = 0.
 
154
      DO 20 I = 1,NROW
 
155
          CALL TBSGET(TID, I, ISEL, STATUS)
 
156
          IF (ISEL) THEN
 
157
             CALL TBERDR(TID, I, ICOL, XX, NULL, STATUS)
 
158
             IF (.NOT.NULL) THEN
 
159
                  J      = (XX-START)/STEP + 1
 
160
                  IF (J.GE.1 .AND. J.LE.NPIX) THEN
 
161
                      F(J)   = F(J) + 1
 
162
                      RMAX   = AMAX1(RMAX,F(J))
 
163
                  ENDIF
 
164
             ENDIF
 
165
          ENDIF
 
166
   20 CONTINUE
 
167
      RETURN
 
168
      END
 
169
 
 
170
 
 
171
      SUBROUTINE
 
172
     .TDIHST(ARRAY,NAXIS,NPIX,SUBLO,SUBHI,CUTS,SLTSIZ,NSLOT,SLOT,
 
173
     .RMIN,RMAX)
 
174
C
 
175
      IMPLICIT NONE
 
176
C 
 
177
      INTEGER      NAXIS,NPIX(*),SUBLO(*),SUBHI(*),NSLOT
 
178
      INTEGER      LOWX,LOWY,LOWZ,HIX,HIY,HIZ
 
179
      INTEGER      N,OFF,YOFF,ZOFF,NX,NY,NZ
 
180
      INTEGER      NPX,NPXY,X
 
181
C 
 
182
      REAL         ARRAY(*),SLOT(*)
 
183
      REAL         SLTSIZ,CUTS(2),F,R, RMIN, RMAX
 
184
C
 
185
C  clear slots
 
186
      RMIN = 0.
 
187
      RMAX = 0.
 
188
      DO 100, N=1,NSLOT
 
189
         SLOT(N) = 0
 
190
100   CONTINUE
 
191
      F = 1./SLTSIZ
 
192
C
 
193
C  determine subarea
 
194
      LOWX = SUBLO(1)
 
195
      HIX = SUBHI(1)
 
196
      NPX = NPIX(1)
 
197
      IF (NAXIS.GE.2) THEN
 
198
         LOWY = SUBLO(2)
 
199
         HIY = SUBHI(2)
 
200
         NPXY = NPX * NPIX(2)
 
201
      ELSE
 
202
         LOWY = 1
 
203
         HIY = 1
 
204
         NPXY = NPX
 
205
      ENDIF
 
206
      IF (NAXIS.GE.3) THEN
 
207
         LOWZ = SUBLO(3)
 
208
         HIZ = SUBHI(3)
 
209
      ELSE
 
210
         LOWZ = 1
 
211
         HIZ = 1
 
212
      ENDIF
 
213
C
 
214
      ZOFF = (LOWZ-1) * NPXY
 
215
      YOFF = (LOWY-1) * NPX
 
216
C
 
217
C  test, if we have excess bins
 
218
      IF (CUTS(2).LE.CUTS(1)) GOTO 1000
 
219
C
 
220
C  main loop over all pixels in given area with excess bins
 
221
      DO 800, NZ=LOWZ,HIZ
 
222
C
 
223
         DO 600, NY=LOWY,HIY
 
224
            OFF = ZOFF + YOFF
 
225
C
 
226
            DO 500, NX=LOWX,HIX
 
227
               N = OFF + NX
 
228
               IF (ARRAY(N).GT.CUTS(2)) THEN
 
229
                  X = NSLOT                        !high excess bin
 
230
               ELSE
 
231
                  R = ARRAY(N) - CUTS(1)
 
232
                  IF (R.LT.0.) THEN
 
233
                     X = 1                      !low excess bin
 
234
                  ELSE
 
235
                     X = INT(F*R) + 2                  !valid bin
 
236
                  ENDIF
 
237
               ENDIF
 
238
               SLOT(X) = SLOT(X) + 1
 
239
               RMAX    = AMAX1(RMAX, SLOT(X))
 
240
500         CONTINUE
 
241
C
 
242
            YOFF = YOFF + NPX
 
243
600      CONTINUE
 
244
C
 
245
         ZOFF = ZOFF + NPXY
 
246
800   CONTINUE
 
247
C
 
248
C  that's it
 
249
      RETURN
 
250
C
 
251
C  main loop over all pixels in given area without excess bins
 
252
1000  DO 1800, NZ=LOWZ,HIZ
 
253
C
 
254
         DO 1600, NY=LOWY,HIY
 
255
            OFF = ZOFF + YOFF
 
256
C
 
257
            DO 1500, NX=LOWX,HIX
 
258
               N = OFF + NX
 
259
               X = INT(F*(ARRAY(N)-CUTS(1))) + 1
 
260
               SLOT(X) = SLOT(X) + 1
 
261
               RMAX    = AMAX1(RMAX, SLOT(X))
 
262
1500        CONTINUE
 
263
C
 
264
            YOFF = YOFF + NPX
 
265
1600     CONTINUE
 
266
C
 
267
         ZOFF = ZOFF + NPXY
 
268
1800  CONTINUE
 
269
C
 
270
      RETURN
 
271
      END