! ******************************************************************
! ******************************************************************
!
! Este programa tenta colocar todos os itens pequenos dentro da caixa
! maior primeiro, com o objetivo de minimizar o numero de caixas total
!
! ******************************************************************
! ******************************************************************

program algencanma

  use packdat

  implicit none

  ! LOCAL SCALARS
  logical      :: hasAppended, useReduction, useHeuristic
  integer      :: allocerr, i, j, it, container, numberOfSolutions, &
       lastContainer, nAllocTrials, nCntnr
  ! Timing variables
  integer(kind=8) :: tini, tend, ticks_ps
  real(kind=8) :: elapsed, f, fbest, remArea, limItArea, area, tiArea

  ! LOCAL ARRAYS
  character(80)         :: filename, solfname
  character(len=15)     :: strtmp
  real(kind=8), pointer :: x(:),lbest(:)
  integer, allocatable  :: lCntnr(:)

  ! EXTERNAL SUBROUTINES
  external :: myevalf,myevalg,myevalh,myevalc,myevaljac,myevalhc, &
              myevalfc,myevalgjac,myevalgjacp,myevalhl,myevalhlp, &
              alevalfc,alevalgjac

  ! Set problem's data

  filename = 'data.txt'

  solfname = 'solution.csv'

  nAllocTrials = 5

  open(99, file=solfname)

  write(99, *) ''

  close(99)

  useReduction = .true.

  ! Check arguments for Heuristic Mode
  useHeuristic = .true.

  if ( COMMAND_ARGUMENT_COUNT() .EQ. 1 ) then

     CALL GET_COMMAND_ARGUMENT(1, strtmp)

     read(strtmp, *) useHeuristic

  end if

  ! Start timing

  call SYSTEM_CLOCK(tini, ticks_ps)

  ! Load data

  call loadData(filename)

  ! Apply heuristics

  numberOfSolutions = 0

  if ( useReduction ) call reduction(numberOfSolutions, solfname)

  it = numberOfSolutions

  area = 0.0D0

  do i = 1, nItems

     area = area + iWidth(i) * iLength(i)

  end do
  write(*,*) 'Items total area:', area

  allocate(lbest(2 * nTItems + 1), x(2 * nTItems + 1), &
           lCntnr(nContainers), stat=allocerr)

  if ( allocerr .ne. 0 ) then

     write(*,*) 'Allocation errors in main program'

     stop

  end if

  ! Start of main loop

  call getAvContainers(lCntnr, nCntnr)

  lastContainer = 1

  do while ( nItems .gt. 0 )

     tiArea = 0.0D0

     do i = 1, nItems

        tiArea = tiArea + iWidth(i) * iLength(i)

     end do

     do container = lastContainer, nCntnr - 1

        call setCurrContainer(lCntnr(container))

        if ( cWidth * cLength .gt. tiArea ) then

           exit

        end if

     end do

     call setCurrContainer(lCntnr(container))

     write(*, *) 'Selected container:', lCntnr(container)

     filename = 'sol1.asy'

     fbest = 1.0D+20

     write(*,*)
     write(*,*) 'Creating initial allocation'
     write(*,*)

     call sortItems(x)

     call initialpoint(x, i * 123455, .false.)

     ! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !
     ! Deal with only one container !
     ! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !

     ! This step reduces the number of items

     call extractBoxes(x)

     write(filename, FMT="('sol',I0.3,'.asy')") it

     limItArea = 1.0D+20

     hasAppended = .true.

     write(*,*)
     write(*,*) 'Solving allocation problem'
     write(*,*)

     if ( useHeuristic ) call drawSol(x, filename, .false.)

     ! If in 'Heuristic Mode' do not go to solver
     do while ( .not. useHeuristic )

        ! Optimize

        fbest = 1.0D+20

        do i = 1, nAllocTrials

           call initialpoint(x, i * 123456, .false.)

           call solver(x, f, nItems, cWidth, cLength, iWidth, iLength)

           if (f .lt. fbest) then

              fbest = f

              do j = 1, 2 * nItems

                 lbest(j) = x(j)

              end do

              call drawSol(lbest, filename, .false.)

           end if

           if ( fbest .le. 1.0D-08 ) exit

        end do

        if ( .not. hasAppended ) exit

        if ( fbest .le. 1.0D-08 ) then

           remArea = cWidth * cLength

           do i = 1, nItems

              remArea = remArea - iWidth(i) * iLength(i)

           end do

           call appendBox(lbest, remArea, limItArea, hasAppended)

        else

           limItArea = iWidth(nItems) * iLength(nItems)

           call removeAppendedBox()

           remArea = cWidth * cLength

           do i = 1, nItems

              remArea = remArea - iWidth(i) * iLength(i)

           end do

           call appendBox(lbest, remArea, limItArea, hasAppended)

        end if

     end do

     if ( container .ne. nCntnr .and. remainingItems() .gt. 0 ) then

        write(*, *) 'Sobraram ', remainingItems(), 'itens, cancelando container', lCntnr(container)

        lastContainer = container + 1

        call resetPacking()

     else

        ! Found a good solution. Save it, remove the packed items and
        ! rebuild the list of possible containers.

        call saveSol(solfname)

        call removeBoxes()

        call getAvContainers(lCntnr, nCntnr)

        lastContainer = 1

        it = it + 1

     end if

     write(*, *)
     write(*, *) 'Remaining items: ', nItems
     write(*, *)

  end do

  ! Stop timing

  call SYSTEM_CLOCK(tend)

  elapsed = REAL(tend - tini) / REAL(ticks_ps)

  call printStats(elapsed)

  deallocate(x,lbest,stat=allocerr)

  if ( allocerr .ne. 0 ) then

     write(*,*) 'Deallocation error in main program'

     stop

  end if

  stop

end program algencanma

! ******************************************************************
! ******************************************************************

subroutine solver(x, f, nItems, cWidth, cLength, iWidth, iLength)

  ! This subroutine sets configuration parameters for the nonlinear
  ! programming solver and calls it.

  implicit none

  ! SCALAR ARGUMENTS
  integer :: nItems
  real(kind=8) :: cWidth, cLength, f

  ! ARRAY ARGUMENTS
  real(kind=8) :: iWidth(nItems), iLength(nItems), x(2 * nItems)

  intent(in   ) :: nItems, cWidth, cLength, iWidth, iLength
  intent(out  ) :: f
  intent(inout) :: x

  ! LOCAL SCALARS
  logical      :: checkder
  integer      :: hnnzmax,inform,jcnnzmax,m,n,nvparam,i
  real(kind=8) :: cnorm,efacc,efstain,eoacc,eostain,epsfeas,epsopt, &
       nlpsupn,snorm

  ! LOCAL ARRAYS
  character(len=15) :: strtmp
  character(len=80) :: specfnm,outputfnm,vparam(10)
  logical           :: coded(11),equatn(0),linear(0)
  real(kind=8)      :: l(2 * nItems),lambda(0),u(2 * nItems)

  ! EXTERNAL SUBROUTINES
  external :: myevalf,myevalg,myevalh,myevalc,myevaljac,myevalhc, &
              myevalfc,myevalgjac,myevalgjacp,myevalhl,myevalhlp, &
              alevalfc,alevalgjac

  ! Number of variables

  n = 2 * nItems

  ! Set lower bounds, upper bounds, and initial guess

  do i = 1, nItems

     l(2 * (i - 1) + 1) = 0.0D0

     u(2 * (i - 1) + 1) = cLength - iLength(i)

     l(2 * i)           = 0.0D0

     u(2 * i)           = cWidth - iWidth(i)

  end do

  ! Constraints

  m = 0

  equatn(1:m) = .false.

  lambda(1:m) = 0.0d0

  linear(1:m) = .true.

  ! Coded subroutines

  coded(1:11) = .false.

  coded(7:8)  = .true.

  ! Upper bounds on the number of sparse-matrices non-null elements

  jcnnzmax = 0

  hnnzmax  = 0

  ! Checking derivatives?

  checkder = .false.

  ! Parameters setting

  epsfeas   = 1.0d-10
  epsopt    = 1.0d-10

  efstain   = sqrt( epsfeas )
  eostain   = epsopt ** 1.5d0

  efacc     = sqrt( epsfeas )
  eoacc     = sqrt( epsopt )

  outputfnm = ''
  specfnm   = 'algencan.dat'

  nvparam = 0

  call algencan(myevalf,myevalg,myevalh,myevalc,myevaljac,myevalhc, &
       alevalfc,alevalgjac,myevalgjacp,myevalhl,myevalhlp,jcnnzmax, &
       hnnzmax,epsfeas,epsopt,efstain,eostain,efacc,eoacc,outputfnm, &
       specfnm,nvparam,vparam,n,x,l,u,m,lambda,equatn,linear,coded, &
       checkder,f,cnorm,snorm,nlpsupn,inform)

end subroutine solver

! ******************************************************************
! ******************************************************************

subroutine myevalf(n,x,f,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer,      intent(in)  :: n
  integer,      intent(out) :: flag
  real(kind=8), intent(out) :: f

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in) :: x(n)

  flag = - 1

end subroutine myevalf

! ******************************************************************
! ******************************************************************

subroutine myevalg(n,x,g,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer,      intent(in)  :: n
  integer,      intent(out) :: flag

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: g(n)

  flag = - 1

end subroutine myevalg

! ******************************************************************
! ******************************************************************

subroutine myevalh(n,x,hrow,hcol,hval,hnnz,lim,lmem,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical,      intent(out) :: lmem
  integer,      intent(in)  :: lim,n
  integer,      intent(out) :: flag,hnnz

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: hcol(lim),hrow(lim)
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: hval(lim)

  flag = - 1

  lmem = .false.

end subroutine myevalh

! ******************************************************************
! ******************************************************************

subroutine myevalc(n,x,ind,c,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer,      intent(in)  :: ind,n
  integer,      intent(out) :: flag
  real(kind=8), intent(out) :: c

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)  :: x(n)

  flag = - 1

end subroutine myevalc

! ******************************************************************
! ******************************************************************

subroutine myevaljac(n,x,ind,jcvar,jcval,jcnnz,lim,lmem,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical, intent(out) :: lmem
  integer, intent(in)  :: ind,lim,n
  integer, intent(out) :: flag,jcnnz

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: jcvar(lim)
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: jcval(lim)

  flag = - 1

  lmem = .false.

end subroutine myevaljac

! ******************************************************************
! ******************************************************************

subroutine myevalhc(n,x,ind,hcrow,hccol,hcval,hcnnz,lim,lmem,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical, intent(out) :: lmem
  integer, intent(in)  :: ind,lim,n
  integer, intent(out) :: flag,hcnnz

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: hccol(lim),hcrow(lim)
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: hcval(lim)

  flag = - 1

  lmem = .false.

end subroutine myevalhc

! ******************************************************************
! ******************************************************************

subroutine myevalfc(n,x,f,m,c,flag)

  use packdat, only: evalover, nItems, iLength

  implicit none

  ! SCALAR ARGUMENTS
  integer,      intent(in)  :: m,n
  integer,      intent(out) :: flag
  real(kind=8), intent(out) :: f

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: c(m)

  ! LOCAL SCALARS
  integer :: i, j

  flag = 0

  f = x(2 * nItems + 1)

  do i = 1, nItems

     do j = i + 1, nItems

        f = f + evalover(x, i, j)

     end do

     c(i) = x(2 * (i - 1) + 1) + iLength(i) - x(2 * nItems + 1)

  end do

end subroutine myevalfc

! ******************************************************************
! ******************************************************************

subroutine alevalfc(n,x,f,m,c,flag)

  use packdat, only: evalover, nItems, iLength

  implicit none

  ! SCALAR ARGUMENTS
  integer,      intent(in)  :: m,n
  integer,      intent(out) :: flag
  real(kind=8), intent(out) :: f

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: c(m)

  ! LOCAL SCALARS
  integer :: i, j

  flag = 0

  f = 0.0D0

  do i = 1, nItems

     do j = i + 1, nItems

        f = f + evalover(x, i, j)

     end do

  end do

end subroutine alevalfc

! ******************************************************************
! ******************************************************************

subroutine myevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,lim,lmem,flag)

  use packdat, only : evaldover, nItems

  implicit none

  ! SCALAR ARGUMENTS
  logical,      intent(out) :: lmem
  integer,      intent(in)  :: lim,m,n
  integer,      intent(out) :: flag,jcnnz

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: jcfun(lim),jcvar(lim)
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: g(n),jcval(lim)

  ! LOCAL SCALARS
  integer :: i, j

  flag = 0

  lmem = .false.

  do i = 1, 2 * nItems + 1

     g(i) = 0.0D0

  end do

  jcnnz = 0

  do i = 1, nItems

     do j = i + 1, nItems

        call evaldover(x, i, j, g)

     end do

     jcnnz = jcnnz + 1

     jcfun(jcnnz) = i
     jcvar(jcnnz) = 2 * (i - 1) + 1
     jcval(jcnnz) = 1.0D0

     jcnnz = jcnnz + 1

     jcfun(jcnnz) = i
     jcvar(jcnnz) = 2 * nItems + 1
     jcval(jcnnz) = - 1.0D0

  end do

  g(2 * nItems + 1) = 1.0D0

end subroutine myevalgjac

! ******************************************************************
! ******************************************************************

subroutine alevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,lim,lmem,flag)

  use packdat, only : evaldover, nItems

  implicit none

  ! SCALAR ARGUMENTS
  logical,      intent(out) :: lmem
  integer,      intent(in)  :: lim,m,n
  integer,      intent(out) :: flag,jcnnz

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: jcfun(lim),jcvar(lim)
  real(kind=8), intent(in)  :: x(n)
  real(kind=8), intent(out) :: g(n),jcval(lim)

  ! LOCAL SCALARS
  integer :: i, j

  flag = 0

  lmem = .false.

  do i = 1, 2 * nItems

     g(i) = 0.0D0

  end do

  do i = 1, nItems

     do j = i + 1, nItems

        call evaldover(x, i, j, g)

     end do

  end do

  jcnnz = 0

end subroutine alevalgjac

! ******************************************************************
! ******************************************************************

subroutine myevalgjacp(n,x,g,m,p,q,work,gotj,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical,   intent(inout) :: gotj
  integer,   intent(in)    :: m,n
  integer,   intent(out)   :: flag
  character, intent(in)    :: work

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)    :: x(n)
  real(kind=8), intent(inout) :: p(m),q(n)
  real(kind=8), intent(out)   :: g(n)

  flag = - 1

end subroutine myevalgjacp

! ******************************************************************
! ******************************************************************

subroutine myevalhl(n,x,m,lambda,sf,sc,hlrow,hlcol,hlval,hlnnz,lim,lmem,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical,      intent(out) :: lmem
  integer,      intent(in)  :: lim,m,n
  integer,      intent(out) :: flag,hlnnz
  real(kind=8), intent(in)  :: sf

  ! ARRAY ARGUMENTS
  integer,      intent(out) :: hlcol(lim),hlrow(lim)
  real(kind=8), intent(in)  :: lambda(m),sc(m),x(n)
  real(kind=8), intent(out) :: hlval(lim)

  flag = - 1

end subroutine myevalhl

! ******************************************************************
! ******************************************************************

subroutine myevalhlp(n,x,m,lambda,sf,sc,p,hp,goth,flag)

  implicit none

  ! SCALAR ARGUMENTS
  logical,      intent(inout) :: goth
  integer,      intent(in)    :: m,n
  integer,      intent(out)   :: flag
  real(kind=8), intent(in)    :: sf

  ! ARRAY ARGUMENTS
  real(kind=8), intent(in)  :: lambda(m),p(n),sc(m),x(n)
  real(kind=8), intent(out) :: hp(n)

  flag = - 1

end subroutine myevalhlp


! chk_location.f90 --
!     Check the Fortran 2008 extensions to the localisation functions
!
program chk_location
    implicit none

    real, dimension(5) :: array = (/ 1.0, 5.0, 3.0, 1.0, 5.0 /)

    write( *, '(a)' ) 'Location of maximum (using BACK=.true.): ', maxloc(array, back= .true.)
    write( *, '(a)' ) 'Location of minimum (using BACK=.true.): ', minloc(array, back= .true.)

    write( *, '(a)' ) 'Location of 3.0:                         ', findloc(array, 3.0)
end program chk_location


      SUBROUTINE trnspt(iorder,ncity,n)
      INTEGER ncity,iorder(ncity),n(6),MXCITY
      PARAMETER (MXCITY=1000)
      INTEGER j,jj,m1,m2,m3,nn,jorder(MXCITY)
      m1=1+mod((n(2)-n(1)+ncity),ncity)
      m2=1+mod((n(5)-n(4)+ncity),ncity)
      m3=1+mod((n(3)-n(6)+ncity),ncity)
      nn=1
      do 11 j=1,m1
        jj=1+mod((j+n(1)-2),ncity)
        jorder(nn)=iorder(jj)
        nn=nn+1
11    continue
      do 12 j=1,m2
        jj=1+mod((j+n(4)-2),ncity)
        jorder(nn)=iorder(jj)
        nn=nn+1
12    continue
      do 13 j=1,m3
        jj=1+mod((j+n(6)-2),ncity)
        jorder(nn)=iorder(jj)
        nn=nn+1
13    continue
      do 14 j=1,ncity
        iorder(j)=jorder(j)
14    continue
      return
      END

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


*DECK FIGI
      SUBROUTINE FIGI (NM, N, T, D, E, E2, IERR)
C***BEGIN PROLOGUE  FIGI
C***PURPOSE  Transforms certain real non-symmetric tridiagonal matrix
C            to symmetric tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1C
C***TYPE      SINGLE PRECISION (FIGI-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products
C     of corresponding pairs of off-diagonal elements are all
C     non-negative, this subroutine reduces it to a symmetric
C     tridiagonal matrix with the same eigenvalues.  If, further,
C     a zero product only occurs when both factors are zero,
C     the reduced matrix is similar to the original matrix.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, T, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix T.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        T contains the nonsymmetric matrix.  Its subdiagonal is
C          stored in the last N-1 positions of the first column,
C          its diagonal in the N positions of the second column,
C          and its superdiagonal in the first N-1 positions of
C          the third column.  T(1,1) and T(N,3) are arbitrary.
C          T is a two-dimensional REAL array, dimensioned T(NM,3).
C
C     On OUTPUT
C
C        T is unaltered.
C
C        D contains the diagonal elements of the tridiagonal symmetric
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the tridiagonal
C          symmetric matrix in its last N-1 positions.  E(1) is not set.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
C          E2 is a one-dimensional REAL array, dimensioned E2(N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          N+I        if T(I,1)*T(I-1,3) is negative and a symmetric
C                     matrix cannot be produced with FIGI,
C          -(3*N+I)   if T(I,1)*T(I-1,3) is zero with one factor
C                     non-zero.  In this case, the eigenvectors of
C                     the symmetric matrix are not simply related
C                     to those of  T  and should not be sought.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  FIGI
C
      INTEGER I,N,NM,IERR
      REAL T(NM,3),D(*),E(*),E2(*)
C
C***FIRST EXECUTABLE STATEMENT  FIGI
      IERR = 0
C
      DO 100 I = 1, N
         IF (I .EQ. 1) GO TO 90
         E2(I) = T(I,1) * T(I-1,3)
         IF (E2(I)) 1000, 60, 80
   60    IF (T(I,1) .EQ. 0.0E0 .AND. T(I-1,3) .EQ. 0.0E0) GO TO 80
C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
C                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
         IERR = -(3 * N + I)
   80    E(I) = SQRT(E2(I))
   90    D(I) = T(I,2)
  100 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
C                ELEMENTS IS NEGATIVE ..........
 1000 IERR = N + I
 1001 RETURN
      END


      subroutine tbdecoup(beam,param,param1,
     1                    emix,emiy,emix1,emiy1,sigp)
      implicit none
      integer*4 i,j
      real*8 beam(6,6),param(21),param1(21),emix,emiy,emix1,emiy1,sigp
      real*8 trans(6,6)
      real*8 a,c,d,p1,p2,p4,q1,q2,q4,m1,m2,m3,m4,r1,r2,r3,r4,f,g
      real*8 detp,detq,detr
      sigp=beam(6,6)
      if(sigp .ne. 0)then
        param(7 )=beam(6,1)/sigp
        param(8 )=beam(6,2)/sigp
        param(9 )=beam(6,3)/sigp
        param(10)=beam(6,4)/sigp
      else
        param( 7)=0.d0
        param( 8)=0.d0
        param( 9)=0.d0
        param(10)=0.d0
      endif
      do 10 i=1,4
        do 20 j=1,i
          beam(i,j)=beam(i,j)-param(6+i)*param(6+j)*sigp
          beam(j,i)=beam(i,j)
20      continue
10    continue
      d=beam(1,1)*beam(2,2)-beam(2,1)**2
      emix=sign(sqrt(abs(d)),d)
      if(emix .ne. 0)then
        param(1)=-beam(2,1)/emix
        param(2)= beam(1,1)/emix
      else
        param(1)=0.d0
        param(2)=0.d0
      endif
      d=beam(3,3)*beam(4,4)-beam(4,3)**2
      emiy=sign(sqrt(abs(d)),d)
      if(emiy .ne. 0)then
        param(4)=-beam(4,3)/emiy
        param(5)=beam(3,3)/emiy
      else
        param(4)=0.d0
        param(5)=0.d0
      endif
      p1= beam(2,2)
      p2= beam(2,1)
      p4= beam(1,1)
      q1= beam(4,4)
      q2= beam(4,3)
      q4= beam(3,3)
      m1= beam(4,2)
      m2= beam(4,1)
      m3= beam(3,2)
      m4= beam(3,1)
      r1=-m4*p1+m3*p2+m3*q2-m1*q4
      r2= m4*p2-m3*p4-m4*q2+m2*q4
      r3=-m2*p1+m1*p2+m3*q1-m1*q2
      r4= m2*p2-m1*p4-m4*q1+m2*q2
      detr=r1*r4-r2*r3
      detp=p1*p4-p2**2
      detq=q1*q4-q2**2
      if(detp .eq. detq)then
        call tclr(param1,14)
        emix1=0.d0
        emiy1=0.d0
        return
      endif
      f=detr/(detp-detq)**2
      g=4.d0*f+1.d0
      if(g .lt. 0.d0)then
        call tclr(param1,14)
        emix1=0.d0
        emiy1=0.d0
        return
      endif
      a=sqrt((g+sqrt(g))/g*.5d0)
      c=(2.d0*a**2-1.d0)/a/(detp-detq)
      r1=c*r1
      r2=c*r2
      r3=c*r3
      r4=c*r4
      param1(11)=r1
      param1(12)=r2
      param1(13)=r3
      param1(14)=r4
      call tinitr(trans)
      trans(1,1)=a
      trans(2,2)=a
      trans(3,3)=a
      trans(4,4)=a
      trans(1,3)=-r4
      trans(1,4)=r2
      trans(2,3)=r3
      trans(2,4)=-r1
      trans(3,1)=r1
      trans(3,2)=r2
      trans(4,1)=r3
      trans(4,2)=r4
      call tmultr(beam,trans,6)
      trans(1,3)=r1
      trans(1,4)=r3
      trans(2,3)=r2
      trans(2,4)=r4
      trans(3,1)=-r4
      trans(3,2)=r3
      trans(4,1)=r2
      trans(4,2)=-r1
      call tmultr(trans,beam,6)
      beam=trans
c      write(*,'(1x,:1p6g12.4)')beam
      d=beam(1,1)*beam(2,2)-beam(2,1)**2
      emix1=sign(sqrt(abs(d)),d)
      if(emix1 .ne. 0)then
        param1(1)=-beam(2,1)/emix1
        param1(2)=beam(1,1)/emix1
      else
        param1(1)=0.d0
        param1(2)=0.d0
      endif
      d=beam(3,3)*beam(4,4)-beam(4,3)**2
      emiy1=sign(sqrt(abs(d)),d)
      if(emiy1 .ne. 0)then
        param1(4)=-beam(4,3)/emiy1
        param1(5)=beam(3,3)/emiy1
      else
        param1(4)=0.d0
        param1(5)=0.d0
      endif
      param1( 7)=a*param( 7)-r4*param(9)+r2*param(10)
      param1( 8)=a*param( 8)+r3*param(9)-r1*param(10)
      param1( 9)=a*param( 9)+r1*param(7)+r2*param( 8)
      param1(10)=a*param(10)+r3*param(7)+r4*param( 8)
      return
      end


      subroutine cubpol (x1,x2,y1,y2,dy1,dy2,b)
C...subroutine     cubpol    01/09/73
      dimension b(4)
      h0=1/(x2-x1)
      h1=h0*h0
      dy=y2-y1
      s1=x2+2*x1
      s2=x1+2*x2
      b(1)=h1*(2*h0*x1*x2*(x1*y2-x2*y1)+y1*x2**2+y2*x1**2-x1*x2*(dy1*x2+
     1dy2*x1))
      b(2)=h1*(-6*h0*x1*x2*dy+dy1*x2*s1+dy2*x1*s2)
      b(3)=3*h0*h1*(dy*(x2+x1))-h1*(dy1*s2+dy2*s1)
      b(4)=h1*(dy2+dy1-2*h0*dy)
      return
      end


SUBROUTINE chkbrdc(ISAT,EPH,AVE,STD)

! NAME       :  chkbrdc.f90
!
! PURPOSE    :  Check the broadcast reference epoch by using 3 to 4 sigma critierion
!
!
! PARAMETERS :
!         IN :  ISAT : Satellite number
!               EPH: Broadcast elements
!
!        OUT :  Print out the status of dynamic elements
!
! AUTHOR     :  Tzupang Tseng
!
!
! CREATED    :  02-08-2019
!
! CHANGES    :  02-08-2019  T. Tseng: Introduce the STD values for quality control

USE mdl_precision
IMPLICIT NONE

INTEGER*4  ::N
INTEGER (KIND = prec_int4) :: ISAT
REAL(KIND = prec_q)::PI
REAL(KIND = prec_q)::axis,cmm,ecc,ron,per,inc,ma,node
REAL(KIND = prec_q)::EPH(20),AVE(8),STD(8)

PI = 4*ATAN(1.D0)
N  = 3 ! This variable can be adjusted.

axis  =EPH(3)
ecc   =EPH(4)
inc   =EPH(5)*180/PI
node  =EPH(6)*180/PI
per   =EPH(7)*180/PI
ma    =EPH(8)*180/PI
cmm   =EPH(9)
ron   =EPH(10)*180/PI

!CHECK SEMI-MAJOR AXIS
!---------------------
IF(ABS(axis-AVE(1))>N*STD(1))PRINT*,'BAD SEMI-MAJOR AXIS, ABS(OBSERVED-MEAN)',ABS(axis-AVE(1)),'Satellite =', ISAT

! CHECK ECCENTRICITY
! ------------------
IF(ABS(ecc-AVE(2))>N*STD(2)) PRINT*,'BAD ECCENTRICITY, ABS(OBSERVED-MEAN)',ABS(ecc-AVE(2)),'Satellite =', ISAT

! CHECK INCLINATION
! ------------------
IF(ABS(inc-AVE(3)*180/PI)>N*STD(3)*180/PI) PRINT*,'BAD INCLINATION, ABS(OBSERVED-MEAN)', ABS(inc-AVE(3)*180/PI),'Satellite =', ISAT

! CHECK NODE
! ----------
IF(ABS(node-AVE(4)*180/PI)>N*STD(4)*180/PI) PRINT*,'BAD NODE, ABS(OBSERVED-MEAN)', ABS(node-AVE(4)*180/PI),'Satellite =', ISAT

! CHECK PERIGEE
! -------------
IF(ABS(per-AVE(5)*180/PI)>N*STD(5)*180/PI) PRINT*,'BAD PERIGEE, ABS(OBSERVED-MEAN)', ABS(per-AVE(5)*180/PI),'Satellite =', ISAT

! CHECK MEAN ANOMALY
! ------------------
IF(ABS(ma-AVE(6)*180/PI)>N*STD(6)*180/PI) PRINT*,'BAD MEAN ANOMALY, ABS(OBSERVED-MEAN)', ABS(ma-AVE(6)*180/PI),'Satellite =', ISAT

! CHECK CORRECTION TO MEAN MOTION
! -------------------------------
IF(ABS(cmm-AVE(7))>N*STD(7)) PRINT*,'BAD CORRECTION TO MEAN MOTION, ABS(OBSERVED-MEAN)', ABS(cmm-AVE(7)),'Satellite =', ISAT

! CHECK RATE OF NODE
! ------------------
IF(ABS(ron-AVE(8)*180/PI)>N*STD(8)*180/PI) PRINT*,'BAD RATE OF NODE, ABS(OBSERVED-MEAN)', ABS(ron-AVE(8)*180/PI),'Satellite =', ISAT

END


!================================================================
!================================================================
!================================================================
!================================================================
subroutine condinit(x,u,dx,nn)
  use amr_parameters
  use hydro_parameters
  implicit none
  integer ::nn                            ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:nvar)::u ! Conservative variables
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates initial conditions for RAMSES.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! U is the conservative variable vector. Conventions are here:
  ! U(i,1): d, U(i,2:ndim+1): d.u,d.v,d.w and U(i,ndim+2): E.
  ! Q is the primitive variable vector. Conventions are here:
  ! Q(i,1): d, Q(i,2:ndim+1):u,v,w and Q(i,ndim+2): P.
  ! If nvar >= ndim+3, remaining variables are treated as passive
  ! scalars in the hydro solver.
  ! U(:,:) and Q(:,:) are in user units.
  !================================================================
  integer::ivar,i
  real(dp),dimension(1:nvector,1:nvar)::q   ! Primitive variables
  real(dp) :: pi,Mvirphu,rvir,cnfw,eta0,gammaKS,d_init,p_init
  real(dp) :: rx,ry,rz,xmass,ymass,zmass,rr
  ! Call built-in initial condition generator
  !call region_condinit(x,q,dx,nn)

  ! Add here, if you wish, some user-defined initial conditions
  ! ........
  pi=3.141592
  Mvirphu = Mvir*1.99d33
  rvir = (3./4./pi*Mvirphu/(overdensity*1.89d-29*0.65**2))**0.333
  cnfw = 6./(Mvir/1.d14)**.2
  eta0 = 0.00676*(cnfw-6.5)**2+0.206*(cnfw-6.5)+2.48
  gammaKS = 1.15+0.01*(cnfw-6.5)
  d_init = 0.1*overdensity*1.89d-29*.65**2&
  &        *cnfw**2/3./(1.+cnfw)**2/(log(1.+cnfw)-cnfw/(1.+cnfw))&
  &        /(1.-3./eta0*(gammaKS-1.0d0)/gammaKS*cnfw/(log(1.+cnfw)&
  &        -cnfw/(1.+cnfw))&
  &        *(1.-log(1.+cnfw)/cnfw))**(1./(gammaKS-1.0d0))
  p_init = 6.672d-8/3.*d_init*Mvirphu/rvir*eta0
  xmass=0.5*boxlen
  ymass=0.5*boxlen
  zmass=0.5*boxlen
  Mdot_BH=2.d72*d_init/(5./3.*p_init/d_init)**1.5

  do i=1,nn
     rx=0.0d0; ry=0.0d0; rz=0.0d0
     rx=x(i,1)-xmass
#if NDIM>1
     ry=x(i,2)-ymass
#endif
#if NDIM>2
     rz=x(i,3)-zmass
#endif
     rr=sqrt(rx**2+ry**2+rz**2)
     U(i,1)=d_init&
     &*(1.-3./eta0*(gammaKS-1.0d0)/gammaKS*cnfw/(log(1.+cnfw)&
     &-cnfw/(1.+cnfw))&
     &*(1.-log(1.+cnfw*rr/rvir)/(cnfw*rr/rvir)))**(1./(gammaKS-1.0d0))
     U(i,2)=0.0d0
     U(i,3)=0.0d0
     U(i,4)=0.0d0
     U(i,5)=p_init/d_init/(gamma-1.0d0)&
     &*(1.-3./eta0*(gammaKS-1.)/gammaKS*cnfw&
     &/(log(1.+cnfw)-cnfw/(1.+cnfw))&
     &*(1.-log(1.+cnfw*rr/rvir)/(cnfw*rr/rvir)))*U(i,1)
  end do

!!$  ! Convert primitive to conservative variables
!!$  ! density -> density
!!$  u(1:nn,1)=q(1:nn,1)
!!$  ! velocity -> momentum
!!$  u(1:nn,2)=q(1:nn,1)*q(1:nn,2)
!!$#if NDIM>1
!!$  u(1:nn,3)=q(1:nn,1)*q(1:nn,3)
!!$#endif
!!$#if NDIM>2
!!$  u(1:nn,4)=q(1:nn,1)*q(1:nn,4)
!!$#endif
!!$  ! kinetic energy
!!$  u(1:nn,ndim+2)=0.0d0
!!$  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,2)**2
!!$#if NDIM>1
!!$  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,3)**2
!!$#endif
!!$#if NDIM>2
!!$  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,4)**2
!!$#endif
!!$  ! pressure -> total fluid energy
!!$  u(1:nn,ndim+2)=u(1:nn,ndim+2)+q(1:nn,ndim+2)/(gamma-1.0d0)
!!$  ! passive scalars
!!$  do ivar=ndim+3,nvar
!!$     u(1:nn,ivar)=q(1:nn,1)*q(1:nn,ivar)
!!$  end do

end subroutine condinit


      SUBROUTINE Update_SUN()

      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      KPP_REAL SunRise, SunSet
      KPP_REAL Thour, Tlocal, Ttmp

      SunRise = 4.5
      SunSet  = 19.5
      Thour = TIME/3600.
      Tlocal = Thour - (INT(Thour)/24)*24

      IF ((Tlocal.GE.SunRise).AND.(Tlocal.LE.SunSet)) THEN
        Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise)
        IF (Ttmp.GT.0) THEN
          Ttmp =  Ttmp*Ttmp
        ELSE
          Ttmp = -Ttmp*Ttmp
        END IF
        SUN = ( 1.0 + COS(PI*Ttmp) )/2.0
      ELSE
        SUN = 0.0
      END IF

      RETURN
      END


subroutine RangKut3

    use arrays
    use global

    implicit none

    integer k               !variable de iteracion
    real(kind = 8) dt_aux   !aux

    !guardamos el valor anterior de los campos
    Phi_aux = Phi
    Psi_aux = Psi
    Pi_aux  = Pi

    !arrancamos el metodo, los coeficientes de RK estan previamente calculados
    do k = 1, 3
        call numeric    !calculo las derivadas de los campos segun los parametros de entrada

        if (k.eq.1) then
            dt_aux = dt
            Phi = Phi_aux + dt_aux*numeric_Phi
            Psi = Psi_aux + dt_aux*numeric_Psi
            pi  = Pi_aux  + dt_aux*numeric_Pi
        else if (k.eq.2) then
            dt_aux = 0.25d0*dt
            Phi = 0.75d0*Phi_aux + 0.25d0*Phi + dt_aux*numeric_Phi
            Psi = 0.75d0*Psi_aux + 0.25d0*Psi + dt_aux*numeric_Psi
            Pi  = 0.75d0*Pi_aux  + 0.25d0*Pi  + dt_aux*numeric_Pi
        else
            dt_aux = 2.0d0*dt/3.0d0
            Phi = (Phi_aux + 2.0d0*Phi)/3.0d0 + dt_aux*numeric_Phi
            Psi = (Psi_aux + 2.0d0*Psi)/3.0d0 + dt_aux*numeric_Psi
            Pi  = (pi_aux  + 2.0d0*Pi)/3.0d0  + dt_aux*numeric_Pi
        end if
    end do

    call boundaries_calc    !condiciones de frontera
    call constriction_calc  !actualiza condiciones de ligadura

end subroutine RangKut3


      REAL FUNCTION EVALRP(TEXT)	!Evaluates a Reverse Polish string.
Caution: deals with single digits only.
       CHARACTER*(*) TEXT	!The RPN string.
       INTEGER SP,STACKLIMIT		!Needed for the evaluation.
       PARAMETER (STACKLIMIT = 6)	!This should do.
       REAL*8 STACK(STACKLIMIT)		!Though with ^ there's no upper limit.
       INTEGER L,D		!Assistants for the scan.
       CHARACTER*4 DEED		!A scratchpad for the annotation.
       CHARACTER*1 C		!The character of the moment.
        WRITE (6,1) TEXT	!A function that writes messages... Improper.
    1   FORMAT ("Evaluation of the Reverse Polish string ",A,//	!Still, it's good to see stuff.
     1   "Char Token Action  SP:Stack...")	!Such as a heading for the trace.
        SP = 0			!Commence with the stack empty.
        STACK = -666		!This value should cause trouble.
        DO L = 1,LEN(TEXT)	!Step through the text.
          C = TEXT(L:L)			!Grab a character.
          IF (C.LE." ") CYCLE		!Boring.
          D = ICHAR(C) - ICHAR("0")	!Uncouth test to check for a digit.
          IF (D.GE.0 .AND. D.LE.9) THEN	!Is it one?
            DEED = "Load"			!Yes. So, load its value.
            SP = SP + 1				!By going up one.
            IF (SP.GT.STACKLIMIT) STOP "Stack overflow!"	!Or, maybe not.
            STACK(SP) = D			!And stashing the value.
           ELSE				!Otherwise, it must be an operator.
            IF (SP.LT.2) STOP "Stack underflow!"	!They all require two operands.
            DEED = "XEQ"		!So, I'm about to do so.
            SELECT CASE(C)		!Which one this time?
             CASE("+"); STACK(SP - 1) = STACK(SP - 1) + STACK(SP)	!A + B = B + A, so it is easy.
             CASE("-"); STACK(SP - 1) = STACK(SP - 1) - STACK(SP)	!A is in STACK(SP - 1), B in STACK(SP)
             CASE("*"); STACK(SP - 1) = STACK(SP - 1)*STACK(SP)		!Again, order doesn't count.
             CASE("/"); STACK(SP - 1) = STACK(SP - 1)/STACK(SP)		!But for division, A/B becomes A B /
             CASE("^"); STACK(SP - 1) = STACK(SP - 1)**STACK(SP)	!So, this way around.
             CASE DEFAULT		!This should never happen!
              STOP "Unknown operator!"	!If the RPN script is indeed correct.
            END SELECT			!So much for that operator.
            SP = SP - 1		!All of them take two operands and make one.
          END IF		!So much for that item.
          WRITE (6,2) L,C,DEED,SP,STACK(1:SP)	!Reveal the state now.
    2     FORMAT (I4,A6,A7,I4,":",66F14.6)	!Aligned with the heading of FORMAT 1.
        END DO			!On to the next symbol.
        EVALRP = STACK(1)	!The RPN string being correct, this is the result.
      END	!Simple enough!

      PROGRAM HSILOP
      REAL V
      V = EVALRP("3 4 2 * 1 5 - 2 3 ^ ^ / +")	!The specified example.
      WRITE (6,*) "Result is...",V
      END


      subroutine solve_hs(ctfm,ctfmp,n_A,n_B,n_C1s,n_C5s,n_psi,octfmp,Nx
     &,hx,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_C1s(Nx)
      real*8 n_C5s(Nx)
      real*8 n_psi(Nx)
      real*8 octfmp(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1333333333333333D1 * n_psi(i + 1) - 0.3333333333333333D0 *
     #n_psi(i + 2)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = n_psi(i) - 0.1D1 / (0.5D1 * n_C5s(i) * n_psi(i) ** 4 * n_A(i)
     # * ctfmp(i) ** 2 * hx ** 2 + n_C1s(i) * n_A(i) * ctfmp(i) ** 2 * h
     #x ** 2 - 0.2D1) * n_A(i) * ctfmp(i) ** 2 * hx ** 2 * (n_C5s(i) * n
     #_psi(i) ** 5 + n_C1s(i) * n_psi(i) + (-0.5000000000000000D0 / n_A(
     #i) / ctfmp(i) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1)) * octfmp(i)
     # + 0.1D1 / ctfm(i) / n_A(i) / ctfmp(i) * (-0.1D1 * n_psi(i - 1) +
     #n_psi(i + 1))) / hx + (0.1D1 / n_A(i) * (n_psi(i - 1) - 0.2D1 * n_
     #psi(i) + n_psi(i + 1)) - 0.1250000000000000D0 / n_A(i) ** 2 * (-0.
     #1D1 * n_A(i - 1) + n_A(i + 1)) * (-0.1D1 * n_psi(i - 1) + n_psi(i
     #+ 1)) + 0.2500000000000000D0 / n_B(i) / n_A(i) * (-0.1D1 * n_B(i -
     # 1) + n_B(i + 1)) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1))) / ctfm
     #p(i) ** 2 / hx ** 2)
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = n_psi(i) - 0.2D1 / (0.2D1 * hx * ctfmp(i) + 0.3D1 * ctfm(i))
     #* hx * ctfmp(i) * (0.5000000000000000D0 * ctfm(i) * (n_psi(i - 2)
     #- 0.4D1 * n_psi(i - 1) + 0.3D1 * n_psi(i)) / hx / ctfmp(i) + n_psi
     #(i) - 0.1D1)
      res(i)=qb
      end do
      endif
      END


      SUBROUTINE INTEGRATE( TIN, TOUT )

      IMPLICIT KPP_REAL (A-H,O-Z)
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'

C TIN - Start Time
      KPP_REAL TIN
C TOUT - End Time
      KPP_REAL TOUT
      INTEGER i

      PARAMETER (LWORK=2*NVAR*NVAR+14*NVAR+20,LIWORK=NVAR+20)
      KPP_REAL WORK(LWORK)
      INTEGER IWORK(LIWORK)
      EXTERNAL FUNC_CHEM,JAC_CHEM,SOLOUT

      ITOL=1     ! --- VECTOR TOLERANCES
      IJAC=1     ! --- COMPUTE THE JACOBIAN ANALYTICALLY
      MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX
      MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX
      IMAS=0     ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
      IOUT=0     ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION
      IDFX=0     ! --- INTERNAL TIME DERIVATIVE

      DO i=1,20
        IWORK(i) = 0
        WORK(i) = 0.D0
      ENDDO
      IWORK(2) = 6

      CALL KPP_ROS4(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT,
     &                  STEPMIN,RTOL,ATOL,ITOL,
     &                  JAC_CHEM,IJAC,MLJAC,MUJAC,FUNC_CHEM,IDFX,
     &                  FUNC_CHEM,IMAS,MLJAC,MUJAC,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,IDID)

      IF (IDID.LT.0) THEN
        print *,'KPP_ROS4: Unsucessful step at T=',
     &          TIN,' (IDID=',IDID,')'
      ENDIF

      RETURN
      END

      SUBROUTINE KPP_ROS4(N,FCN,IFCN,X,Y,XEND,H,
     &                  RelTol,AbsTol,ITOL,
     &                  JAC ,IJAC,MLJAC,MUJAC,DFX,IDFX,
     &                  MAS ,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,IDID)
C ----------------------------------------------------------
C     NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC)
C     SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS  MY'=F(X,Y).
C     THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4
C     (WITH STEP SIZE CONTROL).
C     C.F. SECTION IV.7
C
C     AUTHORS: E. HAIRER AND G. WANNER
C              UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
C              CH-1211 GENEVE 24, SWITZERLAND
C              E-MAIL:  HAIRER@CGEUGE51.BITNET,  WANNER@CGEUGE51.BITNET
C
C     THIS CODE IS PART OF THE BOOK:
C         E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
C         EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
C         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
C         SPRINGER-VERLAG (1990)
C
C     VERSION OF NOVEMBER 17, 1992
C
C     INPUT PARAMETERS
C     ----------------
C     N           DIMENSION OF THE SYSTEM
C
C     FCN         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
C                 VALUE OF F(X,Y):
C                    SUBROUTINE FCN(N,X,Y,F)
C                    KPP_REAL X,Y(N),F(N)
C                    F(1)=...   ETC.
C
C     IFCN        GIVES INFORMATION ON FCN:
C                    IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS)
C                    IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS)
C
C     X           INITIAL X-VALUE
C
C     Y(N)        INITIAL VALUES FOR Y
C
C     XEND        FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
C
C     H           INITIAL STEP SIZE GUESS;
C                 FOR STIFF EQUATIONS WITH INITIAL TRANSIENT,
C                 H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD.
C                 THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY
C                 ADAPTS ITS STEP SIZE. STUDY THE CHOSEN VALUES FOR A FEW
C                 STEPS IN SUBROUTINE "SOLOUT", WHEN YOU ARE NOT SURE.
C                 (IF H=0.D0, THE CODE PUTS H=1.D-6).
C
C     RelTol,AbsTol   RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
C                 CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
C
C     ITOL        SWITCH FOR RelTol AND AbsTol:
C                   ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS.
C                     THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
C                     Y(I) BELOW RelTol*ABS(Y(I))+AbsTol
C                   ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS.
C                     THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
C                     RelTol(I)*ABS(Y(I))+AbsTol(I).
C
C     JAC         NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
C                 THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y
C                 (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY
C                 A DUMMY SUBROUTINE IN THE CASE IJAC=0).
C                 FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM
C                    SUBROUTINE JAC(N,X,Y,DFY,LDFY)
C                    KPP_REAL X,Y(N),DFY(LDFY,N)
C                    DFY(1,1)= ...
C                 LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS
C                 FURNISHED BY THE CALLING PROGRAM.
C                 IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO
C                    BE FULL AND THE PARTIAL DERIVATIVES ARE
C                    STORED IN DFY AS
C                       DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J)
C                 ELSE, THE JACOBIAN IS TAKEN AS BANDED AND
C                    THE PARTIAL DERIVATIVES ARE STORED
C                    DIAGONAL-WISE AS
C                       DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J).
C
C     IJAC        SWITCH FOR THE COMPUTATION OF THE JACOBIAN:
C                    IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE
C                       DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED.
C                    IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC.
C
C     MLJAC       SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN:
C                    MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR
C                       ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
C                    0<=MLJAC<N: MLJAC IS THE LOWER BANDWITH OF JACOBIAN
C                       MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
C                       THE MAIN DIAGONAL).
C
C     MUJAC       UPPER BANDWITH OF JACOBIAN  MATRIX (>= NUMBER OF NON-
C                 ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
C                 NEED NOT BE DEFINED IF MLJAC=N.
C
C     DFX         NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
C                 THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO X
C                 (THIS ROUTINE IS ONLY CALLED IF IDFX=1 AND IFCN=1;
C                 SUPPLY A DUMMY SUBROUTINE IN THE CASE IDFX=0 OR IFCN=0).
C                 OTHERWISE, THIS SUBROUTINE MUST HAVE THE FORM
C                    SUBROUTINE DFX(N,X,Y,FX)
C                    KPP_REAL X,Y(N),FX(N)
C                    FX(1)= ...
C
C     IDFX        SWITCH FOR THE COMPUTATION OF THE DF/DX:
C                    IDFX=0: DF/DX IS COMPUTED INTERNALLY BY FINITE
C                       DIFFERENCES, SUBROUTINE "DFX" IS NEVER CALLED.
C                    IDFX=1: DF/DX IS SUPPLIED BY SUBROUTINE DFX.
C
C     ----   MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS      -----
C     ----   FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): -
C
C     MAS         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS-
C                 MATRIX M.
C                 IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY
C                 MATRIX AND NEEDS NOT TO BE DEFINED;
C                 SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
C                 IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM
C                    SUBROUTINE MAS(N,AM,LMAS)
C                    KPP_REAL AM(LMAS,N)
C                    AM(1,1)= ....
C                    IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED
C                    AS FULL MATRIX LIKE
C                         AM(I,J) = M(I,J)
C                    ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED
C                    DIAGONAL-WISE AS
C                         AM(I-J+MUMAS+1,J) = M(I,J).
C
C     IMAS       GIVES INFORMATION ON THE MASS-MATRIX:
C                    IMAS=0: M IS SUPPOSED TO BE THE IDENTITY
C                       MATRIX, MAS IS NEVER CALLED.
C                    IMAS=1: MASS-MATRIX  IS SUPPLIED.
C
C     MLMAS       SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX:
C                    MLMAS=N: THE FULL MATRIX CASE. THE LINEAR
C                       ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
C                    0<=MLMAS<N: MLMAS IS THE LOWER BANDWITH OF THE
C                       MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
C                       THE MAIN DIAGONAL).
C                 MLMAS IS SUPPOSED TO BE .LE. MLJAC.
C
C     MUMAS       UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON-
C                 ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
C                 NEED NOT BE DEFINED IF MLMAS=N.
C                 MUMAS IS SUPPOSED TO BE .LE. MUJAC.
C
C     SOLOUT      NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
C                 NUMERICAL SOLUTION DURING INTEGRATION.
C                 IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
C                 SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
C                 IT MUST HAVE THE FORM
C                    SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,IRTRN)
C                    KPP_REAL X,Y(N)
C                    ....
C                 SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
C                    GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
C                    THE FIRST GRID-POINT).
C                 "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
C                    IS SET <0, ROS4 RETURNS TO THE CALLING PROGRAM.
C
C     IOUT        GIVES INFORMATION ON THE SUBROUTINE SOLOUT:
C                    IOUT=0: SUBROUTINE IS NEVER CALLED
C                    IOUT=1: SUBROUTINE IS USED FOR OUTPUT
C
C     WORK        ARRAY OF WORKING SPACE OF LENGTH "LWORK".
C                 SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES.
C                 "LWORK" MUST BE AT LEAST
C                             N*(LJAC+LMAS+LE1+8)+5
C                 WHERE
C                    LJAC=N              IF MLJAC=N (FULL JACOBIAN)
C                    LJAC=MLJAC+MUJAC+1  IF MLJAC<N (BANDED JAC.)
C                 AND
C                    LMAS=0              IF IMAS=0
C                    LMAS=N              IF IMAS=1 AND MLMAS=N (FULL)
C                    LMAS=MLMAS+MUMAS+1  IF MLMAS<N (BANDED MASS-M.)
C                 AND
C                    LE1=N               IF MLJAC=N (FULL JACOBIAN)
C                    LE1=2*MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.).
c
C                 IN THE USUAL CASE WHERE THE JACOBIAN IS FULL AND THE
C                 MASS-MATRIX IS THE INDENTITY (IMAS=0), THE MINIMUM
C                 STORAGE REQUIREMENT IS
C                             LWORK = 2*N*N+8*N+5.
C
C     LWORK       DECLARED LENGHT OF ARRAY "WORK".
C
C     IWORK       INTEGER WORKING SPACE OF LENGTH "LIWORK".
C                 "LIWORK" MUST BE AT LEAST N+2.
C
C     LIWORK      DECLARED LENGHT OF ARRAY "IWORK".
C
C ----------------------------------------------------------------------
C
C     SOPHISTICATED SETTING OF PARAMETERS
C     -----------------------------------
C              SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK
C              WELL. THEY MAY BE DEFINED BY SETTING WORK(1),..,WORK(5)
C              AS WELL AS IWORK(1),IWORK(2) DIFFERENT FROM ZERO.
C              FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES:
C
C    IWORK(1)  THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
C              THE DEFAULT VALUE (FOR IWORK(1)=0) IS 100000.
C
C    IWORK(2)  SWITCH FOR THE CHOICE OF THE COEFFICIENTS
C              IF IWORK(2).EQ.1  METHOD OF SHAMPINE
C              IF IWORK(2).EQ.2  METHOD GRK4T OF KAPS-RENTROP
C              IF IWORK(2).EQ.3  METHOD GRK4A OF KAPS-RENTROP
C              IF IWORK(2).EQ.4  METHOD OF VAN VELDHUIZEN (GAMMA=1/2)
C              IF IWORK(2).EQ.5  METHOD OF VAN VELDHUIZEN ("D-STABLE")
C              IF IWORK(2).EQ.6  AN L-STABLE METHOD
C              THE DEFAULT VALUE (FOR IWORK(2)=0) IS IWORK(2)=2.
C
C    WORK(1)   UROUND, THE ROUNDING UNIT, DEFAULT 1.D-16.
C
C    WORK(2)   MAXIMAL STEP SIZE, DEFAULT XEND-X.
C
C    WORK(3), WORK(4)   PARAMETERS FOR STEP SIZE SELECTION
C              THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
C                 WORK(3) <= HNEW/HOLD <= WORK(4)
C              DEFAULT VALUES: WORK(3)=0.2D0, WORK(4)=6.D0
C
C    WORK(5)   AVOID THE HUMP: AFTER TWO CONSECUTIVE STEP REJECTIONS
C              THE STEP SIZE IS MULTIPLIED BY WORK(5)
C              DEFAULT VALUES: WORK(5)=0.1D0
C
C-----------------------------------------------------------------------
C
C     OUTPUT PARAMETERS
C     -----------------
C     X           X-VALUE WHERE THE SOLUTION IS COMPUTED
C                 (AFTER SUCCESSFUL RETURN X=XEND)
C
C     Y(N)        SOLUTION AT X
C
C     H           PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
C
C     IDID        REPORTS ON SUCCESSFULNESS UPON RETURN:
C                   IDID=1  COMPUTATION SUCCESSFUL,
C                   IDID=-1 COMPUTATION UNSUCCESSFUL.
C
C ---------------------------------------------------------
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C          DECLARATIONS
C *** *** *** *** *** *** *** *** *** *** *** *** ***
      IMPLICIT KPP_REAL (A-H,O-Z)
      DIMENSION Y(N),AbsTol(1),RelTol(1),WORK(LWORK),IWORK(LIWORK)
      LOGICAL AUTNMS,IMPLCT,JBAND,ARRET
      EXTERNAL FCN,JAC,DFX,MAS,SOLOUT
      COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL
C -----------------------------------------------------
C --- COMMON STAT CAN BE USED FOR STATISTICS
C ---    NFCN      NUMBER OF FUNC_CHEMCTION EVALUATIONS (THOSE FOR NUMERICAL
C                  EVALUATION OF THE JACOBIAN ARE NOT COUNTED)
C ---    NJAC      NUMBER OF JACOBIAN EVALUATIONS (EITHER ANALYTICALLY
C                  OR NUMERICALLY)
C ---    NSTEP     NUMBER OF COMPUTED STEPS
C ---    NACCPT    NUMBER OF ACCEPTED STEPS
C ---    NREJCT    NUMBER OF REJECTED STEPS (AFTER AT LEAST ONE STEP
C                  HAS BEEN ACCEPTED)
C ---    NDEC      NUMBER OF LU-DECOMPOSITIONS (N-DIMENSIONAL MATRIX)
C ---    NSOL      NUMBER OF FORWARD-BACKWARD SUBSTITUTIONS
C -----------------------------------------------------
C *** *** *** *** *** *** ***
C        SETTING THE PARAMETERS
C *** *** *** *** *** *** ***
      NFCN=0
      NJAC=0
      NSTEP=0
      NACCPT=0
      NREJCT=0
      NDEC=0
      NSOL=0
      ARRET=.FALSE.
C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
      IF(IWORK(1).EQ.0)THEN
         NMAX=100000
      ELSE
         NMAX=IWORK(1)
         IF(NMAX.LE.0)THEN
            WRITE(6,*)' WRONG INPUT IWORK(1)=',IWORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- METH   COEFFICIENTS OF THE METHOD
      IF(IWORK(2).EQ.0)THEN
         METH=2
      ELSE
         METH=IWORK(2)
         IF(METH.LE.0.OR.METH.GE.7)THEN
            WRITE(6,*)' CURIOUS INPUT IWORK(2)=',IWORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------- UROUND   SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0
      IF(WORK(1).EQ.0.D0)THEN
         UROUND=1.D-16
      ELSE
         UROUND=WORK(1)
         IF(UROUND.LE.1.D-14.OR.UROUND.GE.1.D0)THEN
            WRITE(6,*)' COEFFICIENTS HAVE 16 DIGITS, UROUND=',WORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- MAXIMAL STEP SIZE
      IF(WORK(2).EQ.0.D0)THEN
         HMAX=XEND-X
      ELSE
         HMAX=WORK(2)
      END IF
C -------  FAC1,FAC2     PARAMETERS FOR STEP SIZE SELECTION
      IF(WORK(3).EQ.0.D0)THEN
         FAC1=5.D0
      ELSE
         FAC1=1.D0/WORK(3)
      END IF
      IF(WORK(4).EQ.0.D0)THEN
         FAC2=1.D0/6.0D0
      ELSE
         FAC2=1.D0/WORK(4)
      END IF
C -------  FACREJ    FOR THE HUMP
      IF(WORK(5).EQ.0.D0)THEN
         FACREJ=0.1D0
      ELSE
         FACREJ=WORK(5)
      END IF
C --------- CHECK IF TOLERANCES ARE O.K.
      IF (ITOL.EQ.0) THEN
          IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN
              WRITE (6,*) ' TOLERANCES ARE TOO SMALL'
              ARRET=.TRUE.
          END IF
      ELSE
          DO 15 I=1,N
          IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN
              WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL'
              ARRET=.TRUE.
          END IF
  15      CONTINUE
      END IF
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C         COMPUTATION OF ARRAY ENTRIES
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C ---- AUTONOMOUS, IMPLICIT, BANDED OR NOT ?
      AUTNMS=IFCN.EQ.0
      IMPLCT=IMAS.NE.0
      JBAND=MLJAC.NE.N
      ARRET=.FALSE.
C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS ---
C -- JACOBIAN
      IF(JBAND)THEN
         LDJAC=MLJAC+MUJAC+1
      ELSE
         LDJAC=N
      END IF
C -- MATRIX E FOR LINEAR ALGEBRA
      IF(JBAND)THEN
         LDE=2*MLJAC+MUJAC+1
      ELSE
         LDE=N
      END IF
C -- MASS MATRIX
      IF (IMPLCT) THEN
          IF (MLMAS.NE.N) THEN
              LDMAS=MLMAS+MUMAS+1
          ELSE
              LDMAS=N
          END IF
C ------ BANDWITH OF "MAS" NOT LARGER THAN BANDWITH OF "JAC"
          IF (MLMAS.GT.MLJAC.OR.MUMAS.GT.MUJAC) THEN
              WRITE (6,*) 'BANDWITH OF "MAS" NOT LARGER THAN BANDWITH OF
     & "JAC"'
            ARRET=.TRUE.
          END IF
      ELSE
          LDMAS=0
      END IF
      LDMAS2=MAX(1,LDMAS)
C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
      IEYNEW=6
      IEDY1=IEYNEW+N
      IEDY=IEDY1+N
      IEAK1=IEDY+N
      IEAK2=IEAK1+N
      IEAK3=IEAK2+N
      IEAK4=IEAK3+N
      IEFX =IEAK4+N
      IEJAC=IEFX +N
      IEMAS=IEJAC+N*LDJAC
      IEE  =IEMAS+N*LDMAS
C ------ TOTAL STORAGE REQUIREMENT -----------
      ISTORE=IEE+N*LDE-1
      IF(ISTORE.GT.LWORK)THEN
         WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE
         ARRET=.TRUE.
      END IF
C ------- ENTRY POINTS FOR INTEGER WORKSPACE -----
      IEIP=3
C --------- TOTAL REQUIREMENT ---------------
      ISTORE=IEIP+N-1
      IF(ISTORE.GT.LIWORK)THEN
         WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE
         ARRET=.TRUE.
      END IF
C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1
      IF (ARRET) THEN
         IDID=-1
         RETURN
      END IF
C -------- CALL TO CORE INTEGRATOR ------------
      CALL RO4COR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL,JAC,IJAC,
     &   MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID,
     &   NMAX,UROUND,METH,FAC1,FAC2,FACREJ,AUTNMS,IMPLCT,JBAND,
     &   LDJAC,LDE,LDMAS2,WORK(IEYNEW),WORK(IEDY1),WORK(IEDY),
     &   WORK(IEAK1),WORK(IEAK2),WORK(IEAK3),WORK(IEAK4),
     &   WORK(IEFX),WORK(IEJAC),WORK(IEE),WORK(IEMAS),IWORK(IEIP))
C ----------- RETURN -----------
      RETURN
      END
C
C
C
C  ----- ... AND HERE IS THE CORE INTEGRATOR  ----------
C
      SUBROUTINE RO4COR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL,JAC,
     &  IJAC,MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID,
     &  NMAX,UROUND,METH,FAC1,FAC2,FACREJ,AUTNMS,IMPLCT,BANDED,
     &  LFJAC,LE,LDMAS,YNEW,DY1,DY,AK1,AK2,AK3,AK4,FX,FJAC,E,FMAS,IP)
C ----------------------------------------------------------
C     CORE INTEGRATOR FOR ROS4
C     PARAMETERS SAME AS IN ROS4 WITH WORKSPACE ADDED
C ----------------------------------------------------------
C         DECLARATIONS
C ----------------------------------------------------------
      IMPLICIT KPP_REAL (A-H,O-Z)
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_sparse.h'
      KPP_REAL Y(N),YNEW(N),DY1(N),DY(N),AK1(N),
     *  AK2(N),AK3(N),AK4(N),FX(N),
     *  FJAC(LU_NONZERO),E(LU_NONZERO),
     *  FMAS(LDMAS,N),AbsTol(1),RelTol(1)
      INTEGER IP(N)
      LOGICAL REJECT,RJECT2,AUTNMS,IMPLCT,BANDED
      COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL
      EXTERNAL FCN,JAC,MAS,SOLOUT,DFX

C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ----------
      IF (IMPLCT) CALL MAS(N,FMAS,LDMAS)
C ---- PREPARE BANDWIDTHS -----
      IF (BANDED) THEN
          MLE=MLJAC
          MUE=MUJAC
          MBJAC=MLJAC+MUJAC+1
          MBB=MLMAS+MUMAS+1
          MDIAG=MLE+MUE+1
          MBDIAG=MUMAS+1
          MDIFF=MLE+MUE-MUMAS
      END IF
C *** *** *** *** *** *** ***
C  INITIALISATIONS
C *** *** *** *** *** *** ***
      IF (METH.EQ.1) CALL SHAMP (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IF (METH.EQ.2) CALL GRK4T (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IF (METH.EQ.3) CALL GRK4A (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IF (METH.EQ.4) CALL VELDS (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IF (METH.EQ.5) CALL VELDD (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IF (METH.EQ.6) CALL LSTAB (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
C --- INITIAL PREPARATIONS
      POSNEG=SIGN(1.D0,XEND-X)
      HMAXN=MIN(ABS(HMAX),ABS(XEND-X))
      IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6
      H=MIN(ABS(H),HMAXN)
      H=SIGN(H,POSNEG)
      REJECT=.FALSE.
      NSING=0
      IRTRN=1
      XXOLD=X
      IF (IRTRN.LT.0) GOTO 79
C --- BASIC INTEGRATION STEP
   1  IF (NSTEP.GT.NMAX.OR.X+.1D0*H.EQ.X.OR.ABS(H).LE.UROUND) GOTO 79
      IF ((X-XEND)*POSNEG+UROUND.GT.0.D0) THEN
          H=HOPT
          IDID=1
          RETURN
      END IF
      HOPT=H
      IF ((X+H-XEND)*POSNEG.GT.0.D0) H=XEND-X
      CALL FCN(N,X,Y,DY1)
      NFCN=NFCN+1

C *** *** *** *** *** *** ***
C  COMPUTATION OF THE JACOBIAN
C *** *** *** *** *** *** ***
      NJAC=NJAC+1
      CALL JAC(N,X,Y,FJAC)

      IF (.NOT.AUTNMS) THEN
          IF (IDFX.EQ.0) THEN
C --- COMPUTE NUMERICALLY THE DERIVATIVE WITH RESPECT TO X
              DELT=DSQRT(UROUND*MAX(1.D-5,ABS(X)))
              XDELT=X+DELT
              CALL FCN(N,XDELT,Y,AK1)
              DO 19 J=1,N
  19          FX(J)=(AK1(J)-DY1(J))/DELT
          ELSE
C --- COMPUTE ANALYTICALLY THE DERIVATIVE WITH RESPECT TO X
              CALL DFX(N,X,Y,FX)
          END IF
      END IF
   2  CONTINUE

C *** *** *** *** *** *** ***
C  COMPUTE THE STAGES
C *** *** *** *** *** *** ***
      NDEC=NDEC+1
      HC21=C21/H
      HC31=C31/H
      HC32=C32/H
      HC41=C41/H
      HC42=C42/H
      HC43=C43/H
      FAC=1.D0/(H*GAMMA)
C --- THE MATRIX E (B=IDENTITY, JACOBIAN A FULL MATRIX)
              DO 800 I=1,LU_NONZERO
  800         E(I)=-FJAC(I)
              DO 801 J=1,N
  801         E(LU_DIAG(J))=E(LU_DIAG(J))+FAC
              CALL KppDecomp (E,IER)
              IF (IER.NE.0) GOTO 80
              IF (AUTNMS) THEN
C --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
C ---   1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
C ---   2) THE JACOBIAN OF THE PROBLEM IS A FULL MATRIX
C ---   3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS
                  DO 803 I=1,N
  803             AK1(I)=DY1(I)
                  CALL KppSolve(E,AK1)
                  DO 810 I=1,N
  810             YNEW(I)=Y(I)+A21*AK1(I)
                  CALL FCN(N,X,YNEW,DY)
                  DO 811 I=1,N
  811             AK2(I)=DY(I)+HC21*AK1(I)
                  CALL KppSolve(E,AK2)
                  DO 820 I=1,N
  820             YNEW(I)=Y(I)+A31*AK1(I)+A32*AK2(I)
                  CALL FCN(N,X,YNEW,DY)
                  DO 821 I=1,N
  821             AK3(I)=DY(I)+HC31*AK1(I)+HC32*AK2(I)
                  CALL KppSolve(E,AK3)
                  DO 831 I=1,N
  831             AK4(I)=DY(I)+HC41*AK1(I)+HC42*AK2(I)+HC43*AK3(I)
                  CALL KppSolve(E,AK4)
              ELSE
C --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
C ---   1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
C ---   2) THE JACOBIAN OF THE PROBLEM IS A FULL MATRIX
C ---   3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS
                  HD1=H*D1
                  HD2=H*D2
                  HD3=H*D3
                  HD4=H*D4
                  DO 903 I=1,N
  903             AK1(I)=DY1(I)+HD1*FX(I)
                  CALL KppSolve(E,AK1)
                  DO 910 I=1,N
  910             YNEW(I)=Y(I)+A21*AK1(I)
                  CALL FCN(N,X+C2*H,YNEW,DY)
                  DO 911 I=1,N
  911             AK2(I)=DY(I)+HD2*FX(I)+HC21*AK1(I)
                  CALL KppSolve(E,AK2)
                  DO 920 I=1,N
  920             YNEW(I)=Y(I)+A31*AK1(I)+A32*AK2(I)
                  CALL FCN(N,X+C3*H,YNEW,DY)
                  DO 921 I=1,N
  921             AK3(I)=DY(I)+HD3*FX(I)+HC31*AK1(I)+HC32*AK2(I)
                  CALL KppSolve(E,AK3)
                  DO 931 I=1,N
  931             AK4(I)=DY(I)+HD4*FX(I)+HC41*AK1(I)+HC42*AK2(I)
     &                  +HC43*AK3(I)
                  CALL KppSolve(E,AK4)
              END IF
      NSOL=NSOL+4
      NFCN=NFCN+2
C *** *** *** *** *** *** ***
C  ERROR ESTIMATION
C *** *** *** *** *** *** ***
      NSTEP=NSTEP+1
C ------------ NEW SOLUTION ---------------
      DO 240 I=1,N
  240 YNEW(I)=Y(I)+B1*AK1(I)+B2*AK2(I)+B3*AK3(I)+B4*AK4(I)
C ------------ COMPUTE ERROR ESTIMATION ----------------
      ERR=0.D0
      DO 300 I=1,N
      S=E1*AK1(I)+E2*AK2(I)+E3*AK3(I)+E4*AK4(I)
      IF (ITOL.EQ.0) THEN
         SK=AbsTol(1)+RelTol(1)*DMAX1(DABS(Y(I)),DABS(YNEW(I)))
      ELSE
         SK=AbsTol(I)+RelTol(I)*DMAX1(DABS(Y(I)),DABS(YNEW(I)))
      END IF
  300 ERR=ERR+(S/SK)**2
      ERR=DSQRT(ERR/N)
C --- COMPUTATION OF HNEW
C --- WE REQUIRE .2<=HNEW/H<=6.
      FAC=DMAX1(FAC2,DMIN1(FAC1,(ERR)**.25D0/.9D0))
      HNEW=H/FAC
C *** *** *** *** *** *** ***
C  IS THE ERROR SMALL ENOUGH ?
C *** *** *** *** *** *** ***
      IF (ERR.LE.1.D0) THEN
C --- STEP IS ACCEPTED
         NACCPT=NACCPT+1
         DO 44 I=1,N
  44     Y(I)=YNEW(I)
         XXOLD=X
         X=X+H
         IF (IRTRN.LT.0) GOTO 79
         IF (DABS(HNEW).GT.HMAXN) HNEW=POSNEG*HMAXN
         IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H))
         REJECT=.FALSE.
         RJECT2=.FALSE.
         H=HNEW
         GOTO 1
      ELSE
C --- STEP IS REJECTED
         IF (RJECT2) HNEW=H*FACREJ
         IF (REJECT) RJECT2=.TRUE.
         REJECT=.TRUE.
         H=HNEW
         IF (NACCPT.GE.1) NREJCT=NREJCT+1
         GOTO 2
      END IF
C --- EXIT
  80  WRITE (6,*) ' MATRIX E IS SINGULAR, INFO = ',INFO
      NSING=NSING+1
      IF (NSING.GE.5) GOTO 79
      H=H*0.5D0
      GOTO 2
  79  WRITE(6,979)X,H
 979  FORMAT(' EXIT OF ROS4 AT X=',D16.7,'   H=',D16.7)
      IDID=-1
      RETURN
      END
C
      SUBROUTINE SHAMP (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IMPLICIT KPP_REAL (A-H,O-Z)
         A21=2.D0
         A31=48.D0/25.D0
         A32=6.D0/25.D0
         C21=-8.D0
         C31=372.D0/25.D0
         C32=12.D0/5.D0
         C41=-112.D0/125.D0
         C42=-54.D0/125.D0
         C43=-2.D0/5.D0
         B1=19.D0/9.D0
         B2=1.D0/2.D0
         B3=25.D0/108.D0
         B4=125.D0/108.D0
         E1=17.D0/54.D0
         E2=7.D0/36.D0
         E3=0.D0
         E4=125.D0/108.D0
         GAMMA=.5D0
         C2= 0.1000000000000000D+01
         C3= 0.6000000000000000D+00
         D1= 0.5000000000000000D+00
         D2=-0.1500000000000000D+01
         D3= 0.2420000000000000D+01
         D4= 0.1160000000000000D+00
      RETURN
      END
C
      SUBROUTINE GRK4A (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IMPLICIT KPP_REAL (A-H,O-Z)
       A21= 0.1108860759493671D+01
       A31= 0.2377085261983360D+01
       A32= 0.1850114988899692D+00
       C21=-0.4920188402397641D+01
       C31= 0.1055588686048583D+01
       C32= 0.3351817267668938D+01
       C41= 0.3846869007049313D+01
       C42= 0.3427109241268180D+01
       C43=-0.2162408848753263D+01
       B1= 0.1845683240405840D+01
       B2= 0.1369796894360503D+00
       B3= 0.7129097783291559D+00
       B4= 0.6329113924050632D+00
       E1= 0.4831870177201765D-01
       E2=-0.6471108651049505D+00
       E3= 0.2186876660500240D+00
       E4=-0.6329113924050632D+00
       GAMMA= 0.3950000000000000D+00
       C2= 0.4380000000000000D+00
       C3= 0.8700000000000000D+00
       D1= 0.3950000000000000D+00
       D2=-0.3726723954840920D+00
       D3= 0.6629196544571492D-01
       D4= 0.4340946962568634D+00
      RETURN
      END
C
      SUBROUTINE GRK4T (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
      IMPLICIT KPP_REAL (A-H,O-Z)
       A21= 0.2000000000000000D+01
       A31= 0.4524708207373116D+01
       A32= 0.4163528788597648D+01
       C21=-0.5071675338776316D+01
       C31= 0.6020152728650786D+01
       C32= 0.1597506846727117D+00
       C41=-0.1856343618686113D+01
       C42=-0.8505380858179826D+01
       C43=-0.2084075136023187D+01
       B1= 0.3957503746640777D+01
       B2= 0.4624892388363313D+01
       B3= 0.6174772638750108D+00
       B4= 0.1282612945269037D+01
       E1= 0.2302155402932996D+01
       E2= 0.3073634485392623D+01
       E3=-0.8732808018045032D+00
       E4=-0.1282612945269037D+01
       GAMMA= 0.2310000000000000D+00
       C2= 0.4620000000000000D+00
       C3= 0.8802083333333334D+00
       D1= 0.2310000000000000D+00
       D2=-0.3962966775244303D-01
       D3= 0.5507789395789127D+00
       D4=-0.5535098457052764D-01
      RETURN
      END
C
      SUBROUTINE VELDS (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
C --- METHOD GIVEN BY VAN VELDHUIZEN
      IMPLICIT KPP_REAL (A-H,O-Z)
       A21= 0.2000000000000000D+01
       A31= 0.1750000000000000D+01
       A32= 0.2500000000000000D+00
       C21=-0.8000000000000000D+01
       C31=-0.8000000000000000D+01
       C32=-0.1000000000000000D+01
       C41= 0.5000000000000000D+00
       C42=-0.5000000000000000D+00
       C43= 0.2000000000000000D+01
       B1= 0.1333333333333333D+01
       B2= 0.6666666666666667D+00
       B3=-0.1333333333333333D+01
       B4= 0.1333333333333333D+01
       E1=-0.3333333333333333D+00
       E2=-0.3333333333333333D+00
       E3=-0.0000000000000000D+00
       E4=-0.1333333333333333D+01
       GAMMA= 0.5000000000000000D+00
       C2= 0.1000000000000000D+01
       C3= 0.5000000000000000D+00
       D1= 0.5000000000000000D+00
       D2=-0.1500000000000000D+01
       D3=-0.7500000000000000D+00
       D4= 0.2500000000000000D+00
      RETURN
      END
C
      SUBROUTINE VELDD (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
C --- METHOD GIVEN BY VAN VELDHUIZEN
      IMPLICIT KPP_REAL (A-H,O-Z)
       A21= 0.2000000000000000D+01
       A31= 0.4812234362695436D+01
       A32= 0.4578146956747842D+01
       C21=-0.5333333333333331D+01
       C31= 0.6100529678848254D+01
       C32= 0.1804736797378427D+01
       C41=-0.2540515456634749D+01
       C42=-0.9443746328915205D+01
       C43=-0.1988471753215993D+01
       B1= 0.4289339254654537D+01
       B2= 0.5036098482851414D+01
       B3= 0.6085736420673917D+00
       B4= 0.1355958941201148D+01
       E1= 0.2175672787531755D+01
       E2= 0.2950911222575741D+01
       E3=-0.7859744544887430D+00
       E4=-0.1355958941201148D+01
       GAMMA= 0.2257081148225682D+00
       C2= 0.4514162296451364D+00
       C3= 0.8755928946018455D+00
       D1= 0.2257081148225682D+00
       D2=-0.4599403502680582D-01
       D3= 0.5177590504944076D+00
       D4=-0.3805623938054428D-01
      RETURN
      END
C
      SUBROUTINE LSTAB (A21,A31,A32,C21,C31,C32,C41,C42,C43,
     &          B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
C --- AN L-STABLE METHOD
      IMPLICIT KPP_REAL (A-H,O-Z)
       A21= 0.2000000000000000D+01
       A31= 0.1867943637803922D+01
       A32= 0.2344449711399156D+00
       C21=-0.7137615036412310D+01
       C31= 0.2580708087951457D+01
       C32= 0.6515950076447975D+00
       C41=-0.2137148994382534D+01
       C42=-0.3214669691237626D+00
       C43=-0.6949742501781779D+00
C  B_i = M_i
       B1= 0.2255570073418735D+01
       B2= 0.2870493262186792D+00
       B3= 0.4353179431840180D+00
       B4= 0.1093502252409163D+01
C E_i = error estimator
       E1=-0.2815431932141155D+00
       E2=-0.7276199124938920D-01
       E3=-0.1082196201495311D+00
       E4=-0.1093502252409163D+01
C gamma = gamma
       GAMMA= 0.5728200000000000D+00
C  C_i = alpha_i
       C2= 0.1145640000000000D+01
       C3= 0.6552168638155900D+00
C D_i = gamma_i
       D1= 0.5728200000000000D+00
       D2=-0.1769193891319233D+01
       D3= 0.7592633437920482D+00
       D4=-0.1049021087100450D+00
      RETURN
      END

        SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,IRTRN)
C --- PRINTS SOLUTION
        IMPLICIT KPP_REAL (A-H,O-Z)
        DIMENSION Y(N)
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=0.1D0
        ELSE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) X,Y(1),Y(2),NR-1
              XOUT=DMAX1(XOUT+0.1D0,X)
           END IF
        END IF
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END

      SUBROUTINE DEC (N, NDIM, A, IP, IER)
C VERSION REAL KPP_REAL
      INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J
      KPP_REAL A,T
      DIMENSION A(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
C  INPUT..
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF ARRAY  A .
C     A = MATRIX TO BE TRIANGULARIZED.
C  OUTPUT..
C     A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U .
C     A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C     IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C     IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE
C           SINGULAR AT STAGE K.
C  USE  SOL  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N).
C  IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION KppSolveR,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = K
        DO 10 I = KP1,N
          IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I
 10     CONTINUE
        IP(K) = M
        T = A(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        A(M,K) = A(K,K)
        A(K,K) = T
 20     CONTINUE
        IF (T .EQ. 0.D0) GO TO 80
        T = 1.D0/T
        DO 30 I = KP1,N
 30       A(I,K) = -A(I,K)*T
        DO 50 J = KP1,N
          T = A(M,J)
          A(M,J) = A(K,J)
          A(K,J) = T
          IF (T .EQ. 0.D0) GO TO 45
          DO 40 I = KP1,N
 40         A(I,J) = A(I,J) + A(I,K)*T
 45       CONTINUE
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (A(N,N) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DEC -------------------------
      END
C
C
      SUBROUTINE SOL (N, NDIM, A, B, IP)
C VERSION REAL KPP_REAL
      INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1
      KPP_REAL A,B,T
      DIMENSION A(NDIM,N), B(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N = ORDER OF MATRIX.
C    NDIM = DECLARED DIMENSION OF ARRAY  A .
C    A = TRIANGULARIZED MATRIX OBTAINED FROM DEC.
C    B = RIGHT HAND SIDE VECTOR.
C    IP = PIVOT VECTOR OBTAINED FROM DEC.
C  DO NOT USE IF DEC HAS SET IER .NE. 0.
C  OUTPUT..
C    B = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        T = B(M)
        B(M) = B(K)
        B(K) = T
        DO 10 I = KP1,N
 10       B(I) = B(I) + A(I,K)*T
 20     CONTINUE
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        B(K) = B(K)/A(K,K)
        T = -B(K)
        DO 30 I = 1,KM1
 30       B(I) = B(I) + A(I,K)*T
 40     CONTINUE
 50   B(1) = B(1)/A(1,1)
      RETURN
C----------------------- END OF SUBROUTINE SOL -------------------------
      END

      SUBROUTINE FUNC_CHEM(N, T, Y, P)
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'
      INTEGER N
      KPP_REAL   T, Told
      KPP_REAL   Y(NVAR), P(NVAR)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Fun( Y,  FIX, RCONST, P )
      TIME = Told
      RETURN
      END

      SUBROUTINE JAC_CHEM(N, T, Y, J)
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'
      INTEGER N
      KPP_REAL   Told, T
      KPP_REAL   Y(NVAR), J(LU_NONZERO)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Jac_SP( Y,  FIX, RCONST, J )
      TIME = Told
      RETURN
      END


module parameters
  implicit none
!!since HLattice V2.0, all parameters are set in "configure.h", do not change this file anymore.

!!============================================================================
#include "configure.h"

  integer,parameter :: dl=kind(1.d0) !!use double precision
  integer,parameter :: dlc=kind((1.d0,1.d0)) !!double precision complex numbers
  integer,parameter :: IB = 4 !! use 4-bytes integers

  real(dl),parameter :: const_pi =   3.141592653589793238462643383_dl
  real(dl),parameter :: const_2pi =6.283185307179586476925286766_dl
  real(dl),parameter :: const_pi2 = const_pi**2
  real(dl),parameter :: const_sqrt2 = 1.4142135623730950488_dl
  real(dl),parameter :: const_sqrt3 = 1.7320508075688772935_dl
  real(dl),parameter :: const_sqrtpi = 1.7724538509055160273_dl
!!==============================================================================
#if SIMU_RESOLUTION == 16
#include "headfiles/n_params_4.h"
#elif SIMU_RESOLUTION == 32
#include "headfiles/n_params_5.h"
#elif SIMU_RESOLUTION == 64
#include "headfiles/n_params_6.h"
#elif SIMU_RESOLUTION == 128
#include "headfiles/n_params_7.h"
#elif SIMU_RESOLUTION == 256
#include "headfiles/n_params_8.h"
#elif SIMU_RESOLUTION == 512
#include "headfiles/n_params_9.h"
#elif SIMU_RESOLUTION == 1024
#include "headfiles/n_params_10.h"
#elif SIMU_RESOLUTION == 2048
#include "headfiles/n_params_11.h"
#elif SIMU_RESOLUTION == 4096
#include "headfiles/n_params_12.h"
#endif

!!======================= # of scalar fields ==================================
  integer(IB),parameter :: ns = NUM_SCALAR_FIELDS
!!======================= box size ============================================
  real(dl),parameter::boxsize_H = INIT_BOXSIZE_TIMES_H
!!======================= feedback ==============================================
  integer(IB),parameter::n_feedback = FEEDBACK_INTERVAL
!!======================== stop simulation =======================================
  integer(IB),parameter:: stop_at_step = MAX_STEPS
  real(dl),parameter:: stop_at_a = MAX_SCALE_FACTOR
!!======================== check point ============================================
  logical,parameter:: use_checkpoint = .true.
  logical,parameter::write_check_at_step0 = .true.
  integer,parameter:: checkpoint_steps = CHECKPOINT_AND_GW_INTERVAL

!!======================== refined steps for Runge-Kutta sub-integrator ======
  integer(IB),parameter::noncanonical_Runge_Kutta_steps = SUB_INTEGRATOR_STEPS

!!============================= reduced Planck Mass M_p=======================
  real(dl),parameter :: Mpl = REDUCED_PLANCK_MASS !!1024._dl

!!============================ default prefix of output files ================
!!the output files will be in ./data/ directory. All named with a prefix.
!!the prefix can be specified by running HLattice in command line:
!! ./HLattice prefix
!!when you run HLattice without passing a prefix to it, a default prefix will be used. It's defined here:
  character(LEN=256)::run_name="test" !! *

!!============================ do not change things below =========================================
!! n/2
  integer,parameter::Nby2=n/2
!!n^2
  real(dl),parameter:: nsquare = (1._dl*n)**2
!!n^3
  real(dl),parameter:: ncube = (1._dl * n)**3
!!wave number unit * dx
  real(dl),parameter::k_unit = const_2pi/n

  real(dl),parameter :: PlanckMass = 2._dl *const_sqrt2 * const_sqrtpi * Mpl !!the Planck Mass (not reduced)
  real(dl),parameter :: Mplsq = Mpl**2 !!reduced Planck Mass squared
  real(dl),parameter :: Newton_G = 1./Mplsq/8./const_pi
  real(dl),parameter :: GeV = Mpl/2.43e18_dl

  integer(IB),parameter::n_Hamiltonian_terms = 3 ! number of non-comutable terms in Hamiltonian of the system

!!organize file units
  logical::unit_opened(7:99) = .false.

!!a global variable, will be calculated automatically. No need to change it here.
  real(dl):: init_Hubble
!!========================================

end module parameters


      subroutine runCY_00(k,l,Xtwiddle,Gtwiddle,Shat2,N0)
      implicit none
C---  Expression for Eq. 5.54
C---  Calculates C00
C---  Small terms of order Xtwiddle(0,k)*Ci,Xtwiddle(0,0)*Cii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat2(np,z1max,-2:0)

      do ep=-2,0

      Cv(cc00+N0,ep)=
     .  (Gtwiddle(k,1)*Shat2(1,l,ep)
     .  +Gtwiddle(k,2)*Shat2(2,l,ep)
     .  +Xtwiddle(0,k)*Cv(ci(l)+N0,ep)
     .  -Xtwiddle(0,0)*Cv(cii(z2(k,l))+N0,ep))/(2*Gtwiddle(k,l))

c      write(6,*) 'runCY_00:Cv(cc00+N0,ep)',Cv(cc00+N0,ep)

      enddo

      return
      end


      double complex function A7trees(j1,j2,j3,j4,j5,j6,j7,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
c---  DKS Eq. 3.15
      integer j1,j2,j3,j4,j5,j6,j7
      double complex a7treea

      a7trees=a7treea(j1,j2,j3,j4,j5,j6,j7,za,zb)
     .       +a7treea(j1,j2,j6,j5,j4,j3,j7,za,zb)

      return
      end

      double complex function A7treea(j1,j2,j3,j4,j5,j6,j7,za,zb)
C---This function taken from Eq. 2.22 of DKS
c---Multiplied by a factor of (-i)
C---in the natural way this function refers to the process
c---u(2)+dbar(1)-->nu(3)+e^+(3)+b(5)+bbar(6)+g(7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6,j7
      integer i1,i2,i3,i4
      double complex z2
      double precision t134,t256
      z2(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)
      t134=s(j1,j3)+s(j1,j4)+s(j3,j4)
      t256=s(j2,j5)+s(j2,j6)+s(j5,j6)
      A7treea=za(j1,j3)
     . *(za(j1,j3)*zb(j3,j4)*zb(j2,j5)*z2(j6,j2,j5,j7)/t256
     . +z2(j6,j1,j3,j4)*z2(j1,j2,j7,j5)/za(j7,j2))
     . /(za(j1,j7)*s(j3,j4)*s(j5,j6)*t134)
      return
      end

c      double complex function A7treeb(j1,j2,j3,j4,j5,j6,j7,za,zb)
C---This function taken from Eq. 2.23 of DKS
c---Multiplied by a factor of (-i)
C---in the natural way this function refers to the process
c---u(2)+dbar(1)-->nu(3)+e^+(3)+b(5)+bbar(6)+g(7)
c      implicit none
c      include 'constants.f'
c      include 'sprods_com.f'
c      include 'zprods_decl.f'
c      integer j1,j2,j3,j4,j5,j6,j7
c      integer i1,i2,i3,i4
c      double complex z2
c      double precision t127
c      z2(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)
c      t127=s(j1,j2)+s(j1,j7)+s(j2,j7)
c      A7treeb=(-za(j3,j6)*zb(j4,j5)
c     . *(z2(j1,j5,j6,j2)*za(j2,j1)+z2(j1,j5,j6,j7)*za(j7,j1))
c     . +za(j1,j3)*z2(j1,j2,j7,j4)*z2(j6,j3,j4,j5)
c     . -za(j1,j6)*z2(j1,j2,j7,j5)*z2(j3,j5,j6,j4))
c     . /(za(j1,j7)*za(j7,j2)*s(j3,j4)*s(j5,j6)*t127)
c      return
c      end


c
c -------------------------------------------------------------
c
        subroutine finit(val,nvar,mitot,mjtot,irr,
     1               cornx,corny,hx,hy,lstgrd)
c
       implicit double precision (a-h,o-z)
       dimension val(mitot,mjtot,nvar), irr(mitot,mjtot)

      include  "cnodal.i"
      include  "cuser.i"
      include  "cdisc.i"
      include  "cdom.i"

      if (iprob .eq. 1) then
c     # shock/cloud initial conditions
c
        xshock = 2.*xupper
 	do 30 i = 1, mitot
 	   xcen = cornx + (i-.5)*hx
 	   if (xcen .le. xshock) then
 		do 10 j = 1, mjtot
 		      val(i,j,1) = rhoshk
 		      val(i,j,2) = rhoshk*ushk
 		      val(i,j,3) = 0.d0
 		      val(i,j,4) = rhoshk*(eshk+.5d0*ushk**2)
 10             continue
            else
 		do 20 j = 1, mjtot
 		   ycen = corny + (j-.5)*hy
c		   dist = sqrt((xcen-xcircle)**2 + (ycen-ycircle)**2)
c		   if (dist - radius .ge. 0.d0) then
 		      rhotmp = rhoamb
 		      utmp   = uamb
 		      etmp   = eamb
c		   else
c		      rhotmp = rhocld
c		      utmp   = ucld
c 		      etmp   = ecld
c		   endif
 		   val(i,j,1) = rhotmp
 		   val(i,j,2) = rhotmp*utmp
 		   val(i,j,3) = 0.d0
 		   val(i,j,4) = rhotmp*(etmp + .5*utmp**2)

 20              continue
             endif
 30     continue

      else if (iprob .eq. 3) then

	do 130 i = 1, mitot
	   xcen = cornx + (i-.5)*hx
	   if (xcen .gt. xshock) then
	      do 110 j = 1, mjtot
		val(i,j,1) = rhoshk
		val(i,j,2) = rhoshk*ushk
		val(i,j,3) = 0.d0
		val(i,j,4) = rhoshk*(eshk+.5d0*ushk**2)
 110          continue
           else
	      do 120 j = 1, mjtot
		 ycen = corny + (j-.5)*hy
		 dist = dsqrt((xcen-xcircle)**2 + (ycen-ycircle)**2)
		 theta = datan2(ycen-ycircle,xcen-xcircle)
		 upert = eps*(dist/rc)*dexp(alpha*(1.d0-(dist/rc)**2))
     .                    *dsin(theta)
		 vpert =-eps*(dist/rc)*dexp(alpha*(1.d0-(dist/rc)**2))
     .                    *dcos(theta)
		 tpert = -((gamma-1.d0)*eps*eps/(4.d0*alpha*gamma))*
     .                   dexp(2.d0*alpha*(1.d0-(dist/rc)**2))
		 spert = 0.d0

		 ttmp    = tamb+tpert
		 rhotmp  = ttmp**(1.d0/(gamma-1.d0))
		 ptmp    = ttmp*rhotmp

		 utmp    = uamb + upert
		 vtmp    =        vpert

		 etmp    = ptmp/(gamma-1.d0) +
     .                     .5d0*rhotmp*(utmp**2 +vtmp**2)

		 val(i,j,1) = rhotmp
		 val(i,j,2) = rhotmp*utmp
		 val(i,j,3) = rhotmp*vtmp
		 val(i,j,4) = etmp
 120         continue
          endif
 130   continue

      else if (iprob .eq. 2) then
c
c     2d riemann problem initial cond. (see Glaz et al SISSC 14, 1993)
c
	xmid = .5d0 * (xupper+xlower)
	ymid = .5d0 * (yupper+ylower)
	do 50 i = 1, mitot
	xcen = cornx + (i-.5)*hx
	do 50 j = 1, mjtot
	ycen = corny + (j-.5)*hy
	    if (xcen .le. xmid) then
	       if (ycen .le. ymid) then
c                  # 3rd quadrant data
c                  #configuration 3
c		   rho =  0.137992831541219d0
c		   pr  = 0.029032258064516d0
c		   u   =  1.206045378311055d0
c		   v   =  1.206045378311055d0
c                  #configuration B
c                  rho = 1.d0
c                  u   = -.75d0
c                  v   =  .5d0
c                  pr  = 1.d0
c                  #configuration A
                   rho = 1.d0
                   u   =  .75d0
                   v   =  .5d0
                   pr  = 1.d0
	       else
c                  # 2nd quadrant data
c                  #configuration 3
c		   rho = 0.532258064516129d0
c		   pr  = 0.3d0
c		   u   =  1.206045378311055d0
c		   v   =  0.d0
c                  #configuration B
c                  rho = 2.d0
c                  u   =  .75d0
c                  v   =  .5d0
c                  pr  = 1.d0
c                  #configuration A
                   rho = 2.d0
                   u   = -.75d0
                   v   =  .5d0
                   pr  = 1.d0
	       endif
	    else if (ycen .le. ymid) then
c                  # 4th quadrant data
c                  #configuration 3
c		   rho = 0.532258064516129d0
c		   pr  = 0.3d0
c		   u   = 0.d0
c		   v   =  1.206045378311055d0
c                  #configuration B
c                  rho = 3.d0
c                  u   = -.75d0
c                  v   = -.5d0
c                  pr  = 1.d0
c                  #configuration A
                   rho = 3.d0
                   u   =  .75d0
                   v   = -.5d0
                   pr  = 1.d0
	    else
c                  # 1st quadrant data
c                  #configuration 3
c		   rho = 1.5d0
c		   pr  = 1.5d0
c		   u   = 0.d0
c		   v   = 0.d0
c                  #configuration B
c                  rho = 1.d0
c                  u   =  .75d0
c                  v   = -.5d0
c                  pr  = 1.d0
c                  #configuration A
                   rho = 1.d0
                   u   = -.75d0
                   v   = -.5d0
                   pr  = 1.d0
	    endif

	    val(i,j,1) = rho
	    val(i,j,2) = rho * u
	    val(i,j,3) = rho * v
	    val(i,j,4) = pr/gamma1 + .5d0*rho*(u*u + v*v)

 50      continue

      else if (iprob .eq. 5) then

c     # mach 10 30 degree ramp reflection. shock starts at x= xshock at wall
c     # parameters set in setprob.
c     # 2nd ramp problem: mach 1.025 at 18 degrees.

         do 60 i = 1, mitot
	   xcen = cornx + (i-.5)*hx

	   do 60 j = 1, mjtot
	     ycen = corny + (j-.5)*hy

             call cellave(xcen-hx/2.d0,ycen-hy/2.d0,hx,hy,wl)
             rho = (1.d0-wl)*rhoamb + wl*rhoshk
             u =   (1.d0-wl)*uamb   + wl*ushk
             v =   (1.d0-wl)*vamb   + wl*vshk
             p =   (1.d0-wl)*pamb   + wl*pshk

	     val(i,j,1) = rho
	     val(i,j,2) = rho * u
	     val(i,j,3) = rho * v
	     val(i,j,4) = p/gamma1 + .5d0*rho*(u*u+v*v)

 60      continue

      endif

      return
      end


c=======================================================================
c
c     subroutine COVFILRERING3
c
c     This function implements a cov. matrix correction for a filtering
c     level between 0% and 100%.
c
c-----------------------------------------------------------------------
      SUBROUTINE covfiltering3 ( p, cov, filter, iwork, dwork,
     &                           covopt, epsilon, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       p       : matrix size (p>0)                              integer
c       cov     : covariance matrix (p*p)                         double
c       filter  : filtering level (0<=filter<=1)                  double
c
c     WORKSPACE
c       iwork   : 12*p + 3                                       integer
c       dwork   : (p*(15*p + 61))/2 + 1                           double
c
c     OUTPUT
c       covopt  : optimal cov. matrix (p*p)                       double
c       epsilon : calibration parameter                           double
c       info    : diagnostic argument                            integer
c
c     CALL
c       SDLS    : Semidefinite Least Square optimization
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, info
      DOUBLE PRECISION filter, epsilon, cov(*), covopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER alpha, N, nbCst, pisdls, pdsdls, pdb, pdC, pdS
      DOUBLE PRECISION Lmin, Lmax, a, b, x
      DOUBLE PRECISION traceCov, cstPrecision, EPS, minEpsilon
      PARAMETER ( EPS = 1.E-15, minEpsilon = 1.E-8 )
      PARAMETER ( cstPrecision  = 1.E-15 )
c
c     external subroutines
      EXTERNAL TM, sdls, EVMIN, EVMAX, eigenvd
c
c     intrinsic functions
      INTRINSIC MAX
c
c-----------------------------------------------------------------------
c
c     initializations
      info  = 0     ! diagnostic argument
      N     = 100   ! nb. filter increment
      nbCst = 0     ! number of SDLS constraints
      epsilon = 0.0 ! correction parameter
      CALL YM ( p, p, cov, covopt ) ! copy cov -> covopt
c
c     pointers for integer work space : iworka
c     ---------------------------------------
      pisdls = 1
c     pisdls : pointer for SDLS (12*p + 3)
c
c     Total size of iwork array = 12*p + 3
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdS    = 1
c     pdS    : pointer for eigenvalues (p)
      pdC    = pdS + ( p )
c     pdC    : pointer for cst. matrix SDLS (p*p)
      pdb    = pdC + ( p*p )
c     pdb    : pointer for cst. vector SDLS (1)
      pdsdls = pdb + ( 1 )
c     pdsdls : pointer for SDLS
c                    5*p*(p+1)/2 + p*(4*p + 27)
c
c     Total size of dwork array = p + p*p + 1 + 5*p*(p+1)/2  + p*(4*p + 27)
c                               = (p*(15*p + 61))/2 + 1
c
c-----------------------------------------------------------------------
c
c     if filter=0 no correction
      IF (filter .LT. EPS) RETURN
c
c     cov. matrix trace
      CALL TM ( p, cov, traceCov )
      IF (traceCov .LT. EPS) RETURN
c
c     Singular value decomposition
c     cov = U*Diag(S)*U', with sorted singular values S(i) >= S(i+1)
      CALL eigenvd (p, cov, dwork(pdsdls), dwork(pdS),
     &              dwork(pdsdls + p*p + 10*p), info)
c
c     min/max eigenvalue
      CALL EVMIN ( p, dwork(pdS), Lmin )
      CALL EVMAX ( p, dwork(pdS), Lmax )
c
c     SDP constraint (min eigenvalue)
      Lmin = MAX(minEpsilon, Lmin)
c
c     case Lmax = Lmin
      IF ((Lmax-Lmin) .LT. EPS) THEN
        info    = 1310
        epsilon = Lmax
        RETURN
      ENDIF
c
c     exponent coefficient
      alpha = 6
c
c     a and b coefficients
      a = (Lmax - Lmin)/(Lmax**alpha - Lmin**alpha)
      b = Lmin - a*(Lmin**alpha)
c
c     filter [0, 1] -> SDLS epsilon
      x = Lmin + 100*filter*(Lmax-Lmin)/N
      epsilon = a*(x**alpha) + b
c
c     optimization with SDLS
      CALL sdls ( p, cov, nbCst, dwork(pdC), dwork(pdb),
     &            cstPrecision, epsilon,
     &            iwork(pisdls), dwork(pdsdls),
     &            covopt, info )
      IF (info .LT. 0) RETURN
c
      RETURN
      END