lxsd / fvn

Blame view

fvn_fnlib/seterr.f 2.73 KB
edit raw normal view history
38581db0c   daniau   git-svn-id: https... 
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
 
        subroutine seterr (messg, nmessg, nerr, iopt)
  c
  c  this version modified by w. fullerton to dump if iopt = 1 and
  c  not recovering.
  c  seterr sets lerror = nerr, optionally prints the message and dumps
  c  according to the following rules...
  c
  c    if iopt = 1 and recovering      - just remember the error.
  c    if iopt = 1 and not recovering  - print, dump and stop.
  c    if iopt = 2                     - print, dump and stop.
  c
  c  input
  c
  c    messg  - the error message.
  c    nmessg - the length of the message, in characters.
  c    nerr   - the error number. must have nerr non-zero.
  c    iopt   - the option. must have iopt=1 or 2.
  c
  c  error states -
  c
  c    1 - message length not positive.
  c    2 - cannot have nerr=0.
  c    3 - an unrecovered error followed by another error.
  c    4 - bad value for iopt.
  c
  c  only the first 72 characters of the message are printed.
  c
  c  the error handler calls a subroutine named fdump to produce a
  c  symbolic dump. to complete the package, a dummy version of fdump
  c  is supplied, but it should be replaced by a locally written version
  c  which at least gives a trace-back.
  c
        integer messg(1)
        external i1mach, i8save
  c
  c  the unit for error messages.
  c
        iwunit=i1mach(4)
  c
        if (nmessg.ge.1) go to 10
  c
  c  a message of non-positive length is fatal.
  c
          write(iwunit,9000)
   9000   format(52h1error    1 in seterr - message length not positive.)
          go to 60
  c
  c  nw is the number of words the message occupies.
  c
   10   nw=(min0(nmessg,72)-1)/i1mach(6)+1
  c
        if (nerr.ne.0) go to 20
  c
  c  cannot turn the error state off using seterr.
  c
          write(iwunit,9001)
   9001   format(42h1error    2 in seterr - cannot have nerr=0//
       1         34h the current error message follows///)
          call e9rint(messg,nw,nerr,.true.)
          itemp=i8save(1,1,.true.)
          go to 50
  c
  c  set lerror and test for a previous unrecovered error.
  c
   20   if (i8save(1,nerr,.true.).eq.0) go to 30
  c
          write(iwunit,9002)
   9002   format(23h1error    3 in seterr -,
       1         48h an unrecovered error followed by another error.//
       2         48h the previous and current error messages follow.///)
          call eprint
          call e9rint(messg,nw,nerr,.true.)
          go to 50
  c
  c  save this message in case it is not recovered from properly.
  c
   30   call e9rint(messg,nw,nerr,.true.)
  c
        if (iopt.eq.1 .or. iopt.eq.2) go to 40
  c
  c  must have iopt = 1 or 2.
  c
          write(iwunit,9003)
   9003   format(42h1error    4 in seterr - bad value for iopt//
       1         34h the current error message follows///)
          go to 50
  c
  c  test for recovery.
  c
   40   if (iopt.eq.2) go to 50
  c
        if (i8save(2,0,.false.).eq.1) return
  c
  c     call eprint
  c     stop
  c
   50   call eprint
   60   call fdump
        stop
  c
        end