← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/pepsys/src/plantop.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/src/plantop.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or 
 
5
C modify it under the terms of the GNU General Public License as 
 
6
C published by the Free Software Foundation; either version 2 of 
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public 
 
15
C License along with this program; if not, write to the Free 
 
16
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division 
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen 
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
        PROGRAM PLAN
 
29
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.COPYRIGHT (c) Andrew T. Young, 1990
 
31
C.COPYRIGHT (c) European Southern Observatory, 1992
 
32
C.IDENT         program plan
 
33
C.MODULE        plantop.for
 
34
C.AUTHOR        Andrew T. Young
 
35
C.KEYWORD
 
36
C.LANGUAGE      FORTRAN 77
 
37
C.PURPOSE       Makes a photometric observing schedule
 
38
C.COMMENTS
 
39
C.VERSION       0.0
 
40
C               0.5     921202, KB
 
41
C               4.4     930212, ATY
 
42
C               4.6     930322, ATY
 
43
C               4.7     930327, ATY
 
44
C               4.8     930401, ATY
 
45
C               5.2     930429, ATY
 
46
C.RETURNS       error numbers correspond to nearby statement numbers
 
47
C.ENVIRONMENT   MIDAS
 
48
C 
 
49
C 100618        last modif
 
50
C-----------------------------------------------------------------------------
 
51
C
 
52
      IMPLICIT NONE
 
53
C
 
54
C  BEGIN Declarations:
 
55
C
 
56
C
 
57
C  Set up MIDAS declarations:
 
58
C
 
59
        INTEGER MADRID(1)
 
60
C
 
61
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
62
C
 
63
        COMMON /VMR/ MADRID
 
64
C
 
65
C
 
66
C                   JULY 2, 1987 -- PARTLY CLEANED OF REDUNDANT SUBROUTINES.
 
67
C
 
68
C  PLANS PHOTOMETRIC OBSERVATIONS, USING STANDARD STARS FROM STDFIL.
 
69
C
 
70
C *** SYSTEM-DEPENDENT FEATURES ARE FLAGGED BY *** COMMENTS LIKE THIS.
 
71
C
 
72
C   F I L E S :
 
73
C   -----------
 
74
C
 
75
      CHARACTER*80 STDFIL, CATFIL, OBSFIL
 
76
      CHARACTER*80 SAVFIL
 
77
C *** LENGTH OF FILE NAMES MAY BE SYSTEM-DEPENDENT.
 
78
C     FULL SET FOR SUBROUTINE COMPATIBILITY.
 
79
      INTEGER KB, KTV, K2, K3, K4, K7, K8, K9
 
80
      COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9
 
81
C *** UNITS MAY BE SYSTEM-DEPENDENT.
 
82
C
 
83
C
 
84
C    N A M I N G   C O N V E N T I O N S :
 
85
C    ------------------------------------
 
86
C                                        EXTERNAL NAME          SAMPLE
 
87
C    QUANTITY       VARIABLE      TYPE   FOR DATA FILE           VALUE
 
88
C    --------       --------      ----   -------------          ------
 
89
C
 
90
C  NAMES:
 
91
C
 
92
C    PLACE NAME       PLACE       CH*20                      KITT PEAK
 
93
C    BAND NAME        BAND        CH*6
 
94
C    STAR NAME        STAR        CH*20      STAR              HR 8832
 
95
C    STAR CODE       STRCDS       CH*20     STARCD                  17
 
96
C    INDICES        CNAMES(1,NB)  CH*6     V, B-V, M1, ...       -0.20
 
97
C    GAIN CONTROL  GCONTR(NGAIN)  CH*20                         COARSE
 
98
C    GAIN SETTING   GANCOD(I,N)   CH*20   GAINS1, ... ,GAINS4        2
 
99
C
 
100
C  COORDINATES IN RADIANS:
 
101
C
 
102
C    LONGITUDE        ELONG       REAL
 
103
C    LATITUDE         ALAT        REAL
 
104
C    HOUR ANGLE       HA          REAL
 
105
C    RIGHT ASCENSION  RA          REAL
 
106
C    DECLINATION      DEC         REAL
 
107
C    UNIVERSAL TIME   UT          REAL
 
108
C    ZONE TIME        ZT          REAL
 
109
C    SIDEREAL TIME    ST          REAL
 
110
C
 
111
C      EXTERNAL SUB-UNITS ARE NAMED AS FOLLOWS:            TYPE
 
112
C                                                          ----
 
113
C      DEGREES      1ST 2 LETTERS OF REAL VARIABLE//'DEG'  REAL
 
114
C       HOURS        "  "    "    "   "      "    //'HRS'  REAL
 
115
C      MINUTES       "  "    "    "   "      "    //'MIN'  REAL
 
116
C      SECONDS       "  "    "    "   "      "    //'SEC'  REAL
 
117
C
 
118
C   SPECIAL FORMS:
 
119
C      ROTATIONS     "  "    "    "   "      "    //'ROT'  REAL
 
120
C     CHAR.STRING    "  "    "    "   "      "    //'STR'  CHARACTER*20
 
121
C        SIGN        "  "    "    "   "      "    //'SGN'  CHARACTER*20
 
122
C
 
123
C      EXAMPLES: RAHRS, UTMIN, ELSEC, ALDEG, DESTR, DESGN
 
124
C
 
125
C
 
126
C   P E P S Y S   S Y S T E M   V A R I A B L E S
 
127
C   ---------------------------------------------
 
128
C
 
129
      INTEGER MOBS
 
130
      PARAMETER (MOBS=10)
 
131
      CHARACTER *20  PLACE*72, PLACES(MOBS)
 
132
      REAL ELDEGS,ALDEGS,HIGHS
 
133
      DIMENSION ELDEGS(MOBS),ALDEGS(MOBS),HIGHS(MOBS)
 
134
C
 
135
      INCLUDE 'MID_REL_INCL:mstars.inc'
 
136
C     PARAMETER (MSTARS=1650)
 
137
C       commons for star catalog:
 
138
      CHARACTER *32 STARS
 
139
      COMMON /SCATA/ STARS(MSTARS)
 
140
      REAL RAS, DECS, EQUINX, COLORS
 
141
      COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EQUINX(MSTARS), COLORS
 
142
C
 
143
C    CAUTION -- MBANDS IS IN SUBROUTINES RDLIST, OPNFIL, DECOLR, & EPHEM.
 
144
      INCLUDE 'MID_REL_INCL:mbands.inc'
 
145
C     PARAMETER (MBANDS=9)
 
146
      REAL COLORM, COLRIN,  XINV,YINV
 
147
      INTEGER NBANDS,LENB,LENC,KX,KY
 
148
      COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS),
 
149
     1 XINV,YINV,NBANDS,LENB,LENC,KX,KY
 
150
C
 
151
      REAL PHOMAG,FAINTS,BRITES,SZMAX,
 
152
     1 SZMIN,EXTIN,SIGTOT,TINT1,TSUGG
 
153
      COMMON /CMAGS2/PHOMAG(MBANDS),FAINTS(MBANDS),BRITES(MBANDS),SZMAX,
 
154
     1 SZMIN,EXTIN(MBANDS),SIGTOT,TINT1,TSUGG
 
155
      SAVE /CMAGS1/,/CMAGS2/
 
156
C
 
157
      CHARACTER *8 BAND, BANDS(3*MBANDS), CNAMES(2,MBANDS)
 
158
      REAL TRANS,WLS,WIDTHS
 
159
      DIMENSION
 
160
     1 TRANS(MBANDS),WLS(MBANDS),WIDTHS(MBANDS),COLORS(MBANDS,MSTARS)
 
161
      INTEGER KOLR
 
162
      DIMENSION KOLR(MBANDS)
 
163
      INTEGER MBM1,MBM2,MBM3,MBM4,MBM5,MBM6,MBM7
 
164
      PARAMETER(MBM1=MBANDS-1,MBM2=MBANDS-2,MBM3=MBANDS-3,MBM4=MBANDS-4)
 
165
      PARAMETER(MBM5=MBANDS-5,MBM6=MBANDS-6,MBM7=MBANDS-7)
 
166
C
 
167
      INTEGER MSYS
 
168
      PARAMETER (MSYS=8)
 
169
      CHARACTER*6 SYSTEM,SYSTMS(MSYS),STDFLS(MSYS),BNDS(MBANDS,MSYS)
 
170
     1 ,BNDVAR(MBANDS,MSYS)
 
171
      INTEGER JBANDS,LENBS,LENCS, KXS,KYS
 
172
      REAL XINVS,YINVS,STDWLS,FWHMS,TRANSS
 
173
      DIMENSION JBANDS(MSYS),LENBS(MSYS),LENCS(MSYS),
 
174
     1 KXS(MSYS),KYS(MSYS),XINVS(MSYS),YINVS(MSYS)
 
175
      DIMENSION STDWLS(MBANDS,MSYS),FWHMS(MBANDS,MSYS),
 
176
     1TRANSS(MBANDS,MSYS)
 
177
C
 
178
C
 
179
C  PARAMETERS FOR RDLIST/RDBLOK.
 
180
C
 
181
      INTEGER MGAINS,MG2,MA,MCAT,MN,MV,MGRPS,MAREST,MNREST
 
182
      PARAMETER (MGAINS=4, MG2=2*MGAINS)
 
183
      PARAMETER (MA=21+MG2+5)
 
184
      PARAMETER (MCAT=12+2*MBANDS,MN=MCAT+30, MV=MA+MN, MGRPS=8)
 
185
      PARAMETER (MAREST=MA-21-MG2, MNREST=MN-MCAT-15)
 
186
C
 
187
C  MA = MAX. ALPHABETIC (CHARACTER) VARIABLES,  AVAR  IN /NAMES/
 
188
C  MN = MAX. NUMERIC VARIABLES,                 VAR   IN /VALUES/
 
189
C  MV = MAX. VARIABLE NAMES,                    NAMES IN /NAMES/
 
190
C
 
191
C   COMMONS FOR RDLIST/RDBLOK.  NOTE RENAMING OF ELEMENTS OF AVAR.
 
192
C
 
193
C   THESE MA CHARACTER VARIABLES REPLACE AVAR(MA):
 
194
C     CHARACTER NAMES(MV)*6,TITLE*80, AVAR(MA)*20  <--REPLACED BY LIST.
 
195
C
 
196
      CHARACTER NAMES(MV)*6,TITLE*80
 
197
      CHARACTER*32 STAR
 
198
      CHARACTER*20 RASTR,DESTR,BAYER,CONSTL,FLAMST,BSHR,HD,DM,
 
199
     1 SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR,
 
200
     2 FILTCD,STARCD,STRSKY,ASPARE(MAREST),GANCDN(MGAINS),DIMCDN(MGAINS)
 
201
C
 
202
C     COMMON /NAMES/NAMES,TITLE, AVAR
 
203
      COMMON /NAMES/NAMES,TITLE, RASTR,DESTR,STAR,BAYER,CONSTL,FLAMST,
 
204
     1 BSHR,HD,DM,SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR,
 
205
     2 FILTCD,STARCD,STRSKY,ASPARE,GANCDN,DIMCDN
 
206
      EQUIVALENCE (CNAMES,NAMES(13))
 
207
C     13 BECAUSE CVARS IS VAR(13).
 
208
C
 
209
C   REAL VARIABLES THAT REPLACE VAR(MN):
 
210
C     COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,VAR(MN)
 
211
C
 
212
      INTEGER NAM1,NAM2,NGRPS,MURAT,MURAA,MUDEC
 
213
      REAL RAHRS,RAMIN,RASEC,
 
214
     1 DEDEG,DEMIN,DESEC,EPOCH,SIGNAL,TINT,
 
215
     2 CVARS,FMM,DD,YY,YEAR,DAY,
 
216
     3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC,
 
217
     4 ZTHRS,ZTMIN,ZTSEC,VSPARE
 
218
      COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,RAHRS,RAMIN,RASEC,
 
219
     1 DEDEG,DEMIN,DESEC,EPOCH,MURAT,MURAA,MUDEC,SIGNAL,TINT,
 
220
     2 CVARS(2,MBANDS),FMM,DD,YY,YEAR,DAY,
 
221
     3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC,
 
222
     4 ZTHRS,ZTMIN,ZTSEC,VSPARE(MNREST)
 
223
C
 
224
C
 
225
C   COMMONS FOR SPHERICAL TRIG.:
 
226
C
 
227
      REAL SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
 
228
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
 
229
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
 
230
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
 
231
C
 
232
C   COMMONS FOR SUN.
 
233
C
 
234
      REAL COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
 
235
      COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
 
236
C
 
237
C   CAUTION -- THESE APPEAR IN SUBROUTINE FILL ALSO:
 
238
      INTEGER MSET,MROOM,MSG,MTIM
 
239
      PARAMETER (MSET=MSTARS-100,MROOM=2,MSG=14,MTIM=MROOM*MSET+MSG)
 
240
C
 
241
C  MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS.
 
242
C  MTIM IS MAX.LENGTH OF EVENT TIMES.
 
243
C
 
244
      SAVE /CFILL/,/SPHERE/,/CSUN/,/HELPS/
 
245
C
 
246
      REAL UTBGN,UTEND,DARKT,TIMES
 
247
      INTEGER NOBJS,NT
 
248
      COMMON /CFILL/ UTBGN,UTEND,DARKT,TIMES(MTIM),NOBJS(MTIM),NT
 
249
C
 
250
C  TIMES(NT)  IS  EVENT TIME IN SCHEDULE.
 
251
C  NOBJS(NT)  IS  OBJECT NUMBER IN SUBSET OF EXT./STD.STARS.
 
252
C
 
253
C   COMMON FOR ANNOTATIONS:
 
254
      CHARACTER COMENT(MSTARS)*32,SPTYPE(MSTARS)*12,EMAG(MSTARS)*16
 
255
      COMMON /NOTES/COMENT,SPTYPE,EMAG
 
256
C
 
257
C   COMMON FOR HELP COUNT:
 
258
      COMMON /HELPS/ NEEDH,NASSMP
 
259
      CHARACTER ASSMPS(8)*40,ASSUME(8)*40
 
260
      COMMON /ASSUME/ ASSMPS,ASSUME
 
261
      CHARACTER*13  F361
 
262
      COMMON /FMT361/ F361
 
263
      CHARACTER*79 PAGE(21)
 
264
      COMMON /SCREEN/PAGE
 
265
      INTEGER JCONT,JLOG,JDISP
 
266
      COMMON /FLAGS/JCONT,JLOG,JDISP
 
267
C
 
268
      LOGICAL PC,DC,CI,CANNED,NEEDIM,CODEDS,MOVING,DARK,FUNK,FCORN,
 
269
     1        COOLED
 
270
C
 
271
        COMMON /LOGIC/ NEEDED,DIMMED,PC,DC,CI,NEEDIM,CODEDS,DARK,FUNK,
 
272
     1                 FCORN,COOLED
 
273
C
 
274
C
 
275
C  CODEDS IS.TRUE.IF STARS ARE CODED IN DATA.
 
276
C  PC     IS.TRUE.IF DATA ARE PULSE COUNTS.
 
277
C  DC     IS.TRUE.IF DATA ARE CURRENTS.
 
278
C  CI     IS.TRUE.IF DATA ARE CHARGE INTEGRATIONS.
 
279
C  CANNED IS.TRUE.IF PLACE OR STDFIL IS BUILT-IN.
 
280
C  NEEDIM IS.TRUE.IF OPTICAL DIMMER IS NEEDED.
 
281
C  MOVING IS.TRUE.IF EPHEMERIS OBJECTS EXIST.
 
282
C
 
283
C
 
284
C   L O C A L   V A R I A B L E S
 
285
C   -----------------------------
 
286
C
 
287
      CHARACTER A,CARD*80,DMS*32,PNAMES(10)*20,MON*3,TL*4,FL(2)*5,
 
288
     1 TWILIT(MSG+1)*27,INSTNAM*72,
 
289
     2 DAT*30,ELABEL(2)*8,WLABEL(2)*8,ASSUM4(2)*40,ASSUM6(2)*40
 
290
      EQUIVALENCE (ASSUM4,ASSUME(4)),(ASSUM6,ASSUME(6))
 
291
      CHARACTER TEMPRH*34, RALBL*22,DECLBL*7, FILTSTAT*9
 
292
CC 
 
293
      CHARACTER   CTEST*80
 
294
CC
 
295
C
 
296
C  MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS.
 
297
C
 
298
C
 
299
      INTEGER LOCS(10)
 
300
      REAL SALTS(MSG),DJS(2),XS(MSET),YS(MSET),
 
301
     1 RALIMS(2),DECLIM(2)
 
302
C
 
303
      DOUBLE PRECISION DJD
 
304
C
 
305
      LOGICAL SYSSET,DEDSET,NEEDED,DIMMED, FEXIST,NULL
 
306
      LOGICAL BACK1
 
307
      REAL DUM, TELCM,
 
308
     1 HIGH, ELDEG, ALDEG, ELHRS, DEG10, PRAT, DRAT, SCALE, AREA,
 
309
     2 SIGSQ, DECDEG, RADEG, EPHEM1, EPHEM2, DEADT, SDEDT, RATE, ZONE,
 
310
     3 DDAY, YR, OLDYR, Y, DJ
 
311
C
 
312
      INTEGER NEEDH, NASSMP, NROWSAL, KEQUINOX, KMUALPHA, KMUDELTA,
 
313
     1 MTYPE, I, IOBS, ISTAT, NVALS, IUNIT, NULLS, L, KSPTYPE, KVB,
 
314
     2 NCOLS, NROWS, NSORTC, NWPRAL, KTEL, KDIAM, NROW, KLON,
 
315
     3 KLAT, KHI, J, JOLD, K, NEEDST, JSYS, NB, NSTAR, LASTD, ISTD,
 
316
     4 KOBJ, KRA, KDEC, KEPOCH, KMAG, KCOMMENT, KVI, KUV,
 
317
     5 KDATE, KMJD, LEN, NSTARS, I1, I2, INST,
 
318
     6 KDET, KBAND, KDETNM, KNDET, KCOOL, KRL, KRLTYP, KMODE, KDEDT,
 
319
     7 KDEDER, ITIME, NDIG, N, M
 
320
C
 
321
C
 
322
C   INTEGER FCNS.:
 
323
C   -------------
 
324
      INTEGER LWORD, MON2M
 
325
C
 
326
C   CHARACTER FCNS.:
 
327
C   ----------------
 
328
      CHARACTER DEG2MS*13
 
329
C
 
330
C   LOGICAL FCNS.:
 
331
C   -------------
 
332
      LOGICAL HELP,MATCH
 
333
C
 
334
C  END Declarations.
 
335
C
 
336
C
 
337
C  BEGIN DATA statements:
 
338
        INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
339
C
 
340
C
 
341
C   D A T A :
 
342
C   ---------
 
343
C
 
344
C  NUMERICAL VARIABLE NAMES ... (REALLY IN BLOCK DATA)
 
345
C
 
346
C       NAMX() =    1       2       3       4       5       6       7
 
347
C     DATA NAMES/'RAHRS','RAMIN','RASEC','DEDEG','DEMIN','DESEC','EPOCH'
 
348
C
 
349
C         8       9      10      11      12
 
350
C    1,'MURAT','MURAA','MUDEC','SIGNAL','TINT',
 
351
C
 
352
C        13 TO MCAT....        +1   +2   +3    +4    +5
 
353
C    2  MBANDS*' ',MBANDS*' ','MM','DD','YY','YEAR','DAY',
 
354
C
 
355
C   MCAT + 6      +7      +8      +9      +10     +11    +12
 
356
C    3 'UTHRS','UTMIN','UTSEC','CLKERR','STHRS','STMIN','STSEC',
 
357
C
 
358
C   MCAT+13      +14     +15     +16  TO  MCAT +30
 
359
C    4 'ZTHRS','ZTMIN','ZTSEC',     MNREST*' ',
 
360
C
 
361
C  CHARACTER VARIABLE NAMES...
 
362
C
 
363
C       MN+1    MN+2    MN+3   MN+4     MN+5     MN+6    MN+7  MN+8 MN+9
 
364
C    5 'RASTR','DESTR','STAR','BAYER','CONSTL','FLAMST','BSHR','HD','DM'
 
365
C
 
366
C        MN+10   MN+11   MN+12    MN+13  MN+14  MN+15   MN+16   MN+17
 
367
C    6 ,'SPECT','DESGN','DATSTR','MONTH','REM1','REM2','STSTR','ZTSTR',
 
368
C
 
369
C        MN+18   MN+19    MN+20    MN+21   MN+22  TO
 
370
C    7  'UTSTR','FILTCD','STARCD','STRSKY',MGAINS*' ',MGAINS*' ',
 
371
C
 
372
C        MN+
 
373
C    8  MAREST*' '/
 
374
C
 
375
C
 
376
C  PLACE DATA:
 
377
C
 
378
      DATA PLACES/'MT.LAGUNA','KITT PEAK','LOWELL','LICK','MT.WILSON',
 
379
     1  'PALOMAR','CERRO TOLOLO','LAS CAMPANAS','ESO','MCDONALD'/
 
380
      DATA ELDEGS/-116.4258,-111.5947,-111.6633,-121.6455,-118.0597,
 
381
     1 -116.8640,-70.8059,-70.7020,-70.7296,-104.0223/
 
382
      DATA ALDEGS/32.8400 ,31.95842,35.20167,37.34036,34.21653,
 
383
     1 33.35622,-30.16894,-29.00361,-29.25717,30.67158/
 
384
      DATA HIGHS/1859.,2064.,2210.,1283.,1742.,
 
385
     1 1706.,2399.,2282.,2400.,2081./
 
386
      DATA PNAMES/'MT. LAGUNA','KPNO','FLAGSTAFF','MT. LOCKE',
 
387
     1 'CTIO','MT.LOCKE','MT. WILSON','MT.HAMILTON','MT. HAMILTON',
 
388
     2 'MOUNT HAMILTON'/
 
389
      DATA LOCS/1,2,3,10,7,10,5,4,4,4/
 
390
C
 
391
C  SYSTEM DATA:
 
392
C
 
393
      DATA SYSTMS/'UBV','UBVRI','UVBY','H-BETA','UVBYHB','GENEVA','DDO',
 
394
     1 'OTHER'/
 
395
      DATA JBANDS/ 3,      5,      4,      2,      6,      7,      6,
 
396
     1   0/
 
397
C
 
398
      DATA STDFLS/'UBVSTD','UBVSTD','UVBYST','UVBYST','UVBYST','GENSTD',
 
399
     1 'DDOSTD',' '/
 
400
C
 
401
      DATA LENBS/1,1,1,5,5,2,2,1/,LENCS/3,3,3,4,4,5,6,0/
 
402
C
 
403
C   BAND NAMES.
 
404
      DATA BNDS/'U','B','V','RL',MBM4*' ',
 
405
     2  'U','B','V','R','I','RL',MBM6*' ',
 
406
     3  'u','v','b','y',MBM4*' ',
 
407
     4  'betaW','betaN',MBM2*' ',
 
408
     5  'u','v','b','y','betaW','betaN',MBM6*' ',
 
409
     6  'U','B','V','B1','B2','V1','G',MBM7*' ',
 
410
     7  '48','45','42','41','38','35',MBM6*' '     ,MBANDS*' '/
 
411
C
 
412
C   MAGNITUDE AND COLOR NAMES FOR EXTERNAL LISTS.
 
413
      DATA BNDVAR/'V','U-B','B-V',MBM3*' ',
 
414
     2  'V','U-B','B-V','V-R','R-I',MBM5*' ',
 
415
     3  'V','b-y','m1','c1',MBM4*' ',
 
416
     4  'BETA',MBM1*' ',
 
417
     5  'V','b-y','m1','c1','BETA',MBM5*' ',
 
418
     6  'VM','U-B','B-V','U-B2','B1-B2','B2-V1','V1-G',MBM7*' ',
 
419
     7 'M48','C45-48','C42-45','C41-42','C38-41','C35-38',MBM6*' ',
 
420
     8 MBANDS*' '/
 
421
C
 
422
C   EFF.WAVELENGTHS.
 
423
C     UBV:Buser,A.&Ap.62,411(1979); others from Dudley Obs.rept.
 
424
      DATA STDWLS/3652.,4417.,5505.,7000.,MBM4*0.,
 
425
     2  3652.,4417.,5505.,6400.,8000.,7000.,MBM6*0.,
 
426
     3  3425.,4110.,4670.,5510.,MBM4*0.,
 
427
     4  4861.,4861.,MBM2*0.,
 
428
     5  3425.,4110.,4670.,5510.,4861.,4861.,MBM6*0.,
 
429
     6  3458.,4248.,5508.,4022.,4480.,5408.,5814.,MBM7*0.,
 
430
     7  4886.,4517.,4257.,4166.,3815.,3460.,MBM6*0.     ,MBANDS*0./
 
431
C
 
432
C   WIDTHS.  THESE ARE ABOUT 2.64 X MU2.
 
433
      DATA FWHMS/535.,980.,800.,300.,MBM4*0.,
 
434
     2  535.,980.,800.,1400.,1700.,600.,MBM6*0.,
 
435
     3  375.,200.,175.,250.,MBM4*0.,
 
436
     4  150.,30.,MBM2*0.,
 
437
     5  375.,200.,175.,250.,150.,30.,MBM6*0.,
 
438
     6  450.,800.,800.,450.,440.,530.,540.,MBM7*0.,
 
439
     7  186.,76.,73.,83.,330.,383.,MBM6*0.     ,MBANDS*0./
 
440
C   PEAK TRANSMISSIONS.
 
441
      DATA TRANSS/.86,.73,.9,.9,MBM4*0.,
 
442
     2  .86,.73,.9,.77,.86,.9,MBM6*0.,
 
443
     3  .39,.49,.48,.53,MBM4*0.,
 
444
     4  .75,.6,MBM2*0.,
 
445
     5  .39,.49,.48,.53,.75,.6,MBM6*0.,
 
446
     6  .65,.65,.5,.5,.34,.3,.3,MBM7*0.,
 
447
     7  .56,.55,.53,.49,.65,.41,MBM6*0.,     MBANDS*0./
 
448
C
 
449
C   2-COLOR DIAGRAMS.                 O
 
450
C                   U  U  B  4  G     T
 
451
C                U  .  V  E  +  E  D  H
 
452
C                B  .  B  T  H  N  D  E
 
453
C                V  I  Y  A  B  V  O  R
 
454
      DATA  KYS /2, 2, 4, 0, 4, 4, 2, 0/
 
455
      DATA  KXS /3, 3, 2, 0, 2, 6, 3, 0/
 
456
      DATA YINVS/1.,1.,0.,0.,0.,1.,0.,0./
 
457
      DATA XINVS/0.,0.,0.,0.,0.,0.,0.,0./
 
458
C
 
459
      DATA FL/'FIRST',' LAST'/
 
460
C
 
461
C  DATA FOR SUN/MOON SET/RISE AND TWILIGHTS:
 
462
C
 
463
      DATA SALTS/-.0145,-.1045,-.208,-.309,-.309,-.208,-.1045,-.0145,
 
464
C   SUN ABOVE, MOON BELOW.
 
465
     1 -.0145,-.0145,-.12,-.12,+.3,+.3/
 
466
C
 
467
      DATA TWILIT/'SUN SETS','END CIVIL TWILIGHT',
 
468
     1   'END NAUTICAL TWILIGHT'
 
469
     2,'END ASTRONOMICAL TWILIGHT','BEGIN ASTRONOMICAL TWILIGHT',
 
470
     3'BEGIN NAUTICAL TWILIGHT','BEGIN CIVIL TWILIGHT','SUN RISES',
 
471
C
 
472
     4'MOONRISE - FAST SKY CHANGES','MOONSET -- SKY CHANGES FAST',
 
473
     5'BEGIN LUNAR TWILIGHT','END LUNAR TWILIGHT',
 
474
     6'SKY CHANGES MORE SLOWLY','BEGIN RAPID SKY CHANGES',
 
475
     7'CHECK DARK LEVEL'/
 
476
C
 
477
      DATA ELABEL/' RISING','  EAST'/,WLABEL/' SETTING','  WEST'/
 
478
C
 
479
      DATA DECLBL/'   DEC.'/,
 
480
     1 TEMPRH/'TEMP.=        R.H. =        U.T. ='/,
 
481
     2 RALBL/'       <----  R.A.    '/
 
482
C
 
483
      DATA RALIMS/24.,0./,DECLIM/0.,0./
 
484
C
 
485
C  END DATA statements.
 
486
C
 
487
C  ********************  PROLOGUE  ********************
 
488
C
 
489
        CALL STSPRO ('PLAN')
 
490
C
 
491
C  Real program begins here:
 
492
C
 
493
C  PROLOGUE:
 
494
C
 
495
C ***
 
496
      F361='(I7.2,2X,A32)'
 
497
      DUM=KTV
 
498
      CALL PLOT(0,DUM,0.,'U')
 
499
      CALL PLOT(0,79.,23.,'P')
 
500
      NASSMP=0
 
501
      NEEDH=0
 
502
      MTYPE=0
 
503
      ST2UT=0.99726956633
 
504
      PI=3.14159265358979D0
 
505
      TWOPI=PI+PI
 
506
      DEGRAD=PI/180.
 
507
      SZMIN=1.1
 
508
      SZMAX=2.36
 
509
C
 
510
C       Reset error flags:
 
511
C
 
512
      CALL STECNT('GET',JCONT,JLOG,JDISP)
 
513
      CALL STECNT('PUT',1,2,2)
 
514
C
 
515
C  BEGIN DIALOG.
 
516
C
 
517
      CALL SPACE2
 
518
      CALL CENTER('Welcome to PEPSYS3''s PLANNER.')
 
519
      CALL SPACE2
 
520
      CALL ASK('Do you want Instructions?',A)
 
521
      IF(MATCH(A,'N')) GO TO 50
 
522
C
 
523
      NEEDH=2
 
524
      WRITE(PAGE,3)
 
525
    3 FORMAT(/
 
526
     1' PEPSYS needs information on the stars and instrument used.'/
 
527
     2' It will ask you to supply this by asking you questions.'///
 
528
     3' If you don''t understand a question, try typing "HELP" or "?"'/
 
529
     4' -- some on-line help is available.'//)
 
530
      DO 4 I=1,10
 
531
    4 CALL TVN(PAGE(I))
 
532
      WRITE(PAGE,12)
 
533
   12 FORMAT(/' You can abbreviate most answers  --  e.g.,'//
 
534
     1 5X,' you can answer yes/no questions with just "Y" or "N".'//
 
535
     2' If you want to abandon a run, reply "QUIT" to any request for'/
 
536
     3' non-numeric input.'//)
 
537
      DO 13 I=1,10
 
538
   13 CALL TVN(PAGE(I))
 
539
   20 CALL ASK('Do you need to set up a new STAR FILE?',A)
 
540
      IF(MATCH(A,'Y')) CALL FILHLP
 
541
C
 
542
       IF(HELP(A)) THEN
 
543
      CALL TV('Star files exist for UBV and uvby standards.')
 
544
      CALL TVN('You may need to set up new files for other systems, or f
 
545
C     convert next line to lower case:
 
546
     1OR PROGRAM STARS.')
 
547
      GO TO 20
 
548
       END IF
 
549
C
 
550
C  LOCATE OBSERVATORY.
 
551
C
 
552
   50 CONTINUE
 
553
      OBSFIL='esotel.tbl'
 
554
      INQUIRE (FILE=OBSFIL,EXIST=FEXIST)
 
555
   51 IF (FEXIST) THEN
 
556
        CALL TBTOPN (OBSFIL, 1,  IOBS, ISTAT)
 
557
        CALL STDRDC (IOBS, 'OBSERVATORY', 1, 1, 72,
 
558
     1                NVALS, PLACE, IUNIT, NULLS, ISTAT)
 
559
            IF(ISTAT.NE.0)THEN
 
560
                CALL TV('Could not find OBSERVATORY descriptor.')
 
561
                CALL TERROR(IOBS,51,'Please fix table file.')
 
562
            ELSE
 
563
            END IF
 
564
      ELSE
 
565
        CALL TV('The required observatory table file, "esotel.tbl",')
 
566
        CALL TVN('is not available.  Please make sure all required')
 
567
        CALL TVN('files are available in your current directory.')
 
568
        CALL STETER(52,'Missing observatory file "esotel.tbl"')
 
569
      END IF
 
570
      L=LWORD(PLACE)
 
571
      IF (L.GT.42) THEN
 
572
        CALL SPACE
 
573
        CALL TV('Will the observations be made at ')
 
574
        TITLE=PLACE(:L)//'?'
 
575
      ELSE
 
576
        TITLE='Will the observations be made at '//PLACE(:L)//'?'
 
577
      END IF
 
578
      CALL ASK(TITLE,CARD)
 
579
      IF(MATCH(CARD,'NO')) THEN
 
580
        CALL TBTCLO(IOBS, ISTAT)
 
581
        IF(ISTAT.NE.0) CALL TERROR(IOBS,55,'Could not close obs. file.')
 
582
        CALL TV(' ')
 
583
   55   CALL TV('Do you have a table file for the OBSERVATORY')
 
584
        CALL ASKFIL('      where the observations will be made?',OBSFIL)
 
585
        IF (MATCH(OBSFIL,'yes') .OR. MATCH(OBSFIL,'YES'))THEN
 
586
   56      CALL ASKFIL('Please enter the observatory FILE name:',OBSFIL)
 
587
           IF(INDEX(OBSFIL,'.tbl').EQ.0) THEN
 
588
               I=LWORD(OBSFIL)
 
589
               OBSFIL(I+1:)='.tbl'
 
590
           END IF
 
591
           INQUIRE (FILE=OBSFIL,EXIST=FEXIST)
 
592
           IF(FEXIST) GO TO 51
 
593
           CALL TV('File not found.  (Enter Q to quit, if necessary.)')
 
594
           GO TO 56
 
595
        ELSE IF (MATCH(OBSFIL,'no') .OR. MATCH(OBSFIL,'NO'))THEN
 
596
           GO TO 103
 
597
        ELSE
 
598
           IF(INDEX(OBSFIL,'.tbl').EQ.0) THEN
 
599
               I=LWORD(OBSFIL)
 
600
               OBSFIL(I+1:)='.tbl'
 
601
           END IF
 
602
           INQUIRE (FILE=OBSFIL,EXIST=FEXIST)
 
603
           IF(FEXIST) GO TO 51
 
604
           CALL TV('File not found.')
 
605
           GO TO 55
 
606
        END IF
 
607
        GO TO 103
 
608
      END IF
 
609
      IF(.NOT.MATCH(CARD,'YES'))GO TO 104
 
610
      IF(PLACE(:6).EQ.'MOUNT ' .OR. PLACE(:6).EQ.'Mount')THEN
 
611
          CARD='Mt.'//PLACE(7:)
 
612
          PLACE=CARD
 
613
      END IF
 
614
C   Right OBSERVATORY.  Read info from OBSFIL:
 
615
      CALL TBIGET (IOBS,  NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT)
 
616
      CALL TBLSER (IOBS, 'TELESCOP',  KTEL, ISTAT)
 
617
      IF(KTEL.EQ.-1) CALL TERROR(IOBS,53,'Could not find TELESCOP col')
 
618
      CALL TBLSER (IOBS, 'DIAM',  KDIAM, ISTAT)
 
619
      IF(KDIAM.EQ.-1) CALL TERROR(IOBS,54,'Could not find DIAM col')
 
620
      CALL TV(' ')
 
621
      CALL TV('Please choose the telescope to be used:')
 
622
      DO 60 NROW=1,NROWS
 
623
      CALL TBERDC (IOBS, NROW, KTEL, CTEST, NULL, ISTAT)
 
624
      CALL FT_EOS (CTEST,80,CARD,ISTAT)
 
625
      CALL TBERDR (IOBS, NROW, KDIAM,  TELCM, NULL, ISTAT)
 
626
      WRITE(TITLE,'(6X,I2,'':  '',A8,F6.2,'' m'')')nrow,card(:8),telcm
 
627
      CALL TV(TITLE)
 
628
   60 CONTINUE
 
629
      WRITE(TITLE,'(6X,I2,'':  None of these'')') NROWS+1
 
630
      CALL TV(TITLE)
 
631
   61 CALL QF('Enter the NUMBER (not the aperture) of your choice:',
 
632
     1         HIGH)
 
633
      NROW=HIGH
 
634
      IF (NROW.LT.1 .OR. HIGH-FLOAT(NROW).NE.0.) GO TO 61
 
635
      IF (NROW.GT.NROWS) GO TO 103
 
636
      CALL TBLSER (IOBS, 'LON',  KLON, ISTAT)
 
637
      IF(KLON.EQ.-1) CALL TERROR(IOBS,61,'Could not find LON col')
 
638
      CALL TBERDR (IOBS, NROW, KLON,  ELDEG, NULL, ISTAT)
 
639
      CALL TBLSER (IOBS, 'LAT',  KLAT, ISTAT)
 
640
      IF(KLAT.EQ.-1) CALL TERROR(IOBS,64,'Could not find LAT col')
 
641
      CALL TBERDR (IOBS, NROW, KLAT,  ALDEG, NULL, ISTAT)
 
642
      CALL TBLSER (IOBS, 'HEIGHT',  KHI, ISTAT)
 
643
      IF(KHI.EQ.-1) CALL TERROR(IOBS,66,'Could not find HEIGHT col.')
 
644
      CALL TBERDR (IOBS, NROW, KHI,  HIGH, NULL, ISTAT)
 
645
      CALL TBERDR (IOBS, NROW, KDIAM,  TELCM, NULL, ISTAT)
 
646
      TELCM=TELCM*100.
 
647
      CALL TBTCLO(IOBS, ISTAT)
 
648
      CANNED=.TRUE.
 
649
      GO TO 120
 
650
C
 
651
C   NOT HOME. TRY AGAIN.
 
652
  103 CALL ASKFIL('Observatory name?',PLACE)
 
653
  104 J=INDEX(PLACE,'OBS')
 
654
      IF(J.GT.1) PLACE(J:)=' '
 
655
      IF(PLACE(:6).EQ.'MOUNT ' .OR. PLACE(:6).EQ.'Mount')THEN
 
656
          CARD='Mt.'//PLACE(7:)
 
657
          PLACE=CARD
 
658
      END IF
 
659
      DO 106 J=1,MOBS
 
660
      IF(PLACE.EQ.PLACES(J)) GO TO 109
 
661
  106 CONTINUE
 
662
      DO 107 J=1,10
 
663
      IF(PLACE.EQ.PNAMES(J)) GO TO 108
 
664
  107 CONTINUE
 
665
      GO TO 110
 
666
C
 
667
  108 J=LOCS(J)
 
668
  109 PLACE=PLACES(J)
 
669
      ELDEG=ELDEGS(J)
 
670
      ALDEG=ALDEGS(J)
 
671
      HIGH=HIGHS(J)
 
672
      TELCM=0.
 
673
      CANNED=.TRUE.
 
674
      GO TO 120
 
675
C
 
676
C
 
677
C   NOT IN LIST, SO ASK FOR COORDS.
 
678
  110 CALL TV('Enter (East) LONGITUDE in time or degrees:')
 
679
      CALL TV('    h  m  s         o  ''  "')
 
680
      CALL ASK(' ',DMS)
 
681
      CANNED=.FALSE.
 
682
      IF(DMS(:10).EQ.' ') GO TO 113
 
683
C   LONGITUDE IN HOURS.
 
684
      ELHRS=DEG10(DMS(:13))
 
685
      IF(ELHRS.EQ.3.E33)GO TO 110
 
686
      IF(INDEX(DMS,'W').NE.0) ELHRS=-ELHRS
 
687
      GO TO 116
 
688
C   LONGITUDE IN DEGREES. CONVERT TO DECIMAL, HOURS.
 
689
  113 ELDEG=DEG10(DMS(16:32))
 
690
      IF(ELDEG.EQ.3.E33)GO TO 110
 
691
      IF(INDEX(DMS,'W').NE.0) ELDEG=-ELDEG
 
692
      ELHRS=ELDEG/15.
 
693
C    CONVERT HOURS TO DEGREES.
 
694
  116 ELDEG=ELHRS*15.
 
695
  117 CALL TV('Enter LATITUDE:')
 
696
      CALL TV('    o  ''  "')
 
697
      CALL ASK(' ',DMS)
 
698
      ALDEG=DEG10(DMS(:20))
 
699
      IF(ALDEG.EQ.3.E33)GOTO 117
 
700
      IF(INDEX(DMS,'S').NE.0) ALDEG=-ALDEG
 
701
      CALL QF('Enter height (meters) above sea level:',HIGH)
 
702
C
 
703
C    CONVERT FROM DEGREES TO RADIANS.
 
704
  120 ELHRS=ELDEG/15.
 
705
      ELROT=ELHRS/24.
 
706
      ELONG=ELDEG*DEGRAD
 
707
      WRITE(CARD,*) 'Longitude = ',ELDEG,' deg. = ',ELONG,' radians'
 
708
      CALL TV(CARD)
 
709
      TNOON1=-ELROT-.5
 
710
      TNOON2=-ELROT+.5
 
711
      ALAT=ALDEG*DEGRAD
 
712
      WRITE(CARD,*) 'Latitude  = ',ALDEG,' deg. = ', ALAT,' radians'
 
713
      CALL TVN(CARD)
 
714
      COSPHI=COS(ALAT)
 
715
      SINPHI=SIN(ALAT)
 
716
      PRAT=EXP(-HIGH/8.E3)
 
717
      DRAT=PRAT*PRAT
 
718
C   DIP OF HORIZON (P.401 OF EXPL.SUPP.)
 
719
      DO 121 I=1,12
 
720
  121 SALTS(I)=SALTS(I)-6.16E-4*SQRT(HIGH)
 
721
      IF(CANNED)GO TO 125
 
722
C
 
723
        CARD(1:13)=DEG2MS(ELHRS)
 
724
        CARD(21:33)=DEG2MS(ALDEG)
 
725
      WRITE(PAGE,122)PLACE,CARD(1:13),CARD(21:33),HIGH
 
726
  122 FORMAT(/4X,A//'    LONGITUDE      LATITUDE'/'     h  m  s        O
 
727
     1  ''  "'/2X,A13,2X,A13//' HEIGHT =',F6.0,' METERS')
 
728
      DO 123 I=1,8
 
729
  123 CALL TVN(PAGE(I))
 
730
      CALL ASK('OK?',A)
 
731
      IF(MATCH(A,'N')) GOTO 104
 
732
C
 
733
C  TELESCOPE.
 
734
C
 
735
  125 CONTINUE
 
736
      SYSSET=.FALSE.
 
737
      DIMMED=.FALSE.
 
738
      NEEDED=.FALSE.
 
739
      DEDSET=.FALSE.
 
740
      IF(TELCM.GT.0.) GO TO 128
 
741
      CALL ASK('Telescope aperture?',CARD)
 
742
      SCALE=1.
 
743
      JOLD=0
 
744
  126 J=INDEX(CARD,'CM')
 
745
      IF(J.EQ.0)J=INDEX(CARD,'CENTIMET')
 
746
C
 
747
       IF(J.EQ.0)THEN
 
748
      J=INDEX(CARD,'MET')
 
749
      IF(J.EQ.0)J=INDEX(CARD,'M.')
 
750
      IF(J.EQ.0)J=INDEX(CARD,'M ')
 
751
      IF(J.NE.0)SCALE=100.
 
752
       END IF
 
753
C
 
754
       IF(J.EQ.0)THEN
 
755
      J=INDEX(CARD,'IN')
 
756
      IF(J.NE.0)SCALE=2.54
 
757
       END IF
 
758
C
 
759
        IF(HELP(CARD))THEN
 
760
        CALL TV('Give number and units.')
 
761
        GOTO 125
 
762
        END IF
 
763
C
 
764
       IF(J.EQ.0)THEN
 
765
  127 CALL ASK('UNITS?',DMS)
 
766
      NEEDH=NEEDH+1
 
767
        IF(HELP(DMS))THEN
 
768
       CALL TV('cm, meters, or inches, please.')
 
769
       GO TO 127
 
770
        END IF
 
771
      J=INDEX(CARD,'      ')
 
772
      IF(JOLD.EQ.0)JOLD=J
 
773
      CARD(JOLD:)=DMS
 
774
      GO TO 126
 
775
       END IF
 
776
C
 
777
      K=INDEX(CARD,'-')
 
778
      IF(K.NE.0)J=MIN(J,K)
 
779
      CARD(J:)=' '
 
780
      READ(CARD,'(BN,F12.0)',ERR=125)TELCM
 
781
      IF(TELCM.LE.0.)GO TO 125
 
782
      TELCM=TELCM*SCALE
 
783
      WRITE(PAGE,'(/F9.1,'' cm.'')')TELCM
 
784
      CALL TV(PAGE(2))
 
785
  128 AREA=PI*TELCM*TELCM/4.
 
786
C
 
787
C  PRECISION.
 
788
C
 
789
      CALL TV(' ')
 
790
      CALL QF('What RMS precision (mags.) do you want?',SIGTOT)
 
791
        IF(SIGTOT.LT.0.003)THEN
 
792
          CALL TV(
 
793
     1    'Errors below 0.003 cannot be reached with existing systems.')
 
794
          CALL QF('Please re-enter RMS error goal.',SIGTOT)
 
795
        END IF
 
796
      IF(SIGTOT.LE.0.) GO TO 128
 
797
        IF(SIGTOT.LT.0.01)THEN
 
798
        NASSMP=NASSMP+1
 
799
        ASSMPS(NASSMP)='Transformation error may limit precision'
 
800
        CALL TV(ASSMPS(NASSMP))
 
801
        END IF
 
802
      SIGSQ=SIGTOT*SIGTOT
 
803
C   Assume transformation error = .015/star.
 
804
      NEEDST=9.E-4/SIGSQ + 4.
 
805
C   LET SCINT.NOISE AMPL.= HALF OF SIGTOT AT SECZ=SZMAX=2.36.
 
806
      TINT1=8.1E-3*DRAT/(SIGSQ*TELCM**(4./3.))
 
807
C    (8.1E-3 = .09**2)
 
808
C  SCINT.NOISE = SIGTOT/2 IN TINT1 SEC.AT ZENITH.  (SEE 173; 213.5)
 
809
      TINT=TINT1*(SZMAX**4)
 
810
      TSUGG=INT(TINT/5.)*5.+5.
 
811
      WRITE(PAGE,129)TINT,TSUGG
 
812
  129 FORMAT(/' Use',F4.0,' sec minimum integrations for bright stars.'/
 
813
     1/4X,'Suggested integration =',F4.0,' sec')
 
814
      CALL TV(PAGE(2))
 
815
      CALL TV(PAGE(4))
 
816
      CALL ASK('OK?',A)
 
817
C
 
818
      IF(MATCH(A,'Y')) THEN
 
819
C         we are OK.
 
820
      ELSE IF(MATCH(A,'N')) THEN
 
821
          CALL QF('How many sec.do you want?',TSUGG)
 
822
          IF(TSUGG.LT.TINT/SQRT(SZMAX))THEN
 
823
C             revise specs.
 
824
              TELCM=TELCM*(TINT/TSUGG)**0.75
 
825
              SIGTOT=SIGTOT*SQRT(TINT/TSUGG)
 
826
C             convert next line to lower case:
 
827
              WRITE(PAGE,'(/'' Raise error to'',F6.3,
 
828
     +        '' mag''/'' OR USE AT LEAST'',F6.1,'' CM TELESCOPE.'')')
 
829
     +        SIGTOT,TELCM
 
830
              CALL TV(PAGE(2))
 
831
              CALL TVN(PAGE(3))
 
832
              GO TO 51
 
833
          END IF
 
834
      ELSE
 
835
          CALL TV('Please answer "Yes" or "No".')
 
836
          GOTO 128
 
837
      END IF
 
838
C
 
839
C  SYSTEM.
 
840
C
 
841
  130 IF(SYSSET)GOTO 160
 
842
      CALL TV(' ')
 
843
      CALL ASK('Name of Standard System?',SYSTEM)
 
844
      CANNED=.FALSE.
 
845
      DO 131 JSYS=1,MSYS
 
846
      IF(SYSTEM.EQ.SYSTMS(JSYS)) GO TO 132
 
847
  131 CONTINUE
 
848
      JSYS=0
 
849
      NEEDST=0
 
850
      IF(MATCH(SYSTEM,'NONE')) THEN
 
851
         CALL ASKFIL('What file has extinction-star positions?',STDFIL)
 
852
         GO TO 142
 
853
      END IF
 
854
      NEEDH=NEEDH+1
 
855
      CALL TV('Choose "NONE" or one of:')
 
856
      WRITE(PAGE,'(10(1X,A6))') SYSTMS
 
857
      CALL TVN(PAGE(1))
 
858
      GO TO 130
 
859
C
 
860
  132 STDFIL=STDFLS(JSYS)
 
861
      NBANDS=JBANDS(JSYS)
 
862
C     to 140 for "other".
 
863
      IF(JSYS.EQ.MSYS)GO TO 140
 
864
      IF (INDEX(SYSTEM,'RI').GT.0) THEN
 
865
          CALL TV('*******************  CAUTION  *******************')
 
866
          CALL TV('The R and I bands of the Johnson UBVRI system are')
 
867
          CALL TVN('NOT the same as those of the Kron-Cousins system.')
 
868
          CALL TV('    BE SURE you know which system you are using!')
 
869
          CALL TV('    NEVER mix standard stars from the two systems!!')
 
870
      END IF
 
871
      DO 133 NB=1,NBANDS
 
872
      WLS(NB)=STDWLS(NB,JSYS)
 
873
      WIDTHS(NB)=FWHMS(NB,JSYS)
 
874
      TRANS(NB)=TRANSS(NB,JSYS)
 
875
C    SET 2-COLOR DIAGRAM.
 
876
      KX=KXS(JSYS)
 
877
      KY=KYS(JSYS)
 
878
      XINV=XINVS(JSYS)
 
879
      YINV=YINVS(JSYS)
 
880
      LENB=LENBS(JSYS)
 
881
      LENC=LENCS(JSYS)
 
882
      CNAMES(1,NB)=BNDVAR(NB,JSYS)
 
883
      CNAMES(2,NB)='S'//BNDVAR(NB,JSYS)
 
884
  133 BANDS(NB)=BNDS(NB,JSYS)
 
885
      CANNED=.TRUE.
 
886
      GO TO 150
 
887
C
 
888
C  OTHER.
 
889
C
 
890
  140 CALL ASK('Name of System?',SYSTEM)
 
891
      CALL ASKFIL('Name of STD.star file?',STDFIL)
 
892
  142 CALLQF('Number of bands =',DUM)
 
893
      NBANDS=DUM
 
894
      LENB=0
 
895
      LENC=0
 
896
       IF(NBANDS.LE.0)THEN
 
897
      WRITE(PAGE,'(I5,'' is not legal'')')NBANDS
 
898
      CALL TVN(PAGE(1))
 
899
      GO TO 142
 
900
       END IF
 
901
      IF(NBANDS.LE.MBANDS) GO TO 145
 
902
      CALL EXCEED(NBANDS,'MBANDS',MBANDS)
 
903
      CALL STETER(144, 'MBANDS EXCEEDED')
 
904
C
 
905
  145 DO 148 K=1,NBANDS
 
906
      WRITE(DMS,'(''Name of band ('',I1,'')?'')')K
 
907
  146 CALL ASK(DMS,BANDS(K))
 
908
      LENB=MAX(LENB,LWORD(BANDS(K)))
 
909
      IF(LENB.EQ.0)GOTO146
 
910
      CALL QF('Center Wavelength (A)?',WLS(K))
 
911
      CALL QF('Full width (A) at half peak response?',WIDTHS(K))
 
912
      CALL QF('Peak transmission?',TRANS(K))
 
913
  147 CALL ASKFIL('Name of associated magnitude or color?',CNAMES(1,K))
 
914
C    SET FOR FILES WITH S.D.'S OF STD.VALUES:
 
915
      CNAMES(2,K)='S'//CNAMES(1,K)
 
916
      LENC=MAX(LENC,LWORD(CNAMES(1,K)))
 
917
      IF(LENC.EQ.0)GOTO147
 
918
  148 CONTINUE
 
919
      LENB=MIN(LENB,6)
 
920
      LENC=MIN(LENC,6)
 
921
C
 
922
C   2-COLOR DIAGRAM.
 
923
      IF(MATCH(SYSTEM,'NONE') .OR. NBANDS.LT.3)GOTO150
 
924
      CALL TV('Set up 2-color diagram:')
 
925
      CALL ASK('Color on HORIZONTAL axis:',BAND)
 
926
      CALL ASK('Color on VERTICAL axis:',UTSTR)
 
927
      DO 149 K=1,NBANDS
 
928
      IF(CNAMES(1,K).EQ.BAND)KX=K
 
929
      IF(CNAMES(1,K).EQ.UTSTR)KY=K
 
930
  149 CONTINUE
 
931
      XINV=0.
 
932
      YINV=0.
 
933
      PAGE(1)='Does '//CNAMES(1,KX)(:LENC)//' increase to right?'
 
934
      CALL ASK(PAGE(1),A)
 
935
      IF(MATCH(A,'N'))XINV=1.
 
936
      PAGE(1)='Does '//CNAMES(1,KY)(:LENC)//' increase upward?'
 
937
      CALL ASK(PAGE(1),A)
 
938
      IF(MATCH(A,'N'))YINV=1.
 
939
C
 
940
C  DECODE COLORS.
 
941
C
 
942
  150 CALL DECOLR(COLORS,CNAMES,BANDS,SYSTEM,CANNED)
 
943
C
 
944
C  ESTIMATE PHOTON NOISE.
 
945
C
 
946
  160 DO 168 NB=1,NBANDS
 
947
C   Allow for extinction.
 
948
      DUM=5.E3/WLS(NB)
 
949
      EXTIN(NB)=0.15*PRAT*DUM**4 + DRAT*0.1*DUM
 
950
C     .05 IS DQE.
 
951
      PHOMAG(NB) = 15.5 + 2.5*LOG10(SIGSQ*AREA*.05*TINT1*WIDTHS(NB)*
 
952
     1 TRANS(NB)/WLS(NB))
 
953
C   PHOTON NOISE = SIGSQ/4. at PHOMAG for TINT1 sec. outside atmosphere.
 
954
      FAINTS(NB)=3.E33
 
955
  168 BRITES(NB)=-3.E33
 
956
      CALL MAGSET(BANDS)
 
957
      IF(SYSSET)GO TO 200
 
958
C
 
959
C  READ STDFIL.
 
960
C
 
961
      SYSSET=.TRUE.
 
962
      SAVFIL=STDFIL
 
963
  170 NSTAR=1
 
964
      LASTD=0
 
965
      NAM1(1)=1
 
966
      NAM2(1)=12+2*NBANDS
 
967
      NAM1(2)=MN+1
 
968
      NAM2(2)=MN+11
 
969
      NGRPS=2
 
970
C    NGRPS CANNOT EXCEED PARAMETER (MGRPS=8).
 
971
      MOVING=.FALSE.
 
972
C       special for uvby only:
 
973
      IF (SYSTEM(:4).EQ.'UVBY') SYSTEM(:4)='uvby'
 
974
C
 
975
C       OPEN Standard-star file:
 
976
C
 
977
  175 INQUIRE (FILE=STDFIL,EXIST=FEXIST)
 
978
      IF (FEXIST) THEN
 
979
          CALL TBTOPN(STDFIL,1,  ISTD,ISTAT)
 
980
          IF(ISTAT.NE.0)CALLTERROR(IOBS,175,'Could not open star file.')
 
981
          CARD='  ... reading '//STDFIL
 
982
          CALL TV(CARD)
 
983
          IF(LASTD.EQ.0)THEN
 
984
C             display SYSTEM descriptor of std.-star file:
 
985
              CALL STDRDC (ISTD, 'SYSTEM', 1, 1, 32,
 
986
     1                   NVALS, CARD, IUNIT, NULLS, ISTAT)
 
987
              CALL TVN(CARD)
 
988
              IF (INDEX(CARD,SYSTEM(:LWORD(SYSTEM))).EQ.0 .AND.
 
989
     1          .NOT.(SYSTEM.EQ.'H-BETA'.AND.INDEX(CARD,'HB').NE.0))THEN
 
990
                  CALL TV(
 
991
     1                'CAREFUL: this does not appear to be the right')
 
992
                  CALL TVN('photometric system.  Please check:')
 
993
                  CALL TV('Is this REALLY a standard-star file for')
 
994
                  CARD=SYSTEM(:LWORD(SYSTEM))//' ?'
 
995
                  CALL ASKN(CARD,A)
 
996
                  IF (A.EQ.'Y')THEN
 
997
                  ELSE
 
998
                      CALL ASKFIL('Enter the correct file name:',STDFIL)
 
999
                      IF (MATCH(STDFIL,'no').OR.MATCH(STDFIL,'NO'))THEN
 
1000
                          GO TO 188
 
1001
                      ELSE
 
1002
                          GO TO 175
 
1003
                      END IF
 
1004
                  END IF
 
1005
              END IF
 
1006
          END IF
 
1007
      ELSE
 
1008
        IF(INDEX(STDFIL,'.tbl').EQ.0) THEN
 
1009
            CARD=STDFIL(:LWORD(STDFIL))//'.tbl'
 
1010
            STDFIL=CARD
 
1011
            GO TO 175
 
1012
        END IF
 
1013
        CARD='The requested star table file '//STDFIL
 
1014
        CALL TV(CARD)
 
1015
        CALL TVN('is not available.  Please make sure all required')
 
1016
        CALL TVN('files are available in your current directory.')
 
1017
        CARD='Is '//STDFIL(:LWORD(STDFIL))//' the correct file name?'
 
1018
        CALL ASKFIL(CARD,STDFIL)
 
1019
        IF (MATCH(STDFIL,'YES') .OR. MATCH(STDFIL,'yes'))THEN
 
1020
            CALL STETER(175,'Missing standard-star file')
 
1021
        ELSEIF (MATCH(STDFIL,'NO') .OR. MATCH(STDFIL,'no'))THEN
 
1022
            CALL ASKFIL('Please enter the correct file name:',STDFIL)
 
1023
            GO TO 175
 
1024
        ELSE
 
1025
            GO TO 175
 
1026
        END IF
 
1027
      END IF
 
1028
C
 
1029
C       Get columns:
 
1030
C
 
1031
      CALL TBIGET(ISTD,  NCOLS,NROWS,NSORTC,NWPRAL,NROWSAL,ISTAT)
 
1032
      IF(ISTAT.NE.0) CALL TERROR(IOBS,175,'Could not get file info.')
 
1033
      CALL TBLSER(ISTD,'OBJECT', KOBJ,ISTAT)
 
1034
      IF(ISTAT.NE.0) CALL TERROR(IOBS,176,'ERROR finding OBJECT col.')
 
1035
      IF(KOBJ.EQ.-1) CALL TERROR(IOBS,176,'Could not find OBJECT col.')
 
1036
      CALL TBLSER(ISTD,'RA', KRA,ISTAT)
 
1037
      IF(ISTAT.NE.0) CALL TERROR(IOBS,177,'ERROR finding RA col.')
 
1038
      IF(KRA.EQ.-1) CALL TERROR(IOBS,177,'Could not find RA col.')
 
1039
      CALL TBLSER(ISTD,'DEC', KDEC,ISTAT)
 
1040
      IF(ISTAT.NE.0) CALL TERROR(IOBS,178,'ERROR finding DEC col.')
 
1041
      IF(KDEC.EQ.-1) CALL TERROR(IOBS,178,'Could not find DEC col.')
 
1042
      CALL TBLSER(ISTD,'EQUINOX', KEQUINOX,ISTAT)
 
1043
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding EQUINOX col.')
 
1044
      IF(KEQUINOX.EQ.-1) THEN
 
1045
          IF (LASTD.EQ.0) THEN
 
1046
              CALL TERROR(IOBS,179,'Could not find EQUINOX col.')
 
1047
          ELSE
 
1048
C             assume moving object, referred to equinox of date.
 
1049
              CALL TV('No EQUINOX column in this file.')
 
1050
              CALL TVN(
 
1051
     1           'Assume this is an ephemeris file for moving objects.')
 
1052
              MOVING=.TRUE.
 
1053
          END IF
 
1054
      END IF
 
1055
      CALL TBLSER(ISTD,'MUALPHA', KMUALPHA,ISTAT)
 
1056
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MUALPHA col.')
 
1057
      CALL TBLSER(ISTD,'MUDELTA', KMUDELTA,ISTAT)
 
1058
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MUDELTA col.')
 
1059
      CALL TBLSER(ISTD,'EPOCH', KEPOCH,ISTAT)
 
1060
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding EPOCH col.')
 
1061
      CALL TBLSER(ISTD,'SPTYPE', KSPTYPE,ISTAT)
 
1062
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding SPTYPE col.')
 
1063
      CALL TBLSER(ISTD,'MAG', KMAG,ISTAT)
 
1064
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MAG col.')
 
1065
      CALL TBLSER(ISTD,'COMMENT', KCOMMENT,ISTAT)
 
1066
      IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding COMMENT col.')
 
1067
      DO 180 K=1,NBANDS
 
1068
          DMS=CNAMES(1,K)
 
1069
C         special fudge for dumb MIDAS table system:
 
1070
          IF (INDEX(DMS,'-').NE.0)DMS(INDEX(DMS,'-'):INDEX(DMS,'-'))='_'
 
1071
C         DMS holds MIDAS-readable name; CNAMES has human-readable name.
 
1072
          IF (CNAMES(1,K).EQ.' ') THEN
 
1073
             KOLR(K)=-1
 
1074
          ELSE
 
1075
             CALL TBLSER(ISTD,DMS, KOLR(K),ISTAT)
 
1076
             IF(ISTAT.NE.0) THEN
 
1077
                   CARD='ERROR finding column for '//CNAMES(1,K)
 
1078
                   CALL TERROR(ISTD,180,CARD)
 
1079
             END IF
 
1080
          END IF
 
1081
          IF(KOLR(K).EQ.-1) THEN
 
1082
C             look for special cases:
 
1083
              IF (INDEX(SYSTEM,'VRI').GT.0) THEN
 
1084
C                 special for V-I:
 
1085
                  IF (CNAMES(1,K).EQ.'R-I')THEN
 
1086
                      CALL TBLSER(ISTD,'V_I', KVI,ISTAT)
 
1087
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,180,
 
1088
     1                             'ERROR finding column V-I')
 
1089
                      IF(KVI.EQ.-1)THEN
 
1090
C                         could not find V-I either.
 
1091
                          CALL TV('Could not find column R-I or V-I')
 
1092
                      ELSE
 
1093
C                         found V-I.
 
1094
                          GO TO 180
 
1095
                      END IF
 
1096
                  END IF
 
1097
              ELSE IF (INDEX(SYSTEM,'uvby').GT.0) THEN
 
1098
C                 special for u-v and v-b:
 
1099
                  IF (CNAMES(1,K).EQ.'m1')THEN
 
1100
                      CALL TBLSER(ISTD,'v_b', KVB,ISTAT)
 
1101
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,180,
 
1102
     1                             'ERROR finding column v-b')
 
1103
                      IF(KVB.EQ.-1)THEN
 
1104
C                         could not find v-b either.
 
1105
                          CALL TV('Could not find column m1 or v-b')
 
1106
                      ELSE
 
1107
C                         found v-b.
 
1108
                           GO TO 180
 
1109
                      END IF
 
1110
                  ELSE IF (CNAMES(1,K).EQ.'c1')THEN
 
1111
                      CALL TBLSER(ISTD,'u_v', KUV,ISTAT)
 
1112
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,180,
 
1113
     1                             'ERROR finding column u-v')
 
1114
                      IF(KUV.EQ.-1)THEN
 
1115
C                         could not find u-v either.
 
1116
                          CALL TV('Could not find column c1 or u-v')
 
1117
                      ELSE
 
1118
C                         found u-v.
 
1119
                          GO TO 180
 
1120
                      END IF
 
1121
                  ELSE IF (CNAMES(1,K).EQ.'V')THEN
 
1122
C                 special for Vmag:
 
1123
                      CALL TBLSER(ISTD,'Vmag', KOLR(K),ISTAT)
 
1124
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,180,
 
1125
     1                             'ERROR finding column Vmag')
 
1126
                      IF(KOLR(K).EQ.-1)THEN
 
1127
C                         could not find Vmag either.
 
1128
                          CALL TV('Could not find column V or Vmag')
 
1129
                      ELSE
 
1130
C                         found Vmag.
 
1131
                          CALL TVN('      file has Vmag, not V')
 
1132
                          GO TO 180
 
1133
                      END IF
 
1134
                  END IF
 
1135
                  IF(INDEX(SYSTEM,'HB').GT.0)THEN
 
1136
C                     special for H-beta:
 
1137
                      IF (CNAMES(1,K).EQ.' ') THEN
 
1138
                          GO TO 180
 
1139
                      END IF
 
1140
                  END IF
 
1141
              ELSE IF(SYSTEM.EQ.'H-BETA')THEN
 
1142
C                 special for H-beta:
 
1143
                  IF (CNAMES(1,K).EQ.' ') THEN
 
1144
                      GO TO 180
 
1145
                  END IF
 
1146
              END IF
 
1147
              IF(LASTD.EQ.0) THEN
 
1148
C               we are in standard stars; serious error.
 
1149
                CARD='Could not find column for '//CNAMES(1,K)
 
1150
                CALL TERROR(IOBS,180,CARD)
 
1151
              ELSE
 
1152
C               we are in program stars; forget it.
 
1153
              END IF
 
1154
          END IF
 
1155
  180 CONTINUE
 
1156
C
 
1157
      IF (LASTD.GT.0) THEN
 
1158
C         Look for ephemeris data:
 
1159
          CALL TBLSER(ISTD,'DATE', KDATE,ISTAT)
 
1160
          IF(ISTAT.NE.0) CALL TERROR(IOBS,180,'ERROR finding DATE col.')
 
1161
          IF(KDATE.EQ.-1) THEN
 
1162
              CALL TBLSER(ISTD,'MJD_OBS', KMJD,ISTAT)
 
1163
              IF(ISTAT.NE.0) CALL TERROR(IOBS,180,
 
1164
     1                          'ERROR finding DATE col.')
 
1165
              IF(KMJD.EQ.-1) THEN
 
1166
              ELSE
 
1167
                  CALL TV('MJD_OBS column found; ephemeris file.')
 
1168
                  MOVING=.TRUE.
 
1169
              END IF
 
1170
          ELSE
 
1171
              WRITE(CARD,*)'DATE found in col.',KDATE
 
1172
              CALL TV(CARD)
 
1173
              MOVING=.TRUE.
 
1174
          END IF
 
1175
      ELSE
 
1176
      END IF
 
1177
C
 
1178
C       READ Standard-star file:
 
1179
C
 
1180
      DO 181 NROW=1,NROWS
 
1181
C
 
1182
      BACK1=.FALSE.
 
1183
C   Here to examine data read from STDFIL.
 
1184
      CALL TBERDR (ISTD, NROW, KDEC,  DECDEG, NULL, ISTAT)
 
1185
      IF(ISTAT.NE.0) CALL TERROR(IOBS,181,'Could not read DEC col.')
 
1186
C   Skip any stars that never rise.
 
1187
      IF(ABS(ALDEG-DECDEG).GT.90.)GO TO 181
 
1188
C    OK, add to list.
 
1189
      NSTAR=NSTAR+1
 
1190
       IF(NSTAR.GT.MSTARS) THEN
 
1191
          CALL EXCEED(NSTAR,'MSTARS',MSTARS)
 
1192
          CALL ASK('Do you wish to continue?',A)
 
1193
          NSTAR=MSTARS
 
1194
          IF(LASTD.EQ.0)LASTD=MSTARS
 
1195
          IF(MATCH(A,'Y')) GO TO 190
 
1196
          CALL TERROR(ISTD,184, 'CATALOG OVERLFOW')
 
1197
       END IF
 
1198
C     Get R.A.
 
1199
      CALL TBERDR (ISTD, NROW, KRA,  RADEG, NULL, ISTAT)
 
1200
      IF(ISTAT.NE.0) CALL TERROR(IOBS,182,'Could not read RA col.')
 
1201
      IF(NULL) BACK1=.TRUE.
 
1202
C     note that MIDAS stores it as *degrees*!
 
1203
      RAS(NSTAR)=RADEG*DEGRAD
 
1204
      DECS(NSTAR)=DECDEG*DEGRAD
 
1205
C
 
1206
C     Look for equinox, to precess:
 
1207
        IF (KEQUINOX.GT.0) THEN
 
1208
      CALL TBERDR (ISTD, NROW, KEQUINOX,  EQUINX(NSTAR), NULL, ISTAT)
 
1209
      IF(ISTAT.NE.0) CALL TERROR(IOBS,183,'Could not read EQUINOX col.')
 
1210
        ELSE
 
1211
      EQUINX(NSTAR)=0.
 
1212
        END IF
 
1213
      IF(NULL) BACK1=.TRUE.
 
1214
C
 
1215
C   GET STAR NAME.
 
1216
C
 
1217
      CALL TBERDC (ISTD, NROW, KOBJ,CTEST, NULL, ISTAT)
 
1218
      CALL FT_EOS (CTEST,32,STARS(NSTAR),ISTAT)
 
1219
      IF(NULL) BACK1=.TRUE.
 
1220
C
 
1221
      IF(LASTD.EQ.0) THEN
 
1222
C    TRANSFER MAG. & COLORS.
 
1223
       DO 185 K=1,NBANDS
 
1224
          IF(KOLR(K).EQ.-1) THEN
 
1225
C             look for special cases:
 
1226
              IF (INDEX(SYSTEM,'VRI').GT.0) THEN
 
1227
C                 special for V-I:
 
1228
                  IF (CNAMES(1,K).EQ.'R-I' .AND. KVI.GT.0)THEN
 
1229
                      CALL TBERDR (ISTD, NROW, KVI,
 
1230
     1                            COLORS(K,NSTAR), NULL, ISTAT)
 
1231
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,185,
 
1232
     1                             'Could not read column V-I')
 
1233
                      IF (NULL) COLORS(K,NSTAR)=3.E33
 
1234
C                     convert to expected index:
 
1235
C                     R-I = (V-I) - (V-R)
 
1236
                      COLORS(K,NSTAR)=COLORS(K,NSTAR)-COLORS(K-1,NSTAR)
 
1237
                      GO TO 185
 
1238
                  END IF
 
1239
              ELSE IF (INDEX(SYSTEM,'uvby').GT.0) THEN
 
1240
C                 special for u-v and v-b:
 
1241
                  IF (CNAMES(1,K).EQ.'m1' .AND. KVB.GT.0)THEN
 
1242
                      CALL TBERDR (ISTD, NROW, KVB,
 
1243
     1                            COLORS(K,NSTAR), NULL, ISTAT)
 
1244
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,185,
 
1245
     1                             'Could not read column v-b')
 
1246
                      IF (NULL) COLORS(K,NSTAR)=3.E33
 
1247
                      GO TO 185
 
1248
C                     postpone action until u-v is read:
 
1249
                  ELSE IF (CNAMES(1,K).EQ.'c1' .AND. KUV.GT.0)THEN
 
1250
                      CALL TBERDR (ISTD, NROW, KUV,
 
1251
     1                            COLORS(K,NSTAR), NULL, ISTAT)
 
1252
                      IF(ISTAT.NE.0)CALL TERROR(ISTD,185,
 
1253
     1                             'Could not read column u-v')
 
1254
                      IF (NULL) COLORS(K,NSTAR)=3.E33
 
1255
C                     now convert to expected indices:
 
1256
C                     c1 = (u-v) - (v-b)
 
1257
                      COLORS(4,NSTAR)=COLORS(4,NSTAR) - COLORS(3,NSTAR)
 
1258
C                     m1 = (v-b) - (b-y)
 
1259
                      COLORS(3,NSTAR)=COLORS(3,NSTAR) - COLORS(2,NSTAR)
 
1260
                      GO TO 185
 
1261
                  END IF
 
1262
                  IF(INDEX(SYSTEM,'HB').GT.0)THEN
 
1263
C                     special for H-beta:
 
1264
                      IF (CNAMES(1,K).EQ.' ') THEN
 
1265
                          GO TO 185
 
1266
                      END IF
 
1267
                  END IF
 
1268
              ELSE IF(SYSTEM.EQ.'H-BETA')THEN
 
1269
C                 special for H-beta:
 
1270
                  IF (CNAMES(1,K).EQ.' ') THEN
 
1271
                      GO TO 185
 
1272
                  END IF
 
1273
              END IF
 
1274
                CARD='Missing column: '//CNAMES(1,K)
 
1275
                CALL TV(CARD)
 
1276
          ELSE
 
1277
C             normal case:
 
1278
              CALL TBERDR (ISTD, NROW, KOLR(K),
 
1279
     1                            COLORS(K,NSTAR), NULL, ISTAT)
 
1280
              IF(ISTAT.NE.0) THEN
 
1281
                  CARD='Could not read '//CNAMES(1,K)//' column'
 
1282
                  CALL TERROR(IOBS,185,CARD)
 
1283
              END IF
 
1284
              IF (NULL) COLORS(K,NSTAR)=3.E33
 
1285
          END IF
 
1286
  185  CONTINUE
 
1287
      ELSE
 
1288
C         fill in dummy values for pgm.objects.
 
1289
          COLORS(1,NSTAR)=3.E33
 
1290
          COLORS(2,NSTAR)=3.E33
 
1291
          COLORS(3,NSTAR)=3.E33
 
1292
          COLORS(4,NSTAR)=3.E33
 
1293
      END IF
 
1294
C
 
1295
C   DO EPHEMERIS FILES.
 
1296
C
 
1297
           IF(KDATE.GT.0 .OR. KMJD.GT.0)THEN
 
1298
C          This is an ephemeris file.
 
1299
C
 
1300
        IF (KDATE.GT.0) THEN
 
1301
      CALL TBERDC (ISTD, NROW, KDATE, CTEST, NULL, ISTAT)
 
1302
      CALL FT_EOS (CTEST,20,DATSTR,ISTAT)
 
1303
C     DATE exists.  Get it.
 
1304
      IF(DATSTR.NE.' ') CALL GETJD(DJD)
 
1305
      DJD=DJD-2400000.D0
 
1306
        ELSE IF (KMJD.GT.0) THEN
 
1307
C     MJD exists.  Get it.
 
1308
      CALL TBERDD (ISTD, NROW, KMJD,  DJD, NULL, ISTAT)
 
1309
      DJD=DJD+0.5D0
 
1310
        END IF
 
1311
C
 
1312
C   PUT MJD IN COLORS(MBANDS).
 
1313
      COLORS(MBANDS,NSTAR)=DJD
 
1314
C   PUT X,Y,Z IN COLORS(MBM1,MBM2,MBM3)...
 
1315
      COLORS(MBM1,NSTAR)=COS(RAS(NSTAR))*COS(DECS(NSTAR))
 
1316
      COLORS(MBM2,NSTAR)=SIN(RAS(NSTAR))*COS(DECS(NSTAR))
 
1317
      COLORS(MBM3,NSTAR)=SIN(DECS(NSTAR))
 
1318
C    POINT TO END OF TABLE.
 
1319
      DO 186 I=NSTAR-1,1,-1
 
1320
      IF(STARS(I).NE.STARS(NSTAR)) GO TO 187
 
1321
  186 CONTINUE
 
1322
      I=0
 
1323
  187 COLORS(MBM4,I+1)=NSTAR
 
1324
C
 
1325
           END IF
 
1326
C
 
1327
C   END EPHEMERIS FILE.
 
1328
C
 
1329
C     Now get COMMENTS, etc.
 
1330
C
 
1331
      IF (KCOMMENT.NE.-1) THEN
 
1332
          CALL TBERDC(ISTD, NROW, KCOMMENT, CTEST, NULL, ISTAT)
 
1333
          CALL FT_EOS (CTEST,32,COMENT(NSTAR),ISTAT)
 
1334
      ELSE
 
1335
          COMENT(NSTAR)=' '
 
1336
      END IF
 
1337
C
 
1338
      LEN=LWORD(COMENT(NSTAR))
 
1339
      IF (LASTD.EQ.0)THEN
 
1340
C         std.star
 
1341
          IF (LEN.EQ.0) THEN
 
1342
              COMENT(NSTAR)='Standard star ******************'
 
1343
          ELSE
 
1344
              COMENT(NSTAR)(LEN:)='   STD.* ************'
 
1345
          END IF
 
1346
      ELSE
 
1347
C         pgm.star
 
1348
          IF (LEN.EQ.0) THEN
 
1349
              COMENT(NSTAR)='Program star ...................'
 
1350
          ELSE
 
1351
              COMENT(NSTAR)(LEN:)='   Pgm.* ............'
 
1352
          END IF
 
1353
      END IF
 
1354
C
 
1355
      IF (KSPTYPE.NE.-1) THEN
 
1356
          CALL TBERDC (ISTD, NROW, KSPTYPE,CTEST, NULL, ISTAT)
 
1357
          CALL FT_EOS (CTEST,12,SPTYPE(NSTAR),ISTAT)
 
1358
      ELSE
 
1359
          SPTYPE(NSTAR)=' '
 
1360
      END IF
 
1361
C
 
1362
      IF (KMAG.NE.-1) THEN
 
1363
          CALL TBERDC (ISTD, NROW, KMAG, CTEST, NULL, ISTAT)
 
1364
          CALL FT_EOS (CTEST,16,EMAG(NSTAR),ISTAT)
 
1365
      ELSE
 
1366
          EMAG(NSTAR)=' '
 
1367
      END IF
 
1368
C
 
1369
      IF(BACK1) NSTAR=NSTAR-1
 
1370
  181 CONTINUE
 
1371
C
 
1372
      CALL TBTCLO(ISTD, ISTAT)
 
1373
      CARD='Closing star file '//STDFIL
 
1374
      CALL TV(CARD)
 
1375
C
 
1376
C   END CATALOG.
 
1377
C
 
1378
  188 WRITE(PAGE,'(/I8,'' TOTAL STARS''/I8,'' SLOTS FREE'')')NSTAR,
 
1379
     1MSTARS-NSTAR
 
1380
      CALL TV(PAGE(2))
 
1381
      CALL TVN(PAGE(3))
 
1382
C   IS CAT.FULL?
 
1383
      IF(NSTAR.EQ.MSTARS)GO TO 190
 
1384
C---
 
1385
      IF(LASTD.EQ.0)THEN
 
1386
C
 
1387
          IF(JSYS.NE.0)THEN
 
1388
              IF(NEEDH.GT.3)CALL TV('   Additional Standards:')
 
1389
              CALL ASKFIL('Any other STANDARD-star files?',CATFIL)
 
1390
          ELSE
 
1391
              CALL ASKFIL('Any more EXTINCTION-star files?',CATFIL)
 
1392
          END IF
 
1393
C
 
1394
C         Y: goes to end of outer IF-block.
 
1395
          IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))THEN
 
1396
C             transition to pgm.stars.
 
1397
              LASTD=NSTAR
 
1398
              MOVING=.FALSE.
 
1399
              IF(NEEDH.GT.1)CALL TV('   Program Stars:')
 
1400
              CALL ASKFIL('Any PROGRAM-star files?',CATFIL)
 
1401
              IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))GO TO 190
 
1402
C             EXPAND GROUPS TO INCLUDE EPHEMERIS VARIABLES.
 
1403
              NAM2(1)=MN
 
1404
              NAM2(2)=MN+13
 
1405
          END IF
 
1406
C
 
1407
      ELSE
 
1408
C
 
1409
              CALL ASKFIL('More PROGRAM-star files?',CATFIL)
 
1410
              IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))GO TO 190
 
1411
C
 
1412
      END IF
 
1413
C---
 
1414
      IF(MATCH(CATFIL,'YES').OR.MATCH(CATFIL,'yes'))
 
1415
     1 CALL ASKFIL('Name of supplemental star file?',CATFIL)
 
1416
C
 
1417
C     Enter "keyboard" or "keys" to read from keyboard:
 
1418
      IF(MATCH(CATFIL,'KEY').OR.MATCH(CATFIL,'key'))THEN
 
1419
C             MANUAL ENTRY.
 
1420
              NSTAR=NSTAR+1
 
1421
              CALL ASKFIL('Enter Star name:',STARS(NSTAR))
 
1422
              CALL ADDSTR(EQUINX(NSTAR),RAS(NSTAR),DECS(NSTAR))
 
1423
C             flag missing Equinox.
 
1424
              IF(EQUINX(NSTAR).EQ.0.) EQUINX(NSTAR)=3.E33
 
1425
              DO 189 I=1,NBANDS
 
1426
C $$$ NEEDS TO READ COLOR DATA.
 
1427
  189         COLORS(I,NSTAR)=3.E33
 
1428
              GO TO 188
 
1429
      END IF
 
1430
C
 
1431
C   SET UP NEXT CATALOG FILE.
 
1432
       IF(HELP(CATFIL))THEN
 
1433
           CALL TV('If you made a mistake, you can re-start catalogs.')
 
1434
           CALL ASK('Do you want to re-do the star catalogs?',A)
 
1435
           IF (A.EQ.'Y') THEN
 
1436
               CALL TV('Re-enter catalog data.')
 
1437
               STDFIL=SAVFIL
 
1438
               GO TO 170
 
1439
           ELSE IF (A.EQ.'N') THEN
 
1440
C               go on.
 
1441
           ELSE
 
1442
               CALL TV('   ... ambiguous reply ...')
 
1443
               GOTO 188
 
1444
           END IF
 
1445
       END IF
 
1446
      STDFIL=CATFIL
 
1447
      GO TO 175
 
1448
C
 
1449
  190 NSTARS=NSTAR
 
1450
C
 
1451
C  CHECK INTERPOLATION TABLES:
 
1452
       IF(MOVING)THEN
 
1453
      EPHEM1=0.
 
1454
      EPHEM2=3.E33
 
1455
      I1=1
 
1456
  191 DO 192 I=I1,NSTARS
 
1457
      IF(EQUINX(I).NE.3.E33 .AND. EQUINX(I).GT.3.E3) GO TO 193
 
1458
  192 CONTINUE
 
1459
      GO TO 200
 
1460
C   HERE FOR MOVER.
 
1461
  193 STAR=STARS(I)
 
1462
      I1=I
 
1463
      I2=COLORS(MBM4,I)
 
1464
C    FIND LATEST START, FIRST END.
 
1465
      EPHEM1=MAX(EPHEM1,EQUINX(I1))
 
1466
      EPHEM2=MIN(EPHEM2,EQUINX(I2))
 
1467
      IF(I2.LT.I1+4) GO TO 199
 
1468
      CALL TV('Please check plots for jumps due to bad data.')
 
1469
C   PLOT RA(TIME).
 
1470
      J=0
 
1471
      DO 194 I=I1,I2
 
1472
      J=J+1
 
1473
      XS(J)=EQUINX(I)-EQUINX(I1)
 
1474
  194 YS(J)=RAS(I)-RAS(I1)
 
1475
      CARD='   R.A. of '//STAR
 
1476
      CALL TV(CARD)
 
1477
      CALL JD2DAT(EQUINX(I1)+2400000.,DAT)
 
1478
      WRITE(CARD,'(8X,''days from '',A30)')DAT
 
1479
      DO 196 K=1,2
 
1480
      CALL PLOT(J,XS,YS,'*')
 
1481
      CALL RTNCON(CARD,40)
 
1482
C    DEC(TIME).
 
1483
      J=0
 
1484
      DO 195 I=I1,I2
 
1485
      J=J+1
 
1486
  195 YS(J)=DECS(I)-DECS(I1)
 
1487
  196 CARD='   Dec.of '//STAR
 
1488
      CALL TV(CARD)
 
1489
C   PLOT ON SKY.
 
1490
      CALL PLOT(0,1.,0.,'I')
 
1491
      DO 197 J=1,40
 
1492
      DUM=EQUINX(I1)+J*(EQUINX(I2)-EQUINX(I1))/40.
 
1493
      CALL EPHEM(I1,DUM,COLORS,XS(J),YS(J))
 
1494
      IF(XS(J).LT.0.) XS(J)=XS(J)+TWOPI
 
1495
      XS(J)=XS(J)-RAS(I1)
 
1496
  197 YS(J)=YS(J)-DECS(I1)
 
1497
      CALL PLOT(40,XS,YS,'*')
 
1498
      J=INDEX(STAR//'     ','     ')
 
1499
      WRITE(CARD,'(5X,''PATH OF '',A,''ON SKY'')') STAR(:J)
 
1500
      CALL RTNCON(CARD,40)
 
1501
C    RESTORE NORMAL X-AXIS.
 
1502
      CALL PLOT(0,0.,0.,'I')
 
1503
  199 I1=I2+1
 
1504
      GO TO 191
 
1505
       END IF
 
1506
C
 
1507
C  MEASUREMENT TECHNIQUE.
 
1508
C
 
1509
  200 CONTINUE
 
1510
      PC=.FALSE.
 
1511
      DC=.FALSE.
 
1512
      CI=.FALSE.
 
1513
      CALL TV(' ')
 
1514
      CALL ASKFIL('What MIDAS table file describes the instrument?',
 
1515
     1             STDFIL)
 
1516
      IF (MATCH(STDFIL,'none') .OR. MATCH(STDFIL,'NONE')) GO TO 201
 
1517
      IF(INDEX(STDFIL,'.tbl').EQ.0) THEN
 
1518
          I=LWORD(STDFIL)
 
1519
          STDFIL(I+1:)='.tbl'
 
1520
      END IF
 
1521
C       Open instrument file:
 
1522
      INQUIRE (FILE=STDFIL,EXIST=FEXIST)
 
1523
      IF (FEXIST) THEN
 
1524
C       OK.
 
1525
      ELSE
 
1526
        CARD='The requested instrument table file '//STDFIL
 
1527
        CALL TV(CARD)
 
1528
        CALL TVN('is not available.  Please make sure all required')
 
1529
        CALL TVN('files are available in your current directory.')
 
1530
        CARD='Is '//STDFIL(:LWORD(STDFIL))//' the correct file name?'
 
1531
        CALL ASK(CARD,STDFIL)
 
1532
        IF (MATCH(STDFIL,'YES'))THEN
 
1533
            CALL STETER(200,'Missing instrument file')
 
1534
        ELSE
 
1535
            GO TO 200
 
1536
        END IF
 
1537
      END IF
 
1538
      CALL TBTOPN(STDFIL,1,  INST,ISTAT)
 
1539
      IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1540
     1          'Could not open instrument-description file.')
 
1541
      CALL TBIGET (INST,  NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT)
 
1542
      IF(ISTAT.NE.0) CALL TERROR(INST, 200,
 
1543
     1                    'Could not get basic table data.')
 
1544
      CALL STDRDC (INST, 'INSTNAM', 1, 1, 72,
 
1545
     1              NVALS, INSTNAM, IUNIT, NULLS, ISTAT)
 
1546
      IF(ISTAT.NE.0)THEN
 
1547
          CALL TV('Could not find INSTNAM descriptor.')
 
1548
          CALL TERROR(INST,200,'Please fix instrument table file.')
 
1549
      END IF
 
1550
      CALL TV('Instrument identification:')
 
1551
      CALL TV(INSTNAM)
 
1552
      CALL TVN(' ')
 
1553
      CALL STDRDC (INST, 'FILTSTAT', 1, 1, 9,
 
1554
     1              NVALS, FILTSTAT, IUNIT, NULLS, ISTAT)
 
1555
      IF(ISTAT.NE.0)THEN
 
1556
          CALL TV('Could not find FILTSTAT descriptor.')
 
1557
          CALL TERROR(INST,200,'Please fix instrument table file.')
 
1558
      END IF
 
1559
C
 
1560
C       Get required-column pointers:
 
1561
C
 
1562
      CALL TBLSER (INST, 'DET',  KDET, ISTAT)
 
1563
      IF (ISTAT.NE.0 .OR. KDET.EQ.-1)
 
1564
     1    CALL TERROR(INST,200,'Could not find column DET')
 
1565
      CALL TBLSER (INST, 'BAND',  KBAND, ISTAT)
 
1566
      IF (ISTAT.NE.0) CALL TERROR(INST,200,'Could not find column BAND')
 
1567
      CALL TBLSER (INST, 'DETNAME',  KDETNM, ISTAT)
 
1568
      IF(ISTAT.NE.0)CALLTERROR(INST,200,'Could not find column DETNAME')
 
1569
      CALL TBLSER (INST, 'NDET',  KNDET, ISTAT)
 
1570
      IF (ISTAT.NE.0) CALL TERROR(INST,200,'Could not find column NDET')
 
1571
      CALL TBLSER (INST, 'COOLING',  KCOOL, ISTAT)
 
1572
      IF(ISTAT.NE.0)CALLTERROR(INST,200,'Could not find column COOLING')
 
1573
C
 
1574
C     see if we need to check DARK:
 
1575
      CALL TBESRC (INST, KCOOL, 'REGULATED', 1, 12, 1,  NROW, ISTAT)
 
1576
      IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1577
     1                'Could not search COOLING column for "REGULATED"')
 
1578
      IF (NROW.GT.0) THEN
 
1579
          DARK=.FALSE.
 
1580
      ELSE
 
1581
          DARK=.TRUE.
 
1582
      END IF
 
1583
C
 
1584
C     see if we need to remind user about cooling:
 
1585
      CALL TBESRC (INST, KCOOL, 'NONE', 1, 12, 1,  NROW, ISTAT)
 
1586
      IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1587
     1                'Could not search COOLING column for "NONE"')
 
1588
      IF (NROW.GT.0) THEN
 
1589
          COOLED=.FALSE.
 
1590
      ELSE
 
1591
          COOLED=.TRUE.
 
1592
      END IF
 
1593
C
 
1594
      FUNK=.FALSE.
 
1595
      FCORN=.FALSE.
 
1596
C     see if we measure redleaks:
 
1597
      CALL TBLSER (INST, 'REDLEAK',  KRL, ISTAT)
 
1598
      IF (ISTAT.NE.0)
 
1599
     1       CALL TERROR(INST,200,'Could not find column REDLEAK')
 
1600
      CALL TBESRC (INST, KRL, 'MEASURED', 1, 3, 1,  NROW, ISTAT)
 
1601
      IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1602
     1                'Could not search REDLEAK column for "MEASURED"')
 
1603
      IF (NROW.GT.0) THEN
 
1604
C         see if we know RLTYPE:
 
1605
          CALL TBLSER (INST, 'RLTYPE',  KRLTYP, ISTAT)
 
1606
          IF (ISTAT.NE.0)
 
1607
     1       CALL TERROR(INST,200,'Could not find column RLTYPE')
 
1608
          CALL TBESRC (INST, KRLTYP, 'UNKNOWN', 1, 3, 1,  NROW, ISTAT)
 
1609
          IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1610
     1                'Could not search RLTYPE column for "UNKNOWN"')
 
1611
          IF (NROW.GT.0) THEN
 
1612
              FUNK=.TRUE.
 
1613
          END IF
 
1614
C         see if we know MAKER:
 
1615
          CALL TBLSER (INST, 'MAKER',  KRLTYP, ISTAT)
 
1616
          IF (ISTAT.NE.0)
 
1617
     1       CALL TERROR(INST,200,'Could not find column MAKER')
 
1618
          CALL TBESRC (INST, KRLTYP, 'UNKNOWN', 1, 3, 1,  NROW, ISTAT)
 
1619
          IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1620
     1                'Could not search MAKER column for "UNKNOWN"')
 
1621
          IF (NROW.GT.0) THEN
 
1622
              FCORN=.TRUE.
 
1623
          END IF
 
1624
      END IF
 
1625
C
 
1626
C
 
1627
C       Look at detectors:
 
1628
C
 
1629
C     see if PMT is used:
 
1630
      CALL TBESRC (INST, KDET, 'PMT', 1, 3, 1,  NROW, ISTAT)
 
1631
      IF(ISTAT.NE.0) CALL TERROR(INST,200,
 
1632
     1                       'Could not search DET column for "PMT"')
 
1633
      IF(NROW.GT.0) THEN
 
1634
C         get mode:
 
1635
          CALL TBLSER (INST, 'MODE',  KMODE, ISTAT)
 
1636
          IF(ISTAT.NE.0 .OR. KMODE.EQ.-1)THEN
 
1637
              CALL TV('Could not find MODE column.')
 
1638
              CALL TERROR(INST,200,'Please fix instrument table file.')
 
1639
          END IF
 
1640
          CALL TBERDC (INST, NROW, KMODE, CTEST, NULL, ISTAT)
 
1641
          IF(ISTAT.NE.0 .OR. NULL)
 
1642
     1        CALL TERROR(INST,200,'Could not read MODE column.')
 
1643
          CALL FT_EOS (CTEST,32,DMS,ISTAT)
 
1644
C         DMS now holds mode.
 
1645
          IF (DMS(:2).EQ.'PC') THEN
 
1646
C               Pulse-counting.  Get dead-time:
 
1647
              CALL TBLSER (INST, 'DEADTIME',  KDEDT, ISTAT)
 
1648
              IF(ISTAT.NE.0 .OR. KDEDT.EQ.-1)THEN
 
1649
                  CALL TV('Could not find DEADTIME column.')
 
1650
                  CALL TERROR(INST,200,
 
1651
     1                      'Please fix instrument table file.')
 
1652
              END IF
 
1653
              CALL TBERDR (INST, NROW, KDEDT,  DEADT, NULL, ISTAT)
 
1654
              IF(ISTAT.NE.0 .OR. NULL)
 
1655
     1            CALLTERROR(INST,200,'Could not read DEADTIME column.')
 
1656
C              nd deadtime error:
 
1657
              CALL TBLSER (INST, 'DEADTIMEERROR',  KDEDER, ISTAT)
 
1658
              IF(ISTAT.NE.0 .OR. KDEDER.EQ.-1)THEN
 
1659
                  CALL TV('Could not find DEADTIMEERROR column.')
 
1660
                  CALL TERROR(INST,200,
 
1661
     1                      'Please fix instrument table file.')
 
1662
              END IF
 
1663
              CALL TBERDR (INST, NROW, KDEDER,  SDEDT, NULL, ISTAT)
 
1664
              IF(ISTAT.NE.0 .OR. NULL)
 
1665
     1            CALL TERROR(INST,200,
 
1666
     2            'Could not read DEADTIMEERROR column.')
 
1667
              PC=.TRUE.
 
1668
              MTYPE=1
 
1669
              GOTO 212
 
1670
          ELSE IF (DMS(:2).EQ.'DC') THEN
 
1671
C               PMT, DC.
 
1672
              CALL TBTCLO(INST, ISTAT)
 
1673
              GO TO 220
 
1674
          ELSE IF (DMS(:2).EQ.'CI') THEN
 
1675
C               PMT, CI.
 
1676
              CALL TBTCLO(INST, ISTAT)
 
1677
              GO TO 222
 
1678
          ELSE
 
1679
              MTYPE=0
 
1680
              CALL TV('Mode of operation not given in table file.')
 
1681
          END IF
 
1682
C
 
1683
      END IF
 
1684
      CALL TBTCLO(INST, ISTAT)
 
1685
  201 IF(MTYPE.NE.0) GOTO 265
 
1686
      CALL TV(' ')
 
1687
      CALLASK('Are data Pulse Counts, DC, Charge Integration, or mixed?'
 
1688
     1,A)
 
1689
      IF(MATCH(A,'P')) GO TO 204
 
1690
      IF(MATCH(A,'D')) GO TO 220
 
1691
      IF(MATCH(A,'C')) GO TO 222
 
1692
      IF(MATCH(A,'M')) GO TO 240
 
1693
      GO TO 201
 
1694
C
 
1695
C  PULSE COUNTS.
 
1696
C
 
1697
  204 MTYPE=1
 
1698
      IF(DEDSET)GO TO 213
 
1699
  205 CALL ASK('Do you know the Dead Time (ns)?',DMS)
 
1700
      PC=.TRUE.
 
1701
       IF(MATCH(DMS,'NO'))THEN
 
1702
      CALL TV(ASSUME(2))
 
1703
      NASSMP=NASSMP+1
 
1704
      ASSMPS(NASSMP)=ASSUME(2)
 
1705
      WRITE(PAGE,
 
1706
     1'(/''  Keep rate below'',F3.0,''MHz to avoid gain shift.'')')
 
1707
     2  SIGTOT/.0016
 
1708
      CALL TV(PAGE(2))
 
1709
      DEADT=16.
 
1710
      SDEDT=DEADT
 
1711
      GO TO 211
 
1712
       END IF
 
1713
      IF(MATCH(DMS,'YES')) CALL ASK('Dead time (nanoseconds) =',DMS)
 
1714
  210 CALL FINDPM(DMS,DEADT,SDEDT)
 
1715
      WRITE(PAGE,'(/'' Dead time ='',F6.1,'' +/-'',F6.1,'' ns'')')DEADT,
 
1716
     1SDEDT
 
1717
      CALL TV(PAGE(2))
 
1718
      CALL ASK('OK?',A)
 
1719
      IF(MATCH(A,'N'))GOTO 205
 
1720
  211 SDEDT=SDEDT*1.E-9
 
1721
      DEADT=DEADT*1.E-9
 
1722
  212 DEDSET=.TRUE.
 
1723
      IF(DEADT.EQ.0. .OR. SDEDT.EQ.0.)GOTO 210
 
1724
C
 
1725
      IF(SDEDT/DEADT.GT.0.1)THEN
 
1726
C         allow D.T.corrections to be 10 x precision.
 
1727
          NASSMP=NASSMP+1
 
1728
          ASSMPS(NASSMP)=ASSUME(3)
 
1729
          CALL TV(ASSUME(3))
 
1730
          SDEDT=0.1*DEADT
 
1731
          NEEDED=.TRUE.
 
1732
          CALL TV(' EXTRA STARS will be added to allow improvement.')
 
1733
      END IF
 
1734
C
 
1735
  213 CALL TV(
 
1736
     1  'Uncertainty of dead-time correction = half of total error at:')
 
1737
      NEEDIM=.FALSE.
 
1738
      RATE=1./(SIGSQ*TINT1)
 
1739
      DO 215 NB=1,NBANDS
 
1740
        BRITES(NB)=PHOMAG(NB)-2.5*LOG10(SIGTOT/(2.*SDEDT*RATE))
 
1741
C       count rate at phomag is 'RATE'.
 
1742
        WRITE(PAGE,214)BRITES(NB),BANDS(NB)
 
1743
  214   FORMAT(/3X,F5.1,' IN ',A6)
 
1744
        CALL TV(PAGE(2))
 
1745
        IF(BRITES(NB).GT.FAINTS(NB) .AND. .NOT.DC)THEN
 
1746
          CALL TV('TOO MANY PHOTONS -- You need an optical attenuator.')
 
1747
          NEEDIM=.TRUE.
 
1748
        END IF
 
1749
  215 CONTINUE
 
1750
      IF(DC) GO TO 265
 
1751
      IF(NEEDIM)GO TO 217
 
1752
  216 CALL ASK('No BRIGHTER stars will be used.  OK?',A)
 
1753
      IF(MATCH(A,'Y') .OR. MATCH(A,'O')) GO TO 265
 
1754
C
 
1755
C    Ask for dimmer & return to 216 after revising BRITES.
 
1756
  217 CALL BRITEN(BANDS,DIMMED)
 
1757
C    here if revision failed, or not needed.
 
1758
      IF(DIMMED .OR. .NOT.NEEDIM)GO TO 216
 
1759
C
 
1760
        WRITE(ASSMPS(8),'(''Requested precision is'',F6.3,'' mag.'')')
 
1761
     1  SIGTOT
 
1762
        CALL TV(ASSMPS(8))
 
1763
      CALL ASK('Will you accept larger errors?',A)
 
1764
      MTYPE=0
 
1765
      NEEDH=NEEDH-1
 
1766
      IF(MATCH(A,'Y') .OR. MATCH(A,'O'))GO TO 128
 
1767
      CALL TV('You require a SMALLER TELESCOPE, or a DC photometer.')
 
1768
      NASSMP=0
 
1769
      CALL TVN(' ')
 
1770
      CALL TV('Starting over...')
 
1771
      GO TO 51
 
1772
C
 
1773
C  DC.
 
1774
  220 MTYPE=2
 
1775
      DC=.TRUE.
 
1776
      CALL TV(
 
1777
     1'  Use double integrations to allow for chart-reading error.')
 
1778
      GO TO 265
 
1779
C
 
1780
C  CHARGE INTEGRATION.
 
1781
  222 MTYPE=3
 
1782
      CI=.TRUE.
 
1783
C   READ GAINS.
 
1784
      GO TO 265
 
1785
C
 
1786
C  MIXED.
 
1787
  240 MTYPE=4
 
1788
      DC=.TRUE.
 
1789
      CALL ASK('Any Pulse-Counting?',A)
 
1790
      IF(MATCH(A,'Y'))GO TO 205
 
1791
C  MTYPE=5 IF NO PC.
 
1792
      MTYPE=5
 
1793
      CI=.TRUE.
 
1794
C
 
1795
C       Time scale?
 
1796
C
 
1797
  265 CALL ASK('Do you want UT, Zone Time, or Local Sidereal Time?',A)
 
1798
C              ITIME =      1       2              3
 
1799
      ITIME=0
 
1800
      ZONE=0.
 
1801
C
 
1802
       IF(MATCH(A,'U')) THEN
 
1803
      ITIME=1
 
1804
      TL='U.T.'
 
1805
       ELSE IF(MATCH(A,'Z')) THEN
 
1806
C   ZONE TIME.
 
1807
      ITIME=2
 
1808
      CALL ASK('Name of Time Zone?  (MST, PDT,...-- 4 letters max.)',TL)
 
1809
      CALL QF('What U.T. is Zero hours Zone Time?',ZONE)
 
1810
C    UT = STD.time + Zone; convert to rotations.
 
1811
      ZONE=ZONE/24.
 
1812
       ELSE IF(MATCH(A,'L') .OR. MATCH(A,'S')) THEN
 
1813
C   LST.
 
1814
      ITIME=3
 
1815
      TL='LST'
 
1816
       ELSE
 
1817
      GO TO 265
 
1818
       END IF
 
1819
C
 
1820
      TEMPRH(29:32)=TL
 
1821
C
 
1822
C       Names or codes?
 
1823
C
 
1824
  270 CALL TV('Will your data files identify stars by')
 
1825
      CALL ASKN('Full Names, or Codes?',A)
 
1826
      CODEDS=.FALSE.
 
1827
C
 
1828
      IF(MATCH(A,'C')) THEN
 
1829
         CODEDS=.TRUE.
 
1830
  275    CALL QF('How many digits in your star code?',DUM)
 
1831
         NDIG=DUM
 
1832
         IF(NDIG.LT.1 .OR. NDIG.GT.6)THEN
 
1833
             CALL TV('Sorry, PEPSYS uses only 1 to 6.')
 
1834
             GO TO 275
 
1835
         END IF
 
1836
         WRITE(F361(5:5),'(I1)')NDIG
 
1837
      ELSE IF(A.EQ.'F' .OR. A.EQ.'N')THEN
 
1838
C        no action needed.
 
1839
      ELSE
 
1840
         CALL TV(
 
1841
     1       'If your data system uses numerical labels, say "Codes".')
 
1842
         GO TO 270
 
1843
      END IF
 
1844
C
 
1845
C   DATE:
 
1846
C
 
1847
       IF(MOVING)THEN
 
1848
      CALL JD2DAT(2400000.+EPHEM1,DATSTR)
 
1849
      CALL JD2DAT(2400000.+EPHEM2,MONTH)
 
1850
      WRITE(PAGE,'(/4X,''Ephemeris data span only '',A11,'' to '',A11)')
 
1851
     1 DATSTR,MONTH
 
1852
      CALL TV(PAGE(2))
 
1853
       END IF
 
1854
C
 
1855
      CALL TVN(' ')
 
1856
      CALL TV('Enter dates (please spell month name):')
 
1857
      IF(NEEDH.GT.2)CALL TV('  Use double date  -  e.g., May 8/9, 1986')
 
1858
C
 
1859
  305 DO 320 N=1,2
 
1860
  311 PAGE(1)='Enter '//FL(N)//' date of run:'
 
1861
      CALL ASK(PAGE(1),CARD)
 
1862
      IF(N.EQ.2 .AND. CARD.EQ.'SAME') GO TO 315
 
1863
      CALL MDY(CARD,MON,DDAY,YR)
 
1864
      IF(YR.EQ.0.)THEN
 
1865
         IF(N.EQ.2)THEN
 
1866
C           user forgot year on 2nd date:
 
1867
            YR=OLDYR
 
1868
         ELSE
 
1869
            CALL QF('Year?',YR)
 
1870
         END IF
 
1871
      END IF
 
1872
      IF(YR.LT.100.)YR=YR+1900.
 
1873
      OLDYR=YR
 
1874
      CALL TV('   Night begins on')
 
1875
      WRITE(PAGE,'(4X,A3,I3,'','',I5)')MON,INT(DDAY),INT(YR)
 
1876
      CALL TVN(PAGE(1))
 
1877
      IF(DDAY.GT.33.)GOTO 313
 
1878
      DDAY=DDAY+1.
 
1879
C    NEAREST UT DATE TO LOCAL MIDNIGHT.
 
1880
      M=MON2M(MON)
 
1881
      IF(M.GT.0)GO TO 315
 
1882
      WRITE(PAGE,*)MON,' is not the name of a month.'
 
1883
      CALL TVN(PAGE(1))
 
1884
  313 CALL TV('  Please correct DATE:')
 
1885
      GO TO 311
 
1886
C  J.D.: SEE SKY & TEL.61,312 (1981).
 
1887
  315 Y=YR
 
1888
      IF(M.GT.2)GO TO 316
 
1889
      M=M+12
 
1890
      Y=Y-1
 
1891
  316 DJ=AINT(365.25*Y) + AINT(30.6001*(M+1)) + DDAY + 1720981.5D0
 
1892
  320 DJS(N)=DJ
 
1893
C
 
1894
       IF(DJS(2).LT.DJS(1))THEN
 
1895
          CALL TV('Days are in wrong order.')
 
1896
          GO TO 305
 
1897
       ELSE IF(DJS(2)-DJS(1).GT.10.)THEN
 
1898
          WRITE(PAGE,'(/F8.0,'' day interval'')')DJS(2)-DJS(1)
 
1899
          CALL TV(PAGE(2))
 
1900
          CALL TV('Please keep interval less than 1 week.')
 
1901
          GO TO 305
 
1902
       END IF
 
1903
C
 
1904
       CALL PLANBOT(DJS,LASTD,NSTARS,NEEDST,JSYS,DRAT,BANDS,SALTS,
 
1905
     1 PLACE(:20),TELCM,TL,ITIME,ZONE)
 
1906
C
 
1907
        END