← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/pepsys/libsrc/asker.for

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

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/pepsys/libsrc/asker.for
 
1
C @(#)asker.for 19.1 (ES0-DMD) 02/25/03 13:28:45
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
C  @(#)asker.for        19.1  (ESO-IPG)  02/25/03  13:28:45
 
30
      SUBROUTINE ASK(QUERY,REPLY)
 
31
C
 
32
C       Copyright (C) Andrew T. Young, 1990
 
33
C       Copyright (C) European Southern Observatory, 1992
 
34
C
 
35
C                                               FEB.6,1987
 
36
C  ASKS THE QUERY ON THE TERMINAL SCREEN AND
 
37
C  ACCEPTS REPLY FROM KEYBOARD.
 
38
C
 
39
C  QUITS IF REPLY IS 'Q' OR 'QUIT'.
 
40
C
 
41
      IMPLICIT NONE
 
42
      INTEGER ISTAT, NACTEL, IUNIT, NULLS, LWORD, IDIFF, IA, I
 
43
C
 
44
      CHARACTER *(*) QUERY,REPLY, A*1
 
45
      CHARACTER*80 BUFIN, BUFOUT
 
46
C
 
47
C
 
48
      LOGICAL MATCH
 
49
      EXTERNAL MATCH
 
50
C
 
51
        BUFIN=QUERY
 
52
    1   CALL STTPUT(' ',ISTAT)
 
53
    2   CALL STKPRC (BUFIN, 'INPUTC', 1, 1, 80,
 
54
     1              NACTEL, BUFOUT, IUNIT, NULLS, ISTAT)
 
55
        REPLY=BUFOUT
 
56
        IF (ISTAT.NE.0) THEN
 
57
                CALL STTPUT ( 'REPLY was:', ISTAT)
 
58
                CALL STTPUT ( REPLY, ISTAT)
 
59
                CALL STTPUT ('Please try again:', ISTAT)
 
60
                GO TO 99
 
61
        END IF
 
62
        IF(LWORD(REPLY).EQ.0) GOTO 1
 
63
C       modified to convert replies to upper case:
 
64
        IDIFF=ICHAR('A') - ICHAR('a')
 
65
        IA=ICHAR('a')
 
66
        DO 10 I=1, LWORD(REPLY)
 
67
   10   IF (ICHAR(REPLY(I:I)).GE.IA) REPLY(I:I)=
 
68
     1          CHAR(ICHAR(REPLY(I:I)) + IDIFF)
 
69
       IF(MATCH(REPLY,'QUIT'))THEN
 
70
      CALL STKPRC ('DO YOU WANT TO QUIT?','INPUTC', 1, 1, 1,
 
71
     1              NACTEL, A, IUNIT, NULLS, ISTAT)
 
72
      IF(A.EQ.'Y'.OR.A.EQ.'Q'.OR.A.EQ.'y'.OR.A.EQ.'q') THEN
 
73
        CALL TV('ABANDONED.')
 
74
        CALL STETER (9000,
 
75
     1     'Program abandoned.  You can IGNORE the "error" message.')
 
76
      END IF
 
77
      GO TO 1
 
78
       END IF
 
79
      RETURN
 
80
C
 
81
   99 CALL NOEOF
 
82
      GO TO 1
 
83
C
 
84
      ENTRY ASKN(QUERY,REPLY)
 
85
C
 
86
C  SIMILAR, BUT DOESN'T SPACE BEFORE LINE.
 
87
C
 
88
      BUFIN=QUERY
 
89
      GO TO 2
 
90
C
 
91
      END
 
92
      SUBROUTINE TV(MESAGE)
 
93
C
 
94
C  SHOWS THE MESSAGE ON THE TERMINAL SCREEN.
 
95
C
 
96
      IMPLICIT NONE
 
97
      INTEGER ISTAT
 
98
C
 
99
      CHARACTER *(*) MESAGE
 
100
C
 
101
C
 
102
    1 CALL STTPUT(' ',ISTAT)
 
103
    2 CALL STTPUT(MESAGE,ISTAT)
 
104
      IF (ISTAT.NE.0) THEN
 
105
        CALL STTPUT('ERROR in writing to screen!',ISTAT)
 
106
         GO TO 1
 
107
      END IF
 
108
      RETURN
 
109
C
 
110
      ENTRY TVN(MESAGE)
 
111
      GO TO 2
 
112
C
 
113
      END
 
114
      SUBROUTINE QF(Q,F)
 
115
C
 
116
C  ASKS QUERY Q ON THE TERMINAL SCREEN AND        18 FEB.1987
 
117
C  ACCEPTS FLOATING-POINT VALUE F FROM KEYBOARD.
 
118
C
 
119
      IMPLICIT NONE
 
120
      REAL F
 
121
      INTEGER ISTAT, I1SAV, I2SAV, I3SAV, NACTEL, IUNIT, NULLS
 
122
C
 
123
      CHARACTER *(*) Q
 
124
        CHARACTER*80 BUFIN
 
125
C
 
126
C
 
127
        BUFIN=Q
 
128
    1   CALL STTPUT(' ',ISTAT)
 
129
        CALL STECNT ('GET', I1SAV, I2SAV, I3SAV)
 
130
        CALL STECNT ('PUT', 1, 0, 0)
 
131
        CALL STKPRR (BUFIN, 'INPUTR', 1, 1,
 
132
     1              NACTEL, F, IUNIT, NULLS, ISTAT)
 
133
        IF (ISTAT.NE.0 .OR. NACTEL.NE.1) THEN
 
134
                CALL STTPUT ('Failed to obtain REAL value', ISTAT)
 
135
                CALL STTPUT ('Please try again:',ISTAT)
 
136
                GO TO 99
 
137
        END IF
 
138
      CALL STECNT ('PUT', I1SAV, I2SAV, I3SAV)
 
139
      RETURN
 
140
C
 
141
   99 CALL NOEOF
 
142
      GO TO 1
 
143
C
 
144
      END
 
145
      SUBROUTINE NOEOF
 
146
C
 
147
C  CANCELS EOF FROM KEYBOARD AND RE-STARTS INPUT FILE.
 
148
C
 
149
C ***
 
150
C This version does nothing.
 
151
      RETURN
 
152
      END
 
153
      SUBROUTINE CENTER(STRING)
 
154
C
 
155
C  Centers the input string in output.
 
156
C
 
157
      IMPLICIT NONE
 
158
C
 
159
      CHARACTER *(*) STRING
 
160
      CHARACTER *79 CARD
 
161
C
 
162
      INTEGER LEN
 
163
C
 
164
      INTEGER LWORD
 
165
C
 
166
C
 
167
      LEN=(79-LWORD(STRING))/2
 
168
      CARD(:LEN)=' '
 
169
      CARD(LEN:)=STRING
 
170
      CALL TV(CARD)
 
171
C
 
172
      RETURN
 
173
      END