← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/daophot/libsrc/unxdaosubs.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/daophot/libsrc/unxdaosubs.for
 
1
C @(#)unxdaosubs.for    19.1 (ES0-DMD) 02/25/03 13:23:51
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C 
 
28
C 010322                last modif
 
29
C 
 
30
C===========================================================================
 
31
C
 
32
      SUBROUTINE FABORT
 
33
      IMPLICIT     NONE
 
34
      RETURN
 
35
      END
 
36
C
 
37
C=================================================================
 
38
C
 
39
      SUBROUTINE CLFILE (LUN)
 
40
      IMPLICIT NONE
 
41
      INTEGER  LUN
 
42
      CLOSE (LUN)
 
43
      END
 
44
C
 
45
C=========================================================================
 
46
C
 
47
      SUBROUTINE BYEBYE
 
48
      IMPLICIT NONE
 
49
      WRITE (6,*)
 
50
      WRITE (6,*) 'Good bye.'
 
51
      WRITE (6,*)
 
52
      STOP
 
53
      END
 
54
C
 
55
C==========================================================================
 
56
C
 
57
      SUBROUTINE  OOPS
 
58
      IMPLICIT     NONE
 
59
      WRITE (6,*)
 
60
      WRITE (6,*) 'Sorry about that.'
 
61
      WRITE (6,*)
 
62
      STOP
 
63
      END
 
64
C
 
65
C==============================================================================
 
66
C
 
67
      SUBROUTINE INFILE (LUN, FILE, ISTAT)
 
68
      IMPLICIT     NONE
 
69
      INTEGER      LUN  
 
70
      CHARACTER*30 FILE
 
71
      INTEGER      ISTAT
 
72
C
 
73
      CHARACTER*100 EXPAND
 
74
      OPEN (LUN, FILE=EXPAND(FILE), STATUS='OLD', ERR=999)
 
75
      ISTAT = 0
 
76
      RETURN
 
77
  999 ISTAT = -1
 
78
      RETURN
 
79
      END
 
80
C
 
81
C========================================================
 
82
C
 
83
      CHARACTER*(*) FUNCTION EXPAND(FILE)
 
84
      IMPLICIT     NONE
 
85
      CHARACTER*30 FILE
 
86
      INTEGER I
 
87
      INTEGER J
 
88
      INTEGER K
 
89
C
 
90
      K = 0
 
91
      DO I=2,29
 
92
         IF (FILE(I:I) .EQ. ':') THEN
 
93
            CALL GETENV (FILE(1:I-1), EXPAND)
 
94
            DO J=1,100
 
95
               IF (EXPAND(J:J) .NE. ' ') K=J
 
96
            END DO
 
97
            IF (K .NE. 0) THEN
 
98
               EXPAND = EXPAND(1:K)//'/'//FILE(I+1:30)
 
99
               RETURN
 
100
            END IF
 
101
         END IF
 
102
      END DO
 
103
      EXPAND = FILE
 
104
      RETURN
 
105
      END
 
106
C
 
107
C======================================================
 
108
C
 
109
      SUBROUTINE OUTFIL (LUN, FILE, ISTAT)
 
110
      IMPLICIT     NONE
 
111
      INTEGER      LUN
 
112
      CHARACTER*30 FILE
 
113
      INTEGER      ISTAT
 
114
      CHARACTER*30 ANSWER
 
115
      CHARACTER*100 EXPAND
 
116
      LOGICAL EXIST
 
117
C
 
118
 1000 INQUIRE (FILE=EXPAND(FILE), EXIST=EXIST)
 
119
      IF (EXIST) THEN
 
120
         CALL STUPID ('This file already exists: '//FILE)
 
121
         ANSWER = 'OVERWRITE'
 
122
         CALL GETNAM ('NEW OUTPUT FILE NAME:', ANSWER)
 
123
         IF (ANSWER .EQ. 'OVERWRITE') THEN
 
124
            OPEN (LUN, FILE=EXPAND(FILE), STATUS='OLD')
 
125
            CLOSE (LUN, STATUS='DELETE')
 
126
         ELSE
 
127
            FILE = ANSWER
 
128
            GO TO 1000
 
129
         END IF
 
130
      END IF
 
131
      OPEN (LUN, FILE=EXPAND(FILE), STATUS='NEW', IOSTAT=ISTAT)
 
132
      RETURN
 
133
      END
 
134
C
 
135
C====================================================
 
136
C
 
137
      CHARACTER*(*) FUNCTION CASE (STRING)
 
138
      IMPLICIT      NONE
 
139
      CHARACTER*(*) STRING
 
140
C
 
141
C FOR UNIX, LEAVE THE CASES OF THE CHARACTERS ALONE!
 
142
C
 
143
      CASE = STRING
 
144
      RETURN
 
145
      END 
 
146
C
 
147
C
 
148
C====================================================
 
149
C
 
150
      SUBROUTINE OVRWRT (LINE, IWHICH)
 
151
      IMPLICIT      NONE
 
152
      CHARACTER*(*) LINE
 
153
      INTEGER       IWHICH
 
154
C
 
155
      CHARACTER*79 OUTPUT
 
156
      INTEGER LEN
 
157
C
 
158
      IF (IWHICH .EQ. 1) THEN
 
159
         WRITE (6,1) LINE
 
160
    1    FORMAT (A)
 
161
      ELSE IF (IWHICH .EQ. 2) THEN
 
162
         IF (LEN(LINE) .LT. 79) THEN
 
163
            OUTPUT = ' '
 
164
            OUTPUT = LINE
 
165
            WRITE (6,2) OUTPUT, CHAR(13)
 
166
            WRITE (6,2) OUTPUT, CHAR(13)
 
167
    2       FORMAT (A, A1, $)
 
168
         ELSE
 
169
            WRITE (6,2) LINE, CHAR(13)
 
170
         END IF
 
171
      ELSE IF (IWHICH .EQ. 3) THEN
 
172
         WRITE (6,3) LINE
 
173
    3    FORMAT (A)
 
174
      ELSE
 
175
         WRITE (6,4) LINE, CHAR(13)
 
176
    4    FORMAT (/A, A1, $)
 
177
      END IF
 
178
      RETURN
 
179
      END
 
180
C