      subroutine Inverse(buffst1ns,buffst1ew,buffst2ns,buffst2ew,
     &edist,faz)
c
c********1*********2*********3*********4*********5*********6*********7**
c
c name:      inverse
c version:   200208.19
c author:    stephen j. frakes
c purpose:   to compute a geodetic inverse
c            and then display output information
c
c input parameters:
c -----------------
c
c output parameters:
c ------------------
c
c local variables and constants:
c ------------------------------
c answer           user prompt response
c b                semiminor axis polar (in meters)
c baz              azimuth back (in radians)
c buff             input char buffer array
c dd,dm,ds         temporary values for degrees, minutes, seconds
c dlon             temporary value for difference in longitude (radians)
c dmt,d_mt         char constants for meter units
c edist            ellipsoid distance (in meters)
c elips            ellipsoid choice
c esq              eccentricity squared for reference ellipsoid
c faz              azimuth forward (in radians)
c filout           output file name
c finv             reciprocal flattening
c hem              hemisphere flag for lat & lon entry
c ierror           error condition flag with d,m,s conversion
c lgh              length of buff() array
c option           user prompt response
c r1,r2            temporary variables
c ss               temporary variable
c tol              tolerance for conversion of seconds
c
c name1            name of station one
c ld1,lm1,sl1      latitude  sta one - degrees,minutes,seconds
c ald1,alm1,sl1    latitude  sta one - degrees,minutes,seconds
c lat1sn           latitude  sta one - sign (+/- 1)
c d_ns1            latitude  sta one - char ('N','S')
c lod1,lom1,slo1   longitude sta one - degrees,minutes,seconds
c alod1,alom1,slo1 longitude sta one - degrees,minutes,seconds
c lon1sn           longitude sta one - sign (+/- 1)
c d_ew1            longitude sta one - char ('E','W')
c iaz1,maz1,saz1   forward azimuth   - degrees,minutes,seconds
c isign1           forward azimuth   - flag  (+/- 1)
c glat1,glon1      station one       - (lat & lon in radians )
c p1,e1            standpoint one    - (lat & lon in radians )
c
c name2            name of station two
c ld2,lm2,sl2      latitude  sta two - degrees,minutes,seconds
c ald2,alm2,sl2    latitude  sta two - degrees,minutes,seconds
c lat2sn           latitude  sta two - sign (+/- 1)
c d_ns2            latitude  sta two - char ('N','S')
c lod2,lom2,slo2   longitude sta two - degrees,minutes,seconds
c alod2,alom2,slo2 longitude sta one - degrees,minutes,seconds
c lon2sn           longitude sta two - sign (+/- 1)
c d_ew2            longitude sta two - char ('E','W')
c iaz2,maz2,saz2   back azimuth      - degrees,minutes,seconds
c isign2           back azimuth      - flag  (+/- 1)
c glat2,glon2      station two       - (lat & lon in radians )
c p2,e2            forepoint two     - (lat & lon in radians )
c
c global variables and constants:
c -------------------------------
c a                semimajor axis equatorial (in meters)
c f                flattening
c pi               constant 3.14159....
c rad              constant 180.0/pi
c
c    this module called by:  n/a
c
c    this module calls:      elipss, getrad, inver1, todmsp
c    gethem, trim,   bufdms, gvalr8, gvali4, fixdms, gpnhri
c    datan,  write,  read,   dabs,   open,   stop
c
c    include files used:     n/a
c
c    common blocks used:     const, elipsoid
c
c    references:             see comments within subroutines
c
c    comments:
c
c********1*********2*********3*********4*********5*********6*********7**
c::modification history
c::1990mm.dd, sjf, creation of program
c::199412.15, bmt, creation of program on viper
c::200203.08, crs, modified by c.schwarz to correct spelling of Clarke
c::200207.15, rws, modified i/o & standardized program documentation
c::                added subs trim, bufdms, gethem, gvali4, gvalr8
c::200207.23, rws, replaced sub inver1 with gpnarc, gpnloa, gpnhri
c::200208.15, rws, fixed an error in bufdms
c::              - renamed ellips to elipss "common error" with dirct2
c::              - added FAZ & BAZ to printed output
c::200208.19, rws, added more error flags for web interface code
c::              - added logical nowebb
c::200208.xx, sjf, program version number 2.0
c********1*********2*********3*********4*********5*********6*********7**
ce::inverse
c
      implicit double precision (a-h, o-z)
      implicit integer (i-n)
c
      logical  nowebb
c
      character*1  buffst1ns(50),buffst1ew(50)
      character*1  buffst2ns(50),buffst2ew(50)
      character*1  dmt,hem
      character*6  d_ns1, d_ew1, d_ns2, d_ew2, d_mt
      character*30 elips
c
      integer*4    ierror
      integer*4    lgh
c
      common/const/pi,rad
      common/elipsoid/a,f
c
c     ms_unix      0 = web version
c                  1 = ms_dos or unix version
c
      pi   = 4.d0*datan(1.d0)
      rad  = 180.d0/pi
      dmt  = 'm'
      d_mt = 'Meters'
      nowebb = .false.
c
      a=6378137.d0
      f=1.d0/298.25722210088d0
      elips='GRS80 / WGS84  (NAD83)'
c
      esq = f*(2.0d0-f)
c
      hem='N'
      call trim(buffst1ns,lgh,hem)
      call bufdms (buffst1ns,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat1 = 0
      else
        irlat1 = 1
        write(0,*) ' Invalid Latitude ... Program stopped '
        stop
      endif
c
      ald1 = dd
      alm1 = dm
      sl1  = ds
c
      if( hem.eq.'N' ) then
        lat1sn = +1
      else
        lat1sn = -1
      endif
c
      hem='E'
      call trim (buffst1ew,lgh,hem)
      call bufdms (buffst1ew,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon1 = 0
      else
        irlon1 = 1
        write(0,*) ' Invalid Longitude ... Program stopped '
        stop
      endif
c
      alod1 = dd
      alom1 = dm
      slo1  = ds
c
      if( hem.eq.'E' ) then
        lon1sn = +1
      else
        lon1sn = -1
      endif
c
      call getrad(ald1, alm1, sl1, lat1sn, glat1)
      call getrad(alod1,alom1,slo1,lon1sn, glon1)
c
      hem='N'
      call trim (buffst2ns,lgh,hem)
      call bufdms (buffst2ns,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlat2 = 0
      else
        irlat2 = 1
        write(0,*) ' Invalid Latitude ... Program stopped '
        stop
      endif
c
      ald2 = dd
      alm2 = dm
      sl2  = ds
c
      if( hem.eq.'N' ) then
        lat2sn = +1
      else
        lat2sn = -1
      endif
c
c
      hem='E'
      call trim (buffst2ew,lgh,hem)
      call bufdms (buffst2ew,lgh,hem,dd,dm,ds,ierror)
c
      if( ierror.eq.0 )then
        irlon2 = 0
      else
        irlon2 = 1
        write(0,*) ' Invalid Longitude ... Program stopped '
        stop
      endif
c
      alod2 = dd
      alom2 = dm
      slo2  = ds
c
      if( hem.eq.'E' )then
        lon2sn = +1
      else
        lon2sn = -1
      endif
c
      call getrad(ald2, alm2, sl2, lat2sn, glat2)
      call getrad(alod2,alom2,slo2,lon2sn, glon2)
c
      p1 = glat1
      e1 = glon1
      p2 = glat2
      e2 = glon2
c
      if( e1.lt.0.0d0 )then
        e1 = e1+2.0d0*pi
      endif
      if( e2.lt.0.0d0 )then
        e2 = e2+2.0d0*pi
      endif
c
c     compute the geodetic inverse
c
c ************************************************************
c *   replaced subroutine inver1 with gpnhri
c *
c *   call inver1 (glat1,glon1,glat2,glon2,faz,baz,edist)
c *
c ************************************************************
c
      call gpnhri (a,f,esq,pi,p1,e1,p2,e2,faz,baz,edist)
c
c     check for a non distance ... p1,e1 & p2,e2 equal zero ?
c
      if( edist.lt.0.00005d0 )then
        faz = 0.0d0
        baz = 0.0d0
      endif
c
c     set the tolerance (in seconds) for the azimuth conversion
c
      tol = 0.00005d0
c
      call todmsp(faz,iaz1,maz1,saz1,isign1)
      if(isign1.lt.0) then
        iaz1=359-iaz1
        maz1=59-maz1
        saz1=60.d0-saz1
      endif
      call fixdms ( iaz1, maz1, saz1, tol )
c
      call todmsp(baz,iaz2,maz2,saz2,isign2)
      if(isign2.lt.0) then
        iaz2=359-iaz2
        maz2=59-maz2
        saz2=60.d0-saz2
      endif
      call fixdms ( iaz2, maz2, saz2, tol )
c
      call todmsp(glat1, ld1,  lm1,  sl1,  lat1sn)
      call todmsp(glon1, lod1, lom1, slo1, lon1sn)
      call todmsp(glat2, ld2,  lm2,  sl2,  lat2sn)
      call todmsp(glon2, lod2, lom2, slo2, lon2sn)
c
      call hem_ns ( lat1sn, d_ns1 )
      call hem_ew ( lon1sn, d_ew1 )
      call hem_ns ( lat2sn, d_ns2 )
      call hem_ew ( lon2sn, d_ew2 )
c
      finv=1.d0/f
      b=a*(1.d0-f)

      if(faz.lt.0)then
        faz=(faz+(2*pi))*rad
      elseif(faz.ge.(2*pi))then
        faz=(faz-(2*pi))*rad
      else
        faz=faz*rad
      endif
      return
      end subroutine Inverse

      subroutine gpnhri (a,f,esq,pi,p1,e1,p2,e2,az1,az2,s)
c
c********1*********2*********3*********4*********5*********6*********7*
c
c name:        gpnhri
c version:     200208.09
c written by:  robert (sid) safford
c purpose:     subroutine to compute helmert rainsford inverse problem
c
c     solution of the geodetic inverse problem after t. vincenty
c     modified rainsford's method with helmert's elliptical terms
c     effective in any azimuth and at any distance short of antipocal
c     from/to stations must not be the geographic pole.
c     parameter a is the semi-major axis of the reference ellipsoid
c     finv=1/f is the inverse flattening of the reference ellipsoid
c     latitudes and longitudes in radians positive north and west
c     forward and back azimuths returned in radians clockwise from south
c     geodesic distance s returned in units of semi-major axis a
c     programmed for ibm 360-195   09/23/75
c
c     note - note - note -
c     1. do not use for meridional arcs and be careful on the equator.
c     2. azimuths are from north(+) clockwise and
c     3. longitudes are positive east(+)
c
c input parameters:
c -----------------
c a            semi-major axis of reference ellipsoid      meters
c f            flattening (0.0033528...)
c esq          eccentricity squared
c pi           3.14159...
c p1           lat station 1                               radians
c e1           lon station 1                               radians
c p2           lat station 2                               radians
c e2           lon station 2                               radians
c
c output parameters:
c ------------------
c az1          azi at sta 1 -> sta 2                       radians
c az2          azi at sta 2 -> sta 1                       radians
c s            geodetic dist between sta(s) 1 & 2          meters
c
c local variables and constants:
c ------------------------------
c aa               constant from subroutine gpnloa
c alimit           equatorial arc distance along the equator   (radians)
c arc              meridional arc distance latitude p1 to p2 (in meters)
c az1              azimuth forward                          (in radians)
c az2              azimuth back                             (in radians)
c bb               constant from subroutine gpnloa
c dlon             temporary value for difference in longitude (radians)
c equ              equatorial distance                       (in meters)
c r1,r2            temporary variables
c s                ellipsoid distance                        (in meters)
c sms              equatorial - geodesic distance (S - s) "Sms"
c ss               temporary variable
c tol0             tolerance for checking computation value
c tol1             tolerance for checking a real zero value
c tol2             tolerance for close to zero value
c twopi            two times constant pi
c
c global variables and constants:
c -------------------------------
c
c    module called by:    general
c
c    this module calls:   gpnarc, gpnloa
c       llibfore/ dsin,   dcos,   dsqrt,  dabs,  datan2, write
c
c    include files used:
c    common blocks used:
c
c    references: microsoft fortran 4.10 optimizing compiler, 1988
c                ms-dos operating system
c    comments:
c********1*********2*********3*********4*********5*********6*********7*
c::modification history
c::197507.05, rws, ver 00 tencol released for field use
c::198311.20, rws, ver 01 mten   released to field
c::198411.26, rws, ver 07 mten2  released to field
c::198506.10, rws, wrk    enhancements released to field
c::198507.22, rws, code   modified for mten3
c::198509.01, rws, ver 11 mten3  released to field
c::198708.10, rws, code   modified to use new mten4 gpn record format
c::199112.31, rws, ver 20 mten4 released to field
c::200001.13, rws, ver 21 mten4 released to field
c::200005.26, rws, code   restructured & documentation added
c::200012.31, rws, ver 23 mten5 released
c::200104.09, rws, code   added to calblin program
c::200208.09, rws, code   added subroutines gpnarc & gpnloa
c********1*********2*********3*********4*********5*********6*********7*
ce::gpnhri
c  -------------------------------
c     m t e n  (version 3)
c              (version 4.22)
c              (version 5.23)
c  -------------------------------
c
      implicit real*8 (a-h,o-z)
c
      data tol0 /5.0d-15/
      data tol1 /5.0d-14/
      data tol2 /7.0d-03/
c
      twopi = 2.0d0*pi
c
c     test the longitude difference with tol1
c     tol1 is approximately 0.000000001 arc seconds
c
      ss = e2-e1
      if( dabs(ss).lt.tol1 )then
        e2 = e2+tol1
        write(*,*) ' longitudal difference is near zero '
c
        r2 = p2
        r1 = p1
        call gpnarc ( a, f, esq, pi, r1, r2, arc )
        s  = dabs( arc )
c
        if( p2.gt.p1 )then
          az1 = 0.0d0
          az2 = pi
        else
          az1 = pi
          az2 = 0.0d0
        endif
        return
      endif
c
c     test for longitude over 180 degrees
c
      dlon = e2-e1
c
      if( dlon.ge.0.0d0 )then
        if( pi.le.dlon .and. dlon.lt.twopi )then
          dlon = dlon-twopi
        endif
      else
        ss = dabs(dlon)
        if( pi.le.ss .and. ss.lt.twopi )then
          dlon = dlon+twopi
        endif
      endif
c
      ss = dabs( dlon )
      if( ss.gt.pi )then
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference over 180 degrees  '
c::     write(*,*) ' Turn it around '
        ss = twopi-ss
      endif
c
c     compute the limit in longitude (alimit), it is equal
c     to twice the distance from the equator to the pole,
c     as measured along the equator (east/ewst)
c
      alimit = pi*(1.0d0-f)
c
c     test for anti-nodal difference
c
      if( ss.ge.alimit )then
        r1 = dabs(p1)
        r2 = dabs(p2)
c
c       latitudes r1 & r2 are not near the equator
c
        if( r1.gt.tol2 .and. r2.gt.tol2 )then
          goto 60
        endif
c
c       longitude difference is greater than lift-off point
c       now check to see if  "both"  r1 & r2 are on equator
c
        if( r1.lt.tol1 .and. r2.gt.tol2 )then
          goto 60
        endif
        if( r2.lt.tol1 .and. r1.gt.tol2 )then
          goto 60
        endif
c
c       check for either r1 or r2 just off the equator but < tol2
c
        if( r1.gt.tol1. or. r2.gt.tol1 )then
          az1 = 0.0d0
          az2 = 0.0d0
          s   = 0.0d0
          return
        endif
c
c       compute the azimuth to anti-nodal point
c
c::     write(*,*) '  '
c::     write(*,*) ' Longitude difference beyond lift-off point '
c::     write(*,*) '  '
c
        call gpnloa (a,f,esq,pi,dlon,az1,az2,aa,bb,sms)
c
c       compute the equatorial distance & geodetic
c
        equ = a*dabs(dlon)
        s   = equ-sms
        return
      endif
c
   60 continue
c
      f0   = (1.0d0-f)
      b    = a*f0
      epsq = esq/(1.0d0-esq)
      f2   = f*f
      f3   = f*f2
      f4   = f*f3
c
c     the longitude difference
c
      dlon  = e2-e1
      ab    = dlon
      kount = 0
c
c     the reduced latitudes
c
      u1    = f0*dsin(p1)/dcos(p1)
      u2    = f0*dsin(p2)/dcos(p2)
c
      u1    = datan(u1)
      u2    = datan(u2)
c
      su1   = dsin(u1)
      cu1   = dcos(u1)
c
      su2   = dsin(u2)
      cu2   = dcos(u2)
c
c     counter for the iteration operation
c
    1 kount = kount+1
c
      clon  = dcos(ab)
      slon  = dsin(ab)
c
      csig  = su1*su2+cu1*cu2*clon
      ssig  = dsqrt((slon*cu2)**2+(su2*cu1-su1*cu2*clon)**2)
c
      sig   = datan2(ssig,csig)
      sinalf=cu1*cu2*slon/ssig
c
      w   = (1.0d0-sinalf*sinalf)
      t4  = w*w
      t6  = w*t4
c
c     the coefficients of type a
c
      ao  = f-f2*(1.0d0+f+f2)*w/4.0d0+3.0d0*f3*(1.0d0+
     1        9.0d0*f/4.0d0)*t4/16.0d0-25.0d0*f4*t6/128.0d0
      a2  = f2*(1.0d0+f+f2)*w/4.0d0-f3*(1.0d0+9.0d0*f/4.0d0)*t4/4.0d0+
     1        75.0d0*f4*t6/256.0d0
      a4  = f3*(1.0d0+9.0d0*f/4.0d0)*t4/32.0d0-15.0d0*f4*t6/256.0d0
      a6  = 5.0d0*f4*t6/768.0d0
c
c     the multiple angle functions
c
      qo  = 0.0d0
      if( w.gt.tol0 )then
        qo = -2.0d0*su1*su2/w
      endif
c
      q2  = csig+qo
      q4  = 2.0d0*q2*q2-1.0d0
      q6  = q2*(4.0d0*q2*q2-3.0d0)
      r2  = 2.0d0*ssig*csig
      r3  = ssig*(3.0d0-4.0d0*ssig*ssig)
c
c     the longitude difference
c
      s   = sinalf*(ao*sig+a2*ssig*q2+a4*r2*q4+a6*r3*q6)
      xz  = dlon+s
c
      xy  = dabs(xz-ab)
      ab  = dlon+s
c
      if( xy.lt.0.5d-13 )then
        goto 4
      endif
c
      if( kount.le.7 )then
        goto 1
      endif
c
c     the coefficients of type b
c
    4 z   = epsq*w
c
      bo  = 1.0d0+z*(1.0d0/4.0d0+z*(-3.0d0/64.0d0+z*(5.0d0/256.0d0-
     1         z*175.0d0/16384.0d0)))
      b2  = z*(-1.0d0/4.0d0+z*(1.0d0/16.0d0+z*(-15.0d0/512.0d0+
     1         z*35.0d0/2048.0d0)))
      b4  = z*z*(-1.0d0/128.0d0+z*(3.0d0/512.0d0-z*35.0d0/8192.0d0))
      b6  = z*z*z*(-1.0d0/1536.0d0+z*5.0d0/6144.0d0)
c
c     the distance in meters
c
      s   = b*(bo*sig+b2*ssig*q2+b4*r2*q4+b6*r3*q6)
c
c     first compute the az1 & az2 for along the equator
c
      if( dlon.gt.pi )then
        dlon = (dlon-2.0d0*pi)
      endif
c
      if( dabs(dlon).gt.pi )then
        dlon = (dlon+2.0d0*pi)
      endif
c
      az1 = pi/2.0d0
      if( dlon.lt.0.0d0 )then
        az1 = 3.0d0*az1
      endif
c
      az2 = az1+pi
      if( az2.gt.2.0d0*pi )then
        az2 = az2-2.0d0*pi
      endif
c
c     now compute the az1 & az2 for latitudes not on the equator
c
      if( .not.(dabs(su1).lt.tol0 .and. dabs(su2).lt.tol0) )then
        tana1 =  slon*cu2/(su2*cu1-clon*su1*cu2)
        tana2 =  slon*cu1/(su1*cu2-clon*su2*cu1)
        sina1 =  sinalf/cu1
        sina2 = -sinalf/cu2
c
c       azimuths from north,longitudes positive east
c
        az1   = datan2(sina1,sina1/tana1)
        az2   = pi-datan2(sina2,sina2/tana2)
      endif
c
      if( az1.lt.0.0d0 )then
        az1 = az1+2.0d0*pi
      endif
c
      if( az2.lt.0.0d0 )then
        az2 = az2+2.0d0*pi
      endif
c
      return
      end

CB::GPNLOA
C
      SUBROUTINE GPNLOA (AMAX,FLAT,ESQ,PI,DL,AZ1,AZ2,AO,BO,SMS)
C
C********1*********2*********3*********4*********5*********6*********7*
C
C NAME:        GPNLOA
C VERSION:     200005.26
C WRITTEN BY:  ROBERT (Sid) SAFFORD
C PURPOSE:     SUBROUTINE TO COMPUTE THE LIFF-OFF-AZIMUTH CONSTANTS
C
C INPUT PARAMETERS:
C -----------------
C AMAX         SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID
C FLAT         FLATTENING (0.0033528 ... )
C ESQ          ECCENTRICITY SQUARED FOR REFERENCE ELLIPSOID
C PI           3.14159...
C DL           LON DIFFERENCE
C AZ1          AZI AT STA 1 -> STA 2
C
C OUTPUT PARAMETERS:
C ------------------
C AZ2          AZ2 AT STA 2 -> STA 1
C AO           CONST
C BO           CONST
C SMS          DISTANCE ... EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
C LOCAL VARIABLES AND CONSTANTS:
C ------------------------------
C GLOBAL VARIABLES AND CONSTANTS:
C -------------------------------
C
C    MODULE CALLED BY:    GENERAL
C
C    THIS MODULE CALLS:
C       LLIBFORE/ DSIN,   DCOS,   DABS,   DASIN
C
C    INCLUDE FILES USED:
C    COMMON BLOCKS USED:
C
C    REFERENCES: Microsoft FORTRAN 4.10 Optimizing Compiler, 1988
C                MS-DOS Operating System
C    COMMENTS:
C********1*********2*********3*********4*********5*********6*********7*
C::MODIFICATION HISTORY
C::1985xx.xx, RWS, CODE   CREATED
C::198506.10, RWS, WRK    ENHANCEMENTS RELEASED TO FIELD
C::198509.01, RWS, VER 11 MTEN3  RELEASED TO FIELD
C::198512.18, RWS, CODE   MODIFIED FOR MTEN3
C::198708.10, RWS, CODE   MODIFIED TO USE NEW MTEN4 GPN RECORD FORMAT
C::199112.31, RWS, VER 20 MTEN4 RELEASED TO FIELD
C::200001.13, RWS, VER 21 MTEN4 RELEASED TO FIELD
C::200005.26, RWS, CODE   RESTRUCTURED & DOCUMENTATION ADDED
C::200012.31, RWS, VER 23 MTEN5 RELEASED
C********1*********2*********3*********4*********5*********6*********7*
CE::GPNLOA
C ---------------------------
C     M T E N  (VERSION 3)
C              (VERSION 4.22)
C              (VERSION 5.23)
C ---------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DATA TT/5.0D-13/
C
      DLON = DABS(DL)
      CONS = (PI-DLON)/(PI*FLAT)
      F    = FLAT
C
C     COMPUTE AN APPROXIMATE AZ
C
      AZ   = DASIN(CONS)
C
      T1   =    1.0D0
      T2   =  (-1.0D0/4.0D0)*F*(1.0D0+F+F*F)
      T4   =    3.0D0/16.0D0*F*F*(1.0D0+(9.0D0/4.0D0)*F)
      T6   = (-25.0D0/128.0D0)*F*F*F
C
      ITER = 0
    1 ITER = ITER+1
      S    = DCOS(AZ)
      C2   = S*S
C
C     COMPUTE NEW AO
C
      AO   = T1 + T2*C2 + T4*C2*C2 + T6*C2*C2*C2
      CS   = CONS/AO
      S    = DASIN(CS)
      IF( DABS(S-AZ).LT.TT )THEN
        GOTO 2
      ENDIF
C
      AZ   = S
      IF( ITER.LE.6 )THEN
        GOTO 1
      ENDIF
C
    2 AZ1  = S
      IF( DL.LT.0.0D0 )THEN
        AZ1 = 2.0D0*PI-AZ1
      ENDIF
C
      AZ2  = 2.0D0*PI-AZ1
C
C     EQUATORIAL - GEODESIC  (S - s)   "SMS"
C
      ESQP = ESQ/(1.0D0-ESQ)
      S    = DCOS(AZ1)
C
      U2   = ESQP*S*S
      U4   = U2*U2
      U6   = U4*U2
      U8   = U6*U2
C
      T1   =     1.0D0
      T2   =    (1.0D0/4.0D0)*U2
      T4   =   (-3.0D0/64.0D0)*U4
      T6   =    (5.0D0/256.0D0)*U6
      T8   = (-175.0D0/16384.0D0)*U8
C
      BO   = T1 + T2 + T4 + T6 + T8
      S    = DSIN(AZ1)
      SMS  = AMAX*PI*(1.0D0 - FLAT*DABS(S)*AO - BO*(1.0D0-FLAT))
C
      RETURN
      END


************************************************************************
      function trqua2 (n,x,f,dx,d)
cc      dimension x(*),f(*),dx(*),d(*)
      dimension x(n),f(n),dx(n),d(n)
*
*  Calculate the integral over f(x), using dx and d as intermediaries
*  holding the x-differences and the derivatives of f.
*
*  The quadrature is performed with a formula for cubic splines, which
*  may be decomposed into a trapeziodal formula and a correction, where
*  the correction term in each interval is 1/12 times dx**2 times the
*  derivative change across the interval.
*
*  We assume f(x) is an even function of x, and that x(n)=0.0
*
************************************************************************
*
      res=0.
      do 191 i=2,n-1
        dx(i)=x(i)-x(i-1)
        d(i)=(f(i+1)-f(i-1))/(x(i+1)-x(i-1))
191     res=res+dx(i)*(f(i)+f(i-1))
      dx(n)=x(n)-x(n-1)
      res=res+dx(n)*(f(n)+f(n-1))
*
*  This is because f is an even function of x at x(n)=0
*
      d(n)=0.
      d(n-1)=2.*(f(n)-f(n-1))/dx(n)
*
*  Extrapolate derivative to x=1
*
      d1=(f(2)-f(1))/dx(2)
      d2=(f(3)-f(2))/dx(3)
      p=-dx(2)/(dx(2)+dx(3))
      d(1)=p*d2+(1.-p)*d1

      res=res*6.
      do i=2,n
        res=res+(d(i-1)-d(i))*dx(i)**2
      enddo
      res=res*0.083333333
      trqua2=res

      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PXN (RETMIN, PARTYP, LENARY, NELBLK, IXELB, ISEVOK,
     &                NUMIX, IXNODE, IXELEM, PARM1, PARM2, PARM3,
     &                PARM4, PARM5, PARM6, RESULT, *)
C=======================================================================

C   --*** PXN *** (ALGEBRA) Calculate 3x3 principal values
C   --   Written by Amy Gilkey - revised 05/17/88
C   --
C   --PXN determines the minimum or maximum principal values.
C   --
C   --Parameters:
C   --   RETMIN - IN  - true iff minimum versus maximum to be calculated
C   --   PARTYP - IN  - the parameter type (element must be handled differently)
C   --   LENARY - IN  - the length of the parameter arrays
C   --   NELBLK - IN  - the number of element blocks
C   --   IXELB  - IN  - the cumulative element counts for each element block
C   --   ISEVOK - IN  - the element variable truth table for each element block
C   --   NUMIX  - IN  - the number of selected values; <0 if all
C   --   IXNODE - IN  - the indices of the selected nodes (only if NUMIX>=0)
C   --   IXELEM - IN  - the indices of the selected elements (only if NUMIX>=0)
C   --   PARM1, PARM2, PARM3, PARM4, PARM5, PARM6 - IN - the tensor components
C   --   RESULT - OUT - the returned principal values
C   --   *      - OUT - return statement if an error is found

      LOGICAL RETMIN
      CHARACTER PARTYP
      INTEGER IXELB(0:NELBLK)
      LOGICAL ISEVOK(*)
      INTEGER IXNODE(*)
      INTEGER IXELEM(*)
      REAL PARM1(*), PARM2(*), PARM3(*), PARM4(*), PARM5(*), PARM6(*)
      REAL RESULT(*)

      REAL EV(3)
      CHARACTER*5 STRA

      IF (NUMIX .GE. 0) THEN
         IF (PARTYP .NE. 'E') THEN
            DO 100 I = 1, NUMIX
               J = IXNODE(I)

               CALL PRINC3 (PARM1(J), PARM2(J), PARM3(J), PARM4(J),
     $              PARM5(J), PARM6(J), EV, INFO)

               IF (INFO .NE. 0) THEN
                  CALL INTSTR (1, 0, INFO, STRA, LSTRA)
                  CALL PRTERR ('FATAL',
     &               'Library function PRINC3 has an error = '
     &               // STRA(:LSTRA))
                  GOTO 160
               END IF

               IF (RETMIN) THEN
                  RESULT(J) = EV(1)
               ELSE
                  RESULT(J) = EV(3)
               END IF
  100       CONTINUE
         ELSE
            DO 120 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 110 I = IXELB(IELB-1)+1, IXELB(IELB)
                     J = IXELEM(I)
                     CALL PRINC3 (PARM1(J), PARM2(J), PARM3(J),
     $                    PARM4(J), PARM5(J), PARM6(J), EV, INFO)

                     IF (INFO .NE. 0) THEN
                        CALL INTSTR (1, 0, INFO, STRA, LSTRA)
                        CALL PRTERR ('FATAL',
     &                     'Library function PRINC3 has an error = '
     &                     // STRA(:LSTRA))
                        GOTO 160
                     END IF

                     IF (RETMIN) THEN
                        RESULT(J) = EV(1)
                     ELSE
                        RESULT(J) = EV(3)
                     END IF
  110             CONTINUE
               END IF
  120       CONTINUE
         END IF

      ELSE
C        NUMIX < 0; ALL VALUES ARE SELECTED
C        NUMEL=NUMELO; NUMNP=NUMNPO; IXELB(J)+IXELBO(J) J=1,NELBLK
         IF (PARTYP .NE. 'E') THEN
            DO 130 J = 1, LENARY

               CALL PRINC3 (PARM1(J), PARM2(J), PARM3(J), PARM4(J),
     $              PARM5(J), PARM6(J), EV, INFO)
               IF (INFO .NE. 0) THEN
                  CALL INTSTR (1, 0, INFO, STRA, LSTRA)
                  CALL PRTERR ('FATAL',
     &               'Library function PRINC3 has an error = '
     &               // STRA(:LSTRA))
                  GOTO 160
               END IF

               IF (RETMIN) THEN
                  RESULT(J) = EV(1)
               ELSE
                  RESULT(J) = EV(3)
               END IF
  130       CONTINUE

         ELSE
            DO 150 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 140 J = IXELB(IELB-1)+1, IXELB(IELB)
                     CALL PRINC3 (PARM1(J), PARM2(J), PARM3(J),
     $                    PARM4(J), PARM5(J), PARM6(J), EV, INFO)
                     IF (INFO .NE. 0) THEN
                        CALL INTSTR (1, 0, INFO, STRA, LSTRA)
                        CALL PRTERR ('FATAL',
     &                     'Library function PRINC3 has an error = '
     &                     // STRA(:LSTRA))
                        GOTO 160
                     END IF

                     IF (RETMIN) THEN
                        RESULT(J) = EV(1)
                     ELSE
                        RESULT(J) = EV(3)
                     END IF
  140             CONTINUE
               END IF
  150       CONTINUE
         END IF
      END IF

      RETURN

  160 CONTINUE
      RETURN 1
      END


      subroutine gen7m(r,p,m3,m4,m5,wt3,*)
c----generate 7 dimensional phase space weight and vectors p(mxpart,4)
c----           p1+p2+(p3+p4+p5)+(p6+p7+p8)+p9=0
c----  where (p3+p4+p5) has mass m3, (p6+p7+p8) has mass m4 and p9, m5
c----and x1 and x2 given nineteen random numbers
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'masses.f'
      include 'process.f'
      include 'phasemin.f'
      include 'x1x2.f'
      integer nu,j
      double precision r(mxdim),wt3
      double precision p(mxpart,4),
     . p1(4),p2(4),p3(4),p4(4),p5(4),p6(4),p7(4),p8(4),p9(4),m3,m4,m5
      double precision pswt,xjac,tau,y

      include 'energy.f'

      do nu=1,4
      do j=1,mxpart
      p(j,nu)=0d0
      enddo
      enddo

      wt3=0d0
      tau=exp(dlog(taumin)*r(18))
      y=0.5d0*dlog(tau)*(1d0-2d0*r(19))
      xjac=dlog(taumin)*tau*dlog(tau)

      xx(1)=dsqrt(tau)*exp(+y)
      xx(2)=dsqrt(tau)*exp(-y)

c---if x's out of normal range alternative return
      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) return 1

      p1(4)=-xx(1)*sqrts*half
      p1(1)=zip
      p1(2)=zip
      p1(3)=-xx(1)*sqrts*half

      p2(4)=-xx(2)*sqrts*half
      p2(1)=zip
      p2(2)=zip
      p2(3)=+xx(2)*sqrts*half

      if (case .eq. 'tottth') then
      m3=mt
      m4=mt
      m5=hmass
      endif

      call phase7m_alt(r,p1,p2,p3,p4,p5,p6,p7,p8,p9,m3,m4,m5,pswt)

      do nu=1,4
      p(1,nu)=p1(nu)
      p(2,nu)=p2(nu)
      p(3,nu)=p3(nu)
      p(4,nu)=p4(nu)
      p(5,nu)=p5(nu)
      p(6,nu)=p6(nu)
      p(7,nu)=p7(nu)
      p(8,nu)=p8(nu)
      p(9,nu)=p9(nu)
      enddo
      wt3=xjac*pswt

      if (wt3 .eq. 0d0) return 1

      return
      end


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Linear Algebra Data and Routines File
!
! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : cb05cl_ae5_LinearAlgebra.f90
! Time                 : Thu Feb  8 11:36:55 2018
! Working directory    : /home/Earth/mdawson/Documents/partmc-chem/partmc/test/chemistry/cb05cl_ae5
! Equation file        : cb05cl_ae5.kpp
! Output root filename : cb05cl_ae5
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE cb05cl_ae5_LinearAlgebra

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

  IMPLICIT NONE

CONTAINS

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! SPARSE_UTIL - SPARSE utility functions
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecomp( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER  :: IER
      REAL(kind=dp) :: JVS(LU_NONZERO), W(NVAR), a
      INTEGER  :: k, kk, j, jj

      a = 0. ! mz_rs_20050606
      IER = 0
      DO k=1,NVAR
        ! mz_rs_20050606: don't check if real value == 0
        ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN
        IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecomp

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecompCmplx( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization, complex
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER        :: IER
      DOUBLE COMPLEX :: JVS(LU_NONZERO), W(NVAR), a
      REAL(kind=dp)  :: b = 0.0
      INTEGER        :: k, kk, j, jj

      IER = 0
      DO k=1,NVAR
        IF ( ABS(JVS(LU_DIAG(k))) < TINY(b) ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecompCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecompCmplxR( JVSR, JVSI, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Sparse LU factorization, complex
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER       :: IER
      REAL(kind=dp) :: JVSR(LU_NONZERO), JVSI(LU_NONZERO)
      REAL(kind=dp) :: WR(NVAR), WI(NVAR), ar, ai, den
      INTEGER       :: k, kk, j, jj

      IER = 0
      ar  = 0.0
      DO k=1,NVAR
        IF (  ( ABS(JVSR(LU_DIAG(k))) < TINY(ar) ) .AND. &
              ( ABS(JVSI(LU_DIAG(k))) < TINY(ar) ) )  THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              WR( LU_ICOL(kk) ) = JVSR(kk)
              WI( LU_ICOL(kk) ) = JVSI(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            den = JVSR(LU_DIAG(j))**2 + JVSI(LU_DIAG(j))**2
            ar = -(WR(j)*JVSR(LU_DIAG(j)) + WI(j)*JVSI(LU_DIAG(j)))/den
            ai = -(WI(j)*JVSR(LU_DIAG(j)) - WR(j)*JVSI(LU_DIAG(j)))/den
            WR(j) = -ar
            WI(j) = -ai
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               WR( LU_ICOL(jj) ) = WR( LU_ICOL(jj) ) + ar*JVSR(jj) - ai*JVSI(jj)
               WI( LU_ICOL(jj) ) = WI( LU_ICOL(jj) ) + ar*JVSI(jj) + ai*JVSR(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVSR(kk) = WR( LU_ICOL(kk) )
            JVSI(kk) = WI( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecompCmplxR

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveIndirect( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER  :: i, j
      REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KppSolveIndirect

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRIndirect( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve transpose subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER       :: i, j
      REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR)

      DO i=1,NVAR
        X(i) = X(i)/JVS(LU_DIAG(i))
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

END SUBROUTINE KppSolveTRIndirect

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveCmplx( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER        :: i, j
      DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KppSolveCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveCmplxR( JVSR, JVSI, XR, XI )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Complex sparse solve subroutine using indirect addressing
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER       ::  i, j
      REAL(kind=dp) ::  JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), sumr, sumi, den

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             XR(i) = XR(i) - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j)))
             XI(i) = XI(i) - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j)))
         END DO
      END DO

      DO i=NVAR,1,-1
        sumr = XR(i); sumi = XI(i)
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
            sumr = sumr - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j)))
            sumi = sumi - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j)))
        END DO
        den   = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2
        XR(i) = (sumr*JVSR(LU_DIAG(i)) + sumi*JVSI(LU_DIAG(i)))/den
        XI(i) = (sumi*JVSR(LU_DIAG(i)) - sumr*JVSI(LU_DIAG(i)))/den
      END DO

END SUBROUTINE KppSolveCmplxR

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRCmplx( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve transpose subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER        :: i, j
      DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR)

      DO i=1,NVAR
        X(i) = X(i)/JVS(LU_DIAG(i))
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

END SUBROUTINE KppSolveTRCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRCmplxR( JVSR, JVSI, XR, XI )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Complex sparse solve transpose subroutine using indirect addressing
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE cb05cl_ae5_Parameters
  USE cb05cl_ae5_JacobianSP

      INTEGER       ::  i, j
      REAL(kind=dp) ::  JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), den

      DO i=1,NVAR
        den   = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2
        XR(i) = (XR(i)*JVSR(LU_DIAG(i)) + XI(i)*JVSI(LU_DIAG(i)))/den
        XI(i) = (XI(i)*JVSR(LU_DIAG(i)) - XR(i)*JVSI(LU_DIAG(i)))/den
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i))
	  XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i))
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i))
	  XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i))
	END DO
      END DO

END SUBROUTINE KppSolveTRCmplxR

!
! Next few commented subroutines perform sparse big linear algebra
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppDecompBig( JVS, IP, IER )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Sparse LU factorization
!!        for the Runge Kutta (3n)x(3n) linear system
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE cb05cl_ae5_Parameters
!  USE cb05cl_ae5_JacobianSP
!
!      INTEGER  :: IP3(3), IER, IP(3,NVAR)
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), W(3,3,NVAR), a(3,3), E(3,3)
!      INTEGER  :: k, kk, j, jj
!
!      a = 0.0d0
!      IER = 0
!      DO k=1,NVAR
!        DO kk = LU_CROW(k), LU_CROW(k+1)-1
!              W( 1:3,1:3,LU_ICOL(kk) ) = JVS(1:3,1:3,kk)
!        END DO
!        DO kk = LU_CROW(k), LU_DIAG(k)-1
!            j = LU_ICOL(kk)
!            E(1:3,1:3) = JVS( 1:3,1:3,LU_DIAG(j) )
!            ! CALL DGETRF(3,3,E,3,IP3,IER)
!            CALL FAC3(E,IP3,IER)
!            IF ( IER /= 0 )  RETURN
!            ! a = W(j) / JVS( LU_DIAG(j) )
!            a(1:3,1:3) = W( 1:3,1:3,j )
!            ! CALL DGETRS ('N',3,3,E,3,IP3,a,3,IER)
!            CALL SOL3('N',E,IP3,a(1,1))
!            CALL SOL3('N',E,IP3,a(1,2))
!            CALL SOL3('N',E,IP3,a(1,3))
!            W(1:3,1:3,j) = a(1:3,1:3)
!            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
!               W( 1:3,1:3,LU_ICOL(jj) ) = W( 1:3,1:3,LU_ICOL(jj) ) &
!                        - MATMUL( a(1:3,1:3) , JVS(1:3,1:3,jj) )
!            END DO
!         END DO
!         DO kk = LU_CROW(k), LU_CROW(k+1)-1
!            JVS(1:3,1:3,kk) = W( 1:3,1:3,LU_ICOL(kk) )
!         END DO
!      END DO
!
!      DO k=1,NVAR
!         ! CALL WGEFA(JVS(1,1,LU_DIAG(k)),3,3,IP(1,k),IER)
!         ! CALL DGETRF(3,3,JVS(1,1,LU_DIAG(k)),3,IP(1,k),IER)
!         CALL FAC3(JVS(1,1,LU_DIAG(k)),IP(1,k),IER)
!         IF ( IER /= 0 )  RETURN
!      END DO
!
!END SUBROUTINE KppDecompBig
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppSolveBig( JVS, IP, X )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Sparse solve subroutine using indirect addressing
!!        for the Runge Kutta (3n)x(3n) linear system
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE cb05cl_ae5_Parameters
!  USE cb05cl_ae5_JacobianSP
!
!      INTEGER  :: i, j, k, m, IP3(3), IP(3,NVAR), IER
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR), sum(3)
!
!      DO i=1,NVAR
!        DO j = LU_CROW(i), LU_DIAG(i)-1
!          !X(1:3,i) = X(1:3,i) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j)));
!          DO k=1,3
!            DO m=1,3
!	       X(k,i) = X(k,i) - JVS(k,m,j)*X(m,LU_ICOL(j))
!            END DO
!          END DO
!        END DO
!      END DO
!
!      DO i=NVAR,1,-1
!        sum(1:3) = X(1:3,i);
!        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
!          !sum(1:3) = sum(1:3) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j)));
!          DO k=1,3
!            DO m=1,3
!	       sum(k) = sum(k) - JVS(k,m,j)*X(m,LU_ICOL(j))
!            END DO
!          END DO
!        END DO
!        ! X(i) = sum/JVS(LU_DIAG(i));
!        ! CALL DGETRS ('N',3,1,JVS(1:3,1:3,LU_DIAG(i)),3,IP(1,i),sum,3,0)
!        ! CALL WGESL('N',JVS(1,1,LU_DIAG(i)),3,3,IP(1,i),sum)
!        CALL SOL3('N',JVS(1,1,LU_DIAG(i)),IP(1,i),sum)
!        X(1:3,i) = sum(1:3)
!      END DO
!
!END SUBROUTINE KppSolveBig
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppSolveBigTR( JVS, IP, X )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Big sparse transpose solve using indirect addressing
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE cb05cl_ae5_Parameters
!  USE cb05cl_ae5_JacobianSP
!
!      INTEGER       :: i, j, k, m, IP(3,NVAR)
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR)
!
!      DO i=1,NVAR
!        ! X(i) = X(i)/JVS(LU_DIAG(i))
!        CALL SOL3('T',JVS(1,1,LU_DIAG(i)),IP(1,i),X(1,i))
!        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
!	  !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) &
!          !    - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) )
!          DO k=1,3
!            DO m=1,3
!	       X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i)
!            END DO
!          END DO
!	END DO
!      END DO
!
!      DO i=NVAR, 1, -1
!        DO j=LU_CROW(i),LU_DIAG(i)-1
!	  !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) &
!          !   - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) )
!          DO k=1,3
!            DO m=1,3
!	       X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i)
!            END DO
!          END DO
!	END DO
!      END DO
!
!END SUBROUTINE KppSolveBigTR
!
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE FAC3(A,IPVT,INFO)
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!     FAC3 FACTORS THE MATRIX A (3,3) BY
!!           GAUSS ELIMINATION WITH PARTIAL PIVOTING
!!     LINPACK - LIKE
!!
!!     Remove comments to perform pivoting
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!
!      REAL(kind=dp) :: A(3,3)
!      INTEGER       :: IPVT(3),INFO
!!      INTEGER       :: L
!!      REAL(kind=dp) :: t, dmax, da, TMP(3)
!      REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0
!
!      info = 0
!!      t = TINY(da)
!!
!!      da = ABS(A(1,1)); L = 1
!!      IF ( ABS(A(2,1))>da ) THEN
!!        da = ABS(A(2,1)); L = 2
!!        IF ( ABS(A(3,1))>da ) THEN
!!          L = 3
!!        END IF
!!      END IF
!!      IPVT(1)  = L
!!      IF (L /=1 ) THEN
!!         TMP(1:3) = A(L,1:3)
!!         A(L,1:3) = A(1,1:3)
!!         A(1,1:3) = TMP(1:3)
!!      END IF
!!      IF (ABS(A(1,1)) < t) THEN
!!         info = 1
!!         return
!!      END IF
!!
!      A(2,1) = A(2,1)/A(1,1)
!      A(2,2) = A(2,2) - A(2,1)*A(1,2)
!      A(2,3) = A(2,3) - A(2,1)*A(1,3)
!      A(3,1) = A(3,1)/A(1,1)
!      A(3,2) = A(3,2) - A(3,1)*A(1,2)
!      A(3,3) = A(3,3) - A(3,1)*A(1,3)
!
!!      IPVT(2)  = 2
!!      IF (ABS(A(3,2))>ABS(A(2,2))) THEN
!!         IPVT(2)  = 3
!!         TMP(2:3) = A(3,2:3)
!!         A(3,2:3) = A(2,2:3)
!!         A(2,2:3) = TMP(2:3)
!!      END IF
!!      IF (ABS(A(2,2)) < t) THEN
!!         info = 1
!!         return
!!      END IF
!!
!      A(3,2)   = A(3,2)/A(2,2)
!      A(3,3)   = A(3,3) - A(3,2)*A(2,3)
!      IPVT(3)  = 3
!
!END SUBROUTINE FAC3
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE SOL3(Trans,A,IPVT,b)
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!     SOL3 solves the system 3x3
!!     A * x = b  or  trans(a) * x = b
!!     using the factors computed by WGEFA.
!!
!!     Trans      = 'N'   to solve  A*x = b ,
!!                = 'T'   to solve  transpose(A)*x = b
!!     LINPACK - LIKE
!!
!!     Remove comments to use pivoting
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!      CHARACTER     :: Trans
!      REAL(kind=dp) :: a(3,3),b(3)
!      INTEGER       :: IPVT(3)
!!      INTEGER       :: L
!!      REAL(kind=dp) :: TMP
!
!      SELECT CASE (Trans)
!
!      CASE ('n','N')  !  Solve  A * x = b
!
!!     Solve  L*y = b
!!         L = IPVT(1)
!!         IF (L /= 1) THEN
!!            TMP = B(1); B(1) = B(L); B(L) = TMP
!!         END IF
!         b(2) = b(2)-A(2,1)*b(1)
!         b(3) = b(3)-A(3,1)*b(1)
!
!!         L = IPVT(2)
!!         IF (L /= 2) THEN
!!            TMP = B(2); B(2) = B(L); B(L) = TMP
!!         END IF
!         b(3) = b(3)-A(3,2)*b(2)
!
!!     Solve  U*x = y
!         b(3) = b(3)/A(3,3)
!         b(2) = (b(2)-A(2,3)*b(3))/A(2,2)
!         b(1) = (b(1)-A(1,3)*b(3)-A(1,2)*b(2))/A(1,1)
!
!
!      CASE ('t','T')  !  Solve transpose(A) * x = b
!
!!      Solve transpose(U)*y = b
!         b(1) = b(1)/A(1,1)
!         b(2) = (b(2)-A(1,2)*b(1))/A(2,2)
!         b(3) = (b(3)-A(1,3)*b(1)-A(2,3)*b(2))/A(3,3)
!
!!      Solve transpose(L)*x = y
!         b(2) = b(2)-A(3,2)*b(3)
!!         L = ipvt(2)
!!         IF (L /= 2) THEN
!!            TMP = B(2); B(2) = B(L); B(L) = TMP
!!         END IF
!         b(1) = b(1)-A(3,1)*b(3)-A(2,1)*b(2)
!!         L = ipvt(1)
!!         IF (L /= 1) THEN
!!            TMP = B(1); B(1) = B(L); B(L) = TMP
!!         END IF
!
!      END SELECT
!
!END SUBROUTINE SOL3

! End of SPARSE_UTIL function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! KppSolve - sparse back substitution
!   Arguments :
!      JVS       - sparse Jacobian of variables
!      X         - Vector for variables
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE KppSolve ( JVS, X )

! JVS - sparse Jacobian of variables
  REAL(kind=dp) :: JVS(LU_NONZERO)
! X - Vector for variables
  REAL(kind=dp) :: X(NVAR)

  X(33) = X(33)-JVS(117)*X(23)-JVS(118)*X(25)
  X(38) = X(38)-JVS(139)*X(26)-JVS(140)*X(35)-JVS(141)*X(36)-JVS(142)*X(37)
  X(41) = X(41)-JVS(162)*X(25)
  X(45) = X(45)-JVS(186)*X(39)
  X(46) = X(46)-JVS(193)*X(24)
  X(47) = X(47)-JVS(205)*X(41)-JVS(206)*X(44)
  X(48) = X(48)-JVS(223)*X(33)
  X(50) = X(50)-JVS(234)*X(23)-JVS(235)*X(25)-JVS(236)*X(33)-JVS(237)*X(43)
  X(54) = X(54)-JVS(261)*X(53)
  X(55) = X(55)-JVS(268)*X(35)-JVS(269)*X(49)-JVS(270)*X(52)-JVS(271)*X(54)
  X(56) = X(56)-JVS(284)*X(25)-JVS(285)*X(49)-JVS(286)*X(52)-JVS(287)*X(53)-JVS(288)*X(54)
  X(58) = X(58)-JVS(306)*X(57)
  X(59) = X(59)-JVS(314)*X(37)-JVS(315)*X(40)-JVS(316)*X(48)-JVS(317)*X(49)-JVS(318)*X(50)-JVS(319)*X(51)-JVS(320)*X(52)&
            &-JVS(321)*X(53)-JVS(322)*X(54)-JVS(323)*X(55)-JVS(324)*X(56)-JVS(325)*X(57)-JVS(326)*X(58)
  X(60) = X(60)-JVS(338)*X(31)-JVS(339)*X(35)-JVS(340)*X(37)-JVS(341)*X(40)-JVS(342)*X(49)-JVS(343)*X(53)-JVS(344)*X(54)&
            &-JVS(345)*X(55)-JVS(346)*X(56)-JVS(347)*X(57)-JVS(348)*X(58)
  X(61) = X(61)-JVS(363)*X(36)-JVS(364)*X(37)-JVS(365)*X(39)-JVS(366)*X(45)-JVS(367)*X(48)-JVS(368)*X(50)-JVS(369)*X(51)&
            &-JVS(370)*X(52)-JVS(371)*X(53)-JVS(372)*X(54)-JVS(373)*X(57)-JVS(374)*X(58)
  X(62) = X(62)-JVS(388)*X(33)-JVS(389)*X(43)-JVS(390)*X(49)-JVS(391)*X(50)-JVS(392)*X(52)-JVS(393)*X(55)-JVS(394)*X(56)&
            &-JVS(395)*X(57)-JVS(396)*X(58)
  X(63) = X(63)-JVS(407)*X(48)-JVS(408)*X(50)-JVS(409)*X(51)-JVS(410)*X(52)-JVS(411)*X(53)-JVS(412)*X(54)-JVS(413)*X(57)&
            &-JVS(414)*X(58)
  X(64) = X(64)-JVS(425)*X(26)-JVS(426)*X(30)-JVS(427)*X(34)-JVS(428)*X(45)-JVS(429)*X(59)-JVS(430)*X(60)-JVS(431)*X(61)&
            &-JVS(432)*X(62)-JVS(433)*X(63)
  X(65) = X(65)-JVS(445)*X(23)-JVS(446)*X(25)-JVS(447)*X(35)-JVS(448)*X(37)-JVS(449)*X(40)-JVS(450)*X(41)-JVS(451)*X(45)&
            &-JVS(452)*X(48)-JVS(453)*X(49)-JVS(454)*X(50)-JVS(455)*X(51)-JVS(456)*X(52)-JVS(457)*X(53)-JVS(458)*X(54)&
            &-JVS(459)*X(55)-JVS(460)*X(56)-JVS(461)*X(57)-JVS(462)*X(58)-JVS(463)*X(61)-JVS(464)*X(62)-JVS(465)*X(63)&
            &-JVS(466)*X(64)
  X(66) = X(66)-JVS(477)*X(22)-JVS(478)*X(30)-JVS(479)*X(41)-JVS(480)*X(48)-JVS(481)*X(50)-JVS(482)*X(58)-JVS(483)*X(60)&
            &-JVS(484)*X(62)-JVS(485)*X(63)-JVS(486)*X(64)-JVS(487)*X(65)
  X(67) = X(67)-JVS(497)*X(18)-JVS(498)*X(21)-JVS(499)*X(26)-JVS(500)*X(35)-JVS(501)*X(36)-JVS(502)*X(37)-JVS(503)*X(38)&
            &-JVS(504)*X(42)-JVS(505)*X(44)-JVS(506)*X(51)-JVS(507)*X(53)-JVS(508)*X(54)-JVS(509)*X(56)-JVS(510)*X(57)&
            &-JVS(511)*X(58)-JVS(512)*X(59)-JVS(513)*X(60)-JVS(514)*X(61)-JVS(515)*X(62)-JVS(516)*X(63)-JVS(517)*X(64)&
            &-JVS(518)*X(65)-JVS(519)*X(66)
  X(68) = X(68)-JVS(528)*X(27)-JVS(529)*X(33)-JVS(530)*X(39)-JVS(531)*X(42)-JVS(532)*X(55)-JVS(533)*X(56)-JVS(534)*X(57)&
            &-JVS(535)*X(58)-JVS(536)*X(61)-JVS(537)*X(62)-JVS(538)*X(63)-JVS(539)*X(64)-JVS(540)*X(65)-JVS(541)*X(66)&
            &-JVS(542)*X(67)
  X(69) = X(69)-JVS(550)*X(19)-JVS(551)*X(20)-JVS(552)*X(23)-JVS(553)*X(25)-JVS(554)*X(28)-JVS(555)*X(29)-JVS(556)*X(32)&
            &-JVS(557)*X(33)-JVS(558)*X(35)-JVS(559)*X(36)-JVS(560)*X(37)-JVS(561)*X(39)-JVS(562)*X(40)-JVS(563)*X(41)&
            &-JVS(564)*X(42)-JVS(565)*X(43)-JVS(566)*X(44)-JVS(567)*X(45)-JVS(568)*X(47)-JVS(569)*X(48)-JVS(570)*X(49)&
            &-JVS(571)*X(50)-JVS(572)*X(51)-JVS(573)*X(52)-JVS(574)*X(53)-JVS(575)*X(54)-JVS(576)*X(55)-JVS(577)*X(56)&
            &-JVS(578)*X(57)-JVS(579)*X(58)-JVS(580)*X(59)-JVS(581)*X(60)-JVS(582)*X(61)-JVS(583)*X(62)-JVS(584)*X(63)&
            &-JVS(585)*X(64)-JVS(586)*X(65)-JVS(587)*X(66)-JVS(588)*X(67)-JVS(589)*X(68)
  X(70) = X(70)-JVS(596)*X(24)-JVS(597)*X(32)-JVS(598)*X(46)-JVS(599)*X(50)-JVS(600)*X(51)-JVS(601)*X(52)-JVS(602)*X(53)&
            &-JVS(603)*X(54)-JVS(604)*X(57)-JVS(605)*X(58)-JVS(606)*X(59)-JVS(607)*X(60)-JVS(608)*X(61)-JVS(609)*X(62)&
            &-JVS(610)*X(63)-JVS(611)*X(64)-JVS(612)*X(65)-JVS(613)*X(66)-JVS(614)*X(67)-JVS(615)*X(68)-JVS(616)*X(69)
  X(71) = X(71)-JVS(622)*X(19)-JVS(623)*X(20)-JVS(624)*X(21)-JVS(625)*X(23)-JVS(626)*X(25)-JVS(627)*X(26)-JVS(628)*X(27)&
            &-JVS(629)*X(28)-JVS(630)*X(29)-JVS(631)*X(30)-JVS(632)*X(31)-JVS(633)*X(32)-JVS(634)*X(34)-JVS(635)*X(35)&
            &-JVS(636)*X(36)-JVS(637)*X(37)-JVS(638)*X(38)-JVS(639)*X(39)-JVS(640)*X(40)-JVS(641)*X(41)-JVS(642)*X(42)&
            &-JVS(643)*X(44)-JVS(644)*X(45)-JVS(645)*X(46)-JVS(646)*X(47)-JVS(647)*X(48)-JVS(648)*X(50)-JVS(649)*X(51)&
            &-JVS(650)*X(52)-JVS(651)*X(53)-JVS(652)*X(54)-JVS(653)*X(55)-JVS(654)*X(56)-JVS(655)*X(57)-JVS(656)*X(58)&
            &-JVS(657)*X(59)-JVS(658)*X(60)-JVS(659)*X(61)-JVS(660)*X(62)-JVS(661)*X(63)-JVS(662)*X(64)-JVS(663)*X(65)&
            &-JVS(664)*X(66)-JVS(665)*X(67)-JVS(666)*X(68)-JVS(667)*X(69)-JVS(668)*X(70)
  X(72) = X(72)-JVS(673)*X(31)-JVS(674)*X(52)-JVS(675)*X(57)-JVS(676)*X(58)-JVS(677)*X(59)-JVS(678)*X(62)-JVS(679)*X(63)&
            &-JVS(680)*X(64)-JVS(681)*X(65)-JVS(682)*X(66)-JVS(683)*X(67)-JVS(684)*X(68)-JVS(685)*X(69)-JVS(686)*X(70)&
            &-JVS(687)*X(71)
  X(73) = X(73)-JVS(691)*X(20)-JVS(692)*X(28)-JVS(693)*X(51)-JVS(694)*X(52)-JVS(695)*X(53)-JVS(696)*X(54)-JVS(697)*X(57)&
            &-JVS(698)*X(59)-JVS(699)*X(60)-JVS(700)*X(61)-JVS(701)*X(62)-JVS(702)*X(63)-JVS(703)*X(64)-JVS(704)*X(65)&
            &-JVS(705)*X(66)-JVS(706)*X(67)-JVS(707)*X(68)-JVS(708)*X(69)-JVS(709)*X(70)-JVS(710)*X(71)-JVS(711)*X(72)
  X(74) = X(74)-JVS(714)*X(22)-JVS(715)*X(24)-JVS(716)*X(27)-JVS(717)*X(31)-JVS(718)*X(32)-JVS(719)*X(33)-JVS(720)*X(39)&
            &-JVS(721)*X(42)-JVS(722)*X(43)-JVS(723)*X(46)-JVS(724)*X(49)-JVS(725)*X(50)-JVS(726)*X(51)-JVS(727)*X(52)&
            &-JVS(728)*X(53)-JVS(729)*X(54)-JVS(730)*X(56)-JVS(731)*X(57)-JVS(732)*X(58)-JVS(733)*X(59)-JVS(734)*X(60)&
            &-JVS(735)*X(61)-JVS(736)*X(62)-JVS(737)*X(63)-JVS(738)*X(64)-JVS(739)*X(65)-JVS(740)*X(66)-JVS(741)*X(67)&
            &-JVS(742)*X(68)-JVS(743)*X(69)-JVS(744)*X(70)-JVS(745)*X(71)-JVS(746)*X(72)-JVS(747)*X(73)
  X(74) = X(74)/JVS(748)
  X(73) = (X(73)-JVS(713)*X(74))/(JVS(712))
  X(72) = (X(72)-JVS(689)*X(73)-JVS(690)*X(74))/(JVS(688))
  X(71) = (X(71)-JVS(670)*X(72)-JVS(671)*X(73)-JVS(672)*X(74))/(JVS(669))
  X(70) = (X(70)-JVS(618)*X(71)-JVS(619)*X(72)-JVS(620)*X(73)-JVS(621)*X(74))/(JVS(617))
  X(69) = (X(69)-JVS(591)*X(70)-JVS(592)*X(71)-JVS(593)*X(72)-JVS(594)*X(73)-JVS(595)*X(74))/(JVS(590))
  X(68) = (X(68)-JVS(544)*X(69)-JVS(545)*X(70)-JVS(546)*X(71)-JVS(547)*X(72)-JVS(548)*X(73)-JVS(549)*X(74))/(JVS(543))
  X(67) = (X(67)-JVS(521)*X(68)-JVS(522)*X(69)-JVS(523)*X(70)-JVS(524)*X(71)-JVS(525)*X(72)-JVS(526)*X(73)-JVS(527)&
            &*X(74))/(JVS(520))
  X(66) = (X(66)-JVS(489)*X(67)-JVS(490)*X(68)-JVS(491)*X(69)-JVS(492)*X(70)-JVS(493)*X(71)-JVS(494)*X(72)-JVS(495)&
            &*X(73)-JVS(496)*X(74))/(JVS(488))
  X(65) = (X(65)-JVS(468)*X(66)-JVS(469)*X(67)-JVS(470)*X(68)-JVS(471)*X(69)-JVS(472)*X(70)-JVS(473)*X(71)-JVS(474)&
            &*X(72)-JVS(475)*X(73)-JVS(476)*X(74))/(JVS(467))
  X(64) = (X(64)-JVS(435)*X(65)-JVS(436)*X(66)-JVS(437)*X(67)-JVS(438)*X(68)-JVS(439)*X(69)-JVS(440)*X(70)-JVS(441)&
            &*X(71)-JVS(442)*X(72)-JVS(443)*X(73)-JVS(444)*X(74))/(JVS(434))
  X(63) = (X(63)-JVS(416)*X(66)-JVS(417)*X(67)-JVS(418)*X(68)-JVS(419)*X(69)-JVS(420)*X(70)-JVS(421)*X(71)-JVS(422)&
            &*X(72)-JVS(423)*X(73)-JVS(424)*X(74))/(JVS(415))
  X(62) = (X(62)-JVS(398)*X(63)-JVS(399)*X(65)-JVS(400)*X(67)-JVS(401)*X(68)-JVS(402)*X(69)-JVS(403)*X(70)-JVS(404)&
            &*X(71)-JVS(405)*X(73)-JVS(406)*X(74))/(JVS(397))
  X(61) = (X(61)-JVS(376)*X(62)-JVS(377)*X(63)-JVS(378)*X(64)-JVS(379)*X(66)-JVS(380)*X(67)-JVS(381)*X(68)-JVS(382)&
            &*X(69)-JVS(383)*X(70)-JVS(384)*X(71)-JVS(385)*X(72)-JVS(386)*X(73)-JVS(387)*X(74))/(JVS(375))
  X(60) = (X(60)-JVS(350)*X(62)-JVS(351)*X(63)-JVS(352)*X(64)-JVS(353)*X(65)-JVS(354)*X(66)-JVS(355)*X(67)-JVS(356)&
            &*X(68)-JVS(357)*X(69)-JVS(358)*X(70)-JVS(359)*X(71)-JVS(360)*X(72)-JVS(361)*X(73)-JVS(362)*X(74))/(JVS(349))
  X(59) = (X(59)-JVS(328)*X(62)-JVS(329)*X(63)-JVS(330)*X(65)-JVS(331)*X(67)-JVS(332)*X(68)-JVS(333)*X(69)-JVS(334)&
            &*X(70)-JVS(335)*X(71)-JVS(336)*X(73)-JVS(337)*X(74))/(JVS(327))
  X(58) = (X(58)-JVS(308)*X(63)-JVS(309)*X(67)-JVS(310)*X(70)-JVS(311)*X(71)-JVS(312)*X(73)-JVS(313)*X(74))/(JVS(307))
  X(57) = (X(57)-JVS(300)*X(63)-JVS(301)*X(67)-JVS(302)*X(70)-JVS(303)*X(71)-JVS(304)*X(73)-JVS(305)*X(74))/(JVS(299))
  X(56) = (X(56)-JVS(290)*X(57)-JVS(291)*X(58)-JVS(292)*X(62)-JVS(293)*X(63)-JVS(294)*X(67)-JVS(295)*X(70)-JVS(296)&
            &*X(71)-JVS(297)*X(73)-JVS(298)*X(74))/(JVS(289))
  X(55) = (X(55)-JVS(273)*X(56)-JVS(274)*X(57)-JVS(275)*X(63)-JVS(276)*X(65)-JVS(277)*X(67)-JVS(278)*X(68)-JVS(279)&
            &*X(69)-JVS(280)*X(70)-JVS(281)*X(71)-JVS(282)*X(73)-JVS(283)*X(74))/(JVS(272))
  X(54) = (X(54)-JVS(263)*X(63)-JVS(264)*X(67)-JVS(265)*X(70)-JVS(266)*X(71)-JVS(267)*X(73))/(JVS(262))
  X(53) = (X(53)-JVS(256)*X(63)-JVS(257)*X(67)-JVS(258)*X(70)-JVS(259)*X(71)-JVS(260)*X(73))/(JVS(255))
  X(52) = (X(52)-JVS(251)*X(63)-JVS(252)*X(70)-JVS(253)*X(71)-JVS(254)*X(73))/(JVS(250))
  X(51) = (X(51)-JVS(245)*X(63)-JVS(246)*X(67)-JVS(247)*X(70)-JVS(248)*X(71)-JVS(249)*X(73))/(JVS(244))
  X(50) = (X(50)-JVS(239)*X(68)-JVS(240)*X(69)-JVS(241)*X(70)-JVS(242)*X(71)-JVS(243)*X(74))/(JVS(238))
  X(49) = (X(49)-JVS(230)*X(56)-JVS(231)*X(67)-JVS(232)*X(71)-JVS(233)*X(74))/(JVS(229))
  X(48) = (X(48)-JVS(225)*X(50)-JVS(226)*X(63)-JVS(227)*X(68)-JVS(228)*X(71))/(JVS(224))
  X(47) = (X(47)-JVS(208)*X(48)-JVS(209)*X(51)-JVS(210)*X(52)-JVS(211)*X(53)-JVS(212)*X(54)-JVS(213)*X(57)-JVS(214)&
            &*X(58)-JVS(215)*X(59)-JVS(216)*X(60)-JVS(217)*X(61)-JVS(218)*X(63)-JVS(219)*X(67)-JVS(220)*X(70)-JVS(221)*X(71)&
            &-JVS(222)*X(73))/(JVS(207))
  X(46) = (X(46)-JVS(195)*X(50)-JVS(196)*X(58)-JVS(197)*X(59)-JVS(198)*X(60)-JVS(199)*X(61)-JVS(200)*X(62)-JVS(201)&
            &*X(69)-JVS(202)*X(70)-JVS(203)*X(71)-JVS(204)*X(74))/(JVS(194))
  X(45) = (X(45)-JVS(188)*X(61)-JVS(189)*X(64)-JVS(190)*X(68)-JVS(191)*X(69)-JVS(192)*X(71))/(JVS(187))
  X(44) = (X(44)-JVS(180)*X(51)-JVS(181)*X(53)-JVS(182)*X(54)-JVS(183)*X(57)-JVS(184)*X(67)-JVS(185)*X(71))/(JVS(179))
  X(43) = (X(43)-JVS(174)*X(50)-JVS(175)*X(69)-JVS(176)*X(70)-JVS(177)*X(71)-JVS(178)*X(74))/(JVS(173))
  X(42) = (X(42)-JVS(169)*X(63)-JVS(170)*X(67)-JVS(171)*X(68)-JVS(172)*X(69))/(JVS(168))
  X(41) = (X(41)-JVS(164)*X(48)-JVS(165)*X(58)-JVS(166)*X(63)-JVS(167)*X(71))/(JVS(163))
  X(40) = (X(40)-JVS(158)*X(55)-JVS(159)*X(65)-JVS(160)*X(69)-JVS(161)*X(71))/(JVS(157))
  X(39) = (X(39)-JVS(154)*X(61)-JVS(155)*X(68)-JVS(156)*X(69))/(JVS(153))
  X(38) = (X(38)-JVS(144)*X(53)-JVS(145)*X(56)-JVS(146)*X(57)-JVS(147)*X(59)-JVS(148)*X(60)-JVS(149)*X(61)-JVS(150)&
            &*X(64)-JVS(151)*X(67)-JVS(152)*X(71))/(JVS(143))
  X(37) = (X(37)-JVS(137)*X(67)-JVS(138)*X(71))/(JVS(136))
  X(36) = (X(36)-JVS(133)*X(64)-JVS(134)*X(67)-JVS(135)*X(71))/(JVS(132))
  X(35) = (X(35)-JVS(130)*X(67)-JVS(131)*X(71))/(JVS(129))
  X(34) = (X(34)-JVS(123)*X(64)-JVS(124)*X(65)-JVS(125)*X(66)-JVS(126)*X(69)-JVS(127)*X(71)-JVS(128)*X(72))/(JVS(122))
  X(33) = (X(33)-JVS(120)*X(68)-JVS(121)*X(71))/(JVS(119))
  X(32) = (X(32)-JVS(114)*X(69)-JVS(115)*X(71)-JVS(116)*X(74))/(JVS(113))
  X(31) = (X(31)-JVS(110)*X(71)-JVS(111)*X(72)-JVS(112)*X(74))/(JVS(109))
  X(30) = (X(30)-JVS(105)*X(66)-JVS(106)*X(69)-JVS(107)*X(71)-JVS(108)*X(72))/(JVS(104))
  X(29) = (X(29)-JVS(99)*X(39)-JVS(100)*X(51)-JVS(101)*X(63)-JVS(102)*X(68)-JVS(103)*X(71))/(JVS(98))
  X(28) = (X(28)-JVS(95)*X(69)-JVS(96)*X(71)-JVS(97)*X(73))/(JVS(94))
  X(27) = (X(27)-JVS(91)*X(68)-JVS(92)*X(71)-JVS(93)*X(74))/(JVS(90))
  X(26) = (X(26)-JVS(88)*X(67)-JVS(89)*X(71))/(JVS(87))
  X(25) = (X(25)-JVS(86)*X(71))/(JVS(85))
  X(24) = (X(24)-JVS(83)*X(70)-JVS(84)*X(74))/(JVS(82))
  X(23) = (X(23)-JVS(81)*X(71))/(JVS(80))
  X(22) = (X(22)-JVS(78)*X(66)-JVS(79)*X(74))/(JVS(77))
  X(21) = (X(21)-JVS(75)*X(42)-JVS(76)*X(69))/(JVS(74))
  X(20) = (X(20)-JVS(73)*X(63))/(JVS(72))
  X(19) = (X(19)-JVS(71)*X(71))/(JVS(70))
  X(18) = (X(18)-JVS(69)*X(42))/(JVS(68))
  X(17) = (X(17)-JVS(61)*X(22)-JVS(62)*X(24)-JVS(63)*X(31)-JVS(64)*X(55)-JVS(65)*X(65)-JVS(66)*X(69)-JVS(67)*X(71))&
            &/(JVS(60))
  X(16) = (X(16)-JVS(56)*X(25)-JVS(57)*X(68)-JVS(58)*X(69)-JVS(59)*X(71))/(JVS(55))
  X(15) = (X(15)-JVS(53)*X(16)-JVS(54)*X(68))/(JVS(52))
  X(14) = (X(14)-JVS(50)*X(16)-JVS(51)*X(69))/(JVS(49))
  X(13) = (X(13)-JVS(44)*X(52)-JVS(45)*X(63)-JVS(46)*X(70)-JVS(47)*X(71)-JVS(48)*X(73))/(JVS(43))
  X(12) = (X(12)-JVS(39)*X(23)-JVS(40)*X(68)-JVS(41)*X(69)-JVS(42)*X(71))/(JVS(38))
  X(11) = (X(11)-JVS(36)*X(12)-JVS(37)*X(68))/(JVS(35))
  X(10) = (X(10)-JVS(33)*X(12)-JVS(34)*X(69))/(JVS(32))
  X(9) = (X(9)-JVS(30)*X(19)-JVS(31)*X(71))/(JVS(29))
  X(8) = (X(8)-JVS(27)*X(19)-JVS(28)*X(71))/(JVS(26))
  X(7) = (X(7)-JVS(23)*X(63)-JVS(24)*X(70)-JVS(25)*X(71))/(JVS(22))
  X(6) = (X(6)-JVS(18)*X(7)-JVS(19)*X(63)-JVS(20)*X(70)-JVS(21)*X(71))/(JVS(17))
  X(5) = (X(5)-JVS(15)*X(57)-JVS(16)*X(71))/(JVS(14))
  X(4) = (X(4)-JVS(13)*X(71))/(JVS(12))
  X(3) = (X(3)-JVS(8)*X(4)-JVS(9)*X(68)-JVS(10)*X(69)-JVS(11)*X(71))/(JVS(7))
  X(2) = (X(2)-JVS(5)*X(3)-JVS(6)*X(68))/(JVS(4))
  X(1) = (X(1)-JVS(2)*X(3)-JVS(3)*X(69))/(JVS(1))

END SUBROUTINE KppSolve

! End of KppSolve function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! KppSolveTR - sparse, transposed back substitution
!   Arguments :
!      JVS       - sparse Jacobian of variables
!      X         - Vector for variables
!      XX        - Vector for output variables
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE KppSolveTR ( JVS, X, XX )

! JVS - sparse Jacobian of variables
  REAL(kind=dp) :: JVS(LU_NONZERO)
! X - Vector for variables
  REAL(kind=dp) :: X(NVAR)
! XX - Vector for output variables
  REAL(kind=dp) :: XX(NVAR)

  XX(1) = X(1)/JVS(1)
  XX(2) = X(2)/JVS(4)
  XX(3) = (X(3)-JVS(2)*XX(1)-JVS(5)*XX(2))/(JVS(7))
  XX(4) = (X(4)-JVS(8)*XX(3))/(JVS(12))
  XX(5) = X(5)/JVS(14)
  XX(6) = X(6)/JVS(17)
  XX(7) = (X(7)-JVS(18)*XX(6))/(JVS(22))
  XX(8) = X(8)/JVS(26)
  XX(9) = X(9)/JVS(29)
  XX(10) = X(10)/JVS(32)
  XX(11) = X(11)/JVS(35)
  XX(12) = (X(12)-JVS(33)*XX(10)-JVS(36)*XX(11))/(JVS(38))
  XX(13) = X(13)/JVS(43)
  XX(14) = X(14)/JVS(49)
  XX(15) = X(15)/JVS(52)
  XX(16) = (X(16)-JVS(50)*XX(14)-JVS(53)*XX(15))/(JVS(55))
  XX(17) = X(17)/JVS(60)
  XX(18) = X(18)/JVS(68)
  XX(19) = (X(19)-JVS(27)*XX(8)-JVS(30)*XX(9))/(JVS(70))
  XX(20) = X(20)/JVS(72)
  XX(21) = X(21)/JVS(74)
  XX(22) = (X(22)-JVS(61)*XX(17))/(JVS(77))
  XX(23) = (X(23)-JVS(39)*XX(12))/(JVS(80))
  XX(24) = (X(24)-JVS(62)*XX(17))/(JVS(82))
  XX(25) = (X(25)-JVS(56)*XX(16))/(JVS(85))
  XX(26) = X(26)/JVS(87)
  XX(27) = X(27)/JVS(90)
  XX(28) = X(28)/JVS(94)
  XX(29) = X(29)/JVS(98)
  XX(30) = X(30)/JVS(104)
  XX(31) = (X(31)-JVS(63)*XX(17))/(JVS(109))
  XX(32) = X(32)/JVS(113)
  XX(33) = X(33)/JVS(119)
  XX(34) = X(34)/JVS(122)
  XX(35) = X(35)/JVS(129)
  XX(36) = X(36)/JVS(132)
  XX(37) = X(37)/JVS(136)
  XX(38) = X(38)/JVS(143)
  XX(39) = (X(39)-JVS(99)*XX(29))/(JVS(153))
  XX(40) = X(40)/JVS(157)
  XX(41) = X(41)/JVS(163)
  XX(42) = (X(42)-JVS(69)*XX(18)-JVS(75)*XX(21))/(JVS(168))
  XX(43) = X(43)/JVS(173)
  XX(44) = X(44)/JVS(179)
  XX(45) = X(45)/JVS(187)
  XX(46) = X(46)/JVS(194)
  XX(47) = X(47)/JVS(207)
  XX(48) = (X(48)-JVS(164)*XX(41)-JVS(208)*XX(47))/(JVS(224))
  XX(49) = X(49)/JVS(229)
  XX(50) = (X(50)-JVS(174)*XX(43)-JVS(195)*XX(46)-JVS(225)*XX(48))/(JVS(238))
  XX(51) = (X(51)-JVS(100)*XX(29)-JVS(180)*XX(44)-JVS(209)*XX(47))/(JVS(244))
  XX(52) = (X(52)-JVS(44)*XX(13)-JVS(210)*XX(47))/(JVS(250))
  XX(53) = (X(53)-JVS(144)*XX(38)-JVS(181)*XX(44)-JVS(211)*XX(47))/(JVS(255))
  XX(54) = (X(54)-JVS(182)*XX(44)-JVS(212)*XX(47))/(JVS(262))
  XX(55) = (X(55)-JVS(64)*XX(17)-JVS(158)*XX(40))/(JVS(272))
  XX(56) = (X(56)-JVS(145)*XX(38)-JVS(230)*XX(49)-JVS(273)*XX(55))/(JVS(289))
  XX(57) = (X(57)-JVS(15)*XX(5)-JVS(146)*XX(38)-JVS(183)*XX(44)-JVS(213)*XX(47)-JVS(274)*XX(55)-JVS(290)*XX(56))&
             &/(JVS(299))
  XX(58) = (X(58)-JVS(165)*XX(41)-JVS(196)*XX(46)-JVS(214)*XX(47)-JVS(291)*XX(56))/(JVS(307))
  XX(59) = (X(59)-JVS(147)*XX(38)-JVS(197)*XX(46)-JVS(215)*XX(47))/(JVS(327))
  XX(60) = (X(60)-JVS(148)*XX(38)-JVS(198)*XX(46)-JVS(216)*XX(47))/(JVS(349))
  XX(61) = (X(61)-JVS(149)*XX(38)-JVS(154)*XX(39)-JVS(188)*XX(45)-JVS(199)*XX(46)-JVS(217)*XX(47))/(JVS(375))
  XX(62) = (X(62)-JVS(200)*XX(46)-JVS(292)*XX(56)-JVS(328)*XX(59)-JVS(350)*XX(60)-JVS(376)*XX(61))/(JVS(397))
  XX(63) = (X(63)-JVS(19)*XX(6)-JVS(23)*XX(7)-JVS(45)*XX(13)-JVS(73)*XX(20)-JVS(101)*XX(29)-JVS(166)*XX(41)-JVS(169)&
             &*XX(42)-JVS(218)*XX(47)-JVS(226)*XX(48)-JVS(245)*XX(51)-JVS(251)*XX(52)-JVS(256)*XX(53)-JVS(263)*XX(54)&
             &-JVS(275)*XX(55)-JVS(293)*XX(56)-JVS(300)*XX(57)-JVS(308)*XX(58)-JVS(329)*XX(59)-JVS(351)*XX(60)-JVS(377)&
             &*XX(61)-JVS(398)*XX(62))/(JVS(415))
  XX(64) = (X(64)-JVS(123)*XX(34)-JVS(133)*XX(36)-JVS(150)*XX(38)-JVS(189)*XX(45)-JVS(352)*XX(60)-JVS(378)*XX(61))&
             &/(JVS(434))
  XX(65) = (X(65)-JVS(65)*XX(17)-JVS(124)*XX(34)-JVS(159)*XX(40)-JVS(276)*XX(55)-JVS(330)*XX(59)-JVS(353)*XX(60)&
             &-JVS(399)*XX(62)-JVS(435)*XX(64))/(JVS(467))
  XX(66) = (X(66)-JVS(78)*XX(22)-JVS(105)*XX(30)-JVS(125)*XX(34)-JVS(354)*XX(60)-JVS(379)*XX(61)-JVS(416)*XX(63)&
             &-JVS(436)*XX(64)-JVS(468)*XX(65))/(JVS(488))
  XX(67) = (X(67)-JVS(88)*XX(26)-JVS(130)*XX(35)-JVS(134)*XX(36)-JVS(137)*XX(37)-JVS(151)*XX(38)-JVS(170)*XX(42)&
             &-JVS(184)*XX(44)-JVS(219)*XX(47)-JVS(231)*XX(49)-JVS(246)*XX(51)-JVS(257)*XX(53)-JVS(264)*XX(54)-JVS(277)&
             &*XX(55)-JVS(294)*XX(56)-JVS(301)*XX(57)-JVS(309)*XX(58)-JVS(331)*XX(59)-JVS(355)*XX(60)-JVS(380)*XX(61)&
             &-JVS(400)*XX(62)-JVS(417)*XX(63)-JVS(437)*XX(64)-JVS(469)*XX(65)-JVS(489)*XX(66))/(JVS(520))
  XX(68) = (X(68)-JVS(6)*XX(2)-JVS(9)*XX(3)-JVS(37)*XX(11)-JVS(40)*XX(12)-JVS(54)*XX(15)-JVS(57)*XX(16)-JVS(91)*XX(27)&
             &-JVS(102)*XX(29)-JVS(120)*XX(33)-JVS(155)*XX(39)-JVS(171)*XX(42)-JVS(190)*XX(45)-JVS(227)*XX(48)-JVS(239)&
             &*XX(50)-JVS(278)*XX(55)-JVS(332)*XX(59)-JVS(356)*XX(60)-JVS(381)*XX(61)-JVS(401)*XX(62)-JVS(418)*XX(63)&
             &-JVS(438)*XX(64)-JVS(470)*XX(65)-JVS(490)*XX(66)-JVS(521)*XX(67))/(JVS(543))
  XX(69) = (X(69)-JVS(3)*XX(1)-JVS(10)*XX(3)-JVS(34)*XX(10)-JVS(41)*XX(12)-JVS(51)*XX(14)-JVS(58)*XX(16)-JVS(66)*XX(17)&
             &-JVS(76)*XX(21)-JVS(95)*XX(28)-JVS(106)*XX(30)-JVS(114)*XX(32)-JVS(126)*XX(34)-JVS(156)*XX(39)-JVS(160)*XX(40)&
             &-JVS(172)*XX(42)-JVS(175)*XX(43)-JVS(191)*XX(45)-JVS(201)*XX(46)-JVS(240)*XX(50)-JVS(279)*XX(55)-JVS(333)&
             &*XX(59)-JVS(357)*XX(60)-JVS(382)*XX(61)-JVS(402)*XX(62)-JVS(419)*XX(63)-JVS(439)*XX(64)-JVS(471)*XX(65)&
             &-JVS(491)*XX(66)-JVS(522)*XX(67)-JVS(544)*XX(68))/(JVS(590))
  XX(70) = (X(70)-JVS(20)*XX(6)-JVS(24)*XX(7)-JVS(46)*XX(13)-JVS(83)*XX(24)-JVS(176)*XX(43)-JVS(202)*XX(46)-JVS(220)&
             &*XX(47)-JVS(241)*XX(50)-JVS(247)*XX(51)-JVS(252)*XX(52)-JVS(258)*XX(53)-JVS(265)*XX(54)-JVS(280)*XX(55)&
             &-JVS(295)*XX(56)-JVS(302)*XX(57)-JVS(310)*XX(58)-JVS(334)*XX(59)-JVS(358)*XX(60)-JVS(383)*XX(61)-JVS(403)&
             &*XX(62)-JVS(420)*XX(63)-JVS(440)*XX(64)-JVS(472)*XX(65)-JVS(492)*XX(66)-JVS(523)*XX(67)-JVS(545)*XX(68)&
             &-JVS(591)*XX(69))/(JVS(617))
  XX(71) = (X(71)-JVS(11)*XX(3)-JVS(13)*XX(4)-JVS(16)*XX(5)-JVS(21)*XX(6)-JVS(25)*XX(7)-JVS(28)*XX(8)-JVS(31)*XX(9)&
             &-JVS(42)*XX(12)-JVS(47)*XX(13)-JVS(59)*XX(16)-JVS(67)*XX(17)-JVS(71)*XX(19)-JVS(81)*XX(23)-JVS(86)*XX(25)&
             &-JVS(89)*XX(26)-JVS(92)*XX(27)-JVS(96)*XX(28)-JVS(103)*XX(29)-JVS(107)*XX(30)-JVS(110)*XX(31)-JVS(115)*XX(32)&
             &-JVS(121)*XX(33)-JVS(127)*XX(34)-JVS(131)*XX(35)-JVS(135)*XX(36)-JVS(138)*XX(37)-JVS(152)*XX(38)-JVS(161)&
             &*XX(40)-JVS(167)*XX(41)-JVS(177)*XX(43)-JVS(185)*XX(44)-JVS(192)*XX(45)-JVS(203)*XX(46)-JVS(221)*XX(47)&
             &-JVS(228)*XX(48)-JVS(232)*XX(49)-JVS(242)*XX(50)-JVS(248)*XX(51)-JVS(253)*XX(52)-JVS(259)*XX(53)-JVS(266)&
             &*XX(54)-JVS(281)*XX(55)-JVS(296)*XX(56)-JVS(303)*XX(57)-JVS(311)*XX(58)-JVS(335)*XX(59)-JVS(359)*XX(60)&
             &-JVS(384)*XX(61)-JVS(404)*XX(62)-JVS(421)*XX(63)-JVS(441)*XX(64)-JVS(473)*XX(65)-JVS(493)*XX(66)-JVS(524)&
             &*XX(67)-JVS(546)*XX(68)-JVS(592)*XX(69)-JVS(618)*XX(70))/(JVS(669))
  XX(72) = (X(72)-JVS(108)*XX(30)-JVS(111)*XX(31)-JVS(128)*XX(34)-JVS(360)*XX(60)-JVS(385)*XX(61)-JVS(422)*XX(63)&
             &-JVS(442)*XX(64)-JVS(474)*XX(65)-JVS(494)*XX(66)-JVS(525)*XX(67)-JVS(547)*XX(68)-JVS(593)*XX(69)-JVS(619)&
             &*XX(70)-JVS(670)*XX(71))/(JVS(688))
  XX(73) = (X(73)-JVS(48)*XX(13)-JVS(97)*XX(28)-JVS(222)*XX(47)-JVS(249)*XX(51)-JVS(254)*XX(52)-JVS(260)*XX(53)-JVS(267)&
             &*XX(54)-JVS(282)*XX(55)-JVS(297)*XX(56)-JVS(304)*XX(57)-JVS(312)*XX(58)-JVS(336)*XX(59)-JVS(361)*XX(60)&
             &-JVS(386)*XX(61)-JVS(405)*XX(62)-JVS(423)*XX(63)-JVS(443)*XX(64)-JVS(475)*XX(65)-JVS(495)*XX(66)-JVS(526)&
             &*XX(67)-JVS(548)*XX(68)-JVS(594)*XX(69)-JVS(620)*XX(70)-JVS(671)*XX(71)-JVS(689)*XX(72))/(JVS(712))
  XX(74) = (X(74)-JVS(79)*XX(22)-JVS(84)*XX(24)-JVS(93)*XX(27)-JVS(112)*XX(31)-JVS(116)*XX(32)-JVS(178)*XX(43)-JVS(204)&
             &*XX(46)-JVS(233)*XX(49)-JVS(243)*XX(50)-JVS(283)*XX(55)-JVS(298)*XX(56)-JVS(305)*XX(57)-JVS(313)*XX(58)&
             &-JVS(337)*XX(59)-JVS(362)*XX(60)-JVS(387)*XX(61)-JVS(406)*XX(62)-JVS(424)*XX(63)-JVS(444)*XX(64)-JVS(476)&
             &*XX(65)-JVS(496)*XX(66)-JVS(527)*XX(67)-JVS(549)*XX(68)-JVS(595)*XX(69)-JVS(621)*XX(70)-JVS(672)*XX(71)&
             &-JVS(690)*XX(72)-JVS(713)*XX(73))/(JVS(748))
  XX(74) = XX(74)
  XX(73) = XX(73)-JVS(747)*XX(74)
  XX(72) = XX(72)-JVS(711)*XX(73)-JVS(746)*XX(74)
  XX(71) = XX(71)-JVS(687)*XX(72)-JVS(710)*XX(73)-JVS(745)*XX(74)
  XX(70) = XX(70)-JVS(668)*XX(71)-JVS(686)*XX(72)-JVS(709)*XX(73)-JVS(744)*XX(74)
  XX(69) = XX(69)-JVS(616)*XX(70)-JVS(667)*XX(71)-JVS(685)*XX(72)-JVS(708)*XX(73)-JVS(743)*XX(74)
  XX(68) = XX(68)-JVS(589)*XX(69)-JVS(615)*XX(70)-JVS(666)*XX(71)-JVS(684)*XX(72)-JVS(707)*XX(73)-JVS(742)*XX(74)
  XX(67) = XX(67)-JVS(542)*XX(68)-JVS(588)*XX(69)-JVS(614)*XX(70)-JVS(665)*XX(71)-JVS(683)*XX(72)-JVS(706)*XX(73)&
             &-JVS(741)*XX(74)
  XX(66) = XX(66)-JVS(519)*XX(67)-JVS(541)*XX(68)-JVS(587)*XX(69)-JVS(613)*XX(70)-JVS(664)*XX(71)-JVS(682)*XX(72)&
             &-JVS(705)*XX(73)-JVS(740)*XX(74)
  XX(65) = XX(65)-JVS(487)*XX(66)-JVS(518)*XX(67)-JVS(540)*XX(68)-JVS(586)*XX(69)-JVS(612)*XX(70)-JVS(663)*XX(71)&
             &-JVS(681)*XX(72)-JVS(704)*XX(73)-JVS(739)*XX(74)
  XX(64) = XX(64)-JVS(466)*XX(65)-JVS(486)*XX(66)-JVS(517)*XX(67)-JVS(539)*XX(68)-JVS(585)*XX(69)-JVS(611)*XX(70)&
             &-JVS(662)*XX(71)-JVS(680)*XX(72)-JVS(703)*XX(73)-JVS(738)*XX(74)
  XX(63) = XX(63)-JVS(433)*XX(64)-JVS(465)*XX(65)-JVS(485)*XX(66)-JVS(516)*XX(67)-JVS(538)*XX(68)-JVS(584)*XX(69)&
             &-JVS(610)*XX(70)-JVS(661)*XX(71)-JVS(679)*XX(72)-JVS(702)*XX(73)-JVS(737)*XX(74)
  XX(62) = XX(62)-JVS(432)*XX(64)-JVS(464)*XX(65)-JVS(484)*XX(66)-JVS(515)*XX(67)-JVS(537)*XX(68)-JVS(583)*XX(69)&
             &-JVS(609)*XX(70)-JVS(660)*XX(71)-JVS(678)*XX(72)-JVS(701)*XX(73)-JVS(736)*XX(74)
  XX(61) = XX(61)-JVS(431)*XX(64)-JVS(463)*XX(65)-JVS(514)*XX(67)-JVS(536)*XX(68)-JVS(582)*XX(69)-JVS(608)*XX(70)&
             &-JVS(659)*XX(71)-JVS(700)*XX(73)-JVS(735)*XX(74)
  XX(60) = XX(60)-JVS(430)*XX(64)-JVS(483)*XX(66)-JVS(513)*XX(67)-JVS(581)*XX(69)-JVS(607)*XX(70)-JVS(658)*XX(71)&
             &-JVS(699)*XX(73)-JVS(734)*XX(74)
  XX(59) = XX(59)-JVS(429)*XX(64)-JVS(512)*XX(67)-JVS(580)*XX(69)-JVS(606)*XX(70)-JVS(657)*XX(71)-JVS(677)*XX(72)&
             &-JVS(698)*XX(73)-JVS(733)*XX(74)
  XX(58) = XX(58)-JVS(326)*XX(59)-JVS(348)*XX(60)-JVS(374)*XX(61)-JVS(396)*XX(62)-JVS(414)*XX(63)-JVS(462)*XX(65)&
             &-JVS(482)*XX(66)-JVS(511)*XX(67)-JVS(535)*XX(68)-JVS(579)*XX(69)-JVS(605)*XX(70)-JVS(656)*XX(71)-JVS(676)&
             &*XX(72)-JVS(732)*XX(74)
  XX(57) = XX(57)-JVS(306)*XX(58)-JVS(325)*XX(59)-JVS(347)*XX(60)-JVS(373)*XX(61)-JVS(395)*XX(62)-JVS(413)*XX(63)&
             &-JVS(461)*XX(65)-JVS(510)*XX(67)-JVS(534)*XX(68)-JVS(578)*XX(69)-JVS(604)*XX(70)-JVS(655)*XX(71)-JVS(675)&
             &*XX(72)-JVS(697)*XX(73)-JVS(731)*XX(74)
  XX(56) = XX(56)-JVS(324)*XX(59)-JVS(346)*XX(60)-JVS(394)*XX(62)-JVS(460)*XX(65)-JVS(509)*XX(67)-JVS(533)*XX(68)&
             &-JVS(577)*XX(69)-JVS(654)*XX(71)-JVS(730)*XX(74)
  XX(55) = XX(55)-JVS(323)*XX(59)-JVS(345)*XX(60)-JVS(393)*XX(62)-JVS(459)*XX(65)-JVS(532)*XX(68)-JVS(576)*XX(69)&
             &-JVS(653)*XX(71)
  XX(54) = XX(54)-JVS(271)*XX(55)-JVS(288)*XX(56)-JVS(322)*XX(59)-JVS(344)*XX(60)-JVS(372)*XX(61)-JVS(412)*XX(63)&
             &-JVS(458)*XX(65)-JVS(508)*XX(67)-JVS(575)*XX(69)-JVS(603)*XX(70)-JVS(652)*XX(71)-JVS(696)*XX(73)-JVS(729)&
             &*XX(74)
  XX(53) = XX(53)-JVS(261)*XX(54)-JVS(287)*XX(56)-JVS(321)*XX(59)-JVS(343)*XX(60)-JVS(371)*XX(61)-JVS(411)*XX(63)&
             &-JVS(457)*XX(65)-JVS(507)*XX(67)-JVS(574)*XX(69)-JVS(602)*XX(70)-JVS(651)*XX(71)-JVS(695)*XX(73)-JVS(728)&
             &*XX(74)
  XX(52) = XX(52)-JVS(270)*XX(55)-JVS(286)*XX(56)-JVS(320)*XX(59)-JVS(370)*XX(61)-JVS(392)*XX(62)-JVS(410)*XX(63)&
             &-JVS(456)*XX(65)-JVS(573)*XX(69)-JVS(601)*XX(70)-JVS(650)*XX(71)-JVS(674)*XX(72)-JVS(694)*XX(73)-JVS(727)&
             &*XX(74)
  XX(51) = XX(51)-JVS(319)*XX(59)-JVS(369)*XX(61)-JVS(409)*XX(63)-JVS(455)*XX(65)-JVS(506)*XX(67)-JVS(572)*XX(69)&
             &-JVS(600)*XX(70)-JVS(649)*XX(71)-JVS(693)*XX(73)-JVS(726)*XX(74)
  XX(50) = XX(50)-JVS(318)*XX(59)-JVS(368)*XX(61)-JVS(391)*XX(62)-JVS(408)*XX(63)-JVS(454)*XX(65)-JVS(481)*XX(66)&
             &-JVS(571)*XX(69)-JVS(599)*XX(70)-JVS(648)*XX(71)-JVS(725)*XX(74)
  XX(49) = XX(49)-JVS(269)*XX(55)-JVS(285)*XX(56)-JVS(317)*XX(59)-JVS(342)*XX(60)-JVS(390)*XX(62)-JVS(453)*XX(65)&
             &-JVS(570)*XX(69)-JVS(724)*XX(74)
  XX(48) = XX(48)-JVS(316)*XX(59)-JVS(367)*XX(61)-JVS(407)*XX(63)-JVS(452)*XX(65)-JVS(480)*XX(66)-JVS(569)*XX(69)&
             &-JVS(647)*XX(71)
  XX(47) = XX(47)-JVS(568)*XX(69)-JVS(646)*XX(71)
  XX(46) = XX(46)-JVS(598)*XX(70)-JVS(645)*XX(71)-JVS(723)*XX(74)
  XX(45) = XX(45)-JVS(366)*XX(61)-JVS(428)*XX(64)-JVS(451)*XX(65)-JVS(567)*XX(69)-JVS(644)*XX(71)
  XX(44) = XX(44)-JVS(206)*XX(47)-JVS(505)*XX(67)-JVS(566)*XX(69)-JVS(643)*XX(71)
  XX(43) = XX(43)-JVS(237)*XX(50)-JVS(389)*XX(62)-JVS(565)*XX(69)-JVS(722)*XX(74)
  XX(42) = XX(42)-JVS(504)*XX(67)-JVS(531)*XX(68)-JVS(564)*XX(69)-JVS(642)*XX(71)-JVS(721)*XX(74)
  XX(41) = XX(41)-JVS(205)*XX(47)-JVS(450)*XX(65)-JVS(479)*XX(66)-JVS(563)*XX(69)-JVS(641)*XX(71)
  XX(40) = XX(40)-JVS(315)*XX(59)-JVS(341)*XX(60)-JVS(449)*XX(65)-JVS(562)*XX(69)-JVS(640)*XX(71)
  XX(39) = XX(39)-JVS(186)*XX(45)-JVS(365)*XX(61)-JVS(530)*XX(68)-JVS(561)*XX(69)-JVS(639)*XX(71)-JVS(720)*XX(74)
  XX(38) = XX(38)-JVS(503)*XX(67)-JVS(638)*XX(71)
  XX(37) = XX(37)-JVS(142)*XX(38)-JVS(314)*XX(59)-JVS(340)*XX(60)-JVS(364)*XX(61)-JVS(448)*XX(65)-JVS(502)*XX(67)&
             &-JVS(560)*XX(69)-JVS(637)*XX(71)
  XX(36) = XX(36)-JVS(141)*XX(38)-JVS(363)*XX(61)-JVS(501)*XX(67)-JVS(559)*XX(69)-JVS(636)*XX(71)
  XX(35) = XX(35)-JVS(140)*XX(38)-JVS(268)*XX(55)-JVS(339)*XX(60)-JVS(447)*XX(65)-JVS(500)*XX(67)-JVS(558)*XX(69)&
             &-JVS(635)*XX(71)
  XX(34) = XX(34)-JVS(427)*XX(64)-JVS(634)*XX(71)
  XX(33) = XX(33)-JVS(223)*XX(48)-JVS(236)*XX(50)-JVS(388)*XX(62)-JVS(529)*XX(68)-JVS(557)*XX(69)-JVS(719)*XX(74)
  XX(32) = XX(32)-JVS(556)*XX(69)-JVS(597)*XX(70)-JVS(633)*XX(71)-JVS(718)*XX(74)
  XX(31) = XX(31)-JVS(338)*XX(60)-JVS(632)*XX(71)-JVS(673)*XX(72)-JVS(717)*XX(74)
  XX(30) = XX(30)-JVS(426)*XX(64)-JVS(478)*XX(66)-JVS(631)*XX(71)
  XX(29) = XX(29)-JVS(555)*XX(69)-JVS(630)*XX(71)
  XX(28) = XX(28)-JVS(554)*XX(69)-JVS(629)*XX(71)-JVS(692)*XX(73)
  XX(27) = XX(27)-JVS(528)*XX(68)-JVS(628)*XX(71)-JVS(716)*XX(74)
  XX(26) = XX(26)-JVS(139)*XX(38)-JVS(425)*XX(64)-JVS(499)*XX(67)-JVS(627)*XX(71)
  XX(25) = XX(25)-JVS(118)*XX(33)-JVS(162)*XX(41)-JVS(235)*XX(50)-JVS(284)*XX(56)-JVS(446)*XX(65)-JVS(553)*XX(69)&
             &-JVS(626)*XX(71)
  XX(24) = XX(24)-JVS(193)*XX(46)-JVS(596)*XX(70)-JVS(715)*XX(74)
  XX(23) = XX(23)-JVS(117)*XX(33)-JVS(234)*XX(50)-JVS(445)*XX(65)-JVS(552)*XX(69)-JVS(625)*XX(71)
  XX(22) = XX(22)-JVS(477)*XX(66)-JVS(714)*XX(74)
  XX(21) = XX(21)-JVS(498)*XX(67)-JVS(624)*XX(71)
  XX(20) = XX(20)-JVS(551)*XX(69)-JVS(623)*XX(71)-JVS(691)*XX(73)
  XX(19) = XX(19)-JVS(550)*XX(69)-JVS(622)*XX(71)
  XX(18) = XX(18)-JVS(497)*XX(67)
  XX(17) = XX(17)
  XX(16) = XX(16)
  XX(15) = XX(15)
  XX(14) = XX(14)
  XX(13) = XX(13)
  XX(12) = XX(12)
  XX(11) = XX(11)
  XX(10) = XX(10)
  XX(9) = XX(9)
  XX(8) = XX(8)
  XX(7) = XX(7)
  XX(6) = XX(6)
  XX(5) = XX(5)
  XX(4) = XX(4)
  XX(3) = XX(3)
  XX(2) = XX(2)
  XX(1) = XX(1)

END SUBROUTINE KppSolveTR

! End of KppSolveTR function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! BLAS_UTIL - BLAS-LIKE utility functions
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!--------------------------------------------------------------
!
! BLAS/LAPACK-like subroutines used by the integration algorithms
! It is recommended to replace them by calls to the optimized
!      BLAS/LAPACK library for your machine
!
!  (C) Adrian Sandu, Aug. 2004
!      Virginia Polytechnic Institute and State University
!--------------------------------------------------------------

!--------------------------------------------------------------
      SUBROUTINE WCOPY(N,X,incX,Y,incY)
!--------------------------------------------------------------
!     copies a vector, x, to a vector, y:  y <- x
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL  SCOPY(N,X,1,Y,1)   or   CALL  DCOPY(N,X,1,Y,1)
!--------------------------------------------------------------
!     USE cb05cl_ae5_Precision

      INTEGER  :: i,incX,incY,M,MP1,N
      REAL(kind=dp) :: X(N),Y(N)

      IF (N.LE.0) RETURN

      M = MOD(N,8)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = X(i)
        END DO
        IF( N .LT. 8 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,8
        Y(i) = X(i)
        Y(i + 1) = X(i + 1)
        Y(i + 2) = X(i + 2)
        Y(i + 3) = X(i + 3)
        Y(i + 4) = X(i + 4)
        Y(i + 5) = X(i + 5)
        Y(i + 6) = X(i + 6)
        Y(i + 7) = X(i + 7)
      END DO

      END SUBROUTINE WCOPY

!--------------------------------------------------------------
      SUBROUTINE WAXPY(N,Alpha,X,incX,Y,incY)
!--------------------------------------------------------------
!     constant times a vector plus a vector: y <- y + Alpha*x
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SAXPY(N,Alpha,X,1,Y,1) or  CALL DAXPY(N,Alpha,X,1,Y,1)
!--------------------------------------------------------------

      INTEGER  :: i,incX,incY,M,MP1,N
      REAL(kind=dp) :: X(N),Y(N),Alpha
      REAL(kind=dp), PARAMETER :: ZERO = 0.0_dp

      IF (Alpha .EQ. ZERO) RETURN
      IF (N .LE. 0) RETURN

      M = MOD(N,4)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = Y(i) + Alpha*X(i)
        END DO
        IF( N .LT. 4 ) RETURN
      END IF
      MP1 = M + 1
      DO i = MP1,N,4
        Y(i) = Y(i) + Alpha*X(i)
        Y(i + 1) = Y(i + 1) + Alpha*X(i + 1)
        Y(i + 2) = Y(i + 2) + Alpha*X(i + 2)
        Y(i + 3) = Y(i + 3) + Alpha*X(i + 3)
      END DO

      END SUBROUTINE WAXPY

!--------------------------------------------------------------
      SUBROUTINE WSCAL(N,Alpha,X,incX)
!--------------------------------------------------------------
!     constant times a vector: x(1:N) <- Alpha*x(1:N)
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SSCAL(N,Alpha,X,1) or  CALL DSCAL(N,Alpha,X,1)
!--------------------------------------------------------------

      INTEGER  :: i,incX,M,MP1,N
      REAL(kind=dp)  :: X(N),Alpha
      REAL(kind=dp), PARAMETER  :: ZERO=0.0_dp, ONE=1.0_dp

      IF (Alpha .EQ. ONE) RETURN
      IF (N .LE. 0) RETURN

      M = MOD(N,5)
      IF( M .NE. 0 ) THEN
        IF (Alpha .EQ. (-ONE)) THEN
          DO i = 1,M
            X(i) = -X(i)
          END DO
        ELSEIF (Alpha .EQ. ZERO) THEN
          DO i = 1,M
            X(i) = ZERO
          END DO
        ELSE
          DO i = 1,M
            X(i) = Alpha*X(i)
          END DO
        END IF
        IF( N .LT. 5 ) RETURN
      END IF
      MP1 = M + 1
      IF (Alpha .EQ. (-ONE)) THEN
        DO i = MP1,N,5
          X(i)     = -X(i)
          X(i + 1) = -X(i + 1)
          X(i + 2) = -X(i + 2)
          X(i + 3) = -X(i + 3)
          X(i + 4) = -X(i + 4)
        END DO
      ELSEIF (Alpha .EQ. ZERO) THEN
        DO i = MP1,N,5
          X(i)     = ZERO
          X(i + 1) = ZERO
          X(i + 2) = ZERO
          X(i + 3) = ZERO
          X(i + 4) = ZERO
        END DO
      ELSE
        DO i = MP1,N,5
          X(i)     = Alpha*X(i)
          X(i + 1) = Alpha*X(i + 1)
          X(i + 2) = Alpha*X(i + 2)
          X(i + 3) = Alpha*X(i + 3)
          X(i + 4) = Alpha*X(i + 4)
        END DO
      END IF

      END SUBROUTINE WSCAL

!--------------------------------------------------------------
      REAL(kind=dp) FUNCTION WLAMCH( C )
!--------------------------------------------------------------
!     returns epsilon machine
!     after LAPACK
!     replace this by the function from the optimized LAPACK implementation:
!          CALL SLAMCH('E') or CALL DLAMCH('E')
!--------------------------------------------------------------
!      USE cb05cl_ae5_Precision

      CHARACTER ::  C
      INTEGER    :: i
      REAL(kind=dp), SAVE  ::  Eps
      REAL(kind=dp)  ::  Suma
      REAL(kind=dp), PARAMETER  ::  ONE=1.0_dp, HALF=0.5_dp
      LOGICAL, SAVE   ::  First=.TRUE.

      IF (First) THEN
        First = .FALSE.
        Eps = HALF**(16)
        DO i = 17, 80
          Eps = Eps*HALF
          CALL WLAMCH_ADD(ONE,Eps,Suma)
          IF (Suma.LE.ONE) GOTO 10
        END DO
        PRINT*,'ERROR IN WLAMCH. EPS < ',Eps
        RETURN
10      Eps = Eps*2
        i = i-1
      END IF

      WLAMCH = Eps

      END FUNCTION WLAMCH

      SUBROUTINE WLAMCH_ADD( A, B, Suma )
!      USE cb05cl_ae5_Precision

      REAL(kind=dp) A, B, Suma
      Suma = A + B

      END SUBROUTINE WLAMCH_ADD
!--------------------------------------------------------------

!--------------------------------------------------------------
      SUBROUTINE SET2ZERO(N,Y)
!--------------------------------------------------------------
!     copies zeros into the vector y:  y <- 0
!     after BLAS
!--------------------------------------------------------------

      INTEGER ::  i,M,MP1,N
      REAL(kind=dp) ::  Y(N)
      REAL(kind=dp), PARAMETER :: ZERO = 0.0d0

      IF (N.LE.0) RETURN

      M = MOD(N,8)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = ZERO
        END DO
        IF( N .LT. 8 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,8
        Y(i)     = ZERO
        Y(i + 1) = ZERO
        Y(i + 2) = ZERO
        Y(i + 3) = ZERO
        Y(i + 4) = ZERO
        Y(i + 5) = ZERO
        Y(i + 6) = ZERO
        Y(i + 7) = ZERO
      END DO

      END SUBROUTINE SET2ZERO

!--------------------------------------------------------------
      REAL(kind=dp) FUNCTION WDOT (N, DX, incX, DY, incY)
!--------------------------------------------------------------
!     dot produce: wdot = x(1:N)*y(1:N)
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SDOT(N,X,1,Y,1) or  CALL DDOT(N,X,1,Y,1)
!--------------------------------------------------------------
!      USE messy_mecca_kpp_Precision
!--------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: N, incX, incY
      REAL(kind=dp) :: DX(N), DY(N)

      INTEGER :: i, IX, IY, M, MP1, NS

      WDOT = 0.0D0
      IF (N .LE. 0) RETURN
      IF (incX .EQ. incY) IF (incX-1) 5,20,60
!
!     Code for unequal or nonpositive increments.
!
    5 IX = 1
      IY = 1
      IF (incX .LT. 0) IX = (-N+1)*incX + 1
      IF (incY .LT. 0) IY = (-N+1)*incY + 1
      DO i = 1,N
        WDOT = WDOT + DX(IX)*DY(IY)
        IX = IX + incX
        IY = IY + incY
      END DO
      RETURN
!
!     Code for both increments equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 5.
!
   20 M = MOD(N,5)
      IF (M .EQ. 0) GO TO 40
      DO i = 1,M
         WDOT = WDOT + DX(i)*DY(i)
      END DO
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO i = MP1,N,5
          WDOT = WDOT + DX(i)*DY(i) + DX(i+1)*DY(i+1) + DX(i+2)*DY(i+2) +  &
                   DX(i+3)*DY(i+3) + DX(i+4)*DY(i+4)
      END DO
      RETURN
!
!     Code for equal, positive, non-unit increments.
!
   60 NS = N*incX
      DO i = 1,NS,incX
        WDOT = WDOT + DX(i)*DY(i)
      END DO

      END FUNCTION WDOT

!--------------------------------------------------------------
      SUBROUTINE WADD(N,X,Y,Z)
!--------------------------------------------------------------
!     adds two vectors: z <- x + y
!     BLAS - like
!--------------------------------------------------------------
!     USE cb05cl_ae5_Precision

      INTEGER :: i, M, MP1, N
      REAL(kind=dp) :: X(N),Y(N),Z(N)

      IF (N.LE.0) RETURN

      M = MOD(N,5)
      IF( M /= 0 ) THEN
         DO i = 1,M
            Z(i) = X(i) + Y(i)
         END DO
         IF( N < 5 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,5
         Z(i)     = X(i)     + Y(i)
         Z(i + 1) = X(i + 1) + Y(i + 1)
         Z(i + 2) = X(i + 2) + Y(i + 2)
         Z(i + 3) = X(i + 3) + Y(i + 3)
         Z(i + 4) = X(i + 4) + Y(i + 4)
      END DO

      END SUBROUTINE WADD

!--------------------------------------------------------------
      SUBROUTINE WGEFA(N,A,Ipvt,info)
!--------------------------------------------------------------
!     WGEFA FACTORS THE MATRIX A (N,N) BY
!           GAUSS ELIMINATION WITH PARTIAL PIVOTING
!     LINPACK - LIKE
!--------------------------------------------------------------
!
      INTEGER       :: N,Ipvt(N),info
      REAL(kind=dp) :: A(N,N)
      REAL(kind=dp) :: t, dmax, da
      INTEGER       :: j,k,l
      REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0

      info = 0

size: IF (n > 1) THEN

col:  DO k = 1, n-1

!        find l = pivot index
!        l = idamax(n-k+1,A(k,k),1) + k - 1
         l = k; dmax = abs(A(k,k))
         DO j = k+1,n
            da = ABS(A(j,k))
            IF (da > dmax) THEN
              l = j; dmax = da
            END IF
         END DO
         Ipvt(k) = l

!        zero pivot implies this column already triangularized
         IF (ABS(A(l,k)) < TINY(ZERO)) THEN
            info = k
            return
         ELSE
            IF (l /= k) THEN
               t = A(l,k); A(l,k) = A(k,k); A(k,k) = t
            END IF
            t = -ONE/A(k,k)
            CALL WSCAL(n-k,t,A(k+1,k),1)
            DO j = k+1, n
               t = A(l,j)
               IF (l /= k) THEN
                  A(l,j) = A(k,j); A(k,j) = t
               END IF
               CALL WAXPY(n-k,t,A(k+1,k),1,A(k+1,j),1)
            END DO
         END IF

       END DO col

      END IF size

      Ipvt(N) = N
      IF (ABS(A(N,N)) == ZERO) info = N

      END SUBROUTINE WGEFA

!--------------------------------------------------------------
      SUBROUTINE WGESL(Trans,N,A,Ipvt,b)
!--------------------------------------------------------------
!     WGESL solves the system
!     a * x = b  or  trans(a) * x = b
!     using the factors computed by WGEFA.
!
!     Trans      = 'N'   to solve  A*x = b ,
!                = 'T'   to solve  transpose(A)*x = b
!     LINPACK - LIKE
!--------------------------------------------------------------

      INTEGER       :: N,Ipvt(N)
      CHARACTER     :: trans
      REAL(kind=dp) :: A(N,N),b(N)
      REAL(kind=dp) :: t
      INTEGER       :: k,kb,l

      SELECT CASE (Trans)

      CASE ('n','N')  !  Solve  A * x = b

!        first solve  L*y = b
         IF (n >= 2) THEN
          DO k = 1, n-1
            l = Ipvt(k)
            t = b(l)
            IF (l /= k) THEN
               b(l) = b(k)
               b(k) = t
            END IF
            CALL WAXPY(n-k,t,a(k+1,k),1,b(k+1),1)
          END DO
         END IF
!        now solve  U*x = y
         DO kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            CALL WAXPY(k-1,t,a(1,k),1,b(1),1)
         END DO

      CASE ('t','T')  !  Solve transpose(A) * x = b

!        first solve  trans(U)*y = b
         DO k = 1, n
            t = WDOT(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
         END DO
!        now solve trans(L)*x = y
         IF (n >= 2) THEN
         DO kb = 1, n-1
            k = n - kb
            b(k) = b(k) + WDOT(n-k,a(k+1,k),1,b(k+1),1)
            l = Ipvt(k)
            IF (l /= k) THEN
               t = b(l); b(l) = b(k); b(k) = t
            END IF
         END DO
         END IF

      END SELECT

      END SUBROUTINE WGESL
! End of BLAS_UTIL function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE cb05cl_ae5_LinearAlgebra