This file is indexed.

/usr/share/ncarg/tests/tseter.f is in libncarg-data 6.2.0-3.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
      PROGRAM TSETER
C
C This test program demonstrates minimal functioning of the error-
C handling package used by NCAR Graphics.  It first produces a single
C frame showing what output print lines to expect and then steps
C through a simple set of tests that should produce those print lines.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
        PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C Make required character-variable declarations.  ERMSG receives the
C error message returned by the character function SEMESS.
C
        CHARACTER*113 ERMSG,SEMESS
C
C The contents of the array LINE defines the lines of print that this
C program should produce.
C
        CHARACTER*60 LINE(40)
C
        DATA (LINE(I),I=1,10) /
     +  ' ' ,
     +  'PROGRAM TSETER EXECUTING' ,
     +  ' ' ,
     +  'TSETER - CALL ENTSR TO ENTER RECOVERY MODE' ,
     +  ' ' ,
     +  'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 1' ,
     +  ' ' ,
     +  'TSETER - CALL ERROF TO TURN OFF INTERNAL ERROR FLAG' ,
     +  ' ' ,
     +  'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 2' /
C
        DATA (LINE(I),I=11,20) /
     +  ' ' ,
     +  'TSETER - EXECUTE STATEMENT ''IERRO=NERRO(JERRO)''' ,
     +  'TSETER - RESULTING IERRO:             2' ,
     +  'TSETER - RESULTING JERRO:             2' ,
     +  ' ' ,
     +  'TSETER - EXECUTE STATEMENT ''ERMSG=SEMESS(0)''' ,
     +  'TSETER - RESULTING ERMSG:  ROUTINE_NAME_2 - ERROR_MESSAGE_2' ,
     +  'TSETER - (PRINTING ABOVE LINE ALSO TESTED ICLOEM)' ,
     +  ' ' ,
     +  'TSETER - CALL EPRIN TO PRINT CURRENT ERROR MESSAGE' /
C
        DATA (LINE(I),I=21,30) /
     +  'ERROR    2 IN ROUTINE_NAME_2 - ERROR_MESSAGE_2' ,
     +  'TSETER - (AN ERROR MESSAGE SHOULD HAVE BEEN PRINTED)' ,
     +  ' ' ,
     +  'TSETER - CALL ERROF TO TURN OFF INTERNAL ERROR FLAG' ,
     +  ' ' ,
     +  'TSETER - CALL EPRIN TO PRINT CURRENT ERROR MESSAGE' ,
     +  'TSETER - (NOTHING SHOULD HAVE BEEN PRINTED)' ,
     +  ' ' ,
     +  'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 3' ,
     +  ' ' /
C
        DATA (LINE(I),I=31,40) /
     +  'TSETER - TEST THE USE OF ICFELL' ,
     +  ' ' ,
     +  'TSETER - CALL RETSR TO LEAVE RECOVERY MODE - BECAUSE' ,
     +  'TSETER - THE LAST RECOVERABLE ERROR WAS NOT CLEARED,' ,
     +  'TSETER - THIS WILL CAUSE A FATAL-ERROR CALL TO SETER' ,
     +  'ERROR    3 IN SETER - AN UNCLEARED PRIOR ERROR EXISTS' ,
     +  '... MESSAGE FOR UNCLEARED PRIOR ERROR IS AS FOLLOWS:' ,
     +  '... ERROR    6 IN SETER/ROUTINE_NAME_3 - ERROR_MESSAGE_3' ,
     +  '... MESSAGE FOR CURRENT CALL TO SETER IS AS FOLLOWS:' ,
     +  '... ERROR    2 IN RETSR - PRIOR ERROR IS NOW UNRECOVERABLE' /
C
C Open GKS.
C
        CALL GOPKS (IERRF, ISZDM)
        CALL GOPWK (IWKID, LUNIT, IWTYPE)
        CALL GACWK (IWKID)
C
C Produce a single frame of output, detailing what the program ought to
C print.
C
        CALL SET    (0.,1.,0.,1.,0.,1.,0.,1.,1)
C
        CALL PCSETC ('FC - FUNCTION CODE SIGNAL',CHAR(0))
C
        CALL PCSETI ('FN - FONT NUMBER',26)
C
        CALL PLCHHQ (.5,.975,'SETER TEST "tseter"',.025,0.,0.)
C
        CALL PCSETI ('FN - FONT NUMBER',1)
C
        CALL PLCHHQ (.5,.925,'See the print output; it should consist of
     + the following lines:',.011,0.,0.)
C
        DO 101 I=1,40
          CALL PLCHHQ (.15,.9-REAL(I-1)*.022,LINE(I),.011,0.,-1.)
  101   CONTINUE
C
C Advance the frame.
C
        CALL FRAME
C
C Close GKS.
C
        CALL GDAWK (IWKID)
        CALL GCLWK (IWKID)
        CALL GCLKS
C
C Enter recovery mode.
C
        PRINT * , ' '
        PRINT * , 'PROGRAM TSETER EXECUTING'
        PRINT * , ' '
        PRINT * , 'TSETER - CALL ENTSR TO ENTER RECOVERY MODE'
C
        CALL ENTSR (IROLD,1)
C
C Log a recoverable error.  Nothing should be printed, but the internal
C error flag should be set and the message should be remembered.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 1'
C
        CALL SETER ('ROUTINE_NAME_1 - ERROR_MESSAGE_1',1,1)
C
C Clear the internal error flag.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL ERROF TO TURN OFF INTERNAL ERROR FLAG'
C
        CALL ERROF
C
C Log another recoverable error.  Again, nothing should be printed, but
C the internal error flag should be set and the message should be
C remembered.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 2'
C
        CALL SETER ('ROUTINE_NAME_2 - ERROR_MESSAGE_2',2,1)
C
C Pick up and print the error flag, as returned in each of two
C ways by the function NERRO.
C
        PRINT * , ' '
        PRINT * , 'TSETER - EXECUTE STATEMENT ''IERRO=NERRO(JERRO)'''
C
        IERRO=NERRO(JERRO)
C
        PRINT * , 'TSETER - RESULTING IERRO:  ',IERRO
        PRINT * , 'TSETER - RESULTING JERRO:  ',JERRO
C
C Pick up and print the error message, as returned by the function
C SEMESS.  This also tests proper functioning of the function ICLOEM.
C
        PRINT * , ' '
        PRINT * , 'TSETER - EXECUTE STATEMENT ''ERMSG=SEMESS(0)'''
C
        ERMSG=SEMESS(0)
C
        PRINT * , 'TSETER - RESULTING ERMSG:  ',ERMSG(1:ICLOEM(ERMSG))
        PRINT * , 'TSETER - (PRINTING ABOVE LINE ALSO TESTED ICLOEM)'
C
C Print the current error message.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL EPRIN TO PRINT CURRENT ERROR MESSAGE'
C
        CALL EPRIN
C
        PRINT * , 'TSETER - (AN ERROR MESSAGE SHOULD HAVE BEEN PRINTED)'
C
C Clear the internal error flag again.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL ERROF TO TURN OFF INTERNAL ERROR FLAG'
C
        CALL ERROF
C
C Try to print the error message again.  Nothing should be printed.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL EPRIN TO PRINT CURRENT ERROR MESSAGE'
C
        CALL EPRIN
C
        PRINT * , 'TSETER - (NOTHING SHOULD HAVE BEEN PRINTED)'
C
C Log another recoverable error.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL SETER TO REPORT RECOVERABLE ERROR 3'
C
        CALL SETER ('ROUTINE_NAME_3 - ERROR_MESSAGE_3',5,1)
C
C Test the use of ICFELL.
C
        PRINT * , ' '
        PRINT * , 'TSETER - TEST THE USE OF ICFELL'
C
        IF (ICFELL('TSETER',6).NE.5) THEN
          PRINT * , ' '
          PRINT * , 'TSETER - ICFELL MALFUNCTIONED - SOMETHING''S WRONG'
          STOP
        END IF
C
C Turn recovery mode off without clearing the internal error flag,
C which should be treated as a fatal error.
C
        PRINT * , ' '
        PRINT * , 'TSETER - CALL RETSR TO LEAVE RECOVERY MODE - BECAUSE'
        PRINT * , 'TSETER - THE LAST RECOVERABLE ERROR WAS NOT CLEARED,'
        PRINT * , 'TSETER - THIS WILL CAUSE A FATAL-ERROR CALL TO SETER'
C
        CALL RETSR (IROLD)
C
C Control should never get to the next statement, but just in case ...
C
        PRINT * , ' '
        PRINT * , 'TSETER - GOT CONTROL BACK - SOMETHING''S WRONG'
C
        STOP
C
      END