← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/daophot/libsrc/sort.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/daophot/libsrc/sort.for
 
1
C @(#)sort.for  19.1 (ES0-DMD) 02/25/03 13:23:50
 
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
      SUBROUTINE  SORTER (WORK, MAXWRK, SORT, HIGH, LOW, INDEX, 
 
30
     .     MAXSTR, WATCH)
 
31
C
 
32
C=======================================================================
 
33
C
 
34
C Subroutine to read in any of the data files created by DAOPHOT and
 
35
C sort the stars according to magnitude, position, ID number,
 
36
C or OTHER.
 
37
C
 
38
C              OFFICIAL DAO VERSION:  1991 April 18
 
39
C
 
40
C Argument
 
41
C
 
42
C  WATCH (INPUT) governs whether information relating to the progress 
 
43
C        of the reductions is to be typed on the terminal screen
 
44
C        during execution.
 
45
C
 
46
C WATCH is a user-definable optional parameter.
 
47
C
 
48
C=======================================================================
 
49
C
 
50
CC    IMPLICIT NONE
 
51
C
 
52
C Parameters
 
53
C
 
54
C    MAX is the number of different sorts which are possible
 
55
C        (currently 5: by ID number, by X, by Y, by magnitude, and
 
56
C         by OTHER [e.g. SHARP, ROUND, CHI, number of iterations]).
 
57
C
 
58
C MAXSTR is the maximum number of stars permitted in a data file.
 
59
C        It is limited by the size of the WORK array in DAOPHOT:
 
60
C        WORK must contain 282 bytes per star:  4 bytes each for SORT,
 
61
C        INDEX, NLINE1, and, NLINE2, and 133 bytes each for LINE1 and 
 
62
C        LINE2.
 
63
C
 
64
C MAXITM is the maximum number of output data per line of an output.
 
65
C        (currently 15, realized in PHOTOMETRY)
 
66
C
 
67
      INTEGER MAXWRK, MAXSTR, MAXITM
 
68
      PARAMETER (MAXITM=30)
 
69
C
 
70
      REAL DATUM(MAXITM), WORK(MAXWRK), SORT(MAXSTR)
 
71
      INTEGER LOW(MAXSTR), HIGH(MAXSTR), INDEX(MAXSTR)
 
72
C
 
73
      REAL ABS
 
74
      INTEGER NINT
 
75
C
 
76
      CHARACTER*133 TEXT
 
77
      CHARACTER*30 FILE, SWITCH
 
78
      CHARACTER CASE*4, ANSWER*1
 
79
      REAL LOBAD, HIBAD, THRESH, AP1, PHPADU, READNS, FRAD
 
80
      REAL WATCH, WHICH, FLIP
 
81
      INTEGER I, J, K, L, N, NL, NCOL, NROW, ISTAT, ITEMS, NSTAR
 
82
      INTEGER NLO, MODE, AMODE
 
83
C
 
84
C-----------------------------------------------------------------------
 
85
C
 
86
C SECTION 1
 
87
C
 
88
C Get ready.
 
89
C
 
90
C Find out how the user wants to sort.
 
91
C
 
92
      WRITE (6,610) MAXITM
 
93
  610 FORMAT (//
 
94
     .     11X, '   The following sorts are currently possible:'//
 
95
     .     11X, '+/- 1  By increasing/decreasing star ID number'//
 
96
     .     11X, '+/- 2  By increasing/decreasing  X  coordinate'//
 
97
     .     11X, '+/- 3  By increasing/decreasing  Y  coordinate'//
 
98
     .     11X, '+/- 4  By increasing/decreasing magnitude'//
 
99
     .     11X, '+/- n  By increasing/decreasing OTHER (n <= ',
 
100
     .     I2, ')'///)
 
101
      CALL GETDAT ('Which do you want?', WHICH, 1)
 
102
      IF (WHICH .LT. -1.E38) RETURN                 ! CTRL-Z was entered
 
103
C
 
104
      MODE=NINT(WHICH)
 
105
      AMODE = MODE
 
106
      IF (MODE.LT.0) AMODE = -MODE
 
107
      IF ((AMODE .LT. 1) .OR. (AMODE .GT. MAXITM))
 
108
     .     RETURN                                     ! Invalid response
 
109
C
 
110
      FLIP=FLOAT(MODE/AMODE)
 
111
      MODE=AMODE
 
112
C
 
113
C Get input file name, open the file, and read its header.
 
114
C
 
115
      FILE=' '
 
116
  950 CALL GETNAM ('Input file name:', FILE)
 
117
      IF ((FILE .EQ. 'END OF FILE') .OR. (FILE .EQ. 'GIVE UP')) RETURN
 
118
      CALL INFILE (2, FILE, ISTAT)
 
119
      IF (ISTAT .NE. 0) THEN
 
120
         CALL STUPID ('Error opening input file '//FILE)
 
121
         FILE = 'GIVE UP'
 
122
         GO TO 950
 
123
      END IF
 
124
C
 
125
C Get output file name and open the file.
 
126
C
 
127
      FILE = SWITCH(FILE, CASE('.srt'))
 
128
  960 CALL GETNAM ('Output file name:', FILE)
 
129
      IF ((FILE .EQ. 'END OF FILE') .OR. (FILE .EQ. 'GIVE UP')) THEN
 
130
         CALL CLFILE (2)
 
131
         RETURN
 
132
      END IF
 
133
C
 
134
      CALL OUTFIL (3, FILE, ISTAT)
 
135
      IF (ISTAT .NE. 0) THEN
 
136
         CALL STUPID ('Error opening output file '//FILE)
 
137
         FILE = 'GIVE UP'
 
138
         GO TO 960
 
139
      END IF
 
140
C
 
141
      CALL GETYN ('Do you want the stars renumbered?', ANSWER)
 
142
      IF (ANSWER .EQ. 'E') THEN
 
143
         CALL CLFILE (2)
 
144
      END IF
 
145
C
 
146
      NL=-1
 
147
      CALL RDHEAD (2, NL, NCOL, NROW, LOBAD, HIBAD, THRESH, AP1, 
 
148
     .     PHPADU, READNS, FRAD)
 
149
      IF (NL .LE. 0) GO TO 1010                     ! No header in input
 
150
      IF (NL .GT. 3) NL=1
 
151
C
 
152
C Copy input file header to output file.  
 
153
C
 
154
      ITEMS=6
 
155
      IF (FRAD .GT. 0.001) ITEMS=7
 
156
      CALL WRHEAD (3, NL, NCOL, NROW, ITEMS, LOBAD, HIBAD, THRESH, 
 
157
     .     AP1, PHPADU, READNS, FRAD)
 
158
C
 
159
 1010 CONTINUE
 
160
      IF (WATCH .LT. 0.5) GO TO 1020
 
161
      IF (MODE .LE. 4) WRITE (6,611)
 
162
  611 FORMAT (/22X, 'STAR', 6X, 'X', 8X, 'Y', 4X, 'MAG.(1)')
 
163
      IF (MODE .GE. 5) WRITE (6,612) MODE
 
164
  612 FORMAT (/17X, 'STAR', 6X, 'X', 8X, 'Y', 4X, 'MAG.(1)',
 
165
     .     3X, 'ITEM', I3)
 
166
 1020 CONTINUE
 
167
C
 
168
C-----------------------------------------------------------------------
 
169
C
 
170
C SECTION 2
 
171
C
 
172
C Read the input file in line by line, verbatim.  Pack the contents
 
173
C of the line into the REAL array WORK, keeping track of the
 
174
C lower and upper limits in the arrays LINELO and LINEHI.  At the
 
175
C same time, extract the the particular datum 
 
176
C according to which we wish to sort.  Sort these data.  Then write 
 
177
C the file out again, line by line, verbatim, but in the new order.
 
178
C
 
179
      I=0
 
180
      NLO = 0
 
181
C
 
182
 2000 CALL RDCHAR (2, TEXT, N, ISTAT)
 
183
      IF (ISTAT .EQ. 1) GO TO 2100             ! END OF FILE
 
184
      IF (ISTAT .NE. 0) THEN
 
185
         CALL STUPID ('Unable to read input file.')
 
186
         CALL CLFILE (2)
 
187
         RETURN
 
188
      END IF
 
189
C
 
190
      IF (N .LE. 1) GO TO 2000                 ! Blank line encountered
 
191
      READ (TEXT(2:N), 901, IOSTAT=ISTAT) 
 
192
     .     (DATUM(J), J=1,(N-5)/9+1)
 
193
  901 FORMAT (F5.0, 14F9.0)
 
194
      IF (ISTAT .NE. 0) THEN
 
195
         CALL STUPID ('Unable to read data from input file.')
 
196
         CALL CLFILE (2)
 
197
         RETURN
 
198
      END IF
 
199
C
 
200
      I = I+1
 
201
      IF (I .GT. MAXSTR) THEN
 
202
         WRITE (TEXT,77) I-1
 
203
   77    FORMAT (I10, ' stars is all I have room for.  Sorry!')
 
204
         CALL STUPID (TEXT(1:50))
 
205
         CALL CLFILE (2)
 
206
         RETURN
 
207
      END IF
 
208
      LOW(I) = NLO+1
 
209
      HIGH(I) = NLO + (N-2)/4 + 1
 
210
      IF (HIGH(I) .GT. MAXWRK) THEN
 
211
         WRITE (TEXT,77) I-1
 
212
         CALL STUPID (TEXT(1:50))
 
213
         CALL CLFILE (2)
 
214
         RETURN
 
215
      END IF
 
216
C
 
217
      NLO = HIGH(I)
 
218
      READ (TEXT(2:N),66) (WORK(J), J=LOW(I),NLO)
 
219
   66 FORMAT (33A4)
 
220
C
 
221
      IF (NL .EQ. 2) THEN
 
222
 2012    CALL RDCHAR (2, TEXT, N, ISTAT)
 
223
         IF (ISTAT .NE. 0) THEN
 
224
            CALL STUPID ('Unable to read input file.')
 
225
            CALL CLFILE (2)
 
226
            RETURN
 
227
         END IF
 
228
C
 
229
         IF (N .LE. 1) GO TO 2012
 
230
         READ (TEXT(2:N), 902, IOSTAT=ISTAT)
 
231
     .        (DATUM(J), J=16,19+(N-25)/9)
 
232
  902    FORMAT (F12.3, 2F6.3, 12(F8.3, 1X))
 
233
         IF (ISTAT .NE. 0) THEN
 
234
            CALL STUPID ('Unable to read data from input file.')
 
235
            CALL CLFILE (2)
 
236
            RETURN
 
237
         END IF
 
238
C
 
239
         HIGH(I) = HIGH(I) + (N-2)/4+1
 
240
         IF (HIGH(I) .GT. MAXWRK) THEN
 
241
            WRITE (TEXT,77) I-1
 
242
            CALL STUPID (TEXT(1:50))
 
243
            CALL CLFILE (2)
 
244
            RETURN
 
245
         END IF
 
246
         READ (TEXT(2:N),66) (WORK(J), J=NLO+1,HIGH(I))
 
247
         NLO = HIGH(I)
 
248
      END IF
 
249
C
 
250
      SORT(I)=FLIP*DATUM(MODE)
 
251
      GO TO 2000                                     ! End of input loop
 
252
C
 
253
C Perform the sort.
 
254
C
 
255
 2100 NSTAR=I                                        ! Number of stars
 
256
      CALL CLFILE (2)
 
257
      IF (NSTAR .LE. 0) THEN
 
258
         CALL STUPID ('No stars in input file.')
 
259
         RETURN
 
260
      END IF
 
261
      CALL QUICK (SORT, NSTAR, INDEX)
 
262
C
 
263
C The vector SORT is now arranged in order of increasing or decreasing
 
264
C whatever, and the vector INDEX now contains the ordinal position in
 
265
C the input file of the stars, in order of increasing or decreasing
 
266
C whatever.
 
267
C
 
268
C Now write the data out again.
 
269
C
 
270
      DO 2110 I=1,NSTAR
 
271
      J = INDEX(I)
 
272
      IF (NL .NE. 2) THEN
 
273
         NLO = HIGH(J) - LOW(J) + 1
 
274
         K = 4*NLO+1
 
275
         WRITE (TEXT(1:K),67) (WORK(L), L=LOW(J),HIGH(J))
 
276
   67    FORMAT (1X, 33A4)
 
277
C
 
278
C If ID numbers are to be changed, insert the new ID into the text.
 
279
C
 
280
         IF (ANSWER .EQ. 'Y') WRITE (TEXT(2:6),68) I
 
281
   68    FORMAT (I5)
 
282
         WRITE (3,320) TEXT(1:K)
 
283
  320    FORMAT (A)
 
284
         IF (WATCH .LT. 0.5) GO TO 2110
 
285
         IF (MODE .LE. 4) THEN
 
286
            WRITE (6,620) TEXT(2:33)
 
287
  620       FORMAT (21X, A32)
 
288
         ELSE
 
289
            WRITE (6,621) TEXT(2:33), FLIP*SORT(I)
 
290
  621       FORMAT (16X, A32, 1X, F9.3)
 
291
         END IF
 
292
      ELSE
 
293
         NLO = (HIGH(J) - LOW(J) + 1)/2
 
294
         K = 4*NLO+1
 
295
         WRITE (TEXT(1:K),67) (WORK(L), L=LOW(J),LOW(J)+NLO-1)
 
296
         IF (ANSWER .EQ. 'Y') WRITE (TEXT(2:6),68) I
 
297
         WRITE (3,320) TEXT(1:K)
 
298
         IF (WATCH .GE. 0.5) THEN
 
299
            IF (MODE .LE. 4) THEN
 
300
               WRITE (6,620) TEXT(2:33)
 
301
            ELSE
 
302
               WRITE (6,621) TEXT(2:33), FLIP*SORT(I)
 
303
            END IF
 
304
         END IF
 
305
         WRITE (TEXT(1:K),67) (WORK(L), L=LOW(J)+NLO,HIGH(J))
 
306
         WRITE (3,320) TEXT(1:K)
 
307
         WRITE (3,320) ' '
 
308
      END IF
 
309
C
 
310
 2110 CONTINUE                                      ! End of output loop
 
311
C
 
312
C-----------------------------------------------------------------------
 
313
C
 
314
C Normal return.
 
315
C
 
316
      CALL CLFILE (3)
 
317
      RETURN
 
318
C
 
319
      END!