      SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,ne,nb,m,y,nyj,nyk,
     *c,nci,ncj,nck,s,nsi,nsj)
      INTEGER itmax,m,nb,nci,ncj,nck,ne,nsi,nsj,nyj,nyk,indexv(nyj),NMAX
      REAL conv,slowc,c(nci,ncj,nck),s(nsi,nsj),scalv(nyj),y(nyj,nyk)
      PARAMETER (NMAX=10)
CU    USES bksub,difeq,pinvs,red
      INTEGER ic1,ic2,ic3,ic4,it,j,j1,j2,j3,j4,j5,j6,j7,j8,j9,jc1,jcf,
     *jv,k,k1,k2,km,kp,nvars,kmax(NMAX)
      REAL err,errj,fac,vmax,vz,ermax(NMAX)
      k1=1
      k2=m
      nvars=ne*m
      j1=1
      j2=nb
      j3=nb+1
      j4=ne
      j5=j4+j1
      j6=j4+j2
      j7=j4+j3
      j8=j4+j4
      j9=j8+j1
      ic1=1
      ic2=ne-nb
      ic3=ic2+1
      ic4=ne
      jc1=1
      jcf=ic3
      do 16 it=1,itmax
        k=k1
        call difeq(k,k1,k2,j9,ic3,ic4,indexv,ne,s,nsi,nsj,y,nyj,nyk)
        call pinvs(ic3,ic4,j5,j9,jc1,k1,c,nci,ncj,nck,s,nsi,nsj)
        do 11 k=k1+1,k2
          kp=k-1
          call difeq(k,k1,k2,j9,ic1,ic4,indexv,ne,s,nsi,nsj,y,nyj,nyk)
          call red(ic1,ic4,j1,j2,j3,j4,j9,ic3,jc1,jcf,kp,c,nci,ncj,nck,
     *s,nsi,nsj)
          call pinvs(ic1,ic4,j3,j9,jc1,k,c,nci,ncj,nck,s,nsi,nsj)
11      continue
        k=k2+1
        call difeq(k,k1,k2,j9,ic1,ic2,indexv,ne,s,nsi,nsj,y,nyj,nyk)
        call red(ic1,ic2,j5,j6,j7,j8,j9,ic3,jc1,jcf,k2,c,nci,ncj,nck,s,
     *nsi,nsj)
        call pinvs(ic1,ic2,j7,j9,jcf,k2+1,c,nci,ncj,nck,s,nsi,nsj)
        call bksub(ne,nb,jcf,k1,k2,c,nci,ncj,nck)
        err=0.
        do 13 j=1,ne
          jv=indexv(j)
          errj=0.
          km=0
          vmax=0.
          do 12 k=k1,k2
            vz=abs(c(jv,1,k))
            if(vz.gt.vmax) then
               vmax=vz
               km=k
            endif
            errj=errj+vz
12        continue
          err=err+errj/scalv(j)
          ermax(j)=c(jv,1,km)/scalv(j)
          kmax(j)=km
13      continue
        err=err/nvars
        fac=slowc/max(slowc,err)
        do 15 j=1,ne
          jv=indexv(j)
          do 14 k=k1,k2
            y(j,k)=y(j,k)-fac*c(jv,1,k)
14        continue
15      continue
        write(*,100) it,err,fac
        if(err.lt.conv) return
16    continue
      pause 'itmax exceeded in solvde'
100   format(1x,i4,2f12.6)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/solvde.for


C> \ingroup selci
C> @{
C>
C> \brief Find the eigenvalues of a symmetric tridiagonal matrix
C>
C>
C> This subroutine is a translation of the algol procedure
C> tqlrat [1].
C>
C> This subroutine finds the eigenvalues of a symmetric
C> tridiagonal matrix by the rational ql method.
C>
C> Calls pythag for  dsqrt(a*a + b*b) .
C>
C> Questions and comments should be directed to Burton S. Garbow,
C> mathematics and computer science div, argonne national laboratory
C>
C> This version dated august 1983.
C>
C>
C> ### References ###
C>
C> [1] C.H. Reinsch, "Algorithm 464: eigenvalues of a real, symmetric,
C>     tridiagonal matrix [F2]", Comm. ACM. 16 (1973) 689,
C>     doi:
C>     10.1145/355611.362539.
C>
      subroutine selci_tqlrat(n,d,e2,ierr)
*
* $Id$
*
c
      integer n !< [Input] The order of the matrix
      double precision d(n) !< [In/Output] The diagonal of the matrix
                            !< - On input: the diagonal of the
                            !<   tridiagonal matrix
                            !< - On output: the eigenvalues of the
                            !<   matrix
      double precision e2(n) !< [In/Output] The off diagonal elements
                             !< - On input: the squares of the
                             !<   subdiagonal elements of the input
                             !<   matrix in the positions 2:n,
                             !<   element e2(1) is arbitrary
                             !< - On output: destroyed
      integer ierr !< [Output] Error flag
                   !< - 0: routine completed successfully
                   !< - j: Eigenvalue j and further are not converged
      integer i,j,l,m,ii,l1,mml
      double precision b,c,f,g,h,p,r,s,t,selci_epslon,selci_pythag
c
c     this subroutine is a translation of the algol procedure tqlrat,
c     algorithm 464, comm. acm 16, 689(1973) by reinsch.
c
c     this subroutine finds the eigenvalues of a symmetric
c     tridiagonal matrix by the rational ql method.
c
c     on input
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e2 contains the squares of the subdiagonal elements of the
c          input matrix in its last n-1 positions.  e2(1) is arbitrary.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct and
c          ordered for indices 1,2,...ierr-1, but may not be
c          the smallest eigenvalues.
c
c        e2 has been destroyed.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e2(i-1) = e2(i)
c
      f = 0.0d0
      t = 0.0d0
      e2(n) = 0.0d0
c
      do 290 l = 1, n
         j = 0
         h = dabs(d(l)) + dsqrt(e2(l))
         if (t .gt. h) go to 105
         t = h
         b = selci_epslon(t)
         c = b * b
c     .......... look for small squared sub-diagonal element ..........
  105    do 110 m = l, n
            if (e2(m) .le. c) go to 120
c     .......... e2(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 210
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         s = dsqrt(e2(l))
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * s)
         r = selci_pythag(p,1.0d0)
         d(l) = s / (p + dsign(r,p))
         h = g - d(l)
c
         do 140 i = l1, n
  140    d(i) = d(i) - h
c
         f = f + h
c     .......... rational ql transformation ..........
         g = d(m)
         if (g .eq. 0.0d0) g = b
         h = g
         s = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            i = m - ii
            p = g * h
            r = p + e2(i)
            e2(i+1) = s * r
            s = e2(i) / r
            d(i+1) = h + s * (h + d(i))
            g = d(i) - e2(i) / g
            if (g .eq. 0.0d0) g = b
            h = g * p / r
  200    continue
c
         e2(l) = s * g
         d(l) = h
c     .......... guard against underflow in convergence test ..........
         if (h .eq. 0.0d0) go to 210
         if (dabs(e2(l)) .le. dabs(c/h)) go to 210
         e2(l) = h * e2(l)
         if (e2(l) .ne. 0.0d0) go to 130
  210    p = d(l) + f
c     .......... order eigenvalues ..........
         if (l .eq. 1) go to 250
c     .......... for i=l step -1 until 2 do -- ..........
         do 230 ii = 2, l
            i = l + 2 - ii
            if (p .ge. d(i-1)) go to 270
            d(i) = d(i-1)
  230    continue
c
  250    i = 1
  270    d(i) = p
  290 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      double precision function selci_epslon(x)
      double precision x
c
c     estimate unit roundoff in quantities of size x.
c
      double precision a,b,c,eps
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing floating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in floating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger floating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     this version dated 4/6/83.
c
      a = 4.0d0/3.0d0
   10 b = a - 1.0d0
      c = b + b + b
      eps = dabs(c-1.0d0)
      if (eps .eq. 0.0d0) go to 10
      selci_epslon = eps*dabs(x)
      return
      end
      double precision function selci_pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 selci_pythag = p
      return
      end
C>
C> @}


!==============================================================================!
  subroutine Cgs(sol, x, b, prec, miter, niter, tol, fin_res, norm)
!------------------------------------------------------------------------------!
!   Solves the linear systems of equations by a precond. CGS Method.           !
!------------------------------------------------------------------------------!
!   Allows preconditioning of the system by:                                   !
!     1. Diagonal preconditioning                                              !
!     2. Incomplete Cholesky preconditioning                                   !
!                                                                              !
!   The type of precondtioning is chosen by setting the variable prec to 0     !
!   (for no preconditioning), 1 (for diagonal preconditioning) or 2 (for       !
!   incomplete Cholesky preconditioning)                                       !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: p1         => r_cell_01,  &
                      p2         => r_cell_02,  &
                      q1         => r_cell_03,  &
                      q2         => r_cell_04,  &
                      r1         => r_cell_06,  &
                      r2         => r_cell_07,  &
                      u1         => r_cell_08,  &
                      u2         => r_cell_09,  &
                      v2         => r_cell_10,  &
                      u1_plus_q1 => r_cell_11
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Solver_Type), target :: sol
  real              :: x(-sol % pnt_grid % n_bnd_cells :  &
                          sol % pnt_grid % n_cells)
  real              :: b( sol % pnt_grid % n_cells)  ! [A]{x}={b}
  character(len=80) :: prec                          ! preconditioner
  integer           :: miter                         ! max and actual ...
  integer           :: niter                         ! ... num. iterations
  real              :: tol                           ! tolerance
  real              :: fin_res                       ! residual
  real, optional    :: norm                          ! normalization
!-----------------------------------[Locals]-----------------------------------!
  type(Matrix_Type), pointer :: a
  type(Matrix_Type), pointer :: d
  integer                    :: nt, ni, nb
  real                       :: alfa, beta, rho, rho_old, bnrm2, res
  integer                    :: i, j, k, iter
!==============================================================================!

  ! Take some aliases
  a => sol % a
  d => sol % d
  nt = a % pnt_grid % n_cells
  ni = a % pnt_grid % n_cells - a % pnt_grid % comm % n_buff_cells
  nb = a % pnt_grid % n_bnd_cells

  res = 0.0

  !---------------------!
  !   Preconditioning   !
  !---------------------!
  call Prec_Form(ni, a, d, prec)

  !-----------------------------------!
  !    This is quite tricky point.    !
  !   What if bnrm2 is very small ?   !
  !-----------------------------------!
  if(.not. present(norm)) then
    bnrm2 = Normalized_Root_Mean_Square(ni, b(1:nt), a, x(1:nt))
  else
    bnrm2 = Normalized_Root_Mean_Square(ni, b(1:nt), a, x(1:nt), norm)
  end if

  if(bnrm2 < tol) then
    iter=0
    goto 1
  end if

  !-----------------!
  !   r1 = b - Ax   !
  !-----------------!
  call Residual_Vector(ni, r1(1:nt), b(1:nt), a, x(1:nt))

  !--------------------------------!
  !   Calculate initial residual   !
  !--------------------------------!
  res = Normalized_Root_Mean_Square(ni, r1(1:nt), a, x(1:nt))

  if(res < tol) then
    iter=0
    goto 1
  end if

  !-------------!
  !   r2 = r1   !
  !-------------!
  r2(1:ni) = r1(1:ni)

  !---------------!
  !               !
  !   Main loop   !
  !               !
  !---------------!
  do iter = 1, miter

    !-------------------!
    !   rho = (r2,z1)   !
    !-------------------!
    rho = dot_product(r1(1:ni), r2(1:ni))
    call Comm_Mod_Global_Sum_Real(rho)

    if(iter .eq. 1) then
      u1(1:ni) = r1(1:ni)
      u2(1:ni) = u1(1:ni)
    else
      beta = rho / rho_old
      u1(1:ni) = r1(1:ni) + beta *  q1(1:ni)
      u2(1:ni) = u1(1:ni) + beta * (q1(1:ni) + beta*u2(1:ni))
    end if

    !---------------------!
    !   Solve M p2 = u2   !
    !---------------------!
    call Prec_Solve(ni, a, d, p2(1:nt), u2(1:nt), prec)

    !--------------!
    !   v2 = Ap2   !
    !--------------!
    call Grid_Mod_Exchange_Cells_Real(a % pnt_grid, p2(-nb:ni))
    do i = 1, ni
      v2(i) = 0.0
      do j = a % row(i), a % row(i+1)-1
        k = a % col(j)
        v2(i) = v2(i) + a % val(j) * p2(k)
      end do
      alfa = alfa + r2(i) * v2(i)
    end do

    !------------------------!
    !   alfa = rho/(r2,v2)   !
    !------------------------!
    alfa = dot_product(r2(1:ni), v2(1:ni))
    call Comm_Mod_Global_Sum_Real(alfa)
    alfa=rho / alfa

    !-------------------------!
    !   q1 = u1 - alfa * v2   !
    !-------------------------!
    q1(1:ni) = u1(1:ni) - alfa * v2(1:ni)

    !-------------------------!
    !   solve Mp1 = u1 + q1   !
    !-------------------------!
    u1_plus_q1(1:ni) = u1(1:ni) + q1(1:ni)
    call Prec_Solve(ni, a, d, p1(1:nt), u1_plus_q1(1:nt), prec)

    !---------------------!
    !   x = x + alfa p1   !
    !---------------------!
    x(1:ni) = x(1:ni) + alfa * p1(1:ni)

    !---------------!
    !   q2 = A p1   !
    !---------------!
    call Grid_Mod_Exchange_Cells_Real(a % pnt_grid, p1(-nb:ni))
    do i = 1, ni
      q2(i) = 0.0
      do j = a % row(i), a % row(i+1)-1
        k = a % col(j)
        q2(i) = q2(i) + a % val(j) * p1(k)
      end do
    end do

    !---------------------!
    !   r = r - alfa q2   !
    !---------------------!
    r1(1:ni) = r1(1:ni) - alfa * q2(1:ni)

    !-----------------------!
    !   Check convergence   !
    !-----------------------!
    if(.not. present(norm)) then
      res = Normalized_Root_Mean_Square(ni, r1(1:nt), a, x(1:nt))
    else
      res = Normalized_Root_Mean_Square(ni, r1(1:nt), a, x(1:nt), norm)
    end if

    if(res < tol) goto 1

    rho_old=rho

  end do                ! iter

  !----------------------------------!
  !                                  !
  !   Convergence has been reached   !
  !                                  !
  !----------------------------------!
1 continue
  fin_res = res
  niter  = iter

  end subroutine


program test

  use pix_tools
  use fitstools, only: getsize_fits, input_map
  use nrtype
  use nrutil
  use ran_state

  IMPLICIT NONE
  DOUBLE PRECISION theta,phi
  integer nside,ipix

  nside=2048
  theta=0.4543
  phi=1.75574

  call ang2pix_ring(nside,theta,phi,ipix)
  write(*,*) 'pixel=', ipix

end program


	SUBROUTINE GH_WRNG  ( ntime, data, iloc1, iloc2, range, ystrt,
     +			     ystop, nylbl, ylbl, iret )
C************************************************************************
C* GH_WRNG								*
C*									*
C* This subroutine chooses a range for the wind data.			*
C*									*
C* GH_WRNG  ( NTIME, DATA, ILOC1, ILOC2, RANGE, YSTRT, YSTOP, NYLBL,	*
C*           YLBL, IRET )						*
C*									*
C* Input parameters:							*
C*									*
C*	NTIME		INTEGER		Number of times in data array   *
C*	DATA (NTIME)    REAL		Data values			*
C*									*
C* Output parameters:							*
C*	ILOC1		INTEGER		Location of minimum value	*
C*	ILOC2		INTEGER		Location of maximum value	*
C*	RANGE 		CHAR*		Range between labels		*
C*	YSTRT 		REAL		Starting y axis value		*
C*	YSTOP 		REAL		Ending y axis value		*
C*	NYLBL 		INTEGER		Number of y axis labels		*
C*	YLBL (NYLBL)	REAL		Array of y axis labels		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* A. Hardy/GSC		 4/01	Modified from SFXRNG			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	range
	REAL		data (*), ylbl (*), ystrt, ystop
C*
	CHARACTER	rrr*48, tmp(3)*20, tmp1*20, chmax*3, chmin*3,
     +                  parm*4
	REAL		value (3)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the minimum and maximum from the data.
C
	np = iloc2 - iloc1 + 1
	CALL GR_STAT  ( data , ntime, np, 1, 1, ntime, np,
     +			rmin, rmax, ravg, rdev, ier )
	IF  ( ERMISS ( rmin ) )  THEN
	    nylbl = 0
	    ystrt = 0
	    ystop = 1
	    RETURN
	END IF
	dmin = rmin
	dmax = rmax
        IF (dmin .lt. 0 ) dmin = 0.
C
C*          Round lower limit down to nearest 5 mph
C*          Round upper limit up to nearest 5 mph
C
            maxint = INT ( (( dmax) + 4.5 ) / 5.0 ) * 5 + 5
            minint = INT ( (( dmin) - 2.5 ) / 5.0 ) * 5
            IF ( minint .lt. 0 ) minint = 0
C
C*          Make range divisible by 10 mph
C
	    IF ( ( ( MOD ( minint,10 ) .eq. 0 ) .and.
     +             ( MOD ( maxint, 10) .ne. 0 ) ) .or.
     +           ( ( MOD ( minint, 10) .ne. 0 ) .and.
     +             ( MOD ( maxint, 10 ) .eq. 0 ) ) ) THEN
                   maxint = maxint + 5
            END IF
C
            rmax = FLOAT ( maxint )
            rmin = FLOAT ( minint )
C
C*	Check for conditional axis limits denoted by +.  If a
C*	start or stop value is preceded by a +, then that value
C*	is used as an axis limit unless the data actually goes
C*	beyond it.
C
C*	FIRST check for the case when the start value equals the
C*	stop value.  This value (x) is the range about the mean of
C*	the data.  The axis ranges from RAVG - x to RAVG + x.  If
C*	the data goes beyond this range it will not be visible.
C

        CALL ST_INCH ( minint, chmin, ier)
        CALL ST_INCH ( maxint, chmax, ier)
        CALL ST_LSTR (chmin, lenn, ier )
        CALL ST_LSTR (chmax, lenx, ier )
	rrr = chmin(:lenn) // ';' // chmax(:lenx) // ';-10;'
	CALL ST_CLST ( rrr, ';', ' ', 3, tmp, ns, ier )
	DO i = 1, 3
	    IF ( tmp (i) .eq. ' ' ) THEN
		value (i) = RMISSD
	    ELSE
		iplus = INDEX ( tmp (i), '+' )
		tmp1 = tmp (i) ( (iplus+1): )
		CALL ST_CRNM ( tmp1, value (i), ier )
	    END IF
	END DO
	IF ( .not. ERMISS ( value (1) ) .and. value (1) .eq.
     +	     value (2) ) THEN
	    rmin = ravg - ABS ( value (1) )
	    rmax = ravg + ABS ( value (1) )
	    value (1) = rmin
	    value (2) = rmax
	    CALL ST_RLCH  ( rmin, 5, tmp1, ier )
	    CALL ST_LSTR ( tmp1, lng, ier )
	    IF ( INDEX ( tmp(1), '+' ) .eq. 0 ) THEN
		tmp (1) = tmp1 (1:lng)
	    ELSE
		tmp (1) = '+' // tmp1 (1:lng)
	    END IF
	    CALL ST_RLCH  ( rmax, 5, tmp1, ier )
	    CALL ST_LSTR ( tmp1, lng, ier )
	    IF ( INDEX ( tmp(2), '+' ) .eq. 0 ) THEN
		tmp (2) = tmp1 (1:lng)
	    ELSE
		tmp (2) = '+' // tmp1 (1:lng)
	    END IF
	END IF
C
C*	Process +'s; replace the semicolons in range with slashes.
C
	rrr = ' '
	DO i = 1, 3
	    IF ( ERMISS ( value (i) ) ) tmp (i) = ' '
	    iplus = INDEX ( tmp(i), '+' )
	    IF ( iplus .ne. 0 ) THEN
		IF ( i .eq. 1 .and. dmin .lt. value(i) ) THEN
		    rmin = dmin
		    rrr = ' '
		ELSE IF ( i .eq. 2 .and. dmax .gt. value(i) ) THEN
		    rmax = dmax
		    CALL ST_LSTR ( rrr, lng, ier )
		    IF ( lng .gt. 0 ) THEN
			rrr = rrr (1:lng) // '/' // ' '
		    ELSE
			rrr = '/' // ' '
		    END IF
		ELSE IF ( i .eq. 1 ) THEN
		    CALL ST_RLCH ( value(i), 5, tmp1, ier )
		    IF ( ERMISS ( value (i) ) ) tmp1 = ' '
		    CALL ST_LSTR ( tmp1, lngt, ier )
		    rrr = tmp1 (1:lngt)
		ELSE
		    CALL ST_RLCH ( value(i), 5, tmp1, ier )
		    IF ( ERMISS ( value (i) ) ) tmp1 = ' '
		    CALL ST_LSTR ( tmp1, lngt, ier )
		    CALL ST_LSTR ( rrr, lng, ier )
		    rrr = rrr (1:lng) // '/' // tmp1 (1:lngt)
		END IF
	    ELSE IF ( i .eq. 1 ) THEN
		rrr = tmp (1)
	    ELSE
		tmp1 = tmp (i)
		CALL ST_LSTR ( tmp1, lngt, ier )
		CALL ST_LSTR ( rrr, lng, ier )
		rrr = rrr (1:lng) // '/' // tmp1 (1:lngt)
	    END IF
	END DO
C
C*	Get points along axis.
C
	ilfdef = 1
     	igfdef = 0
	itfdef = 0
        icord = 0
        parm = ' '

        CALL ST_LSTR ( rrr, lenr, ier )
	CALL IN_AXIS  ( rrr(:lenr), icord, .false. , parm,
     +                  rmin, rmax, ilfdef, igfdef, itfdef, ystrt,
     +			ystop, ylbl, nylbl, ilbfrq, iglfrq, itmfrq,
     +			ier )
C*
	RETURN
	END


! eos_lj_module.f90
! Routines for Lennard-Jones fitted equations of state
MODULE eos_lj_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! The routines in this module use the fitting function described and parametrized in
  ! M Thol, G Rutkai, R Span, J Vrabec, R Lustig, Int J Thermophys 36, 25 (2015)
  ! M Thol, G Rutkai, A Koester, R Lustig, R Span, J Vrabec, J Phys Chem Ref Data 45, 023101 (2016)
  ! Those authors also supply C++ codes (in the supplementary information of those papers)
  ! They are NOT responsible for this Fortran code, which was written independently by Michael P Allen
  ! A similar notation, consistent with the papers, is retained for clarity.

  IMPLICIT NONE
  PRIVATE

  ! Public routines
  PUBLIC :: a_res_full, a_res_cutshift

  ! Private derived types for sets of coefficients

  TYPE :: power_type ! Coefficients for power function
     REAL :: n ! Amplitude
     REAL :: t ! Power of tau
     REAL :: d ! Power of delta
  END TYPE power_type

  TYPE :: expon_type ! Coefficients for exponential function
     REAL :: n ! Amplitude
     REAL :: t ! Power of tau
     REAL :: d ! Power of delta
     REAL :: l ! Power of delta in exponent
  END TYPE expon_type

  TYPE :: gauss_type ! Coefficients for Gaussian function
     REAL :: n       ! Amplitude
     REAL :: t       ! Power of tau
     REAL :: d       ! Power of delta
     REAL :: beta    ! Width factor for tau
     REAL :: gamma   ! Shift factor for tau
     REAL :: eta     ! Width factor for delta
     REAL :: epsilon ! Shift factor for delta
  END TYPE gauss_type

  ! Private arrays of coefficients for each function
  TYPE(power_type), DIMENSION(:), ALLOCATABLE :: cp ! Coefficients for powers
  TYPE(expon_type), DIMENSION(:), ALLOCATABLE :: ce ! Coefficients for exponentials
  TYPE(gauss_type), DIMENSION(:), ALLOCATABLE :: cg ! Coefficients for Gaussians

CONTAINS

  FUNCTION power ( tau, delta, c ) RESULT ( f )
    IMPLICIT NONE
    REAL, DIMENSION(0:2,0:2)            :: f     ! Returns power function and scaled derivatives
    REAL,                    INTENT(in) :: tau   ! Reduced inverse temperature
    REAL,                    INTENT(in) :: delta ! Reduced density
    TYPE(power_type),        INTENT(in) :: c     ! Coefficients

    ! f(0,0) is n*(tau**t)*(delta**d)
    ! f(i,:) is differentiated i times with respect to tau, and then multiplied by tau**i
    ! f(:,j) is differentiated j times with respect to delta, and then multiplied by delta**j

    f(:,:) = c%n * (tau**c%t) * (delta**c%d)
    f(1,:) = f(1,:) * c%t
    f(2,:) = f(2,:) * c%t * ( c%t - 1.0 )
    f(:,1) = f(:,1) * c%d
    f(:,2) = f(:,2) * c%d * ( c%d - 1.0 )

  END FUNCTION power

  FUNCTION expon ( tau, delta, c ) RESULT ( f )
    IMPLICIT NONE
    REAL, DIMENSION(0:2,0:2)            :: f     ! Returns exponential function and scaled derivatives
    REAL,                    INTENT(in) :: tau   ! Reduced inverse temperature
    REAL,                    INTENT(in) :: delta ! Reduced density
    TYPE(expon_type),        INTENT(in) :: c     ! Coefficients

    ! f(0,0) is n*(tau**t)*(delta**d)*exp(-delta**l)
    ! f(i,:) is differentiated i times with respect to tau, and then multiplied by tau**i
    ! f(:,j) is differentiated j times with respect to delta, and then multiplied by delta**j

    f(:,:) = c%n * (tau**c%t) * (delta**c%d) * EXP(-delta**c%l)
    f(1,:) = f(1,:) * c%t
    f(2,:) = f(2,:) * c%t * ( c%t - 1.0 )
    f(:,1) = f(:,1) * (c%d-c%l*delta**c%l)
    f(:,2) = f(:,2) * ( (c%d-c%l*delta**c%l) * (c%d-1.0-c%l*delta**c%l) - (c%l**2)*delta**c%l )

  END FUNCTION expon

  FUNCTION gauss ( tau, delta, c ) RESULT ( f )
    IMPLICIT NONE
    REAL, DIMENSION(0:2,0:2)            :: f     ! Returns Gaussian function and scaled derivatives
    REAL,                    INTENT(in) :: tau   ! Reduced inverse temperature
    REAL,                    INTENT(in) :: delta ! Reduced density
    TYPE(gauss_type),        INTENT(in) :: c     ! Coefficients

    ! f(0,0) is n*(tau**t)*exp(-beta*(tau-gamma)**2)*(delta**d)*exp(-eta*(delta-epsilon)**2)
    ! f(i,:) is differentiated i times with respect to tau, and then multiplied by tau**i
    ! f(:,j) is differentiated j times with respect to delta, and then multiplied by delta**j

    f(:,:) = c%n*(tau**c%t)*EXP(-c%beta*(tau-c%gamma)**2)*(delta**c%d)*EXP(-c%eta*(delta-c%epsilon)**2)
    f(1,:) = f(1,:) * ( c%t - 2.0*c%beta*tau*(tau-c%gamma) )
    f(2,:) = f(2,:) * ( ( c%t - 2.0*c%beta*tau*(tau-c%gamma) )**2 - c%t - 2*c%beta*tau**2 )
    f(:,1) = f(:,1) * ( c%d - 2.0*c%eta*delta*(delta-c%epsilon) )
    f(:,2) = f(:,2) * ( ( c%d - 2.0*c%eta*delta*(delta-c%epsilon) )**2 - c%d - 2*c%eta*delta**2 )

  END FUNCTION gauss

  FUNCTION a_res_full ( temp, rho ) RESULT ( a )
    IMPLICIT NONE
    REAL, DIMENSION(0:2,0:2) :: a    ! Reduced residual free energy and scaled derivatives
    REAL, INTENT(in)         :: temp ! Temperature in LJ units
    REAL, INTENT(in)         :: rho  ! Density in LJ units

    ! This routine is for the full Lennard-Jones potential
    ! In a(i,j), index i refers to the tau-derivative and index j to the delta-derivative
    ! The derivatives are multiplied by the corresponding powers of tau and delta
    ! a(i,:) is differentiated i times with respect to tau, and then multiplied by tau**i
    ! a(:,j) is differentiated j times with respect to delta, and then multiplied by delta**j

    REAL    :: tau, delta
    INTEGER :: i

    REAL, PARAMETER :: temp_crit = 1.32 ! Critical temperature
    REAL, PARAMETER :: rho_crit  = 0.31 ! Critical density

    tau   = temp_crit / temp ! Reduced inverse temperature
    delta = rho / rho_crit   ! Reduced density

    ! Coefficients taken from Table 2 of
    ! M Thol, G Rutkai, A Koester, R Lustig, R Span, J Vrabec, J Phys Chem Ref Data 45, 023101 (2016)

    ALLOCATE ( cp(6) )
    cp%n = [ 0.005208073, 2.186252, -2.161016, 1.452700, -2.041792, 0.18695286 ]
    cp%t = [ 1.000, 0.320, 0.505, 0.672, 0.843, 0.898 ]
    cp%d = [ 4.0,   1.0,   1.0,   2.0,   2.0,   3.0   ]

    ALLOCATE ( ce(6) )
    ce%n = [ -0.090988445, -0.49745610, 0.10901431, -0.80055922, -0.56883900, -0.62086250 ]
    ce%t = [ 1.294, 2.590, 1.786, 2.770, 1.786, 1.205 ]
    ce%d = [ 5.0,   2.0,   2.0,   3.0,   1.0,   1.0   ]
    ce%l = [ 1.0,   2.0,   1.0,   2.0,   2.0,   1.0   ]

    ALLOCATE ( cg(11) )
    cg%n       = [ -1.4667177,  1.8914690,  -0.13837010, -0.38696450, 0.12657020, 0.6057810, &
         &          1.1791890, -0.47732679, -9.9218575,  -0.57479320, 0.0037729230 ]
    cg%t       = [ 2.830,  2.548, 4.650, 1.385, 1.460, 1.351, 0.660, 1.496,   1.830, 1.616, 4.970 ]
    cg%d       = [ 1.0,    1.0,   2.0,   3.0,   3.0,   2.0,   1.0,   2.0,     3.0,   1.0,   1.0   ]
    cg%eta     = [ 2.067,  1.522, 8.82,  1.722, 0.679, 1.883, 3.925, 2.461,  28.2,   0.753, 0.82  ]
    cg%beta    = [ 0.625,  0.638, 3.91,  0.156, 0.157, 0.153, 1.16,  1.73,  383.0,   0.112, 0.119 ]
    cg%gamma   = [ 0.71,   0.86,  1.94,  1.48,  1.49,  1.945, 3.02,  1.11,    1.17,  1.33,  0.24  ]
    cg%epsilon = [ 0.2053, 0.409, 0.6,   1.203, 1.829, 1.397, 1.39,  0.539,   0.934, 2.369, 2.43  ]

    a = 0.0

    DO i = 1, SIZE(cp)
       a = a + power ( tau, delta, cp(i) )
    END DO

    DO i = 1, SIZE(ce)
       a = a + expon ( tau, delta, ce(i) )
    END DO

    DO i = 1, SIZE(cg)
       a = a + gauss ( tau, delta, cg(i) )
    END DO

    DEALLOCATE ( cp, ce, cg )

  END FUNCTION a_res_full

  FUNCTION a_res_cutshift ( temp, rho ) RESULT ( a )
    IMPLICIT NONE
    REAL, DIMENSION(0:2,0:2) :: a    ! Reduced residual free energy and scaled derivatives
    REAL, INTENT(in)         :: temp ! Temperature in LJ units
    REAL, INTENT(in)         :: rho  ! Density in LJ units

    ! This routine is for the Lennard-Jones potential cut-and-shifted at 2.5 sigma
    ! In a(i,j), index i refers to the tau-derivative and index j to the delta-derivative
    ! The derivatives are multiplied by the corresponding powers of tau and delta
    ! a(i,:) is differentiated i times with respect to tau, and then multiplied by tau**i
    ! a(:,j) is differentiated j times with respect to delta, and then multiplied by delta**j

    REAL    :: tau, delta
    INTEGER :: i

    REAL, PARAMETER :: temp_crit = 1.086 ! Critical temperature
    REAL, PARAMETER :: rho_crit  = 0.319 ! Critical density

    tau   = temp_crit / temp ! Reduced inverse temperature
    delta = rho / rho_crit   ! Reduced density

    ! Coefficients taken from Table 1 of
    ! M Thol, G Rutkai, R Span, J Vrabec, R Lustig, Int J Thermophys 36, 25 (2015)

    ALLOCATE ( cp(6) )
    cp%n = [ 0.015606084, 1.7917527, -1.9613228, 1.3045604, -1.8117673, 0.15483997 ]
    cp%t = [ 1.000, 0.304, 0.583, 0.662, 0.870, 0.870 ]
    cp%d = [ 4.0,   1.0,   1.0,   2.0,   2.0,   3.0   ]

    ALLOCATE ( ce(6) )
    ce%n = [ -0.094885204, -0.20092412,  0.11639644, -0.50607364, -0.58422807, -0.47510982 ]
    ce%t = [  1.250, 3.000, 1.700, 2.400, 1.960, 1.286 ]
    ce%d = [  5.0,   2.0,   2.0,   3.0,   1.0,   1.0   ]
    ce%l = [  1.0,   2.0,   1.0,   2.0,   2.0,   1.0   ]

    ALLOCATE ( cg(9) )
    cg%n       = [  0.0094333106, 0.30444628,  -0.0010820946, -0.099693391, 0.0091193522, &
         &          0.12970543,   0.023036030, -0.082671073,  -2.2497821 ]
    cg%t       = [  3.600, 2.080, 5.240, 0.960, 1.360, 1.655, 0.900, 0.860,  3.950 ]
    cg%d       = [  1.0,   1.0,   2.0,   3.0,   3.0,   2.0,   1.0,   2.0,    3.0   ]
    cg%eta     = [  4.70,  1.92,  2.70,  1.49,  0.65,  1.73,  3.70,  1.90,  13.2   ]
    cg%beta    = [ 20.0,   0.77,  0.5,   0.8,   0.4,   0.43,  8.0,   3.3,  114.0   ]
    cg%gamma   = [  1.0,   0.5,   0.8,   1.5,   0.7,   1.6,   1.3,   0.6,    1.3   ]
    cg%epsilon = [  0.55,  0.7,   2.0,   1.14,  1.2,   1.31,  1.14,  0.53,   0.96  ]

    a = 0.0

    DO i = 1, SIZE(cp)
       a = a + power ( tau, delta, cp(i) )
    END DO

    DO i = 1, SIZE(ce)
       a = a + expon ( tau, delta, ce(i) )
    END DO

    DO i = 1, SIZE(cg)
       a = a + gauss ( tau, delta, cg(i) )
    END DO

    DEALLOCATE ( cp, ce, cg )

  END FUNCTION a_res_cutshift

END MODULE eos_lj_module


  MODULE IMSReorderingModule
    use KindModule, only: DP, I4B
    private
    public :: ims_odrv
  contains

      subroutine ims_odrv(n, nja, nsp, ia, ja, p, ip, isp, flag)
        !
        !                                                                3/12/82
        !***********************************************************************
        !  odrv -- driver for sparse matrix reordering routines
        !***********************************************************************
        !
        !  description
        !
        !    odrv finds a minimum degree ordering of the rows and columns
        !    of a matrix m stored in (ia,ja,a) format (see below).  for the
        !    reordered matrix, the work and storage required to perform
        !    gaussian elimination is (usually) significantly less.
        !
        !    note.. odrv and its subordinate routines have been modified to
        !    compute orderings for general matrices, not necessarily having any
        !    symmetry.  the minimum degree ordering is computed for the
        !    structure of the symmetric matrix  m + m-transpose.
        !    modifications to the original odrv module have been made in
        !    the coding in subroutine mdi, and in the initial comments in
        !    subroutines odrv and md.
        !
        !    if only the nonzero entries in the upper triangle of m are being
        !    stored, then odrv symmetrically reorders (ia,ja,a), (optionally)
        !    with the diagonal entries placed first in each row.  this is to
        !    ensure that if m(i,j) will be in the upper triangle of m with
        !    respect to the new ordering, then m(i,j) is stored in row i (and
        !    thus m(j,i) is not stored),  whereas if m(i,j) will be in the
        !    strict lower triangle of m, then m(j,i) is stored in row j (and
        !    thus m(i,j) is not stored).
        !
        !
        !  storage of sparse matrices
        !
        !    the nonzero entries of the matrix m are stored row-by-row in the
        !    array a.  to identify the individual nonzero entries in each row,
        !    we need to know in which column each entry lies.  these column
        !    indices are stored in the array ja.  i.e., if  a(k) = m(i,j),  then
        !    ja(k) = j.  to identify the individual rows, we need to know where
        !    each row starts.  these row pointers are stored in the array ia.
        !    i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row
        !    and  a(k) = m(i,j),  then  ia(i) = k.  moreover, ia(n+1) points to
        !    the first location following the last element in the last row.
        !    thus, the number of entries in the i-th row is  ia(i+1) - ia(i),
        !    the nonzero entries in the i-th row are stored consecutively in
        !
        !            a(ia(i)),  a(ia(i)+1),  ..., a(ia(i+1)-1),
        !
        !    and the corresponding column indices are stored consecutively in
        !
        !            ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1).
        !
        !    since the coefficient matrix is symmetric, only the nonzero entries
        !    in the upper triangle need be stored.  for example, the matrix
        !
        !             ( 1  0  2  3  0 )
        !             ( 0  4  0  0  0 )
        !         m = ( 2  0  5  6  0 )
        !             ( 3  0  6  7  8 )
        !             ( 0  0  0  8  9 )
        !
        !    could be stored as
        !
        !            - 1  2  3  4  5  6  7  8  9 10 11 12 13
        !         ---+--------------------------------------
        !         ia - 1  4  5  8 12 14
        !         ja - 1  3  4  2  1  3  4  1  3  4  5  4  5
        !          a - 1  2  3  4  2  5  6  3  6  7  8  8  9
        !
        !    or (symmetrically) as
        !
        !            - 1  2  3  4  5  6  7  8  9
        !         ---+--------------------------
        !         ia - 1  4  5  7  9 10
        !         ja - 1  3  4  2  3  4  4  5  5
        !          a - 1  2  3  4  5  6  7  8  9          .
        !
        !
        !  parameters
        !
        !    n    - order of the matrix
        !
        !    nja  - number of nonzeroes in the matrix
        !
        !    nsp  - declared dimension of the one-dimensional array isp.  nsp
        !           must be at least  3n+4k,  where k is the number of nonzeroes
        !           in the strict upper triangle of m
        !
        !    ia   - integer one-dimensional array containing pointers to delimit
        !           rows in ja and a.  dimension = n+1
        !
        !    ja   - integer one-dimensional array containing the column indices
        !           corresponding to the elements of a.  dimension = number of
        !           nonzero entries in (the upper triangle of) m
        !
        !    a    - real one-dimensional array containing the nonzero entries in
        !           (the upper triangle of) m, stored by rows.  dimension =
        !           number of nonzero entries in (the upper triangle of) m
        !
        !    p    - integer one-dimensional array used to return the permutation
        !           of the rows and columns of m corresponding to the minimum
        !           degree ordering.  dimension = n
        !
        !    ip   - integer one-dimensional array used to return the inverse of
        !           the permutation returned in p.  dimension = n
        !
        !    isp  - integer one-dimensional array used for working storage.
        !           dimension = nsp
        !
        !    path - integer path specification.  values and their meanings are -
        !             1  find minimum degree ordering only
        !             2  find minimum degree ordering and reorder symmetrically
        !                  stored matrix (used when only the nonzero entries in
        !                  the upper triangle of m are being stored)
        !             3  reorder symmetrically stored matrix as specified by
        !                  input permutation (used when an ordering has already
        !                  been determined and only the nonzero entries in the
        !                  upper triangle of m are being stored)
        !             4  same as 2 but put diagonal entries at start of each row
        !             5  same as 3 but put diagonal entries at start of each row
        !
        !    flag - integer error flag.  values and their meanings are -
        !               0    no errors detected
        !              9n+k  insufficient storage in md
        !             10n+1  insufficient storage in odrv
        !             11n+1  illegal path specification
        !
        !
        !  conversion from real to double precision
        !
        !    change the real declarations in odrv and sro to double precision
        !    declarations.
        !
        !-----------------------------------------------------------------------
        !
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: nja
        integer(I4B), intent(in) :: nsp
        integer(I4B), dimension(n+1), intent(in) :: ia
        integer(I4B), dimension(nja), intent(in) :: ja
        integer(I4B), dimension(n), intent(inout) :: p
        integer(I4B), dimension(n), intent(inout) :: ip
        integer(I4B), dimension(nsp), intent(inout) :: isp
        integer(I4B), intent(inout) :: flag

        ! -- local
        integer(I4B) :: v
        integer(I4B) :: l
        integer(I4B) :: head
        integer(I4B) :: mmax
        integer(I4B) :: next
        integer(I4B) :: path
        !
        ! set path for finding ordering only
        !
        path = 1
        !
        !
        ! initialize error flag and validate path specification
        flag = 0
        if (path < 1 .or. 5 < path)  go to 111
        !
        ! find minimum degree ordering
        mmax = (nsp-n)/2
        v    = 1
        l    = v     +  mmax
        head = l     +  mmax
        next = head  +  n
        if (mmax < n)  go to 110
        !
        call ims_md(n, nja, ia, ja, mmax, isp(v), isp(l), isp(head), p, &
                    ip, isp(v), flag)
        if (flag.ne.0)  go to 100
        !
        return
        !
        ! ** error -- error detected in md
        !             flag = 9 * n + vi from routine mdi.
        !
100     return
        ! ** error -- insufficient storage
110     flag = 10*n + 1
        return
        ! ** error -- illegal path specified
111     flag = 11*n + 1
        return
      end subroutine ims_odrv

      subroutine ims_md(n, nja, ia, ja, mmax, v, l, head, last, next,           &
                        mark, flag)
        !
        !*****************************************************************
        !  ims_md -- minimum degree algorithm (based on element model)
        !*****************************************************************
        !
        !  description
        !
        !    ims_md finds a minimum degree ordering of the rows and
        !    columns of a general sparse matrix m stored in (ia,ja,a)
        !    format. when the structure of m is nonsymmetric, the ordering
        !    is that obtained for the symmetric matrix  m + m-transpose.
        !
        !
        !  additional parameters
        !
        !    mmax  - declared dimension of the one-dimensional arrays v and l.
        !           mmax must be at least  n+2k,  where k is the number of
        !           nonzeroes in the strict upper triangle of m
        !
        !    v    - integer one-dimensional work array.  dimension = mmax
        !
        !    l    - integer one-dimensional work array.  dimension = mmax
        !
        !    head - integer one-dimensional work array.  dimension = n
        !
        !    last - integer one-dimensional array used to return the permutation
        !           of the rows and columns of m corresponding to the minimum
        !           degree ordering.  dimension = n
        !
        !    next - integer one-dimensional array used to return the inverse of
        !           the permutation returned in last.  dimension = n
        !
        !    mark - integer one-dimensional work array (may be the same as v).
        !           dimension = n
        !
        !    flag - integer error flag.  values and their meanings are -
        !             0      no errors detected
        !             11n+1  insufficient storage in md
        !
        !
        !  definitions of internal parameters
        !
        !    ---------+---------------------------------------------------------
        !    v(s)     - value field of list entry
        !    ---------+---------------------------------------------------------
        !    l(s)     - link field of list entry  (0 =) end of list)
        !    ---------+---------------------------------------------------------
        !    l(vi)    - pointer to element list of uneliminated vertex vi
        !    ---------+---------------------------------------------------------
        !    l(ej)    - pointer to boundary list of active element ej
        !    ---------+---------------------------------------------------------
        !    head(d)  - vj =) vj head of d-list d
        !             -  0 =) no vertex in d-list d
        !
        !
        !             -                  vi uneliminated vertex
        !             -          vi in ek           -       vi not in ek
        !    ---------+-----------------------------+---------------------------
        !    next(vi) - undefined but nonnegative   - vj =) vj next in d-list
        !             -                             -  0 =) vi tail of d-list
        !    ---------+-----------------------------+---------------------------
        !    last(vi) - (not set until mdp)         - -d =) vi head of d-list d
        !             --vk =) compute degree        - vj =) vj last in d-list
        !             - ej =) vi prototype of ej    -  0 =) vi not in any d-list
        !             -  0 =) do not compute degree -
        !    ---------+-----------------------------+---------------------------
        !    mark(vi) - mark(vk)                    - nonneg. tag .lt. mark(vk)
        !
        !
        !             -                   vi eliminated vertex
        !             -      ei active element      -           otherwise
        !    ---------+-----------------------------+---------------------------
        !    next(vi) - -j =) vi was j-th vertex    - -j =) vi was j-th vertex
        !             -       to be eliminated      -       to be eliminated
        !    ---------+-----------------------------+---------------------------
        !    last(vi) -  m =) size of ei = m        - undefined
        !    ---------+-----------------------------+---------------------------
        !    mark(vi) - -m =) overlap count of ei   - undefined
        !             -       with ek = m           -
        !             - otherwise nonnegative tag   -
        !             -       .lt. mark(vk)         -
        !
        !-----------------------------------------------------------------------
        !
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: nja
        integer(I4B), dimension(n+1), intent(in) :: ia
        integer(I4B), dimension(nja), intent(in) :: ja
        integer(I4B), intent(in) :: mmax
        integer(I4B), dimension(mmax), intent(inout) :: v
        integer(I4B), dimension(mmax), intent(inout) :: l
        integer(I4B), dimension(n), intent(inout) :: head
        integer(I4B), dimension(n), intent(inout) :: last
        integer(I4B), dimension(n), intent(inout) :: next
        integer(I4B), dimension(n), intent(inout) :: mark
        integer(I4B), intent(inout) :: flag

        ! -- local
        integer(I4B) :: tag
        integer(I4B) :: dmin
        integer(I4B) :: vk
        integer(I4B) :: ek
        integer(I4B) :: tail
        integer(I4B) :: k

        equivalence(vk, ek)
        !
        ! initialization
        tag = 0
        call ims_mdi(n, nja, ia, ja, mmax ,v, l, head, last, next,              &
                     mark, tag, flag)
        if (flag.ne.0)  return
        !
        k = 0
        dmin = 1
        !
        ! while  k .lt. n  do
1       if (k >= n)  go to 4
        !
        ! search for vertex of minimum degree
2       if (head(dmin) > 0)  go to 3
        dmin = dmin + 1
        go to 2
        !
        ! remove vertex vk of minimum degree from degree list
3       vk = head(dmin)
        head(dmin) = next(vk)
        if (head(dmin) > 0)  last(head(dmin)) = -dmin
        !
        ! number vertex vk, adjust tag, and tag vk
        k = k+1
        next(vk) = -k
        last(ek) = dmin - 1
        tag = tag + last(ek)
        mark(vk) = tag
        !
        ! form element ek from uneliminated neighbors of vk
        call ims_mdm(n, mmax, vk, tail, v, l, last, next, mark)
        !
        ! purge inactive elements and do mass elimination
        call ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark)
        !
        ! update degrees of uneliminated vertices in ek
        call ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark)
        !
        go to 1
        !
        ! generate inverse permutation from permutation
4       do k = 1, n
          next(k) = -next(k)
          last(next(k)) = k
        end do
        !
        return
      end subroutine ims_md

      subroutine ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next,          &
                         mark, tag, flag)
        !
        !***********************************************************************
        !  ims_mdi -- initialization
        !***********************************************************************
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: nja
        integer(I4B), dimension(n+1), intent(in) :: ia
        integer(I4B), dimension(nja), intent(in) :: ja
        integer(I4B), intent(in) :: mmax
        integer(I4B), dimension(mmax), intent(inout) :: v
        integer(I4B), dimension(mmax), intent(inout) :: l
        integer(I4B), dimension(n), intent(inout) :: head
        integer(I4B), dimension(n), intent(inout) :: last
        integer(I4B), dimension(n), intent(inout) :: next
        integer(I4B), dimension(n), intent(inout) :: mark
        integer(I4B), intent(in) :: tag
        integer(I4B), intent(inout) :: flag

        ! -- local
        integer(I4B) :: sfs
        integer(I4B) :: vi
        integer(I4B) :: dvi
        integer(I4B) :: vj
        integer(I4B) :: jmin
        integer(I4B) :: jmax
        integer(I4B) :: j
        integer(I4B) :: lvk
        integer(I4B) :: kmax
        integer(I4B) :: k
        integer(I4B) :: nextvi
        integer(I4B) :: ieval
        !
        ! initialize degrees, element lists, and degree lists
        do vi = 1, n
          mark(vi) = 1
          l(vi) = 0
          head(vi) = 0
        end do
        sfs = n + 1
        !
        ! create nonzero structure
        ! for each nonzero entry a(vi,vj)
        louter: do vi = 1, n
          jmin = ia(vi)
          jmax = ia(vi+1) - 1
          if (jmin > jmax)  cycle louter
          linner1: do j = jmin, jmax !5
            vj = ja(j)
            !if (vj-vi) 2, 5, 4
            ieval = vj - vi
            if (ieval == 0) cycle linner1 !5
            if (ieval > 0) go to 4
            !
            ! if a(vi,vj) is in strict lower triangle
            ! check for previous occurrence of a(vj,vi)
            lvk = vi
            kmax = mark(vi) - 1
            if (kmax == 0) go to 4
            linner2: do k = 1, kmax
              lvk = l(lvk)
              if (v(lvk) == vj) cycle linner1 !5
            end do linner2
            ! for unentered entries a(vi,vj)
4           if (sfs >= mmax)  go to 101
            !
            ! enter vj in element list for vi
            mark(vi) = mark(vi) + 1
            v(sfs) = vj
            l(sfs) = l(vi)
            l(vi) = sfs
            sfs = sfs+1
            !
            ! enter vi in element list for vj
            mark(vj) = mark(vj) + 1
            v(sfs) = vi
            l(sfs) = l(vj)
            l(vj) = sfs
            sfs = sfs + 1
          end do linner1
        end do louter
        !
        ! create degree lists and initialize mark vector
        do vi = 1, n
          dvi = mark(vi)
          next(vi) = head(dvi)
          head(dvi) = vi
          last(vi) = -dvi
          nextvi = next(vi)
          if (nextvi > 0)  last(nextvi) = vi
          mark(vi) = tag
        end do
        !
        return
        !
        ! ** error-  insufficient storage
101     flag = 9*n + vi
        return
      end subroutine ims_mdi

      subroutine ims_mdm(n, mmax, vk, tail, v, l, last, next, mark)
      !
      !***********************************************************************
      !  ims_mdm -- form element from uneliminated neighbors of vk
      !***********************************************************************
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: mmax
        integer(I4B), intent(in) :: vk
        integer(I4B), intent(inout) :: tail
        integer(I4B), dimension(mmax), intent(inout) :: v
        integer(I4B), dimension(mmax), intent(inout) :: l
        integer(I4B), dimension(n), intent(inout) :: last
        integer(I4B), dimension(n), intent(inout) :: next
        integer(I4B), dimension(n), intent(inout) :: mark

        ! -- local
        integer(I4B) :: tag
        integer(I4B) :: s
        integer(I4B) :: ls
        integer(I4B) :: vs
        integer(I4B) :: es
        integer(I4B) :: b
        integer(I4B) :: lb
        integer(I4B) :: vb
        integer(I4B) :: blp
        integer(I4B) :: blpmax

        equivalence  (vs, es)
        !
        ! initialize tag and list of uneliminated neighbors
        tag = mark(vk)
        tail = vk
        !
        ! for each vertex/element vs/es in element list of vk
        ls = l(vk)
1       s = ls
        if (s == 0)  go to 5
        ls = l(s)
        vs = v(s)
        if (next(vs) < 0)  go to 2
        !
        ! if vs is uneliminated vertex, then tag and append to list of
        ! uneliminated neighbors
        mark(vs) = tag
        l(tail) = s
        tail = s
        go to 4
        !
        ! if es is active element, then ...
        ! for each vertex vb in boundary list of element es
2       lb = l(es)
        blpmax = last(es)
        louter: do blp = 1, blpmax !3
          b = lb
          lb = l(b)
          vb = v(b)
          !
          ! if vb is untagged vertex, then tag and append to list of
          ! uneliminated neighbors
          if (mark(vb) >= tag)  cycle louter !3
          mark(vb) = tag
          l(tail) = b
          tail = b
        end do louter
        !
        ! mark es inactive
        mark(es) = tag
        !
4       go to 1
        !
        ! terminate list of uneliminated neighbors
5       l(tail) = 0
        !
        return
      end subroutine ims_mdm

      subroutine ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark)
        !
        !***********************************************************************
        !  ims_mdp -- purge inactive elements and do mass elimination
        !***********************************************************************
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: mmax
        integer(I4B), intent(inout) :: k
        integer(I4B), intent(in) :: ek
        integer(I4B), intent(inout) :: tail
        integer(I4B), dimension(mmax), intent(inout) :: v
        integer(I4B), dimension(mmax), intent(inout) :: l
        integer(I4B), dimension(n), intent(inout) :: head
        integer(I4B), dimension(n), intent(inout) :: last
        integer(I4B), dimension(n), intent(inout) :: next
        integer(I4B), dimension(n), intent(inout) :: mark

        ! -- local
        integer(I4B) :: tag
        integer(I4B) :: free
        integer(I4B) :: li
        integer(I4B) :: vi
        integer(I4B) :: lvi
        integer(I4B) :: evi
        integer(I4B) :: s
        integer(I4B) :: ls
        integer(I4B) :: es
        integer(I4B) :: ilp
        integer(I4B) :: ilpmax
        integer(I4B) :: i
        !
        ! initialize tag
        tag = mark(ek)
        !
        ! for each vertex vi in ek
        li = ek
        ilpmax = last(ek)
        if (ilpmax <= 0)  go to 12
        louter: do ilp = 1, ilpmax !11
          i = li
          li = l(i)
          vi = v(li)
          !
          ! remove vi from degree list
          if (last(vi) == 0)  go to 3
          if (last(vi) > 0)  go to 1
          head(-last(vi)) = next(vi)
          go to 2
1         next(last(vi)) = next(vi)
2         if (next(vi) > 0)  last(next(vi)) = last(vi)
          !
          ! remove inactive items from element list of vi
3         ls = vi
4         s = ls
          ls = l(s)
          if (ls == 0)  go to 6
          es = v(ls)
          if (mark(es) < tag)  go to 5
          free = ls
          l(s) = l(ls)
          ls = s
5         go to 4
          !
          ! if vi is interior vertex, then remove from list and eliminate

6         lvi = l(vi)
          if (lvi.ne.0)  go to 7
          l(i) = l(li)
          li = i
          !
          k = k + 1
          next(vi) = -k
          last(ek) = last(ek) - 1
          cycle louter !11
          !
          ! else ...
          ! classify vertex vi
7         if (l(lvi).ne.0)  go to 9
          evi = v(lvi)
          if (next(evi) >= 0)  go to 9
          if (mark(evi) < 0)  go to 8
          !
          ! if vi is prototype vertex, then mark as such, initialize
          ! overlap count for corresponding element, and move vi to end
          ! of boundary list
          last(vi) = evi
          mark(evi) = -1
          l(tail) = li
          tail = li
          l(i) = l(li)
          li = i
          go to 10
          !
          ! else if vi is duplicate vertex, then mark as such and adjust
          ! overlap count for corresponding element
8         last(vi) = 0
          mark(evi) = mark(evi) - 1
          go to 10
          !
          ! else mark vi to compute degree
9         last(vi) = -ek
          !
          ! insert ek in element list of vi
10        v(free) = ek
          l(free) = l(vi)
          l(vi) = free
        end do louter !11
        !
        ! terminate boundary list
12      l(tail) = 0
        !
        return
      end subroutine ims_mdp

      subroutine ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark)
        !
        !***********************************************************************
        !  ims_mdu -- update degrees of uneliminated vertices in ek
        !***********************************************************************
        implicit none

        ! -- dummy variables
        integer(I4B), intent(in) :: n
        integer(I4B), intent(in) :: mmax
        integer(I4B), intent(in) :: ek
        integer(I4B), intent(inout) :: dmin
        integer(I4B), dimension(mmax), intent(inout) :: v
        integer(I4B), dimension(mmax), intent(inout) :: l
        integer(I4B), dimension(n), intent(inout) :: head
        integer(I4B), dimension(n), intent(inout) :: last
        integer(I4B), dimension(n), intent(inout) :: next
        integer(I4B), dimension(n), intent(inout) :: mark

        ! -- local
        integer(I4B) :: tag
        integer(I4B) :: vi
        integer(I4B) :: evi
        integer(I4B) :: dvi
        integer(I4B) :: s
        integer(I4B) :: vs
        integer(I4B) :: es
        integer(I4B) :: b
        integer(I4B) :: vb
        integer(I4B) :: ilp
        integer(I4B) :: ilpmax
        integer(I4B) :: blp
        integer(I4B) :: blpmax
        integer(I4B) :: i

        equivalence  (vs, es)
        !
        ! initialize tag
        tag = mark(ek) - last(ek)
        !
        ! for each vertex vi in ek
        i = ek
        ilpmax = last(ek)
        if (ilpmax <= 0)  go to 11
        louter: do ilp = 1, ilpmax !10
          i = l(i)
          vi = v(i)
          !if (last(vi))  1, 10, 8
          if (last(vi) == 0) cycle louter !10
          if (last(vi) > 0) goto 8
          !
          ! if vi neither prototype nor duplicate vertex, then merge elements
          ! to compute degree
          tag = tag + 1
          dvi = last(ek)
          !
          ! for each vertex/element vs/es in element list of vi
          s = l(vi)
2         s = l(s)
          if (s == 0)  go to 9
          vs = v(s)
          if (next(vs) < 0)  go to 3
          !
          ! if vs is uneliminated vertex, then tag and adjust degree
          mark(vs) = tag
          dvi = dvi + 1
          go to 5
          !
          ! if es is active element, then expand
          ! check for outmatched vertex
3         if (mark(es) < 0)  go to 6
          !
          ! for each vertex vb in es
          b = es
          blpmax = last(es)
          linner: do blp = 1, blpmax !4
            b = l(b)
            vb = v(b)
            !
            ! if vb is untagged, then tag and adjust degree
            if (mark(vb) >= tag)  cycle linner !4
            mark(vb) = tag
            dvi = dvi + 1
          end do linner !4
          !
5         go to 2
          !
          ! else if vi is outmatched vertex, then adjust overlaps but do not
          ! compute degree
6         last(vi) = 0
          mark(es) = mark(es) - 1
7         s = l(s)
          if (s == 0)  cycle louter !10
          es = v(s)
          if (mark(es) < 0)  mark(es) = mark(es) - 1
          go to 7
          !
          ! else if vi is prototype vertex, then calculate degree by
          ! inclusion/exclusion and reset overlap count
8         evi = last(vi)
          dvi = last(ek) + last(evi) + mark(evi)
          mark(evi) = 0
          !
          ! insert vi in appropriate degree list
9         next(vi) = head(dvi)
          head(dvi) = vi
          last(vi) = -dvi
          if (next(vi) > 0)  last(next(vi)) = vi
          if (dvi < dmin)  dmin = dvi
          !
        end do louter !10
        !
11      return
      end subroutine ims_mdu

  end module IMSReorderingModule


SUBROUTINE formtb(pb,km,g)
!
! This subroutine assembles an unsymmetrical band matrix pb from
! element constituent matrices km.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 INTEGER,INTENT(IN)::g(:)
 REAL(iwp),INTENT(OUT)::pb(:,:)
 INTEGER::i,j,idof,icd,iw
 idof=SIZE(km,1)
 iw=(SIZE(pb,2)-1)/2
 DO i=1,idof
   IF(g(i)/=0)THEN
     DO j=1,idof
       IF(g(j)/=0)THEN
         icd=g(j)-g(i)+iw+1
         pb(g(i),icd)=pb(g(i),icd)+km(i,j)
       END IF
     END DO
   END IF
 END DO
RETURN
END SUBROUTINE formtb


module blas_d3
  use blas_kinds, only : ik, dp
  implicit none

  interface
    subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: transa
      character(len=1) :: transb
      integer(ik) :: m
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: b(ldb, *)
      real(dp) :: beta
      real(dp) :: c(ldc, *)
    end subroutine dgemm
  end interface
  interface
    subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      integer(ik) :: m
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: b(ldb, *)
      real(dp) :: beta
      real(dp) :: c(ldc, *)
    end subroutine dsymm
  end interface
  interface
    subroutine dsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: b(ldb, *)
      real(dp) :: beta
      real(dp) :: c(ldc, *)
    end subroutine dsyr2k
  end interface
  interface
    subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: beta
      real(dp) :: c(ldc, *)
    end subroutine dsyrk
  end interface
  interface
    subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      character(len=1) :: transa
      character(len=1) :: diag
      integer(ik) :: m
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: b(ldb, *)
    end subroutine dtrmm
  end interface
end module blas_d3


  program vars

! Program to show some features of variables in fortran
! Many of the techinques used here are not good programming
! practice.

  implicit none

! Define some generic type variables
  integer*4 i, j, k
  real*4    r04_1, r04_2
  real*8    r08_1, r08_2   ! Definitions of single variables
  real*8    r08_a(10)  !10 element array
  real*8    r08_b(2,3) ! A 2-row, 3-column matrix

  complex*8 c08_1  ! A complex variable (real and imaginary)

  logical*4 l04_1, l04_2   ! Logical

  character*32 string

!    Tests  ******
! See what happen when we pass these variables and constants into
! into subroutine
! First fill the arrays
  do i =1,10
     r08_a(i) = dble(i)
  end do
  do i = 1, 2
     do j = 1, 3
    r08_b(i,j) = dble(i)*1000.d0 + dble(j)
     end do
  end do

! Now pass these arrays into subroutines and see what happens
! Correct passage:
  call var_sub_01(j, r08_a, r08_b)

  print *,'Return from var_sub_01 ',j

! In this call, we have changed the dimensioning inside the
! subroutine.

  call var_sub_02(j, r08_a, r08_b)
  print *,'Return from var_sub_02 ',j

! In this call, we have the correct dimensioning but we have
! changed the variable types

  call var_sub_03(j, r08_a, r08_b)
  print *,'Return from var_sub_03 ',j

  end

!TITLE VAR_SUB_01

  subroutine var_sub_01(n, d1, d2)

! Test 01: correct declaration of variables
!
  implicit none

! PASSED VARIABLES
  integer*4 n
  real*8 d1(10), d2(2,3)

! LOCAL VARIABLES
  integer*4 i,j

!***  Write out the values that have been passed.
  write(*,100)
100  format(/,'VARS: Test 01: Correct declaration of arrays. Type and dimension correct')
  write(*,110) (i,d1(i), i=1,10)
110  format('Array1: ',10(i3,F8.2))
  write(*,120) ((i,j,d2(i,j), i=1,2),j=1,3)
120  format('Array 2: ',10(i3,i3,F8.2))

! Set a return value
  n = 10

!***  Thats all
  return
  end

!TITLE VAR_SUB_02

  subroutine var_sub_02(n, d1, d2)

! Test 02: Change the declaration but keep the type
! the same (you should not do this)
!
  implicit none

! PASSED VARIABLES
  integer*4 n
  real*8 d1(2,5), d2(6)

! LOCAL VARIABLES
  integer*4 i,j

!***  Write out the values that have been passed.
  write(*,100)
100  format(/,'VARS: Test 02: In correct declaration of arrays', &
              ' Type correct, dimension incorrect')
  write(*,110) ((i,j,d1(i,j), i=1,2),j=1,5)
110  format('Array 1: ',10(i3,i3,F8.2))
  write(*,120) (i,d2(i), i=1,6)
120  format('Array 2: ',10(i3,F8.2))

! Set a return value
  n = 11

!***  Thats all
  return
  end

!TITLE VAR_SUB_03

  subroutine var_sub_03(n, d1, d2)

! Test 03: correct dimensions, but wrong type
!
  implicit none

! PASSED VARIABLES
  integer*4 n
  real*4 d1(10), d2(2,3)

! LOCAL VARIABLES
  integer*4 i,j

!***  Write out the values that have been passed.
  write(*,100)
100  format(/,'VARS: Test 01: correct dimensioning ', &
              ' but type is wrong.')
  write(*,110) (i,d1(i), i=1,10)
110  format('Array1: ',10(i3,F8.2))
  write(*,120) ((i,j,d2(i,j), i=1,2),j=1,3)
120  format('Array 2: ',10(i3,i3,F8.2))

! Set a return value
  n =12

!***  Thats all
  return
  end


module com_prog
use array_work
contains

subroutine rk4 ( t0, u0, dt, f, u )
  implicit none

  real ( kind = 8 ) dt
  external f
  real ( kind = 8 ) f0
  real ( kind = 8 ) f1
  real ( kind = 8 ) f2
  real ( kind = 8 ) f3
  real ( kind = 8 ) t0
  real ( kind = 8 ) t1
  real ( kind = 8 ) t2
  real ( kind = 8 ) t3
  real ( kind = 8 ) u
  real ( kind = 8 ) u0
  real ( kind = 8 ) u1
  real ( kind = 8 ) u2
  real ( kind = 8 ) u3
  call f ( t0, u0, f0 )

  t1 = t0 + dt / 2.0D+00
  u1 = u0 + dt * f0 / 2.0D+00
  call f ( t1, u1, f1 )

  t2 = t0 + dt / 2.0D+00
  u2 = u0 + dt * f1 / 2.0D+00
  call f ( t2, u2, f2 )

  t3 = t0 + dt
  u3 = u0 + dt * f2
  call f ( t3, u3, f3 )

  u = u0 + dt * ( f0 + 2.0D+00 * f1 + 2.0D+00 * f2 + f3 ) / 6.0D+00
  return
end

subroutine drkgs(prmt, ndim, ihlf, ibeam)
  implicit none
  dimension a(4),b(4),c(4),prmt(5)
  double precision prmt,a,b,c,x,xend,h,aj,bj,cj,r1,r2,delt,ttau0

  integer ndim,ihlf,i,irec,istep,iend,itest,j,imod,itemp,ibeam
	ttau0=prmt(1)
	itemp=1

  do 1 i=1,ndim
    aux(8,i)=.066666666666666667d0*dery(i)
1   continue

    x=prmt(1)
    xend=prmt(2)
    h=prmt(3)
    prmt(5)=0.d0

    call fct(x,ibeam)

    if(h*(xend-x)) 38,37,2
2   a(1)=.5d0
    a(2)=.29289321881345248d0
    a(3)=1.7071067811865475d0
    a(4)=.16666666666666667d0
    b(1)=2.d0
    b(2)=1.d0
    b(3)=1.d0
    b(4)=2.d0
    c(1)=.5d0
    c(2)=.29289321881345248d0
    c(3)=1.7071067811865475d0
    c(4)=.5d0

    do 3 i=1,ndim
      aux(1,i)=yarray(i)
      aux(2,i)=dery(i)
      aux(3,i)=0.d0
      aux(6,i)=0.d0
3     continue
      irec=0
      h=h+h
      ihlf=-1
      istep=0
      iend=0
    4 if((x+h-xend)*h)7,6,5
    5 h=xend-x
    6 iend=1
    7 call outp(x,irec,ndim,prmt,ttau0,itemp,1,ibeam)
      if(prmt(5))40,8,40
    8 itest=0
    9 istep=istep+1
      j=1
   10 aj=a(j)
      bj=b(j)
      cj=c(j)
      do 11 i=1,ndim
      r1=h*dery(i)
      r2=aj*(r1-bj*aux(6,i))
      yarray(i)=yarray(i)+r2
      r2=r2+r2+r2
      aux(6,i)=aux(6,i)+r2-cj*r1
   11 continue
      if(j-4)12,15,15
   12 j=j+1
      if(j-3)13,14,13
   13 x=x+.5d0*h
   14 call fct(x,ibeam)
      goto 10
   15 if(itest)16,16,20
   16 do 17 i=1,ndim
       aux(4,i)=yarray(i)
   17 continue
      itest=1
      istep=istep+istep-2
   18 ihlf=ihlf+1
      x=x-h
      h=.5d0*h
      do 19 i=1,ndim
      yarray(i)=aux(1,i)
      dery(i)=aux(2,i)
      aux(6,i)=aux(3,i)
   19 continue
      goto 9
   20 imod=istep/2
      if(istep-imod-imod)21,23,21
   21 call fct(x,ibeam)
      do 22 i=1,ndim
      aux(5,i)=yarray(i)
      aux(7,i)=dery(i)
   22 continue
      goto 9
   23 delt=0.d0
      do 24 i=1,ndim
      delt=delt+aux(8,i)*dabs(aux(4,i)-yarray(i))
   24 continue
      if(delt-prmt(4))28,28,25
   25 if(ihlf-10)26,36,36
   26 do 27 i=1,ndim
      aux(4,i)=aux(5,i)
   27 continue
      istep=istep+istep-4
      x=x-h
      iend=0
      goto 18
   28 call fct(x,ibeam)
      do 29 i=1,ndim
      aux(1,i)=yarray(i)
      aux(2,i)=dery(i)
      aux(3,i)=aux(6,i)
      yarray(i)=aux(5,i)
      dery(i)=aux(7,i)
   29 continue
      call outp(x-h,ihlf,ndim,prmt,ttau0,itemp,2, ibeam)
      if(prmt(5))40,30,40
   30 do 31 i=1,ndim
      yarray(i)=aux(1,i)
      dery(i)=aux(2,i)
   31 continue
      irec=ihlf
      if(iend)32,32,39
   32 ihlf=ihlf-1
      istep=istep/2
      h=h+h
      if(ihlf)4,33,33
   33 imod=istep/2
      if(istep-imod-imod)4,34,4
   34 if(delt-.02d0*prmt(4))35,35,4
   35 ihlf=ihlf-1
      istep=istep/2
      h=h+h
      goto 4
   36 ihlf=11
      call fct(x,ibeam)
      goto 39
   37 ihlf=12
      goto 39
   38 ihlf=13
   39 call outp(x,ihlf,ndim,prmt,ttau0,itemp,3, ibeam)
   40 return
end subroutine

real function integrate(func, a, b, eps)
  implicit none
  real*8 :: a, b, eps
  real*8, external :: func
  real*8 :: curr, prev
  integrate = 0.0d0
  prev = a
  curr = a + eps
  do while (curr < b)
    integrate = integrate + (curr - prev) * 0.5d0 * &
    (func((prev+curr)*0.5d0 - (curr-prev)*0.2886751345948129d0) + &
    func((prev+curr)*0.5d0 + (curr-prev)*0.2886751345948129d0))
    prev = curr
    curr = curr + eps
  end do
  return
end function integrate

end module com_prog


!-------------------------------------------------
! Subroutine to evolve the disk
!-------------------------------------------------

subroutine evolve

  use gravdata
  use planetdata
  use unitdata
use winddata, only: sigdot_wind, sigdot_accrete

  implicit none

  real(kind=8) :: dtmin,C0,C1,dr2,dr
  real(kind=8) :: tot_lumin,term1,term2
  real :: dtorque, dTcdr, vr, dt_torque
  logical :: timestepOK

  integer :: i,j,k, iplanet
  integer :: Lcalc

  timestepOK = .false.

  ! Repeat calculation until timestep OK
  do while(.not.timestepOK)

     ! Determine disc parameters and viscosity

     snew(:) = 0.0
     Tnew(:) = 0.0

     call disc_properties

     if(planetchoice=='y') then
        ! Compute torques induced on the disc by planets
        call compute_planet_torques
     endif

     ! Get system timestep
     call timestep

     ! Set v_r = 0 outer bc
     ! This requires nu.sigma.r^{1/2} to have zero gradient

     nu_tc(isr-1) = nu_tc(isr)
     nu_tc(ier+1) = nu_tc(ier)
     sigma(ier+1) = sigma(ier) * sqrt(rz(ier)/rz(ier+1))

     ! Calculate net heating and cooling

     heatfunc(:) = 9.0*nu_tc(:)*sigma(:)*omegaK(:)*omegaK(:)/8.0

     ! Calculate wind parameters
     call compute_wind

     ! Evolve the surface density with the diffusive term

     !$OMP PARALLEL &
     !$OMP shared(rf1_2,nu_tc,sigma,rz1_2,dt,sigdot) &
     !$OMP shared(drzm1,drfm1,isr,ier) &
     !$OMP private(term1,term2,i)
     !$OMP DO SCHEDULE(runtime)
     do i = isr, ier

        term1=rf1_2(i+1)*(nu_tc(i+1)*sigma(i+1)*rz1_2(i+1)-nu_tc(i)*sigma(i)*rz1_2(i))*drfm1(i+1)
        term2=rf1_2(i)*(nu_tc(i)*sigma(i)*rz1_2(i)-nu_tc(i-1)*sigma(i-1)*rz1_2(i-1))*drfm1(i)

        dtorque = 0.0
        if(planetchoice=='y') then

           ! Symmetrised planet torque
           ! 1/2[ ((i+1) - (i)) + (i)-(i-1)) ]
           dtorque = 0.5*(torque_term(i+1) - torque_term(i-1))

           if(3.0*(term1-term2)-dtorque>0.0) then
              dtorque = 0.0
          endif

           do iplanet=1,nplanet
              if(i==iplanetrad(iplanet) .or. i-1==iplanetrad(iplanet))then
                 dtorque = 0.0
              endif
           enddo

        endif

        vr = -3.0*(term2)/(rf(i)*sigma(i))

        dTcdr = (Tc(i+1) -Tc(i))*drzm1(i)

        !if(t> 2.0*yr) then
        !write(75,'(9(1pe15.5,2X))') rz(i)/AU,sigma(i),total_planet_torque(i), &
        !     (total_planet_torque(i+1) - total_planet_torque(i))*drzm1(i), &
        !     torque_term(i), rzm1(i)*drzm1(i)*dtorque, &
        !     rzm1(i)*drzm1(i)*3.0*(term1-term2), &
        !     rzm1(i)*drzm1(i)*(3.0*(term1-term2) - dtorque)*dt, &
        !     nu_tc(i)
        !endif

        snew(i) = sigma(i) + rzm1(i)*drzm1(i)*(3.0*(term1-term2) - dtorque)*dt -(sigdot_wind(i)-sigdot_accrete(i))*dt
        !write(*,'(3(1pe15.5,2X))') rz(i)/AU, 3.0*(term1-term2)-dtorque

        if(snew(i)<0.0) snew(i) = 0.0
        if(runmode/='Q') then
           Tnew(i) = Tc(i) + 2.0*dt*(heatfunc(i)-coolfunc(i))/(cp(i)*sigma(i)) -vr*dTcdr*dt
        else
           Tnew(i) = Tc(i)
        endif

     enddo
     !$OMP END DO
     !$OMP END PARALLEL

     ! Check if surface density negative anywhere - if so, repeat calculation with reduced timestep
     timestepOK = .true.
     do i=isr,ier
        !print*, i, snew(i)
        if(snew(i)<0.0)  timestepOK = .false.

     enddo

     if(.not.timestepOK) then
        print*, 'Reducing maximum allowed timestep ',maxstep, maxstep/10.0
        maxstep = maxstep/10.0

        if(maxstep<1.0e-10) then
           print*, 'MAXIMUM TIMESTEP TOO LOW: ending run'
           stop
        endif
     endif

  enddo
  ! Copy back to surface density

  !$OMP PARALLEL &
  !$OMP shared(sigma,snew,isr,ier) &
  !$OMP private(i)
  !$OMP DO SCHEDULE(runtime)
  do i = isr, ier
     sigma(i) = snew(i)
     Tc(i) = Tnew(i)
  enddo
  !$OMP END DO
  !$OMP END PARALLEL

   if(planetchoice=='y') then
    ! Move planets
    call migrate_planets
endif

!print*, t/yr,dt/yr
!if(t>2.0*yr) STOP
!stop
  return
end subroutine evolve


C$Procedure      SETELM ( Calculate set of SPICE conic elements )

      SUBROUTINE SETELM ( CNGMVL, DVL, DSTCOF, ANGCOF,
     .                    PARAM,  NPARAM, ELTS, ERRFLG, ERRTXT )

C$ Abstract
C
C     Calculate set of standard conic elements used by SPICELIB
C     procedure CONIC from a set of different parameters allowed for
C     the input data type ELEMENTS.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     MKSPK User's Guide
C
C$ Keywords
C
C     None.
C
C$ Declarations

      IMPLICIT   NONE

      DOUBLE PRECISION      CNGMVL
      DOUBLE PRECISION      DVL    ( * )
      DOUBLE PRECISION      ANGCOF
      DOUBLE PRECISION      DSTCOF
      INTEGER               PARAM  ( * )
      INTEGER               NPARAM
      DOUBLE PRECISION      ELTS   ( 8 )
      LOGICAL               ERRFLG
      CHARACTER*(*)         ERRTXT ( 2 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     CNGMVL     I   Gravitational parameter (GM) of primary body
C     DVL        I   Array of input parameters values
C     PARAM      I   Array of parameter indexes
C     NPARAM     I   Number elements in PARAM
C     ANGCOF     I   Angle unit coefficient
C     DSTCOF     I   Distance unit coefficient
C     ELTS       O   Set of conic elements
C     ERRFLG     O   Logical error flag
C     ERRTXT     O   Error explanation text
C
C$ Detailed_Input
C
C                                                       3    2
C     CNGMVL      is the gravitational parameter (GM, km /sec ) of
C                 the primary body.
C
C     DVL         is a set of parameter values obtained by parsing
C                 input text data of type ELEMENTS according
C                 to the specified DATA_ORDER. The parameters in the
C                 arrays are the following order (see array DOVAL in
C                 the main module):
C
C                    'EPOCH', 'X', 'Y', 'Z', 'VX' , 'VY', 'VZ',
C                    'A', 'E', 'RP', 'T', 'P', 'INC', 'PER', 'NOD',
C                    'MEAN', 'EXAN', 'TRAN', 'EPOCHP', 'TAU',
C                    'EQ_A', 'EQ_H', 'EQ_K', 'EQ_ML', 'EQ_P', 'EQ_Q',
C                    'DPER/DT', 'DMPN/DT', 'DNOD/DT' , 'SKIP'
C
C     PARAM       is an array of input parameter indexes in DVL
C                 arranged in accordance with the specified DATA_ORDER
C                 value. Index of each parameter is as ordinal number
C                 of the corresponding word in array DOVAL.
C
C     NPARAM      is the number of elements in array PARAM.
C
C     ANGCOF      is the coefficient that converts input angle units
C                 to radians.
C
C     DSTCOF      is the coefficient that converts input distance units
C                 to kilometers.
C
C$ Detailed_Output
C
C     ELTS        are conic elements describing the orbit of an object
C                 around a primary body. The elements are, in order:
C
C                            Perifocal distance.
C                            Eccentricity.
C                            Inclination.
C                            Longitude of the ascending node.
C                            Argument of periapsis.
C                            Mean anomaly at epoch.
C                            Epoch.
C                            Gravitational parameter.
C
C                 The epoch of the elements is the epoch of the input
C                 state. Units are km, rad, rad/sec. The same elements
C                 are used to describe all three types (elliptic,
C                 hyperbolic, and parabolic) of conic orbit.
C
C     ERRFLG      is the logical flag of the error. Set to .TRUE. value
C                 if calculation of the comic elements from a given
C                 input parameters wasn't possible.
C
C     ERRTXT      is the error explanation text.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     If input elements are inconsistent or incomplete, this routine
C     doesn't signal an error but rather returns long anf short
C     error messages through its output parameters.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.G. Khavenson (IKI RAS, Russia)
C     B.V. Semenov   (NAIF, JPL)
C
C$ Version
C
C-    Version 1.0.4, 18-JAN-2000 (BVS).
C
C        Added CHKOUT calls before each RETURN.
C
C-    Version 1.0.3, 19-MAR-1999 (BVS).
C
C        Corrected comments.
C
C-    Version 1.0.2, 13-JAN-1999 (BVS).
C
C        Modified error messages.
C
C-    Version 1.0.1, 22-NOV-1998 (NGK).
C
C
C-    Version 1.0.0, 8-SEP-1998 (NGK).
C
C-&

C$ Index_Entries
C
C     Calculate set of conic elements from MKSPK input parameters.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               ISRCHI
      DOUBLE PRECISION      TWOPI
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      DACOSH
      LOGICAL               RETURN

C
C     Local variables
C

      DOUBLE PRECISION      TWOTHR
      DOUBLE PRECISION      SENSE
      DOUBLE PRECISION      WRKEL
      DOUBLE PRECISION      MEANM

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SETELM' )
      END IF

C
C     Initialize error flag.
C
      ERRFLG = .FALSE.

C
C     Assign constant value.
C
      TWOTHR = 2.D0 / 3.D0

C
C     All listed below DVL are present in the input data. We already
C     checked this when we checked specified DATA_ORDER against input
C     output type in CHCKDO.
C
      ELTS (2) = DVL (9)
      ELTS (3) = DVL (13) * ANGCOF
      ELTS (4) = DVL (15) * ANGCOF
      ELTS (5) = DVL (14) * ANGCOF
      ELTS (7) = DVL (1)
      ELTS (8) = CNGMVL

C
C     First we need to compute the distance of the periapsis.
C
      IF ( ISRCHI ( 10, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Distance of the peripsis is defined in input file.
C
         ELTS (1) = DVL (10) * DSTCOF

      ELSE IF ( ISRCHI ( 8, NPARAM, PARAM ) .NE. 0) THEN

C
C        Semi-major axis is defined in input file.
C
         IF ( DVL (9) .NE. 1.D0  ) THEN

C           Case of elliptic or hyperbolic orbits.
C
            ELTS (1) = DABS ( ( DVL (9) - 1.D0 ) * DVL (8) ) * DSTCOF

         ELSE

C
C           Case of parabolic orbit. Complain and exit.
C
            ERRTXT (1) = 'Semi-major axis can not be used as ' //
     .                   'input parameter in case of a parabolic ' //
     .                   'orbit (ecc = 1.0).'
            ERRTXT (2) = 'SPICE(INCONSISTELEMENTS)'

            ERRFLG = .TRUE.

            CALL CHKOUT ( 'SETELM' )
            RETURN

         END IF

      ELSE IF ( ISRCHI( 12, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Semi-latus rectum is defined in input file.
C
         ELTS (1) = DVL (12) / ( 1.D0 + DVL (9) ) * DSTCOF

      ELSE IF ( ISRCHI( 11, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Orbital period is defined in input file.
C
         IF ( DVL (9) .LT. 1.D0 )  THEN

C
C           Case of elliptic orbit.
C
            ELTS (1) = ( 1.D0 - DVL (9) ) *
     .            ( DVL (11) * DSQRT ( CNGMVL ) / TWOPI () ) ** TWOTHR
     .             * DSTCOF

         ELSE

C
C           Case of parabolic or hyperbolic orbit. Complain and exit.
C
            ERRTXT (1) = 'Orbital period can not be used as input ' //
     .                   'parameter in case of a parabolic ' //
     .                   '(ecc = 1.0) or hyperbolic (ecc > 1.0) ' //
     .                   'orbit.'
            ERRTXT (2) = 'SPICE(INCONSISTELEMENTS)'

            ERRFLG = .TRUE.

            CALL CHKOUT ( 'SETELM' )
            RETURN

         END IF

      ELSE

C
C        Not enough input data to calculate the periapsis distance.
C        Complain and exit.
C
         ERRTXT (1) = 'Perifocal distance can not be computed ' //
     .                'from given set of orbital elements.'
         ERRTXT (2) = 'SPICE(INCOMPLETEELEMENTS)'

         ERRFLG = .TRUE.

         CALL CHKOUT ( 'SETELM' )
         RETURN

      END IF

C
C     Second we need to compute the mean anomaly.
C
      IF ( ISRCHI ( 16, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Mean anomaly is defined in the input file.
C
         ELTS (6) = DVL (16) * ANGCOF

      ELSE IF ( ISRCHI( 17, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Eccentric anomaly is defined in the input file.
C
         WRKEL = DVL (17) * ANGCOF

         IF ( DVL (9) .LT. 1.D0  ) THEN

C
C           Case of elliptic orbit.
C
            ELTS (6) =  WRKEL - DVL (9) * DSIN ( WRKEL )

         ELSE IF ( DVL (9) .GT. 1.D0  ) THEN

C
C           Case of hyperbolic orbit.
C
            ELTS (6) = DVL (9) * DSINH ( WRKEL ) - WRKEL

         ELSE

C
C           Case of parabolic  orbit. Complain and exit.
C
            ERRTXT (1) = 'Eccentric anomaly can not be used as ' //
     .                   'input parameter in case of a parabolic ' //
     .                   'orbit (ecc = 1.0).'
            ERRTXT (2) = 'SPICE(INCONSISTELEMENTS)'
            ERRFLG = .TRUE.

            CALL CHKOUT ( 'SETELM' )
            RETURN

         END IF

      ELSE IF ( ISRCHI( 18, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        True anomaly is defined in input file.
C
         WRKEL = DVL (18) * ANGCOF

         IF ( WRKEL .LT. PI () ) THEN

            SENSE = 1.D0

         ELSE

            SENSE = -1.D0

         END IF

         IF ( DVL (9) .LT. 1.D0  ) THEN

C
C           Case of elliptic orbit.
C
            WRKEL = DACOS (
     .           (   DVL (9) + DCOS ( WRKEL )      ) /
     .           ( 1.D0 + DVL (9) * DCOS ( WRKEL ) )   )
            ELTS (6) = SENSE * ( WRKEL - DVL (9) * DSIN ( WRKEL ) )

            IF ( ELTS (6) .LT. 0.D0 ) THEN

               ELTS (6) = ELTS (6) + TWOPI ()

            END IF

         ELSE  IF ( DVL (9) .GT. 1.D0  ) THEN

C
C           Case of hyperbolic orbit.
C
            WRKEL = DACOSH (
     .           (   DVL (9) + DCOS ( WRKEL )     ) /
     .           ( 1.D0 + DVL (9) * DCOS( WRKEL ) )    )
            ELTS (6) = SENSE*( ( DVL (9) * DSINH ( WRKEL ) - WRKEL ) )

         ELSE

C
C           Case of parabolic orbit.
C
            WRKEL = DTAN ( WRKEL / 2.D0 )
            ELTS (6) = SENSE * ( WRKEL + WRKEL ** 3 / 3.D0 )

         END IF

      ELSE IF ( ISRCHI( 19, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Epoch of periapsis is defined in input file.
C
         IF ( DVL (9) .LT. 1.D0 ) THEN

C
C           Case of elliptic orbit.
C
            WRKEL = ( 1.D0 - DVL (9) ) / ELTS (1)
            MEANM = DSQRT ( ELTS (8) * WRKEL ) *  WRKEL
            ELTS (6) = MEANM * ( DVL (1) - DVL (19) )

         ELSE  IF ( DVL (9) .GT. 1.D0  ) THEN

C
C           Case of hyperbolic orbit.
C
            WRKEL = ( DVL (9) - 1.D0 ) / ELTS (1)
            MEANM = DSQRT ( ELTS (8) * WRKEL ) * WRKEL
            ELTS (6) = MEANM * ( DVL (1) - DVL (19) )

         ELSE

C
C           Case of parabolic orbit.
C
            MEANM = DSQRT ( ELTS (8) / 2.D0 / ELTS (1) ) / ELTS (1)
            ELTS (6) = MEANM * ( DVL (1) - DVL (19) )

         END IF

      ELSE IF ( ISRCHI( 20, NPARAM, PARAM ) .NE. 0 ) THEN

C
C        Time interval between current epoch and periapsis epoch
C        is defined in input file.
C
         IF ( DVL (9) .LT. 1.D0 ) THEN

C
C           Case of elliptic orbit.
C
            WRKEL = ( 1.D0 - DVL (9) ) / ELTS (1)
            MEANM = DSQRT ( ELTS (8) * WRKEL ) * WRKEL
            ELTS (6) = MEANM * DVL (20)

         ELSE  IF ( DVL (9) .GT. 1.D0  ) THEN

C
C           Case of hyperbolic orbit.
C
            WRKEL = ( DVL (9) - 1.D0 ) / ELTS (1)
            MEANM = DSQRT ( ELTS (8) * WRKEL ) * WRKEL
            ELTS ( 6 ) = MEANM * DVL (20)

         ELSE

C
C           Case of parabolic orbit.
C
            MEANM = DSQRT ( ELTS (8) / 2.D0 / ELTS (1) ) / ELTS (1)
            ELTS (6) = MEANM * DVL (20)

         END IF

      ELSE

C
C        Not enough input data to calculate mean anomaly.
C        Complain and exit.
C
         ERRTXT (1) = 'Mean anomaly can not be computed ' //
     .                'from given set of orbital elements.'
         ERRTXT (2) = 'SPICE(INCOMPLETEELEMENTS)'
         ERRFLG = .TRUE.

         CALL CHKOUT ( 'SETELM' )
         RETURN

      END IF

      CALL CHKOUT ( 'SETELM' )
      RETURN

      END