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
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
|
SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD)
C
C +-----------------------------------------------------------------+
C | |
C | Copyright (C) 1986 by UCAR |
C | University Corporation for Atmospheric Research |
C | All Rights Reserved |
C | |
C | NCARGRAPHICS Version 1.00 |
C | |
C +-----------------------------------------------------------------+
C
C
C
C
C
C
C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS
C TO BE CREATED.
C ASH SEE IOFFD.
C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE
C MAGNITUDE OF VALU IS TO BE CREATED.
C .1 .LE. ABS(VALU) .LE. 99999.49999...
C OR VALUE .EQ. 0.0. THE LABEL CREATED
C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING
C ON THE MAGNITUDE OF VALU. SEE IOUT.
C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT
C THE MAGNITUDE OF VALU IS TO BE CREATED.
C ASH IS USED AS THE NORMALIZATION FACTOR.
C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR
C VALU .EQ. 0.0. THE LABEL CREATED SHOULD
C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE
C MAGNITUDE OF ASH*VALU. SEE IOUT.
C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO
C LEADING BLANKS. SEE NC.
C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE
C 1 TO 5.
C
SAVE
CHARACTER*11 IFMT
CHARACTER*(*) IOUT
C
C IFMT MUST HOLD 11 CHARACTERS
C
VAL = VALU
IF (IOFFD .NE. 0) GO TO 103
IF (VAL) 101,104,101
101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000
V = VAL
NS = MAX0(4,MIN0(6,LOG+2))
ND = MIN0(3,MAX0(0,2-LOG))
c IF (VAL.LT.0) NS = NS + 1
c + NOAO - replacing ftn i/o for iraf implementation
c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')'
102 continue
ifmt(1:6) = '(f . )'
ifmt(3:3) = char (ns + ichar ('0'))
ifmt(5:5) = char (nd + ichar ('0'))
c WRITE (IOUT,IFMT) V
call encode (ns, ifmt, iout, v)
NC = NS
c + NOAO
c The following statement was making 5 digit labels (+4800) come out
c truncated (+480) and it has been commented out.
c IF (LOG.GE.3) NC = NC - 1
c - NOAO
RETURN
103 NS = 4
IF (VAL.LT.0.) NS=5
IF (VAL.EQ.0.) NS=2
ND = 0
V = VAL*ASH
LOG = 100
GO TO 102
104 iout(1:3) = '0.0'
nc = 3
c 104 NS = 3
c ND = 1
c LOG = -100
c V = 0.
c GO TO 102
C
C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')')
C
END
C
SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL)
INTEGER SZFMT, SZBUF
PARAMETER (SZFMT=11)
PARAMETER (SZBUF=15)
CHARACTER*(*) FTNFMT
CHARACTER*(*) FTNOUT
INTEGER*2 SPPFMT(SZFMT), SPPOUT(SZBUF)
C UNPACK THE FORTRAN CHARACTER STRING, CALL FENCD TO ACTUALLY ENCODE THE
C OUTPUT STRING, THEN PACK THE OUTPUT STRING INTO A FORTRAN STRING FOR RETURN
C
CALL F77UPK (FTNFMT, SPPFMT, SZFMT)
CALL FENCD (NCHARS, SPPFMT, SPPOUT, RVAL)
CALL F77PAK (SPPOUT, FTNOUT, NCHARS)
END
C
C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES
C FOLLOWS THIS PACKAGE DESCRIPTION.
C
C LATEST REVISION FEBRUARY 1985
C
C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR
C HANDLING PACKAGE.
C
C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN
C THE SAME MANNER AS THEIR SIMILARLY NAMED
C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT
C FOR ROUTINE SETER, THE CALLING SEQUENCES
C OF THESE ROUTINES ARE THE SAME AS FOR
C THEIR PORT COUNTERPARTS.
C ERPRT77 ENTRY PORT ENTRY
C ------------- ----------
C ENTSR ENTSRC
C RETSR RETSRC
C NERRO NERROR
C ERROF ERROFF
C SETER SETERR
C EPRIN EPRINT
C FDUM FDUMP
C
C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES.
C
C PRECISION NOT APPLICABLE
C
C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON
C FILES NCAR'S CRAY MACHINES.
C
C LANGUAGE FORTRAN 77
C
C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER,
C COLORADO BY FRED CLARE OF THE SCIENTIFIC
C COMPUTING DIVISION BY ADAPTING THE NON-
C PROPRIETARY, ERROR HANDLING ROUTINES
C FROM THE PORT LIBRARY OF BELL LABS.
C
C PORTABILITY FULLY PORTABLE
C
C REFERENCES SEE THE MANUAL
C PORT MATHEMATICAL SUBROUTINE LIBRARY
C ESPECIALLY "ERROR HANDLING" IN SECTION 2
C OF THE INTRODUCTION, AND THE VARIOUS
C SUBROUTINE DESCRIPTIONS.
C ******************************************************************
C
C SUBBROUTINE ENTSR(IROLD,IRNEW)
C
C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND
C SETS A NEW ONE. IT ALSO CHECKS THE ERROR
C STATE, AND IF THERE IS AN ACTIVE ERROR
C STATE A MESSAGE IS PRINTED.
C
C USAGE CALL ENTSR(IROLD,IRNEW)
C
C ARGUMENTS
C
C ON INPUT IRNEW
C VALUE SPECIFIED BY USER FOR ERROR
C RECOVERY
C = 0 LEAVES RECOVERY UNCHANGED
C = 1 GIVES RECOVERY
C = 2 TURNS RECOVERY OFF
C
C ON OUTPUT IROLD
C RECEIVES THE CURRENT VALUE OF THE ERROR
C RECOVERY MODE
C
C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE
C MESSAGE IS PRINTED AND EXECUTION STOPS.
C
C ERROR STATES -
C 1 - ILLEGAL VALUE OF IRNEW.
C 2 - CALLED WHILE IN AN ERROR STATE.
C ******************************************************************
C
C SUBROUTINE RETSR(IROLD)
C
C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN
C BY THE INPUT ARGUMENT. A TEST IS THEN MADE
C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH
C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN
C ERROR MESSAGE AND TERMINATES THE RUN.
C
C BY CONVENTION, RETSR IS USED UPON EXIT
C FROM A SUBROUTINE TO RESTORE THE PREVIOUS
C RECOVERY MODE STATUS STORED BY ROUTINE
C ENTSR IN IROLD.
C
C USAGE CALL RETSR(IROLD)
C
C ARGUMENTS
C
C ON INPUT IROLD
C = 1 SETS FOR RECOVERY
C = 2 SETS FOR NONRECOVERY
C
C ON OUTPUT NONE
C
C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE,
C THE MESSAGE IS PRINTED AND EXECUTION STOPS.
C
C ERROR STATES -
C 1 - ILLEGAL VALUE OF IROLD.
C ******************************************************************
C
C INTEGER FUNCTION NERRO(NERR)
C
C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY)
C OR ZERO IF THE PROGRAM IS NOT IN THE
C ERROR STATE.
C
C USAGE N = NERRO(NERR)
C
C ARGUMENTS
C
C ON INPUT NONE
C
C ON OUTPUT NERR
C CURRENT VALUE OF THE ERROR NUMBER
C ******************************************************************
C SUBROUTINE ERROF
C
C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE
C ERROR NUMBER TO ZERO
C
C USAGE CALL ERROF
C
C ARGUMENTS
C
C ON INPUT NONE
C
C ON OUTPUT NONE
C ******************************************************************
C
C SUBROUTINE SETER(MESSG,NERR,IOPT)
C
C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING
C ON THE OPTIONS STATED BELOW, PRINTS A
C MESSAGE AND PROVIDES A DUMP.
C
C
C USAGE CALL SETER(MESSG,NERR,IOPT)
C
C ARGUMENTS
C
C ON INPUT MESSG
C HOLLERITH STRING CONTAINING THE MESSAGE
C ASSOCIATED WITH THE ERROR
C
C NERR
C THE NUMBER TO ASSIGN TO THE ERROR
C
C IOPT
C = 1 FOR A RECOVERABLE ERROR
C = 2 FOR A FATAL ERROR
C
C IF IOPT = 1 AND THE USER IS IN ERROR
C RECOVERY MODE, SETERR SIMPLY REMEMBERS
C THE ERROR MESSAGE, SETS THE ERROR NUMBER
C TO NERR, AND RETURNS.
C
C IF IOPT = 1 AND THE USER IS NOT IN ERROR
C RECOVERY MODE, SETERR PRINTS THE ERROR
C MESSAGE AND TERMINATES THE RUN.
C
C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR
C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN.
C
C ON OUTPUT NONE
C
C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT
C TO ANY VALUE OTHER THAN 1 OR 2.
C ******************************************************************
C
C SUBROUTINE EPRIN
C
C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE
C PROGRAM IS IN THE ERROR STATE; OTHERWISE
C NOTHING IS PRINTED.
C
C USAGE CALL EPRIN
C
C ARGUMENTS
C
C ON INPUT NONE
C
C ON OUTPUT NONE
C ******************************************************************
C
C SUBROUTINE FDUM
C
C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES
C AS A PLACEHOLDER FOR A SYMBOLIC DUMP
C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO
C PROVIDE SUCH A ROUTINE.
C
C USAGE CALL EPRIN
C
C ARGUMENTS
C
C ON INPUT NONE
C
C ON OUTPUT NONE
C ******************************************************************
SUBROUTINE ENTSR(IROLD,IRNEW)
C
LOGICAL TEMP
IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2)
C
TEMP = IRNEW.NE.0
IROLD = I8SAV(2,IRNEW,TEMP)
C
C IF HAVE AN ERROR STATE, STOP EXECUTION.
C
IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER
1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2)
C
RETURN
C
END
SUBROUTINE RETSR(IROLD)
C
IF (IROLD.LT.1 .OR. IROLD.GT.2)
1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2)
C
ITEMP=I8SAV(2,IROLD,.TRUE.)
C
C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP.
C
IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN
C
CALL EPRIN
CALL FDUM
c STOP
C
END
INTEGER FUNCTION NERRO(NERR)
C
NERRO=I8SAV(1,0,.FALSE.)
NERR=NERRO
RETURN
C
END
SUBROUTINE ERROF
C
I=I8SAV(1,0,.TRUE.)
RETURN
C
END
SUBROUTINE SETER(MESSG,NERR,IOPT)
C
CHARACTER*(*) MESSG
COMMON /UERRF/IERF
C
C THE UNIT FOR ERROR MESSAGES IS I1MACH(4)
C
c + NOAO - blockdata uerrbd changed to runtime initialization subroutine
C FORCE LOAD OF BLOCKDATA
C
c EXTERNAL UERRBD
call uerrbd
c - NOAO
IF (IERF .EQ. 0) THEN
IERF = I1MACH(4)
ENDIF
C
NMESSG = LEN(MESSG)
IF (NMESSG.GE.1) GO TO 10
C
C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
C
c + NOAO - FTN writes rewritten as calls to uliber for IRAF
c WRITE(IERF,9000)
c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.')
call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80)
c - NOAO
GO TO 60
C
10 CONTINUE
IF (NERR.NE.0) GO TO 20
C
C CANNOT TURN THE ERROR STATE OFF USING SETER.
C
c + NOAO - FTN writes rewritten as calls to uliber for IRAF
c WRITE(IERF,9001)
c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/
c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/)
call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80)
call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80)
c - NOAO
CALL E9RIN(MESSG,NERR,.TRUE.)
ITEMP=I8SAV(1,1,.TRUE.)
GO TO 50
C
C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
C
20 CONTINUE
IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30
C
c + NOAO - FTN writes rewritten as calls to uliber for IRAF
c WRITE(IERF,9002)
c9002 FORMAT(' ERROR 3 IN SETER -',
c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'//
c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///)
call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80)
call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80)
c - NOAO
CALL EPRIN
CALL E9RIN(MESSG,NERR,.TRUE.)
GO TO 50
C
C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
C
30 CALL E9RIN(MESSG,NERR,.TRUE.)
C
IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
C
C MUST HAVE IOPT = 1 OR 2.
C
c + NOAO - FTN writes rewritten as calls to uliber for IRAF
c WRITE(IERF,9003)
c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'//
c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///)
call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80)
call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80)
c - NOAO
GO TO 50
C
C TEST FOR RECOVERY.
C
40 CONTINUE
IF (IOPT.EQ.2) GO TO 50
C
IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN
C
CALL EPRIN
CALL FDUM
c STOP
C
50 CALL EPRIN
60 CALL FDUM
c STOP
C
END
SUBROUTINE EPRIN
C
CHARACTER*1 MESSG
C
CALL E9RIN(MESSG,1,.FALSE.)
RETURN
C
END
SUBROUTINE E9RIN(MESSG,NERR,SAVE)
C
C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
C
CHARACTER*(*) MESSG
CHARACTER*113 MESSGP
INTEGER NERRP
LOGICAL SAVE
COMMON /UERRF/IERF
SAVE MESSGP,NERRP
C
C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE
C
C
C START WITH NO PREVIOUS MESSAGE.
C
DATA MESSGP/'1'/
DATA NERRP/0/
C
IF (.NOT.SAVE) GO TO 20
C
C SAVE THE MESSAGE.
C
NERRP=NERR
MESSGP = MESSG
C
GO TO 30
C
20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30
C
C PRINT THE MESSAGE.
C
c + NOAO - FTN write rewritten as call to uliber
c WRITE(IERF,9000) NERRP,MESSGP
c9000 FORMAT(' ERROR ',I4,' IN ',A113)
call uliber (nerrp, messgp, 113)
C
30 RETURN
C
END
INTEGER FUNCTION I8SAV(ISW,IVALUE,SET)
C
C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND
C SETS IT TO IVALUE IF SET = .TRUE. .
C
C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND
C SETS IT TO IVALUE IF SET = .TRUE. .
C
LOGICAL SET
INTEGER LERROR, LRECOV
SAVE LERROR,LRECOV
C
C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
C
DATA LERROR/0/ , LRECOV/2/
IF (ISW .EQ. 1) THEN
I8SAV = LERROR
IF (SET) LERROR = IVALUE
ELSE IF (ISW .EQ. 2) THEN
I8SAV = LRECOV
IF (SET) LRECOV = IVALUE
ENDIF
RETURN
END
SUBROUTINE FDUM
C
C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED
C
RETURN
END
C
SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION)
C
C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1)
C ARGUMENTS
C
C LATEST REVISION MARCH 1984
C
C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH
C INFORMATION ABOUT THE CIRCUMSTANCES OF A
C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING
C TAPE FOR LATER PROCESSING.
C
C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE
C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH
C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT
C MONITORS USE OF NCAR ROUTINES WITH LOCAL
C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL
C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE
C DELETED FROM ALL NSSL ROUTINES.
C
CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION
C
RETURN
END
c + NOAO - Blockdata uerrbd rewritten as a runtime initialization subroutine
c BLOCKDATA UERRBD
subroutine uerrbd
c
COMMON /UERRF/IERF
C DEFAULT ERROR UNIT
c DATA IERF/0/
IERF= 0
END
c -NOAO
subroutine uliber (errcode, pkerrmsg, msglen)
character*80 pkerrmsg
integer errcode, msglen
integer*2 sppmsg(81)
integer SZLINE
parameter (SZLINE=80)
c unpack the fortran character string, call fulib to output the string.
c
call f77upk (pkerrmsg, sppmsg, SZLINE)
call fulib (errcode, sppmsg, msglen)
end
|
