← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/pepsys/libsrc/subs1.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/pepsys/libsrc/subs1.for
 
1
C @(#)subs1.for 19.1 (ES0-DMD) 02/25/03 13:28:48
 
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  @(#)subs1.for        4.5  (ESO-IPG)  3/26/93  15:40:53
 
30
C *************  COMMON FUNCTIONS AND SUBROUTINES  **********************
 
31
C
 
32
C       Copyright (C) Andrew T. Young, 1990
 
33
C       Copyright (C) European Southern Observatory, 1992
 
34
C
 
35
C
 
36
      FUNCTION GETIME(STR,HRS,TMIN,SEC)
 
37
C
 
38
C  RETURNS TIME IN RADIANS.    AUG.1985
 
39
C
 
40
C
 
41
      IMPLICIT NONE
 
42
C
 
43
      REAL GETIME, HRS, TMIN, SEC, DEGRAD, DEG10
 
44
C
 
45
      CHARACTER STR*20, STR2*40
 
46
      DATA DEGRAD/0.017453292519943/
 
47
C
 
48
        IF(STR.NE.' ')THEN
 
49
      GETIME=DEG10(STR)*15.*DEGRAD
 
50
        ELSE
 
51
      IF(SEC.EQ.3.E33)SEC=0.
 
52
      IF(TMIN.EQ.3.E33)TMIN=0.
 
53
       IF(HRS.GT.24. .OR. TMIN.GT.60. .OR. SEC.GT.60.)THEN
 
54
      CALLTV('Time not legal')
 
55
      WRITE(STR2,5)HRS,TMIN,SEC
 
56
    5 FORMAT(' HRS =',F5.1,'  MIN =',F5.1,'  SEC =',F5.1)
 
57
      CALL TV(STR2)
 
58
      CALL STETER(900, 'BAD TIME')
 
59
       END IF
 
60
      GETIME=(HRS+(TMIN+SEC/60.)/60.)*15.*DEGRAD
 
61
        END IF
 
62
      RETURN
 
63
      END
 
64
      FUNCTION DEG10(STRING)
 
65
C
 
66
C       Copyright (C) Andrew T. Young, 1990
 
67
C
 
68
C  CONVERTS CHARACTER STRING FROM DEG MIN SEC TO DECIMAL DEGREES.
 
69
C     NOMINAL STRING FORMAT (3F3.0)            5 JAN.'87
 
70
C
 
71
C
 
72
      IMPLICIT NONE
 
73
C
 
74
      REAL DEG10, DEG, DMIN, SEC
 
75
      INTEGER L, LCOL, LDOT
 
76
C
 
77
      CHARACTER STRING*(*),LINE*20,LDUM*20
 
78
C
 
79
      LINE=STRING
 
80
C  LEFT-JUSTIFY.
 
81
      DO 1 L=1,10
 
82
      IF(LINE(L:L).NE.' ') GO TO 2
 
83
    1 CONTINUE
 
84
      DEG10=0.
 
85
      RETURN
 
86
C
 
87
    2 LDUM=LINE(L:)
 
88
C  FIND SEPARATORS.
 
89
    3 LCOL=INDEX(LDUM,':')
 
90
C
 
91
       IF(LCOL.NE.0)THEN
 
92
C   REPLACE COLONS.
 
93
      LDUM(LCOL:LCOL)=' '
 
94
      GO TO 3
 
95
       END IF
 
96
C
 
97
      LDOT=INDEX(LDUM,'.')
 
98
      L=INDEX(LDUM,' ')
 
99
        IF(LDOT.EQ.0 .OR. L.LT.LDOT)THEN
 
100
C   LINE UP.
 
101
      LINE=' '
 
102
      LINE(6-L:)=LDUM
 
103
      IF(LDOT.NE.0) LDOT=LDOT+5-L
 
104
C   DEGREES ARE IN COL.1-4.
 
105
C
 
106
       IF(LDOT.EQ.11 .OR. (LDOT.EQ.0 .AND. LINE(5:5).EQ.' '))THEN
 
107
C    DECIMAL SECONDS.
 
108
      READ(LINE,'(F4.0,F3.0,BZ,F6.3)',ERR=99) DEG,DMIN,SEC
 
109
       ELSE IF(LDOT.EQ.8)THEN
 
110
C    MINUTES AND TENTHS.
 
111
      READ(LINE,'(F4.0,F5.1)',ERR=99) DEG,DMIN
 
112
      SEC=0.
 
113
       ELSE
 
114
      GO TO 99
 
115
       END IF
 
116
C
 
117
        ELSE
 
118
C    DECIMAL DEGREES.
 
119
      READ(LDUM,'(F11.8)',ERR=99) DEG10
 
120
      RETURN
 
121
        END IF
 
122
C
 
123
      DEG10=ABS(DEG)+((SEC/60.+DMIN)/60.)
 
124
      IF(SEC.GT.60. .OR. DMIN.GT.60.) GO TO 98
 
125
      IF(INDEX(LDUM,'-').NE.0) DEG10=-DEG10
 
126
      RETURN
 
127
C
 
128
C
 
129
   98 CALL TV('More than 60 min.or sec.')
 
130
   99 CALL TV('BADLY FORMATTED DATA:')
 
131
      CALL TV(LINE)
 
132
      DEG10=3.E33
 
133
      RETURN
 
134
      END
 
135
      FUNCTION DEG2MS(DEG)
 
136
C
 
137
C       Copyright (C) Andrew T. Young, 1990
 
138
C
 
139
C  CONVERT DECIMAL DEG TO DEG/MIN/SEC STRING.     4 JAN.87
 
140
C
 
141
C
 
142
      IMPLICIT NONE
 
143
C
 
144
      REAL DEG, FMIN, SEC
 
145
      INTEGER LDEG, MIN, LSEC, LT
 
146
C
 
147
      CHARACTER*13 DEG2MS,B13
 
148
C
 
149
      LDEG=DEG
 
150
C   USE TRUNCATED DEG.
 
151
      FMIN=ABS(DEG-(LDEG))*60.
 
152
      MIN=FMIN
 
153
C   USE TRUNCATED MINUTE.
 
154
      SEC=(FMIN-(MIN))*60.
 
155
      LSEC=SEC
 
156
C   ROUND.
 
157
      LT=(SEC-LSEC)*10.+.5
 
158
      IF(LT.LT.10) GO TO 10
 
159
      LT=0
 
160
      LSEC=LSEC+1
 
161
      IF(LSEC.LT.60)GO TO 10
 
162
      LSEC=0
 
163
      MIN=MIN+1
 
164
      IF(MIN.LT.60)GO TO 10
 
165
      MIN=0
 
166
      LDEG=LDEG+SIGN(1.,DEG)
 
167
   10 WRITE(B13,'(3I3.2,''.'',I1)')LDEG,MIN,LSEC,LT
 
168
C    ASSUME NO NEGATIVE VALUES LARGER THAN 99.
 
169
      IF(LDEG.EQ.0 .AND. DEG.LT.0.) B13(:1)='-'
 
170
        DEG2MS=B13
 
171
      RETURN
 
172
      END
 
173
      FUNCTION MON2M(MON)
 
174
C
 
175
C       Copyright (C) Andrew T. Young, 1990
 
176
C       Copyright (C) European Southern Observatory, 1992
 
177
C
 
178
C  CONVERTS 1ST 3 LETTERS OF MONTH TO INTEGER.
 
179
C   RETURNS 0 IF NAME NOT RECOGNISED.
 
180
C
 
181
C
 
182
      IMPLICIT NONE
 
183
C
 
184
      INTEGER MON2M, M
 
185
C
 
186
      CHARACTER*3 MON, MONTHS(12), LMON(12)
 
187
      CHARACTER*20 EMSG
 
188
C
 
189
      DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL',
 
190
     1 'AUG','SEP','OCT','NOV','DEC'/
 
191
      DATA LMON/'Jan','Feb','Mar','Apr','May','Jun','Jul',
 
192
     1 'Aug','Sep','Oct','Nov','Dec'/
 
193
C
 
194
      DO 403 M=1,12
 
195
      IF(MON.EQ.MONTHS(M))GO TO 405
 
196
  403 CONTINUE
 
197
c       Try lower-case if not found:
 
198
      DO 404 M=1,12
 
199
      IF(MON.EQ.LMON(M))GO TO 405
 
200
  404 CONTINUE
 
201
c       Complain if not found:
 
202
      EMSG='Incorrect month:'//MON
 
203
      CALL TV(EMSG)
 
204
      M=0
 
205
  405 MON2M=M
 
206
      RETURN
 
207
      END
 
208
      FUNCTION M2MON(M)
 
209
C
 
210
C       Copyright (C) Andrew T. Young, 1990
 
211
C
 
212
C  CONVERT INTEGER TO MON(TH NAME).
 
213
C
 
214
C
 
215
      IMPLICIT NONE
 
216
C
 
217
      INTEGER M
 
218
C
 
219
      CHARACTER*3 MONTHS(12), M2MON
 
220
C
 
221
      DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL',
 
222
     1 'AUG','SEP','OCT','NOV','DEC'/
 
223
C
 
224
      M2MON=MONTHS(M)
 
225
      RETURN
 
226
      END
 
227
      SUBROUTINE DECOLR(COLORS,CNAMES,BANDS,SYSTEM,CANNED)
 
228
C
 
229
C       Copyright (C) Andrew T. Young, 1990
 
230
C       Copyright (C) European Southern Observatory, 1992
 
231
C
 
232
C  SETS UP COLOR MATRICES, ETC.      31 JAN. 1987
 
233
C
 
234
C
 
235
C       Deduces relation between bands and indices from color names CNAMES
 
236
C       and band names BANDS, and stores this matrix in COLORM.  Copies this
 
237
C       to COLORS (used as scratch space), and forms inverse in COLRIN.
 
238
C
 
239
C
 
240
      IMPLICIT NONE
 
241
C
 
242
      REAL COLORS, COLORM, COLRIN, XINV, YINV, DUM, BIG, PMULT
 
243
      INTEGER NBANDS, LENB, LENC, KX, KY, MAGS, K, J, N, MINUS, NB, L, 
 
244
     1         LWORD, I, IP1, NBGRW, NCOLB, NROW, NXS, KK
 
245
C
 
246
      INCLUDE 'MID_REL_INCL:mbands.inc'
 
247
C     PARAMETER (MBANDS=9)
 
248
      COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS),
 
249
     1 XINV,YINV,NBANDS,LENB,LENC,KX,KY
 
250
      SAVE /CMAGS1/
 
251
C
 
252
      INCLUDE 'MID_REL_INCL:mstars.inc'
 
253
C     PARAMETER (MSTARS=1650)
 
254
      CHARACTER *8 BANDS(3*MBANDS), CNAMES(2,MBANDS), SYSTEM*6, A*1
 
255
      CHARACTER *80 PAGE(MBANDS)
 
256
      DIMENSION COLORS(MBANDS,MSTARS)
 
257
      LOGICAL CANNED
 
258
C
 
259
      MAGS=0
 
260
C
 
261
      DO 4 K=1,NBANDS
 
262
      DO 1 J=1,NBANDS
 
263
      COLRIN(J,K)=0.
 
264
    1 COLORM(J,K)=0.
 
265
      COLRIN(K,K)=1.
 
266
      N=0
 
267
      MINUS=INDEX(CNAMES(1,K),'-')
 
268
C
 
269
       IF(MINUS.NE.0)THEN
 
270
C   COLOR INDEX.
 
271
C
 
272
      DO 2 NB=1,NBANDS
 
273
      L=LWORD(BANDS(NB))
 
274
      J=INDEX(CNAMES(1,K),BANDS(NB)(:L))
 
275
       IF(J.NE.0)THEN
 
276
C
 
277
        IF(J.LT.MINUS .AND. L.EQ.MINUS-J)THEN
 
278
      COLORM(NB,K)=1.
 
279
      N=N+1
 
280
        ELSE IF(J.GT.MINUS .AND. BANDS(NB).EQ.CNAMES(1,K)(MINUS+1:))THEN
 
281
      COLORM(NB,K)=-1.
 
282
      N=N+1
 
283
        END IF
 
284
C
 
285
       END IF
 
286
    2 CONTINUE
 
287
      IF(N.NE.2) MAGS=5
 
288
C
 
289
       ELSE
 
290
C   MAGNITUDE.
 
291
C
 
292
      DO 3 NB=1,NBANDS
 
293
      IF(CNAMES(1,K).EQ.BANDS(NB) .OR. CNAMES(1,K)(2:).EQ.BANDS(NB))
 
294
     1 COLORM(NB,K)=1.
 
295
    3 CONTINUE
 
296
      MAGS=MAGS+1
 
297
C
 
298
       END IF
 
299
    4 CONTINUE
 
300
C
 
301
C   SPECIALS for uvby, etc.
 
302
       IF(SYSTEM(:4).EQ.'UVBY')THEN
 
303
C    MAG.IS Y, NOT V.
 
304
         COLORM(2,1)=0.
 
305
         COLORM(4,1)=1.
 
306
C    M1 IN ROW 3, C1 IN 4.
 
307
         COLORM(2,3)=1.
 
308
         COLORM(3,3)=-2.
 
309
         COLORM(4,3)=1.
 
310
         COLORM(1,4)=1.
 
311
         COLORM(2,4)=-2.
 
312
         COLORM(3,4)=1.
 
313
       END IF
 
314
C   FIX H-BETAS.
 
315
       IF(SYSTEM.EQ.'UVBYHB')THEN
 
316
         COLORM(5,5)=-1.
 
317
         COLORM(6,5)=1.
 
318
         COLORM(5,6)=1.
 
319
       ELSE IF(SYSTEM.EQ.'H-BETA') THEN
 
320
         COLORM(1,1)=-1.
 
321
         COLORM(2,1)=1.
 
322
         COLORM(1,2)=1.
 
323
C   FIX GENEVA (VM = V).
 
324
       ELSE IF(SYSTEM.EQ.'GENEVA') THEN
 
325
         COLORM(3,1)=1.
 
326
       END IF
 
327
      IF(CANNED) MAGS=1
 
328
C   Detect problems.
 
329
    5 IF(.NOT.CANNED .OR. MAGS.GT.1)THEN
 
330
    6   CALL TV('Please check this transformation matrix:')
 
331
        WRITE(PAGE,7)(BANDS(I),I=1,NBANDS)
 
332
    7   FORMAT(/17X,9A7)
 
333
        DO 10 I=1,(NBANDS+17)/9
 
334
   10     CALL TVN(PAGE(I))
 
335
        DO 20 I=1,NBANDS
 
336
        DO 20 N=1,NBANDS,9
 
337
          WRITE(PAGE,15)I,CNAMES(1,I),(COLORM(J,I),J=N,MIN(NBANDS,N+8))
 
338
   15     FORMAT(/I2,2X,A6,' = ',9F7.1/(12X,9F7.1))
 
339
          DO 18 J=1,(NBANDS+17)/9
 
340
   18       CALL TVN(PAGE(J))
 
341
   20   CONTINUE
 
342
        CALL ASK('OK?',A)
 
343
        IF(A.EQ.'N')THEN
 
344
          CALLQF('Which ROW (number) is wrong?',DUM)
 
345
          N=DUM
 
346
   25     CALL ASK('Enter correct values for entire row.',PAGE(1))
 
347
          READ(PAGE(1),*,ERR=25) (COLORM(I,N),I=1,NBANDS)
 
348
          GO TO 6
 
349
        END IF
 
350
      END IF
 
351
C
 
352
C  COPY & INVERT MATRIX.
 
353
      DO 160 J=1,NBANDS
 
354
      DO 160 I=1,NBANDS
 
355
  160 COLORS(I,J)=COLORM(I,J)
 
356
C   START SYSTEM REDUCTION.
 
357
      DO 166 I=1,NBANDS-1
 
358
C   FIND COLUMN PIVOT, IN ROW NBGRW.
 
359
      IP1=I+1
 
360
      BIG=COLORS(I,I)
 
361
      NBGRW=I
 
362
      DO 161 J=IP1,NBANDS
 
363
      IF(ABS(BIG).GE.ABS(COLORS(I,J))) GO TO 161
 
364
      BIG=COLORS(I,J)
 
365
      NBGRW=J
 
366
  161 CONTINUE
 
367
      IF(BIG.EQ.0.)THEN
 
368
      CALL TV('MATRIX is SINGULAR')
 
369
      MAGS=5
 
370
      GO TO 5
 
371
      END IF
 
372
C    SWAP ROW I WITH ROW NBGRW UNLESS I=NBGRW.
 
373
      IF(NBGRW.NE.I)THEN
 
374
      DO 162 J=I,NBANDS
 
375
      DUM=COLORS(J,NBGRW)
 
376
      COLORS(J,NBGRW)=COLORS(J,I)
 
377
  162 COLORS(J,I)=DUM
 
378
      DO 163 J=1,NBANDS
 
379
      DUM=COLRIN(J,NBGRW)
 
380
      COLRIN(J,NBGRW)=COLRIN(J,I)
 
381
  163 COLRIN(J,I)=DUM
 
382
      END IF
 
383
C   ELIMINATE UNKNOWNS FROM FIRST COLUMN.
 
384
      DO 166 K=IP1,NBANDS
 
385
      PMULT=-COLORS(I,K)/BIG
 
386
      DO 164 J=IP1,NBANDS
 
387
  164 COLORS(J,K)=PMULT*COLORS(J,I)+COLORS(J,K)
 
388
      DO 165 L=1,NBANDS
 
389
  165 COLRIN(L,K)=PMULT*COLRIN(L,I)+COLRIN(L,K)
 
390
  166 CONTINUE
 
391
      IF(COLORS(NBANDS,NBANDS).EQ.0.)THEN
 
392
      CALL TV('MATRIX is SINGULAR')
 
393
      MAGS=5
 
394
      GO TO 5
 
395
      END IF
 
396
C   BACK SUBSTITUTION.
 
397
      DO 169 NCOLB=1,NBANDS
 
398
      DO 169 I=1,NBANDS
 
399
      NROW=NBANDS+1-I
 
400
      DUM=0.0
 
401
C    NUMBER OF PREVIOUSLY COMPUTED UNKNOWNS = NXS
 
402
      NXS=NBANDS-NROW
 
403
      IF(NXS.NE.0)THEN
 
404
      DO 168 K=1,NXS
 
405
      KK=NBANDS+1-K
 
406
  168 DUM=DUM+COLRIN(NCOLB,KK)*COLORS(KK,NROW)
 
407
      END IF
 
408
      DUM=COLRIN(NCOLB,NROW)-DUM
 
409
      COLRIN(NCOLB,NROW)=DUM/COLORS(NROW,NROW)
 
410
  169 CONTINUE
 
411
C
 
412
       IF(.NOT.CANNED .OR. MAGS.GT.1)THEN
 
413
      CALL TV('Inverse matrix:')
 
414
      WRITE(PAGE,7)(CNAMES(1,I),I=1,NBANDS)
 
415
      DO 170 I=1,(NBANDS+17)/18
 
416
  170 CALL TVN(PAGE(I))
 
417
      DO 180 I=1,NBANDS
 
418
  180 WRITE(PAGE,15)I,BANDS(I),(COLRIN(J,I),J=1,NBANDS)
 
419
      DO 200 I=1,(NBANDS+17)/9
 
420
  200 CALL TVN(PAGE(I))
 
421
       END IF
 
422
C
 
423
      RETURN
 
424
      END
 
425
      SUBROUTINE EXCEED(N,LABEL,M)
 
426
C
 
427
C       Copyright (C) Andrew T. Young, 1990
 
428
C       Copyright (C) European Southern Observatory, 1992
 
429
C
 
430
C                                     16 MAR.1987
 
431
C
 
432
      IMPLICIT NONE
 
433
C
 
434
      INTEGER M, N
 
435
C
 
436
      CHARACTER*6 LABEL
 
437
      CHARACTER*46 LINE(5)
 
438
C
 
439
      WRITE(LINE,2)N,LABEL,M
 
440
    2 FORMAT(I5,' EXCEEDS PARAMETER (',A6,'=',I3,').'/
 
441
     1 /' INCREASE PARAMETER AND RECOMPILE.'//' (FATAL ERROR)')
 
442
      CALL TV(LINE(1))
 
443
      CALL TVN(LINE(2))
 
444
      CALL TVN(LINE(3))
 
445
      CALL TVN(LINE(4))
 
446
      CALL TVN(LINE(5))
 
447
      RETURN
 
448
      END
 
449
      SUBROUTINE MDY(CARD,MONTH,DAY,YEAR)
 
450
C
 
451
C       Copyright (C) Andrew T. Young, 1990
 
452
C
 
453
C  EXTRACTS 3-CHAR.MONTH, FLOATING DAY & YEAR FROM STRING CARD.   3 JAN.87
 
454
C
 
455
C
 
456
      IMPLICIT NONE
 
457
C
 
458
      REAL DAY, YEAR
 
459
      INTEGER I, NEXT, LAST, I1, J
 
460
C
 
461
      CHARACTER CARD*80, MONTH*3, FIELD*5, CHAR
 
462
C
 
463
    1 FORMAT(A4)
 
464
C    SET ILLEGAL VALUES TO FLAG ERROR RETURNS.
 
465
      MONTH='XXX'
 
466
      DAY=99.
 
467
      YEAR=0.
 
468
      DO 2 I=1,80
 
469
      IF(CARD(I:I).NE.' ') GO TO 5
 
470
    2 CONTINUE
 
471
      RETURN
 
472
C
 
473
    4 FORMAT(BN,F4.0)
 
474
C
 
475
C  FIRST NON-BLANK...
 
476
    5 ASSIGN 25 TO NEXT
 
477
      ASSIGN 21 TO LAST
 
478
      IF(CARD(I:I).GT.'9' .OR. CARD(I:I).LT.'0') GO TO 14
 
479
C   FIRST FIELD NUMERIC, SO MONTH SECOND.
 
480
      I1=I
 
481
      DO 6 I=I,80
 
482
      CHAR=CARD(I:I)
 
483
      IF(CHAR.GT.'9' .OR. CHAR.LT.'0') GO TO 10
 
484
    6 CONTINUE
 
485
      RETURN
 
486
C
 
487
C   FIRST FIELD ENDS AT (I-1), I NON-NUM.
 
488
   10 WRITE(FIELD,1) CARD(I1:I-1)
 
489
      IF(I-I1-3) 11,24,20
 
490
C    1ST FIELD IS DAY.
 
491
   11 READ(FIELD,4)DAY
 
492
      ASSIGN 18 TO LAST
 
493
C     MONTH STARTS W.LETTER.
 
494
   12 DO 13 I=I,80
 
495
      CHAR=CARD(I:I)
 
496
      IF(CHAR.GE.'A' .AND. CHAR.LE.'Z') GO TO 14
 
497
   13 CONTINUE
 
498
      RETURN
 
499
C
 
500
C      GET MONTH.
 
501
   14 MONTH=CARD(I:I+2)
 
502
      I=I+3
 
503
C     FIND LAST NUMERIC FIELD.
 
504
   15 DO 16 I=I,80
 
505
      CHAR=CARD(I:I)
 
506
      IF(CHAR.GE.'0' .AND. CHAR.LE.'9') GO TO LAST,(18,21)
 
507
   16 CONTINUE
 
508
      RETURN
 
509
C    YEAR LAST.
 
510
   18 J=I+3
 
511
      IF(CARD(I+2:J).EQ.'  ')J=I+1
 
512
      WRITE(FIELD,1) CARD(I:J)
 
513
      READ(FIELD,4,ERR=19)YEAR
 
514
   19 RETURN
 
515
C
 
516
C    YEAR FIRST.
 
517
   20 READ(FIELD,4,ERR=24)YEAR
 
518
      ASSIGN 24 TO NEXT
 
519
      GO TO 12
 
520
C     (TO DO MONTH.)
 
521
C
 
522
C    DAY LAST. ENDS AT NON-NUM.I1.
 
523
   21 DO 22 I1=I+1,80
 
524
      CHAR=CARD(I1:I1)
 
525
      IF(CHAR.GT.'9' .OR. CHAR.LT.'0') GO TO 23
 
526
   22 CONTINUE
 
527
      RETURN
 
528
C
 
529
   23 WRITE(FIELD,1) CARD(I:I1-1)
 
530
      READ(FIELD,4,ERR=24) DAY
 
531
c       fudged to fool stupid MIDAS pre-processor:
 
532
      IF(.TRUE.)GO TO NEXT,(24,25)
 
533
   24 RETURN
 
534
C
 
535
C     SKIP 2ND PART OF DOUBLE DATE.
 
536
   25 I=I1+1
 
537
      ASSIGN 18 TO LAST
 
538
      IF(CARD(I1:I1).NE.'/' .AND. CARD(I1:I1).NE.'-') GO TO 15
 
539
C     DOUBLE DATE.  SKIP TO SEPARATOR.
 
540
      I=INDEX(CARD(I1:I1+3),',')
 
541
      IF(I.EQ.0) I=INDEX(CARD(I1:I1+3),' ')
 
542
      IF(I.EQ.0) GO TO 24
 
543
      I=I+I1
 
544
      GO TO 15
 
545
      END
 
546
      SUBROUTINE GETJD(DJ)
 
547
C
 
548
C       Copyright (C) Andrew T. Young, 1990
 
549
C
 
550
C  GETS DP JULIAN DAY FROM DATSTR, in common block /NAMES/.
 
551
C  Note: DJ is double precision.
 
552
C
 
553
C
 
554
      IMPLICIT NONE
 
555
C
 
556
      REAL RAHRS, RAMIN, RASEC, DEDEG, DEMIN, DESEC, EPOCH, SIGNAL,TINT, 
 
557
     1     CVARS, FMM, DD, YY, YEAR, DAY, UTHRS, UTMIN, UTSEC, CLKERR, 
 
558
     2     STHRS, STMIN, STSEC, ZTHRS, ZTMIN, ZTSEC, VSPARE, RAS, DECS, 
 
559
     3     EPOCHS, COLORS, DDAY, Y
 
560
      INTEGER NAM1, NAM2, NGRPS, MURAT, MURAA, MUDEC
 
561
      INTEGER M, MON2M, NSTAR, N, K
 
562
C
 
563
      DOUBLE PRECISION DJ
 
564
C
 
565
      INCLUDE 'MID_REL_INCL:mbands.inc'
 
566
C     PARAMETER (MBANDS=9)
 
567
C
 
568
C  Declare integer parameters for stupid compilers:
 
569
C
 
570
      INTEGER MGAINS,MG2,MA,MCAT,MN,MV,MGRPS,MAREST,MNREST
 
571
      PARAMETER (MGAINS=4, MG2=2*MGAINS)
 
572
      PARAMETER (MA=21+MG2+5)
 
573
      PARAMETER (MCAT=12+2*MBANDS,MN=MCAT+30, MV=MA+MN, MGRPS=8)
 
574
      PARAMETER (MAREST=MA-21-MG2, MNREST=MN-MCAT-15)
 
575
C
 
576
      CHARACTER NAMES(MV)*6,TITLE*80
 
577
      CHARACTER*32 STAR
 
578
      CHARACTER*20 RASTR,DESTR,BAYER,CONSTL,FLAMST,BSHR,HD,DM,
 
579
     1 SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR,
 
580
     2 FILTCD,STARCD,STRSKY,ASPARE(MAREST),GANCDN(MGAINS),DIMCDN(MGAINS)
 
581
C
 
582
C     COMMON /NAMES/NAMES,TITLE, AVAR
 
583
      COMMON /NAMES/NAMES,TITLE, RASTR,DESTR,STAR,BAYER,CONSTL,FLAMST,
 
584
     1 BSHR,HD,DM,SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR,
 
585
     2 FILTCD,STARCD,STRSKY,ASPARE,GANCDN,DIMCDN
 
586
C
 
587
      COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,RAHRS,RAMIN,RASEC,
 
588
     1 DEDEG,DEMIN,DESEC,EPOCH,MURAT,MURAA,MUDEC,SIGNAL,TINT,
 
589
     2 CVARS(2,MBANDS),FMM,DD,YY,YEAR,DAY,
 
590
     3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC,
 
591
     4 ZTHRS,ZTMIN,ZTSEC,VSPARE(MNREST)
 
592
C
 
593
      CHARACTER MON*3
 
594
C
 
595
      INCLUDE 'MID_REL_INCL:mstars.inc'
 
596
C     PARAMETER (MSTARS=1650)
 
597
C       commons for star catalog:
 
598
      CHARACTER *32 STARS
 
599
      COMMON /SCATA/ STARS(MSTARS)
 
600
      COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EPOCHS(MSTARS), COLORS
 
601
      DIMENSION COLORS(MBANDS,MSTARS)
 
602
C          MONTH, DAY, YEAR, MM, DD, YY   ARE EXTERNAL NAMES.
 
603
C
 
604
C    MONTH IS NAME OF MONTH,  MON IS 1ST 3 LETTERS,  MM & M ARE NUMBER.
 
605
C    YEAR IS FULL YEAR,  YY IS LAST 2 DIGITS,  Y IS INTERNAL.
 
606
C
 
607
       IF(DATSTR.NE.' ' .OR. MONTH.NE.' ')THEN
 
608
        IF(DATSTR.NE.' ')THEN
 
609
      CALL MDY(DATSTR,MON,DDAY,Y)
 
610
        ELSE
 
611
      MON=MONTH
 
612
      DDAY=DAY
 
613
      Y=YEAR
 
614
        END IF
 
615
C   CONVERT MON TO INTEGER:
 
616
      M=MON2M(MON)
 
617
      IF(M.EQ.0) CALL STETER(901, 'BAD MONTH IN DATA')
 
618
       ELSE IF(FMM.NE.3.E33 .AND. DD.NE.3.E33 .AND. YY.NE.3.E33)THEN
 
619
      DDAY=DD
 
620
      M=FMM
 
621
      Y=YY+1900.
 
622
       ELSE
 
623
      CALL TV('NO DATE. FATAL ERROR.')
 
624
      CALL STETER(902, 'NO DATE')
 
625
       END IF
 
626
C    CHECK YEAR.
 
627
      IF(Y.LT.100.)Y=Y+1900.
 
628
C  J.D.: SEE SKY & TEL.61,312 (1981).
 
629
      IF(M.GT.2)GO TO 416
 
630
      M=M+12
 
631
      Y=Y-1
 
632
  416 DJ=AINT(365.25*Y) + AINT(30.6001*(M+1)) + DDAY + 1720981.5D0
 
633
C
 
634
      RETURN
 
635
C
 
636
C
 
637
      ENTRY GETSN(NSTAR)
 
638
C
 
639
C  GETS STAR NAME FROM HEADED FILE VIA /NAMES/.   10 MAR.'85
 
640
C
 
641
      IF(STAR.NE.' ')THEN
 
642
       STARS(NSTAR)=STAR
 
643
C   HD.
 
644
      ELSE IF (HD.NE.' ') THEN
 
645
       CALL CATHED(HD,'HD ')
 
646
       STARS(NSTAR)=HD
 
647
C   BD OR OTHER DM.
 
648
      ELSE IF (DM.NE.' ') THEN
 
649
       STARS(NSTAR)=DM
 
650
C   HR.
 
651
      ELSE IF (BSHR.NE.' ') THEN
 
652
       CALL CATHED(BSHR,'HR ')
 
653
       STARS(NSTAR)=BSHR
 
654
C   BAYER/FLAMSTEED.
 
655
      ELSE IF (BAYER.NE.' ') THEN
 
656
       N=INDEX(BAYER,'  ')
 
657
       STARS(NSTAR)=BAYER(:N)//CONSTL
 
658
C    FLAMSTEED.
 
659
       IF(FLAMST.NE.' ')THEN
 
660
        N=INDEX(FLAMST,'   ')
 
661
        FLAMST(N+1:)=STARS(NSTAR)
 
662
        STARS(NSTAR)=FLAMST
 
663
       END IF
 
664
C   FLAMSTEED ALONE.
 
665
      ELSE
 
666
       IF(FLAMST.NE.' ') THEN
 
667
        N=INDEX(FLAMST,'   ')
 
668
        STARS(NSTAR)=FLAMST(:N)//CONSTL
 
669
       ELSE
 
670
C   NO NAME AT ALL.
 
671
        STARS(NSTAR)='ANON.'
 
672
      WRITE(STARS(NSTAR)(6:),'(I4)')NSTAR
 
673
       END IF
 
674
      END IF
 
675
C  ADD SECOND NAME IF SPACE.
 
676
      N=INDEX(STARS(NSTAR),'        ')
 
677
       IF(N.NE.0)THEN
 
678
      IF(BAYER.NE.' ')THEN
 
679
       K=INDEX(BAYER,'   ')
 
680
       STARS(NSTAR)(N+2:)=BAYER(:MIN(K,16-N))//CONSTL
 
681
      ELSE IF(FLAMST.NE.' ')THEN
 
682
       K=INDEX(FLAMST,'    ')
 
683
       STARS(NSTAR)(N+2:)=FLAMST(:MIN(K,16-N))//CONSTL
 
684
      ELSE IF(HD.NE.' ' .AND. BSHR.NE.' ')THEN
 
685
       CALL CATHED(BSHR,'HR ')
 
686
       STARS(NSTAR)(N+2:)=BSHR
 
687
      ELSE IF(HD.NE.' ' .AND. DM.NE.' ')THEN
 
688
       STARS(NSTAR)(N+2:)=DM
 
689
      END IF
 
690
       END IF
 
691
C
 
692
      RETURN
 
693
C
 
694
      END
 
695
      SUBROUTINE JD2DAT(DJ,DATSTR)
 
696
C
 
697
C       Copyright (C) Andrew T. Young, 1990
 
698
C
 
699
C  CONVERTS JD (IN DJ) TO DATE-STRING IN STD.FORMAT.   15 FEB.'85
 
700
C  Note: argument DJ is real, *NOT* double-precision!
 
701
C
 
702
C
 
703
      IMPLICIT NONE
 
704
C
 
705
      REAL DJ, Z, A, B, C, FK, E, D, Y
 
706
      INTEGER K,M
 
707
C
 
708
      CHARACTER DATSTR*(*),M2MON*3,A11*11
 
709
C
 
710
      EXTERNAL M2MON
 
711
C
 
712
C  SEE SKY & TEL.61, 312 (1981).
 
713
C
 
714
C     ASSUME 0 H U.T.; ROUND TO INTEGER DAY.
 
715
      Z=AINT(DJ+0.6)
 
716
      A=AINT((Z-1867216.25D0)/36524.25D0)
 
717
      B=Z+A-AINT(A/4.)+1525.
 
718
      C=AINT((B-122.1)/365.25)
 
719
      K=365.25*C
 
720
      FK=K
 
721
      E=AINT((B-FK)/30.6001)
 
722
      D=B-FK-AINT(30.6001*E)
 
723
      IF(E.LT.13.5)THEN
 
724
        M=E-1.
 
725
      ELSE
 
726
        M=E-13.
 
727
      END IF
 
728
      IF(M.GE.3)THEN
 
729
        Y=C-4716.
 
730
      ELSE
 
731
        Y=C-4715.
 
732
      END IF
 
733
C  FORMAT STRING.
 
734
      WRITE(A11,7)M2MON(M),INT(D),INT(Y)
 
735
    7 FORMAT(A3,I3,I5)
 
736
      DATSTR=A11
 
737
      RETURN
 
738
      END
 
739
      SUBROUTINE EPHEM(I1,DJMOD,COLORS,RA,DEC)
 
740
C
 
741
C       Copyright (C) Andrew T. Young, 1990
 
742
C
 
743
C  INTERPOLATES EPHEMERIS OBJECTS TO DJMOD.      15 AUG.'85
 
744
C
 
745
C
 
746
      IMPLICIT NONE
 
747
C
 
748
      REAL DJMOD, COLORS, RA, DEC, RECT, DIF, DEN, F
 
749
      INTEGER I1, I2, I, MID, J
 
750
C
 
751
C  RECT.COORDS.IN COLORS(MBM1...MBM3,I).
 
752
C
 
753
      INCLUDE 'MID_REL_INCL:mbands.inc'
 
754
C     PARAMETER (MBANDS=9)
 
755
      INTEGER MBM1,MBM2,MBM3,MBM4
 
756
      PARAMETER(MBM1=MBANDS-1,MBM2=MBANDS-2,MBM3=MBANDS-3,MBM4=MBANDS-4)
 
757
      INCLUDE 'MID_REL_INCL:mstars.inc'
 
758
C     PARAMETER (MSTARS=1650)
 
759
      DIMENSION COLORS(MBANDS,MSTARS), RECT(3)
 
760
      CHARACTER A, DATSTR*11, EMSG*38
 
761
C
 
762
C   FIND END OF TABLE.
 
763
      I2=COLORS(MBM4,I1)
 
764
      DIF=3.E33
 
765
      DO 10 I=I1,I2
 
766
       IF(ABS(COLORS(MBANDS,I)-DJMOD).LT.DIF)THEN
 
767
      DIF=ABS(COLORS(MBANDS,I)-DJMOD)
 
768
      MID=I
 
769
       ELSE
 
770
      GO TO 20
 
771
       END IF
 
772
   10 CONTINUE
 
773
      IF(DJMOD.GT.COLORS(MBANDS,I2))CALL TV('Extrapolation required.')
 
774
C    ASSUME TIMES INCREASE.
 
775
   20 IF(MID.GE.I2) MID=I2-1
 
776
      DEN=COLORS(MBANDS,MID+1)-COLORS(MBANDS,MID)
 
777
       IF(DEN.EQ.0.)THEN
 
778
      CALL TV('Duplicated dates in table.  Interpolation impossible.')
 
779
      CALL ASK('Do you want to continue?',A)
 
780
      IF(A.EQ.'N')CALL STETER(903, 'BAD TABLE')
 
781
      RECT(1)=COLORS(MBM1,MID)
 
782
      RECT(2)=COLORS(MBM2,MID)
 
783
      RECT(3)=COLORS(MBM3,MID)
 
784
      GO TO 90
 
785
       END IF
 
786
C    START AT I1+1 FOR 3-POINT FORM.
 
787
      IF(I2.GT.I1+1 .AND. MID.EQ.I1)MID=I1+1
 
788
C
 
789
C    GET WEIGHTS.
 
790
      F=(DJMOD-COLORS(MBANDS,MID))/DEN
 
791
      IF(F.LT.-2.) GO TO 99
 
792
       IF(F.GT.2.)THEN
 
793
      CALLTV('*** FATAL ERROR')
 
794
      CALL JD2DAT(DJMOD+2400001.,DATSTR)
 
795
      EMSG='Please extend tables to '//DATSTR
 
796
      CALL TV(EMSG)
 
797
      GO TO 999
 
798
       END IF
 
799
C
 
800
C   DETERMINE ORDER.
 
801
C
 
802
       IF(I2.EQ.I1+1)THEN
 
803
C
 
804
C   LINEAR INTERPOLATION.
 
805
      IF(MID.EQ.I1 .AND. F.LT.0.) CALL TV('Extrapolate backward.')
 
806
      DO 25 J=1,3
 
807
   25 RECT(J)=(1.-F)*COLORS(MBANDS-J,MID) + F*COLORS(MBANDS-J,MID+1)
 
808
C
 
809
       ELSE
 
810
C
 
811
C   QUADRATIC (3-POINT).
 
812
C
 
813
      IF(MID.EQ.I1+1 .AND. F.LT.-1.)CALL TV('Extrapolate backward.')
 
814
      DO 30 J=1,3
 
815
   30 RECT(J)=((F-1.)*COLORS(MBANDS-J,MID-1) + (F+1.)*COLORS(MBANDS-J,
 
816
     1      MID+1))*F/2. -(F+1.)*(F-1.)*COLORS(MBANDS-J,MID)
 
817
       END IF
 
818
C
 
819
   90 RA=ATAN2(RECT(2),RECT(1))
 
820
      DEC=ATAN2(RECT(3),SQRT(RECT(1)*RECT(1)+RECT(2)*RECT(2)))
 
821
      RETURN
 
822
C
 
823
   99 CALL JD2DAT(DJMOD+2399999.,DATSTR)
 
824
      EMSG='Please begin tables at '//DATSTR
 
825
      CALL TV(EMSG)
 
826
      CALLTV('*** FIRST DATE PRECEDES EPHEMERIS -- FATAL ERROR')
 
827
  999 CALL STETER(905, 'INADEQUATE EPHEMERIS')
 
828
      END