! 21Jul1999 fgtok -impno -s r8_precision.sub "r8con.csh conversion"
c  dmc-- lsode error message routine
c   portability modifications:  21 July 1999
c
c     to set error message unit number (lun),
c     call xsetun_lsode(lun)
c     don't use call xsetun(lun) -- xsetun name conflicts with slatec
c     which has an incompatible messaging system
c
c     to set message level (mesflg=0, no messages, danger!, or mesflg=1),
c     call xsetf_lsode(mesflg)
c     don't use call xsetf(mesflg) -- xsetf name conflicts with slatec
c     which has an incompatible messaging system
c
c     the xerrwv code has been changed for portability, so that
c     conditional compilation or actual code modification is not
c     necessary when moving from machine to machine.  this is done
c     by using the integer function isize_get_lsode which is a C
c     code that calls sizeof(int) to get the number of bytes, characters,
c     per integer word.
c
      subroutine xerrwv_r8 (msg, nmes, nerr, level, ni, i1, i2, nr, 
     1     r1, r2)
 
      IMPLICIT NONE
      integer msg, nmes, nerr, level, ni, i1, i2, nr,
     1   i, lun, lunit, mesflg, ncpw, nch, nwds
      INTEGER isize_get_lsode_r8,idum
      REAL*8 r1, r2
      dimension msg(nmes)
c
c-----------------------------------------------------------------------
c subroutines xerrwv, xsetf, and xsetun, as given here, constitute
c a simplified version of the slatec error handling package.
c written by a. c. hindmarsh at llnl.  version of march 30, 1987.
c
c all arguments are input arguments.
c
c msg    = the message (hollerith literal or integer array).
c nmes   = the length of msg (number of characters).
c nerr   = the error number (not used).
c level  = the error level..
c          0 or 1 means recoverable (control returns to caller).
c          2 means fatal (run is aborted--see note below).
c ni     = number of integers (0, 1, or 2) to be printed with message.
c i1,i2  = integers to be printed, depending on ni.
c nr     = number of reals (0, 1, or 2) to be printed with message.
c r1,r2  = reals to be printed, depending on nr.
c
c note..  this routine is machine-dependent and specialized for use
c in limited context, in the following ways..
c 1. the number of hollerith characters stored per word, denoted
c    by ncpw below, is a data-loaded constant.
c 2. the value of nmes is assumed to be at most 60.
c    (multi-line messages are generated by repeated calls.)
c 3. if level = 2, control passes to the statement   stop
c    to abort the run.  this statement may be machine-dependent.
c 4. r1 and r2 are assumed to be in single precision and are printed
c    in e21.13 format.
c 5. the common block /eh0001/ below is data-loaded (a machine-
c    dependent feature) with default values.
c    this block is needed for proper retention of parameters used by
c    this routine which the user can reset by calling xsetf or xsetun.
c    the variables in this block are as follows..
c       mesflg = print control flag..
c                1 means print all messages (the default).
c                0 means no printing.
c       lunit  = logical unit number for messages.
c                the default is 6 (machine-dependent).
c-----------------------------------------------------------------------
c the following are instructions for installing this routine
c in different machine environments.
c
c to change the default output unit, change the data statement below.
c
c for some systems, the data statement below must be replaced
c by a separate block data subprogram.
c
c for a different number of characters per word, change the
c data statement setting ncpw below, and format 10.  alternatives for
c various computers are shown in comment cards.
c
c for a different run-abort command, change the statement following
c statement 100 at the end.
c-----------------------------------------------------------------------
      external xerrwv_blockd_r8
c
      common /eh0001/ mesflg, lunit
c
ccc   data mesflg/1/, lunit/6/  ! dmc -- see block data
c-----------------------------------------------------------------------
c the following data-loaded value of ncpw is valid for the cdc-6600
c and cdc-7600 computers.
c     data ncpw/10/
c the following is valid for the cray-1 computer.
ccc      data ncpw/8/
c the following is valid for the burroughs 6700 and 7800 computers.
c     data ncpw/6/
c the following is valid for the pdp-10 computer.
c     data ncpw/5/
c the following is valid for the vax computer with 4 bytes per integer,
c and for the ibm-360, ibm-370, ibm-303x, and ibm-43xx computers.
c     data ncpw/4/
c the following is valid for the pdp-11, or vax with 2-byte integers.
c     data ncpw/2/
c-----------------------------------------------------------------------
c  dmc -- local character variables
c
      integer ichari
      character*20 buf0
      character*60 buf1
c
c-----------------------------------------------------------------------
c
      if (mesflg .eq. 0) go to 100
c get logical unit number. ---------------------------------------------
      lun = lunit
c get number of words in message. --------------------------------------
      ncpw = isize_get_lsode_r8(idum)      ! dmc -- get ncpw from C code
      nch = min(nmes,60)
      nwds = nch/ncpw
      if (nch .ne. nwds*ncpw) nwds = nwds + 1
c generate the message
      ichari=0
      do i=1,nwds
         write(buf0,'(A)') msg(i)
         buf1(ichari+1:ichari+ncpw)=buf0(1:ncpw)
         ichari=ichari+ncpw
      enddo
c write the message. ---------------------------------------------------
      write (lun, '(1x,A)') buf1
ccc      write (lun, 10) (msg(i),i=1,nwds)
c-----------------------------------------------------------------------
c the following format statement is to have the form
c 10  format(1x,mmann)
c where nn = ncpw and mm is the smallest integer .ge. 60/ncpw.
c the following is valid for ncpw = 10.
c 10  format(1x,6a10)
c the following is valid for ncpw = 8.
  10  format(1x,8a8)
c the following is valid for ncpw = 6.
c 10  format(1x,10a6)
c the following is valid for ncpw = 5.
c 10  format(1x,12a5)
c the following is valid for ncpw = 4.
c 10  format(1x,15a4)
c the following is valid for ncpw = 2.
c 10  format(1x,30a2)
c-----------------------------------------------------------------------
      if (ni .eq. 1) write (lun, 20) i1
 20   format(6x,23hin above message,  i1 =,i10)
      if (ni .eq. 2) write (lun, 30) i1,i2
 30   format(6x,23hin above message,  i1 =,i10,3x,4hi2 =,i10)
      if (nr .eq. 1) write (lun, 40) r1
 40   format(6x,23hin above message,  r1 =,e21.13)
      if (nr .eq. 2) write (lun, 50) r1,r2
 50   format(6x,15hin above,  r1 =,e21.13,3x,4hr2 =,e21.13)
c abort the run if level = 2. ------------------------------------------
 100  if (level .ne. 2) return
      call errmsg_exit('lsode error exit!')
      !!! stop
c----------------------- end of subroutine xerrwv ----------------------
      end
c-----------------------------------------------------------------------
      block data xerrwv_blockd_r8
c
      IMPLICIT NONE
      INTEGER mesflg,lunit
      common /eh0001/ mesflg, lunit
 
      data mesflg/1/, lunit/6/
c
      end
c-----------------------------------------------------------------------
      subroutine xsetun_lsode_r8(lun)
c
      IMPLICIT NONE
      INTEGER mesflg,lunit,lun
      common /eh0001/ mesflg, lunit
 
      lunit=lun
c
      return
      end
c-----------------------------------------------------------------------
      subroutine xsetf_lsode_r8(imes)
c
      IMPLICIT NONE
      INTEGER mesflg,lunit,imes
      common /eh0001/ mesflg, lunit
 
      if(imes.eq.0) then
         mesflg=0
      else
         mesflg=1
      endif
c
      return
      end
c-----------------------------------------------------------------------
