9f8f03af9512497abb7a87c629d855a7dec85aa7
[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       character*80 str
63 c-----------------------------------------------------------------------
64       if (mesflg .eq. 0) go to 100
65 c get logical unit number. ---------------------------------------------
66
67 cstd      lun = lunit
68       lun = wte
69 c get number of words in message. --------------------------------------
70       nch = min(len(msg),80)
71 c write the message. ---------------------------------------------------
72 c     retrieve display information
73       call errmds(num,imess,imode)
74 cstd      write (lun, 10) (msg(i:i),i=1,nch)
75 cstd 10   format(1x,80a1)
76 c     print if we are not inside of an execstr("...", "errcatch", "n")
77       if (imess .eq. 0) then
78          call basout(io,lun,msg(1:nch))
79       endif
80       if (ni .eq. 1) then
81 cstd         write (lun, 20) i1
82          write (str, 20) i1
83  20      format(6x,'where i1 is : ',i10)
84          if (imess .eq. 0) then
85             call basout(io,lun,str)
86          endif
87       elseif (ni .eq. 2) then
88 cstd         write (lun, 30) i1,i2
89          write (str, 30) i1,i2
90  30      format(6x,'where i1 is : ',i10,3x,' and i2 : ',i10)
91          if (imess .eq. 0) then
92             call basout(io,lun,str)
93          endif
94       endif
95       if (nr .eq. 1) then
96 cstd         write (lun, 40) r1
97          write (str, 40) r1
98  40      format(6x,'where r1 is : ',d21.13)
99          if (imess .eq. 0) then
100             call basout(io,lun,str)
101          endif
102       elseif (nr .eq. 2) then
103 cstd         write (lun, 50) r1,r2
104          write (str, 50) r1,r2
105  50      format(6x,'where r1 is : ',d21.13,3x,'and r2 : ',d21.13)
106          if (imess .eq. 0) then
107             call basout(io,lun,str)
108          endif
109       endif
110 c abort the run if iert = 2. -------------------------------------------
111  100  if (iert .ne. 2) return
112       ierror = 1
113       end