2e24c35602b4f324801f5c63acf853a9c61b2e39
[scilab.git] / scilab / modules / differential_equations / src / fortran / xerrwv.f
1 C/MEMBR ADD NAME=XERRWV,SSI=0
2       subroutine xerrwv (msg, nmes, nerr, iert, ni, i1, i2, nr, r1, r2)
3       integer nmes, nerr, iert, ni, i1, i2, nr,lun, lunit, mesflg, nch
4
5       double precision r1, r2
6       character*(*) msg
7 c-----------------------------------------------------------------------
8 c%purpose
9 c subroutines xerrwv, xsetf, and xsetun, as given here, constitute
10 c a simplified version of the slatec error handling package.
11 c written by a. c. hindmarsh at llnl.  version of august 13, 1981.
12 c this version is in double precision.
13 c
14 c%calling sequence
15 c all arguments are input arguments.
16 c
17 c msg    = the message (character string).
18 c nmes   = the length of msg (not used).
19 c nerr   = the error number (not used).
20 c iert   = the error type..
21 c          1 means recoverable (control returns to caller).
22 c          2 means fatal (run is aborted--see note below).
23 c ni     = number of integers (0, 1, or 2) to be printed with message.
24 c i1,i2  = integers to be printed, depending on ni.
25 c nr     = number of reals (0, 1, or 2) to be printed with message.
26 c r1,r2  = reals to be printed, depending on nr.
27 c
28 c%note..
29 c    this routine is machine-dependent and specialized for use
30 c in limited context, in the following ways..
31 c 2. the value of nmes is assumed to be at most 80.
32 c    (multi-line messages are generated by repeated calls.)
33 c 3. if iert = 2, control passes to the statement   stop
34 c    to abort the run.  this statement may be machine-dependent.
35 c 4. r1 and r2 are assumed to be in double precision and are printed
36 c    in d21.13 format.
37 c 5. the common block /eh0001/ below is data-loaded (a machine-
38 c    dependent feature) with default values.
39 c    this block is needed for proper retention of parameters used by
40 c    this routine which the user can reset by calling xsetf or xsetun.
41 c    the variables in this block are as follows..
42 c       mesflg = print control flag..
43 c                1 means print all messages (the default).
44 c                0 means no printing.
45 c       lunit  = logical unit number for messages.
46 c                the default is 6 (machine-dependent).
47 c-----------------------------------------------------------------------
48 c%instalation
49 c the following are instructions for installing this routine
50 c in different machine environments.
51 c
52 c to change the default output unit, change the data statement
53 c in the block data subprogram below.
54 c
55 c for a different run-abort command, change the statement following
56 c statement 100 at the end.
57 c!
58 c-----------------------------------------------------------------------
59       include 'stack.h'
60       integer num, imess, imode
61       common /eh0001/ mesflg, lunit
62       integer         iero
63       common /ierode/ iero
64       character*80 str
65 c-----------------------------------------------------------------------
66       if (mesflg .eq. 0) go to 100
67 c get logical unit number. ---------------------------------------------
68
69 cstd      lun = lunit
70       lun = wte
71 c get number of words in message. --------------------------------------
72       nch = min(len(msg),80)
73 c write the message. ---------------------------------------------------
74 c     retrieve display information
75       call errmds(num,imess,imode)
76 cstd      write (lun, 10) (msg(i:i),i=1,nch)
77 cstd 10   format(1x,80a1)
78 c     print if we are not inside of an execstr("...", "errcatch", "n")
79       if (imess .eq. 0) then
80          call basout(io,lun,msg(1:nch))
81       endif
82       if (ni .eq. 1) then
83 cstd         write (lun, 20) i1
84          write (str, 20) i1
85  20      format(6x,'where i1 is : ',i10)
86          if (imess .eq. 0) then
87             call basout(io,lun,str)
88          endif
89       elseif (ni .eq. 2) then
90 cstd         write (lun, 30) i1,i2
91          write (str, 30) i1,i2
92  30      format(6x,'where i1 is : ',i10,3x,' and i2 : ',i10)
93          if (imess .eq. 0) then
94             call basout(io,lun,str)
95          endif
96       endif
97       if (nr .eq. 1) then
98 cstd         write (lun, 40) r1
99          write (str, 40) r1
100  40      format(6x,'where r1 is : ',d21.13)
101          if (imess .eq. 0) then
102             call basout(io,lun,str)
103          endif
104       elseif (nr .eq. 2) then
105 cstd         write (lun, 50) r1,r2
106          write (str, 50) r1,r2
107  50      format(6x,'where r1 is : ',d21.13,3x,'and r2 : ',d21.13)
108          if (imess .eq. 0) then
109             call basout(io,lun,str)
110          endif
111       endif
112 c abort the run if iert = 2. -------------------------------------------
113  100  if (iert .ne. 2) return
114       iero = 1
115       end