← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/pepsys/src/danish.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/danish.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 DANISH
 
29
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.IDENT         danish.for
 
31
C.MODULE
 
32
C.AUTHOR        Andrew T. Young
 
33
C.KEYWORD
 
34
C.LANGUAGE      FORTRAN 77
 
35
C.PURPOSE       convert Danish photometric data files to uniform ascii
 
36
C.COMMENTS
 
37
C.VERSION       5.2    ATY  April 21, 1993
 
38
C 
 
39
C 100621        last modif
 
40
C-----------------------------------------------------------------------------
 
41
C*****************************************************************************
 
42
C
 
43
C       This program reads data recorded in intermixed formats and combines
 
44
C       them into a uniform format, in the file 'data.dat' that is converted
 
45
C       into a MIDAS table-format file, using the *.fmt file 'data.fmt'.
 
46
C
 
47
C       The version you see here is designed to convert data from the Danish
 
48
C       0.5-meter telescope.  Data codes are in col. 1.
 
49
C       These codes are read and decoded at statements 110-190 in the main
 
50
C       program.
 
51
C
 
52
C       The basic method is to load the data as they are read from different
 
53
C       types of cards into the COMMON blocks /OUTR/ and /OUTC/, which hold
 
54
C       real and character variables, respectively.  (Some compilers want you
 
55
C       to keep such blocks separate.)  When enough card images have been read
 
56
C       to make a complete observation, the contents of /OUT*/ are written to
 
57
C       the uniform-format file 'data.dat'; then the common blocks are cleared,
 
58
C       to the appropriate "null" values.  (Blanks are used to clear character
 
59
C       strings.)
 
60
C
 
61
C       The MIDAS command CREATE/TABLE can then be used, with the *.fmt file
 
62
C       supplied, to convert the uniform 'data.dat' file to MIDAS table format.
 
63
C       This is done in the command CONVERT/PHOT.
 
64
C
 
65
C       As this is based on the esodcon program, it probably contains fossils.
 
66
C
 
67
C
 
68
C*****************************************************************************
 
69
C
 
70
        IMPLICIT NONE
 
71
C
 
72
C  BEGIN Declarations:
 
73
C
 
74
        DOUBLE PRECISION DJD, OLDMJD
 
75
C
 
76
        REAL DIAM, ELONG, PHI
 
77
C
 
78
        INTEGER INULL
 
79
        REAL RNULL
 
80
        DOUBLE PRECISION DNULL
 
81
        COMMON /NULLS/ INULL, RNULL, DNULL
 
82
C
 
83
        INTEGER NDATA, NOUTP
 
84
C
 
85
        INTEGER NREC,NRECOLD
 
86
C
 
87
        INTEGER NBAD(4)
 
88
        REAL RELERR(4),COUNT(4)
 
89
C
 
90
        CHARACTER*80 LINE(2), DATFIL
 
91
        COMMON /LINES/LINE
 
92
        INTEGER LENBUF, NOW
 
93
        COMMON /BUF/LENBUF, NOW
 
94
C
 
95
        INTEGER ITBL, ISTAT, NCOLS, NROWS, NSORTC, NWPRAL, 
 
96
     1         NROWSAL, NCOL, NCDIAM, NROW, I, NBANDS, J, LWORD, K, K2
 
97
C
 
98
        CHARACTER A*1, CODE*2, END*1, STATUS*7
 
99
        CHARACTER*10 LSTSTR,OLDLST
 
100
        CHARACTER*32 COM1,COM2,COM3
 
101
C 
 
102
        CHARACTER*32  CTEST
 
103
C
 
104
        CHARACTER BNDCOD(6),BNAME(6)*5,CODES(4)
 
105
C
 
106
        LOGICAL MATCH
 
107
        LOGICAL EFLAG
 
108
C
 
109
C
 
110
C       Declarations for the output (must be in WRITER too!):
 
111
C
 
112
        DOUBLE PRECISION MJDOBS
 
113
        REAL SIGNAL,EXPTIME,ESTERR
 
114
        COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS,ESTERR
 
115
        CHARACTER OBJECT*9,STARSKY*4,BAND*8,COMMENT*32,DIAPH
 
116
        COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT,DIAPH
 
117
C
 
118
C  Set up MIDAS declarations:
 
119
C
 
120
        INTEGER MADRID(1)
 
121
C
 
122
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
123
C
 
124
        COMMON /VMR/ MADRID
 
125
C
 
126
        INTEGER NACTEL, IUNIT, NULLS
 
127
C
 
128
C  END Declarations.
 
129
C
 
130
C
 
131
C  BEGIN DATA statements:
 
132
C
 
133
        INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
134
C
 
135
        DATA NDATA/7/, NOUTP/8/
 
136
C
 
137
        DATA BNDCOD/'U', 'V', 'B', 'Y',   'W',    'N'/
 
138
        DATA BNAME /'u', 'v', 'b', 'y', 'betaW','betaN'/
 
139
C
 
140
C
 
141
C  END DATA statements.
 
142
C
 
143
C
 
144
C  ********************  PROLOGUE  ********************
 
145
C
 
146
        CALL STSPRO ('DANISH')
 
147
C
 
148
C       Because the Sun library barfs on -Inf (which is used as NULL
 
149
C       by MIDAS), I define my own "NULL" values here as 3.e33:
 
150
C
 
151
        RNULL=3.E33
 
152
        DNULL=3.D33
 
153
C
 
154
C  Real program begins here:            (use RUN DANISH to test in MIDAS)
 
155
C
 
156
C
 
157
        INQUIRE(FILE='data.dat',EXIST=EFLAG)
 
158
        IF (EFLAG) THEN
 
159
                CALL TV('File "data.dat" already exists!')
 
160
    1           CALL ASK ('Do you want to write over it?? ',A)
 
161
                IF (MATCH(A,'Y')) THEN
 
162
                        OPEN(NOUTP,FILE='data.dat',STATUS='UNKNOWN')
 
163
                        REWIND NOUTP
 
164
C                       Make sure it gets truncated to zero length.
 
165
                        CLOSE (NOUTP,STATUS='DELETE')
 
166
                ELSE IF (MATCH(A,'N')) THEN
 
167
                        CALL STETER(1,
 
168
     1                  'Please move "data.dat" to a new name.')
 
169
                ELSE
 
170
                        CALL TV('Please reply "yes" or "no".')
 
171
                        GO TO 1
 
172
                END IF
 
173
         END IF
 
174
C               Open the uniform-format ascii file:
 
175
        OPEN(NOUTP,FILE='data.dat',STATUS='UNKNOWN')
 
176
        REWIND NOUTP
 
177
C
 
178
C       Find telescope coordinates:
 
179
C
 
180
        INQUIRE (FILE='esotel.tbl', EXIST=EFLAG)
 
181
        IF (EFLAG) THEN
 
182
                CALL TBTOPN ('esotel.tbl', 0,  ITBL, ISTAT)
 
183
                IF (ISTAT.NE.0) THEN
 
184
                        CALL TV('Problem opening "esotel.tbl".')
 
185
                        CALL STETER(2,'Do you have read permission?')
 
186
                END IF
 
187
                CALL TBIGET (ITBL,
 
188
     1                    NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT)
 
189
                CALL TBLSER (ITBL, 'TELESCOP',  NCOL, ISTAT)
 
190
                CALL TBLSER (ITBL, 'DIAM',  NCDIAM, ISTAT)
 
191
                CALL TV(' ')
 
192
                CALL TV ('Which telescope did you use?')
 
193
                DO 2 NROW=1,NROWS
 
194
                CALL TBERDC (ITBL, NROW, NCOL, CTEST, EFLAG, ISTAT)
 
195
                CALL FT_EOS (CTEST,32,COM2,ISTAT)
 
196
                IF (EFLAG.OR. ISTAT.NE.0) GOTO 2
 
197
                CALL TBERDR (ITBL, NROW, NCDIAM,  DIAM, EFLAG, ISTAT)
 
198
                IF (EFLAG.OR. ISTAT.NE.0) GOTO 2
 
199
                WRITE (COM1,'(8X,I2,'':  '',A8,F6.2,'' m'')')
 
200
     1                              NROW,COM2,DIAM
 
201
                CALL TV (COM1)
 
202
    2           CONTINUE
 
203
                WRITE(COM1,'(8X,I2,'':  (None of these)'')') NROWS+1
 
204
                CALL TV(COM1)
 
205
                CALL ASK ('Please enter the number: ',COM1)
 
206
    3           READ (COM1,'(BN,I2)', ERR=4) NROW
 
207
                IF (NROW.LE.NROWS .AND. NROW.GE.1) THEN
 
208
                       CALL TBERDC (ITBL,NROW,NCOL,CTEST,EFLAG,ISTAT)
 
209
                       CALL FT_EOS (CTEST,32,COM2,ISTAT)
 
210
                ELSE
 
211
                        COM2='"none"'
 
212
                END IF
 
213
                GO TO 6
 
214
C
 
215
C               Bad row number:
 
216
    4           DO 5 NROW=1,NROWS
 
217
                CALL TBERDC (ITBL, NROW, NCOL,CTEST, EFLAG, ISTAT)
 
218
                CALL FT_EOS (CTEST,32,COM2,ISTAT)
 
219
                IF (COM1.EQ.COM2) THEN
 
220
                        GO TO 6
 
221
                END IF
 
222
    5           CONTINUE
 
223
                CALL ASK ('Please use the numbers at left.',COM1)
 
224
                GO TO 3
 
225
C
 
226
    6           WRITE(COM1,'(''   You selected '',A8)') COM2
 
227
                CALL TV (COM1)
 
228
C
 
229
                IF (INDEX(COM2,'DAN').NE.1) THEN
 
230
                   CALL TV('Not a Danish telescope.  Please try again.')
 
231
                   GO TO 3
 
232
                END IF
 
233
C
 
234
                IF (NROW.LE.NROWS .AND. NROW.GE.1) THEN
 
235
                        CALL TBLSER (ITBL, 'LON',  NCOL, ISTAT)
 
236
                        CALL TBERDR (ITBL,NROW,NCOL, ELONG,EFLAG,ISTAT)
 
237
                        IF(EFLAG.OR. ISTAT.NE.0) THEN
 
238
                            CALL QF('Enter EAST longitude (deg):',
 
239
     1                                 ELONG)
 
240
                        END IF
 
241
                        CALL TBLSER (ITBL, 'LAT',  NCOL, ISTAT)
 
242
                        CALL TBERDR (ITBL,NROW,NCOL, PHI,EFLAG,ISTAT)
 
243
                        IF(EFLAG.OR. ISTAT.NE.0) THEN
 
244
                             CALL QF('Enter Latitude (deg):', PHI)
 
245
                        END IF
 
246
                ELSE
 
247
                        CALL QF('Enter EAST longitude (deg):', ELONG)
 
248
                        CALL QF('Enter Latitude (deg):', PHI)
 
249
                END IF
 
250
                ELONG=ELONG/15.
 
251
                CALL TBTCLO(ITBL, ISTAT)
 
252
        ELSE
 
253
                CALL TV('File "esotel.tbl" not available!')
 
254
                CALL STETER(6,'Please get a copy of "esotel.tbl"')
 
255
        END IF
 
256
C
 
257
C
 
258
C       clear data storage:
 
259
C
 
260
        OBJECT=' '
 
261
        STARSKY=' '
 
262
        BAND=' '
 
263
        DIAPH=' '
 
264
        COMMENT=' '
 
265
        SIGNAL=RNULL
 
266
        ESTERR=RNULL
 
267
        EXPTIME=RNULL
 
268
        MJDOBS=DNULL
 
269
C
 
270
C       *** Prepare input buffer ***
 
271
C
 
272
        CALL TV(' ')
 
273
    7   Call STKRDC ('RAWDAT',1,1,80,  NACTEL,DATFIL,IUNIT,NULLS,ISTAT)
 
274
C   7   CALL ASKFIL('What is the name of the file of observed data?',
 
275
C    1                  DATFIL)
 
276
        INQUIRE(FILE=DATFIL,EXIST=EFLAG)
 
277
        IF (.NOT.EFLAG) THEN
 
278
                CALL TV('No such file exists!')
 
279
                CALL TVN('Please try again:')
 
280
                GO TO 7
 
281
        END IF
 
282
        OPEN(NDATA,FILE=DATFIL,STATUS='UNKNOWN')
 
283
        REWIND NDATA
 
284
        CALL TV('Converting data...')
 
285
C
 
286
        OLDMJD=0.
 
287
        NRECOLD=0
 
288
        OLDLST=' '
 
289
C
 
290
C       Read data.
 
291
C
 
292
  110   READ (7,'(A80)',END=200) LINE(1),LINE(2)
 
293
C
 
294
C
 
295
C           Start reading first card:
 
296
            A=LINE(1)(:1)
 
297
            IF (A.EQ.'c') GO TO 112
 
298
            READ (LINE(1),111,ERR=301) A,NREC,DJD,LSTSTR,STATUS
 
299
  111       FORMAT(A1,I4,F12.5,2(1X,A7))
 
300
C           Convert Danish MJD to real JD.
 
301
            DJD=DJD+2440000.D0
 
302
C           Convert real JD to MJD.
 
303
            MJDOBS=DJD-2400000.5D0
 
304
C           Check that times are in order.
 
305
            IF (MJDOBS.LT.OLDMJD .OR. NREC.LT.NRECOLD .OR.
 
306
     1                (LSTSTR.LT.OLDLST .AND. LSTSTR(:2).NE.'00')) THEN
 
307
               CALL SPACE2
 
308
               CALL TV('     Sequence error:')
 
309
               CALL TV('Record    Danish JD      LST')
 
310
               CALL TVN('------   -----------   -------')
 
311
               WRITE(DATFIL,'(I4,5X,F11.5,3X,A)')
 
312
     1                      NRECOLD,OLDMJD-39999.5,OLDLST
 
313
               IF (DATFIL(10:10).EQ.' ') DATFIL(10:10)='0'
 
314
               CALL TVN(DATFIL)
 
315
               CALL TV('    is followed by')
 
316
               WRITE(DATFIL,'(I4,5X,F11.5,3X,A)')
 
317
     1                      NREC,MJDOBS-39999.5,LSTSTR
 
318
               IF (DATFIL(10:10).EQ.' ') DATFIL(10:10)='0'
 
319
               CALL TV(DATFIL)
 
320
C
 
321
               I=0
 
322
               CALL SPACE2
 
323
               IF (NREC.LT.NRECOLD) THEN
 
324
                  CALL TVN('     RECORD numbers out of order')
 
325
                  I=1
 
326
               END IF
 
327
C
 
328
               IF (MJDOBS.LT.OLDMJD) THEN
 
329
                  CALL TVN('     JDs out of order')
 
330
                  I=2
 
331
               END IF
 
332
C
 
333
               IF (LSTSTR.LT.OLDLST .AND. LSTSTR(:2).NE.'00' .AND.
 
334
     1                      OLDLST(:2).NE.'23') THEN
 
335
                  CALL TVN('     LSTs out of order')
 
336
                  I=4
 
337
               END IF
 
338
C
 
339
               IF (I.EQ.1)THEN
 
340
                  CALL TV('Bad record number?')
 
341
               ELSE IF (I.EQ.2) THEN
 
342
                  CALL TV('JD is probably wrong; others are in order.')
 
343
               ELSE IF (I.EQ.4) THEN
 
344
                  CALL TV('LST is probably wrong; others are in order.')
 
345
               END IF
 
346
            END IF
 
347
            OLDMJD=MJDOBS
 
348
            NRECOLD=NREC
 
349
            OLDLST=LSTSTR
 
350
C
 
351
            DIAPH=STATUS(2:2)
 
352
C
 
353
C
 
354
  112       IF (A.EQ.'s') THEN
 
355
C
 
356
C                       s: measurement
 
357
C
 
358
C               Finish reading first card:
 
359
                READ(LINE(1),113,ERR=392)EXPTIME,OBJECT,CODE
 
360
  113           FORMAT(40X,F3.0,1X,A9,1X,A2)
 
361
                IF (EXPTIME.EQ.0.) THEN
 
362
                   DATFIL='ZERO exposure time at MJDOBS ='
 
363
                   WRITE(DATFIL(31:),'(F12.5)') MJDOBS
 
364
                   CALL TV(DATFIL)
 
365
                   CALL TVN('   Observation rejected.')
 
366
                   GO TO 110
 
367
                END IF
 
368
C               convert MJDOBS from end to start of exposure.
 
369
                MJDOBS=MJDOBS-EXPTIME/86400.
 
370
C
 
371
C               Interpret second card:
 
372
                IF (STATUS(:1).EQ.'U')THEN
 
373
C                   uvby data:
 
374
                    READ(LINE(2),114,ERR=393)
 
375
     1                 (CODES(I),COUNT(I),RELERR(I),NBAD(I),I=1,4),END
 
376
  114               FORMAT(4(A1,F9.0,1X,F4.4,I3,1X),A1)
 
377
                    NBANDS=4
 
378
                ELSE IF (STATUS(:1).EQ.'H')THEN
 
379
C                   H-beta data:
 
380
                    READ(LINE(2),115,ERR=394)
 
381
     1                 (CODES(I),COUNT(I),RELERR(I),NBAD(I),I=1,2),END
 
382
  115               FORMAT(2(A1,F9.0,1X,F4.4,I3,1X),38X,A1)
 
383
                    IF (END.NE.'e') THEN
 
384
                       I=LWORD(LINE(2))
 
385
                       END=LINE(2)(I:I)
 
386
                    END IF
 
387
                    NBANDS=2
 
388
                ELSE
 
389
C                   unknown data:
 
390
                    CALL TV('Unknown data:')
 
391
                    CALL TV(LINE(1))
 
392
                    CALL TVN(LINE(2))
 
393
                    CALL SPACE
 
394
                    GO TO 399
 
395
                END IF
 
396
C
 
397
                IF (END.NE.'e') GO TO 395
 
398
C
 
399
C               Convert STAR/SKY flag to standard strings.
 
400
                IF (CODE.EQ.'*0') THEN
 
401
                        STARSKY='STAR'
 
402
                ELSE IF (CODE.EQ.'B0') THEN
 
403
                        STARSKY='SKY'
 
404
                ELSE
 
405
                        CALL TV(CODE)
 
406
                        CALL TV('Unexpected code in STAR/SKY column:')
 
407
                        CALL TV(LINE(1))
 
408
                        CALL TVN(LINE(2))
 
409
                        CALL SPACE
 
410
                        CALL STETER(118,'Fix data and try again.')
 
411
                END IF
 
412
C
 
413
C               Loop over bands:
 
414
C
 
415
                DO 150 I=1,NBANDS
 
416
C                  Convert band codes to band names:
 
417
                   DO 120 J=1,6
 
418
                      IF (CODES(I).EQ.BNDCOD(J)) THEN
 
419
                         BAND=BNAME(J)
 
420
                         GO TO 121
 
421
                      END IF
 
422
  120              CONTINUE
 
423
C
 
424
                   CALL TV('Non-standard band name!')
 
425
                   GO TO 399
 
426
C
 
427
  121              CONTINUE
 
428
C
 
429
                   IF (STATUS(3:3).EQ.'1') THEN
 
430
C                       OPEN position.  Go on.
 
431
                   ELSE IF (STATUS(3:3).EQ.'2') THEN
 
432
C                       CLOSED position.  Set to DARKn.
 
433
                        BAND='DARK'
 
434
                        WRITE(BAND(5:5),'(I1)') J
 
435
                   ELSE IF (STATUS(3:3).EQ.'3') THEN
 
436
C                       ND=1 position.  Append ND1.
 
437
                        BAND(LWORD(BAND)+1:)='ND1'
 
438
                   ELSE
 
439
                        DATFIL='Undefined shutter code (status(3:3)):'
 
440
                        DATFIL(39:39)=STATUS(3:3)
 
441
                        CALL TV(DATFIL)
 
442
                        CALL TV(LINE(1))
 
443
                        CALL TVN(LINE(2))
 
444
                        CALL ASK(
 
445
     1                       'Ignore this observation and continue?',A)
 
446
                        IF (A.EQ.'Y' .OR. A.EQ.'O')THEN
 
447
C                           Clear data & look for next observation.
 
448
                            GO TO 160
 
449
                        ELSE
 
450
                            CALL TV('Program cannot continue.')
 
451
                            CALLSTETER(122,'Fix data and try again.')
 
452
                        END IF
 
453
                   END IF
 
454
C
 
455
C                  Check for v & b neutral-density filters:
 
456
                   IF ((J.EQ.2 .OR. J.EQ.3) .AND.
 
457
     1                       STATUS(4:4).EQ.'G') THEN
 
458
                        IF (BAND(2:3).EQ.'ND') THEN
 
459
C                           Both ND filters.
 
460
                             BAND(4:4)='3'
 
461
                        ELSE
 
462
C                           Only the vb filter.
 
463
                            BAND(4:4)='2'
 
464
                        END IF
 
465
                   END IF
 
466
C
 
467
C                  Check for viewing optics in the way:
 
468
                   IF (STATUS(6:6).EQ.'M' .OR. STATUS(7:7).EQ.'M') THEN
 
469
                      CALL SPACE2
 
470
                      IF (STATUS(6:6).EQ.'M') THEN
 
471
                         CALL TV('Field-viewing optics in the way.')
 
472
                      ELSE IF (STATUS(7:7).EQ.'M') THEN
 
473
                         CALL TV('Viewing microscope in the way.')
 
474
                      END IF
 
475
                      CALL TV(LINE(1))
 
476
                      CALL TVN(LINE(2))
 
477
                      CALL ASK('Do you want to use this as DARK?',A)
 
478
                      IF (A.EQ.'Y' .OR. A.EQ.'O') THEN
 
479
                         BAND='DARK'
 
480
                         DATFIL=COMMENT(:LWORD(COMMENT))//
 
481
     1                                      'Optics in beam'
 
482
                         COMMENT=DATFIL(:32)
 
483
                      ELSE
 
484
                         GO TO 160
 
485
                      END IF
 
486
                   END IF
 
487
C
 
488
                   SIGNAL=COUNT(I)
 
489
C                  RELERR was read as a fraction, not %.
 
490
                   ESTERR=RELERR(I)*SIGNAL
 
491
                   IF (SIGNAL.EQ.0.) SIGNAL=RNULL
 
492
                   IF (ESTERR.EQ.0.) ESTERR=RNULL
 
493
                   CALL WRITER
 
494
  150           CONTINUE
 
495
C
 
496
C               clear data arrays:
 
497
C
 
498
  160           OBJECT=' '
 
499
                STARSKY=' '
 
500
                BAND=' '
 
501
                COMMENT=' '
 
502
                EXPTIME=RNULL
 
503
                MJDOBS=DNULL
 
504
C
 
505
                GO TO 110
 
506
C
 
507
C
 
508
C
 
509
            ELSE IF (A.EQ.'c')THEN
 
510
C
 
511
C                       c: comment
 
512
C
 
513
C               Split up comment card cleanly if possible:
 
514
                DO 186 K=34,14,-1
 
515
                IF (LINE(2)(K:K).EQ.' ') GO TO 187
 
516
  186           CONTINUE
 
517
  187           DO 188 K2=K+32,K+12,-1
 
518
                IF (LINE(2)(K2:K2).EQ.' ') GO TO 189
 
519
  188           CONTINUE
 
520
  189           IF (LINE(2)(K2+32:).EQ.' ') THEN
 
521
                        COM1=LINE(2)(3:K)
 
522
                        COM2=LINE(2)(K+1:K2)
 
523
                        COM3=LINE(2)(K2+1:)
 
524
                ELSE
 
525
                        READ (LINE(2),'(2X,2A32,A14)') COM1,COM2,COM3
 
526
                END IF
 
527
                COMMENT=COM1
 
528
                CALL WRITER
 
529
                MJDOBS=OLDMJD+1.D-6
 
530
                COMMENT=COM2
 
531
                IF (COM2.NE.' ') CALL WRITER
 
532
                MJDOBS=OLDMJD+2.D-6
 
533
                COMMENT=COM3
 
534
                IF (COM3.NE.' ') CALL WRITER
 
535
                GO TO 110
 
536
C
 
537
C
 
538
            ELSE IF (A.EQ.'f') THEN
 
539
C
 
540
C                       f: error
 
541
C
 
542
                GO TO 110
 
543
C
 
544
C
 
545
            ELSE
 
546
C
 
547
C                       other: Illegal card.
 
548
C
 
549
                GO TO 399
 
550
C
 
551
            END IF
 
552
C
 
553
C
 
554
  200   CLOSE(NOUTP)
 
555
C
 
556
C       Now make format file:
 
557
C
 
558
        OPEN (NOUTP,FILE='data.fmt',STATUS='UNKNOWN')
 
559
        WRITE(NOUTP,'(A29)')'! Format file for Danish Data'
 
560
  300   FORMAT(A39)
 
561
C       Caution -- columns here MUST match FORMATs 5 & 6 in WRITER !!
 
562
        WRITE(NOUTP,300)'DEFINE/FIELD   1  10 R   F10.0 :SIGNAL '
 
563
        WRITE(NOUTP,300)'DEFINE/FIELD  11  42 C   A9    :OBJECT '
 
564
        WRITE(NOUTP,300)'DEFINE/FIELD  44  47 C   A7    :STARSKY'
 
565
        WRITE(NOUTP,300)'DEFINE/FIELD  49  56 C*8 A7    :BAND   '
 
566
        WRITE(NOUTP,300)'DEFINE/FIELD  57  68 D   F12.6 :MJD_OBS'
 
567
        WRITE(NOUTP,300)'DEFINE/FIELD  69  76 R   F8.3  :EXPTIME'
 
568
        WRITE(NOUTP,300)'DEFINE/FIELD  77 108 C   A32   :COMMENT'
 
569
        WRITE(NOUTP,300)'DEFINE/FIELD 109 118 R   F10.0 :ESTERR '
 
570
        WRITE(NOUTP,300)'DEFINE/FIELD 120 123 C   A6  :DIAPHRAGM'
 
571
        WRITE(NOUTP,'(A3)')'END'
 
572
        CLOSE(NOUTP)
 
573
C
 
574
        CALL TV('Danish is finished')
 
575
C
 
576
C
 
577
C       End MIDAS:
 
578
C
 
579
        CALL STSEPI
 
580
C
 
581
C       --------------------
 
582
C
 
583
C       Error messages:
 
584
C
 
585
  301   CALL TV('ERROR reading card at 111.')
 
586
        GO TO 399
 
587
C
 
588
  392   CALL TV('ERROR reading card at 113.')
 
589
        GO TO 399
 
590
C
 
591
  393   CALL TV('ERROR reading card at 114.')
 
592
        GO TO 399
 
593
C
 
594
  394   CALL TV('ERROR reading card at 115.')
 
595
        GO TO 399
 
596
C
 
597
  395   CALL TV('Card does not end with "e".')
 
598
        GO TO 399
 
599
C
 
600
  399   CONTINUE
 
601
        CALL TV('These cards are not in standard format:')
 
602
        CALL TV(LINE(1))
 
603
        CALL TVN(LINE(2))
 
604
        CALL SPACE
 
605
        CALL TV('Please fix data and try again.')
 
606
        CALL STETER(399,'Data not in std. format')
 
607
        END
 
608
        SUBROUTINE WRITER
 
609
C
 
610
C       writes output to uniform ascii file 'data.dat'
 
611
C
 
612
        INTEGER INULL
 
613
        REAL RNULL
 
614
        DOUBLE PRECISION DNULL
 
615
        COMMON /NULLS/ INULL, RNULL, DNULL
 
616
C
 
617
        DOUBLE PRECISION MJDOBS
 
618
        REAL SIGNAL,EXPTIME,ESTERR
 
619
        COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS,ESTERR
 
620
        CHARACTER OBJECT*9,STARSKY*4,BAND*8,COMMENT*32,DIAPH
 
621
        COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT,DIAPH
 
622
C
 
623
        CHARACTER C*124
 
624
C
 
625
C
 
626
        WRITE(C,5) SIGNAL,OBJECT,STARSKY,BAND,MJDOBS,EXPTIME,COMMENT
 
627
    5   FORMAT        (F10.0,A9,24X,A4,1X,A8,F12.6,F8.3,A32)
 
628
        WRITE(C(109:),6) ESTERR,DIAPH
 
629
    6   FORMAT(F10.0,1X,A1)
 
630
C
 
631
C       Fix up NULL fields:
 
632
C
 
633
        IF (SIGNAL.EQ.RNULL) C(1:10)=' '
 
634
        IF (MJDOBS.EQ.DNULL) C(57:68)=' '
 
635
        IF (EXPTIME.EQ.RNULL) C(69:76)=' '
 
636
        IF (ESTERR.EQ.RNULL) C(109:118)=' '
 
637
C
 
638
        WRITE(8,'(A123)') C
 
639
C
 
640
        RETURN
 
641
        END