@PROCESS FREE(F90) INIT(F90PTR)
!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-C41                                                         *
!    (C) COPYRIGHT IBM CORP. 1997. ALL RIGHTS RESERVED.               *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
!
!  READ_MAT subroutine reads a matrix and its right hand sides,
!  all stored in a BCS format file. The B field is optional,.
!
!  Character                            :: filename*20
!     On Entry: name of file to be processed.
!     On Exit : unchanged.
!
!  Type(D_SPMAT)                        :: A
!     On Entry: fresh variable.
!     On Exit : will contain the global sparse matrix as follows:
!        A%AS for coefficient values
!        A%IA1  for column indices
!        A%IA2  for row pointers
!        A%M    for number of global matrix rows
!        A%K    for number of global matrix columns
!
!  Integer                              :: ICTXT
!     On Entry: BLACS context.
!     On Exit : unchanged.
!
!  Real(Kind(1.D0)), Pointer, Optional  :: B(:,:)
!     On Entry: fresh variable.
!     On Exit:  will contain right hand side(s).
!
!  Integer, Optional                    :: inroot
!     On Entry: Index of root processor (default: 0)
!     On Exit : unchanged.
!
!  Real(Kind(1.D0)), Pointer, Optional  :: indwork(:)
!     On Entry/Exit: Double Precision Work Area.
!
!  Integer, Pointer, Optional           :: iniwork()
!     On Entry/Exit: Integer Work Area.
!
MODULE READ_MAT
  PUBLIC READMAT
CONTAINS
  SUBROUTINE READMAT (FILENAME, A, ICTXT, B, INROOT,&
       & INDWORK, INIWORK)

    USE F90SPARSE

    ! Parameters
    IMPLICIT NONE
    REAL(KIND(1.D0)), POINTER, OPTIONAL   :: B(:,:)
    INTEGER                               :: ICTXT
    TYPE(D_SPMAT)                         :: A
    CHARACTER                             :: FILENAME*(*)
    INTEGER, OPTIONAL                     :: INROOT
    REAL(KIND(1.0D0)), POINTER, OPTIONAL  :: INDWORK(:)
    INTEGER, POINTER, OPTIONAL            :: INIWORK(:)

  ! Local Variables
    INTEGER, PARAMETER          :: INFILE = 2
    CHARACTER                   :: MXTYPE*3, KEY*8, TITLE*72,&
         & INDFMT*16, PTRFMT*16, RHSFMT*20, VALFMT*20, RHSTYP
    INTEGER                     :: INDCRD,  PTRCRD, TOTCRD,&
         & VALCRD, RHSCRD, NROW, NCOL, NNZERO, NELTVL, NRHS, NRHSIX
    REAL(KIND(1.0D0)), POINTER  :: AS_LOC(:), DWORK(:)
    INTEGER, POINTER            :: IA1_LOC(:), IA2_LOC(:), IWORK(:)
    INTEGER                     :: D_ALLOC, I_ALLOC, IRCODE, I,&
         & J, LIWORK, LDWORK, ROOT, NPROW, NPCOL, MYPROW, MYPCOL

    IF (PRESENT(INROOT)) THEN
       ROOT = INROOT
    ELSE
       ROOT = 0
    END IF

    CALL BLACS_GRIDINFO(ICTXT, NPROW, NPCOL, MYPROW, MYPCOL)

    IF (MYPROW == ROOT) THEN
       WRITE(*, *) 'Start read_matrix'

     ! Open Input File
       OPEN(INFILE,FILE=FILENAME, STATUS='OLD', ERR=901, ACTION="READ")
       READ(INFILE,FMT='(A72,A8,/,5I14,/,A3,11X,4I14,/,2A16,2A20)',&
            & END=902) TITLE, KEY, TOTCRD, PTRCRD,INDCRD, VALCRD,&
            & RHSCRD, MXTYPE, NROW, NCOL, NNZERO, NELTVL,&
            & PTRFMT, INDFMT, VALFMT, RHSFMT

       A%M    = NROW
       A%N    = NCOL
       A%FIDA = 'CSR'
       IF (RHSCRD>0) READ(INFILE, FMT='(A1,13X,2I14)',&
            & END=902)  RHSTYP, NRHS, NRHSIX

       IF (MXTYPE == 'RUA') THEN
          ALLOCATE(A%AS(NNZERO), A%IA1(NNZERO), A%IA2(NROW + 1),&
               & STAT = IRCODE)
          IF (IRCODE <> 0)   GOTO 993
          READ(INFILE,FMT=PTRFMT,END=902) (A%IA2(I), I=1,NROW+1)
          READ(INFILE,FMT=INDFMT,END=902) (A%IA1(I), I=1,NNZERO)
          READ(INFILE,FMT=VALFMT,END=902) (A%AS(I), I=1,NNZERO)

       ELSE IF (MXTYPE == 'RSA') THEN
        ! We are generally working with non-symmetric matrices, so
        ! we de-symmetrize what we are about to read
          ALLOCATE(A%AS(2*NNZERO),A%IA1(2*NNZERO),&
               & A%IA2(NROW+1),AS_LOC(2*NNZERO),&
               & IA1_LOC(2*NNZERO),IA2_LOC(NROW+1),STAT=IRCODE)
          IF (IRCODE <> 0)   GOTO 993
          READ(INFILE,FMT=PTRFMT,END=902) (IA2_LOC(I), I=1,NROW+1)
          READ(INFILE,FMT=INDFMT,END=902) (IA1_LOC(I), I=1,NNZERO)
          READ(INFILE,FMT=VALFMT,END=902) (AS_LOC(I), I=1,NNZERO)

          LDWORK = MAX(NROW + 1, 2 * NNZERO)
          IF (PRESENT(INDWORK)) THEN
             IF (SIZE(INDWORK) >= LDWORK) THEN
                DWORK => INDWORK
                D_ALLOC = 0
             ELSE
                ALLOCATE(DWORK(LDWORK), STAT = IRCODE)
                D_ALLOC = 1
             END IF
          ELSE
             ALLOCATE(DWORK(LDWORK), STAT = IRCODE)
             D_ALLOC = 1
          END IF
          IF (IRCODE <> 0)   GOTO 993

          LIWORK = NROW + 1
          IF (PRESENT(INIWORK)) THEN
             IF (SIZE(INIWORK) >= LIWORK) THEN
                IWORK => INIWORK
                I_ALLOC = 0
             ELSE
                ALLOCATE(IWORK(LIWORK), STAT = IRCODE)
                I_ALLOC = 1
             END IF
          ELSE
             ALLOCATE(IWORK(LIWORK), STAT = IRCODE)
             I_ALLOC = 1
          END IF
          IF (IRCODE <> 0)   GOTO 993

        ! After this call NNZERO contains the actual value for
        ! desymetrized matrix
          CALL DESYM(NROW, AS_LOC, IA1_LOC, IA2_LOC, A%AS, A%IA1,&
               & A%IA2, IWORK, DWORK, NNZERO, 1)

          DEALLOCATE(AS_LOC, IA1_LOC, IA2_LOC)
          IF (D_ALLOC == 1)   DEALLOCATE(DWORK)
          IF (I_ALLOC == 1)   DEALLOCATE(IWORK)
       ELSE
          WRITE(0,*) 'READ_MATRIX: matrix type not yet supported'
          CALL BLACS_ABORT(ICTXT, 1)
       END IF

     ! Read Right Hand Sides
       IF (PRESENT(B) .AND. (NRHS > 0)) THEN
          WRITE(0,*) 'Reading RHS'
          IF (RHSTYP == 'F') THEN
             ALLOCATE(B(NROW, NRHS), STAT = IRCODE)
             IF (IRCODE <> 0)   GOTO 993
             READ(INFILE,FMT=RHSFMT,END=902) ((B(I,J), I=1,NROW),J=1,NRHS)
          ELSE !(RHSTYP <> 'F')
             WRITE(0,*) 'READ_MATRIX: unsupported RHS type'
          END IF
       END IF

       CLOSE(INFILE)
       WRITE(*,*) 'End READ_MATRIX'
    END IF

    RETURN

  ! Open failed
901 WRITE(0,*) 'READ_MATRIX: Could not open file ',&
         & INFILE,' for input'
    CALL BLACS_ABORT(ICTXT, 1)

  ! Unexpected End of File
902 WRITE(0,*) 'READ_MATRIX: Unexpected end of file ',INFILE,&
         & ' during input'
    CALL BLACS_ABORT(ICTXT, 1)

  ! Allocation Failed
993 WRITE(0,*) 'READ_MATRIX: Memory allocation failure'
    CALL BLACS_ABORT(ICTXT, 1)

  END SUBROUTINE READMAT
END MODULE READ_MAT


subroutine mrqmin(x,y,ndata,a,ma,covar,alpha,nca,chisq,alamda)
  !Levenberg-Marquardt method, attempting to reduce the value
  !$\chi^2$ of a fit between a set of data points
  !\texttt{x(1:ndata)}, \texttt{y(1:ndata)}, and a nonlinear function
  !dependent on \texttt{ma} coefficients \texttt{a(1:ma)}. The program
  !returns current best-fit values for the
  !parameters \texttt{a(1:ma)}, and $\chi^2 = \texttt{chisq}$. The
  !arrays \texttt{covar(1:nca,1:nca)}, \texttt{alpha(1:nca,1:nca)}
  !with physical dimension \texttt{nca} ($\geq$ the number of fitted
  !parameters) are used as working space during most iterations.
  ! On the first call provide an initial guess for the
  !parameters \texttt{a}, and set $\texttt{alamda}<0$ for
  !initialization (which then sets $\texttt{alamda}=.001$). If
  !a step succeeds \texttt{chisq} becomes smaller and \texttt{alamda}
  !decreases by a factor of 10. If a step fails \texttt{alamda} grows
  !by a factor of 10. You must call this routine repeatedly until
  !convergence is achieved. Then, make one final call with
  !$\texttt{alamda}=0$, so that \texttt{covar(1:ma,1:ma)} returns the
  !covariance matrix, and \texttt{alpha} the curvature matrix.
  !(Parameters held fixed will return zero covariances.)
  implicit none
  integer(4), intent(in) :: ndata ! Number of datapoints to be fitted
  integer(4), intent(in) :: ma    ! Number of coefficients
  integer(4), intent(in) :: nca   ! Size of working-space arrays
  real(8),    intent(in) :: x(*)  ! abscisas of the datapoints
  complex*16, intent(in) :: y(*)  ! data value of the datapoint
  real(8),    intent(inout) :: alamda, chisq
  real(8),    intent(inout) :: a(ma)
  real(8),    intent(inout) :: covar(nca,nca), alpha(nca,nca)
  !
  integer :: j, k, l
  real(8) :: ochisq
  integer, parameter :: max = 50
  real(8) :: atry(max), beta(max), da(max)
  !
  save ochisq,atry,beta,da
  external covsrt
  external gaussj
  external mrqcof
  ! Original subroutine: mrqmin.for (c) copr. 1986-92 numerical recipes
  ! software &680i..
  ! Last modified: 7th. Jul. 2005 by RGA
  if(alamda.lt.0.0d0)then ! Initialization.
     alamda=1.0d-3
     call mrqcof(x,y,ndata,a,ma,alpha,beta,nca,chisq)
     ochisq=chisq
     do j=1,ma
        atry(j)=a(j)
     enddo
  endif
  !     Alter linearized fitting matrix, by augmenting diagonal elements.
  do j=1,ma
     do k=1,ma
        covar(j,k)=alpha(j,k)
     enddo ! k
     covar(j,j)=alpha(j,j)*(1.0d0+alamda)
     da(j)=beta(j)
  enddo ! j
  call gaussj(covar,ma,nca,da,1,1)
  !      Once converged, evaluate covariance matrix.
  !
  !      if(alamda.eq.0.0d0)then
  !        call covsrt(covar,nca,ma,ia,mfit)
  !
  !       Spread out alpha to its full size too.
  !
  !        call covsrt(alpha,nca,ma,ia,mfit)
  !        return
  !      endif
  j=0
  !
  !     Did the trial succeed?
  !
  do l=1,ma
     atry(l)=a(l)+da(l)
  enddo ! l

  call mrqcof(x,y,ndata,atry,ma,covar,da,nca,chisq)

  if(chisq.lt.ochisq) then     ! Success, accept the new solution.
     alamda=0.1d0*alamda
     ochisq=chisq
     do j=1,ma
        do k=1,ma
           alpha(j,k)=covar(j,k)
        enddo ! k
        beta(j)=da(j)
     enddo ! j
     do l=1,ma
        a(l)=atry(l)
     enddo ! l
  else                        ! Failure, increase alamda and return.
     alamda=1.0d+1*alamda
     chisq=ochisq
  endif
  return
end subroutine mrqmin

subroutine stdesc(x,y,ndata,a,ma,varsq)
  ! This program perform one iteration of the steepest descent method.
  implicit none
  integer,    intent(in) :: ndata ! Number of datapoints to be fitted
  integer,    intent(in) :: ma    ! Number of coefficients
  real(8),    intent(in) :: x(*)  ! abscisas of the datapoints
  complex*16, intent(in) :: y(*)  ! data value of the datapoint
  real(8), intent(inout) :: varsq
  real(8), intent(inout) :: a(ma)
  !
  integer(4) :: j, i, it
  real(8) :: varsqold, num, denomi, denom, lambda, deltach
  real(8) :: atemp(ma)
  real(8), allocatable :: beta(:), alpha(:,:)
  logical :: conv
  real(8), parameter :: tolstd = 1.0d-3
  external mrqcof
  !
  allocate(beta(1:ma))
  allocate(alpha(1:ma,1:ma))
  varsqold=0.0d0
  conv=.false.
  it=0
  do while (.not.conv)
     it=it+1
     call mrqcof(x,y,ndata,a,ma,alpha,beta,ma,varsq)
     num=0.0d0
     denom=0.0d0
     do i=1,ma
        num=num+beta(i)*beta(i)
        denomi=0.0d0
        do j=1,ma
           denomi=denomi+alpha(i,j)*beta(j)
        enddo
        denom=denom+denomi*beta(i)
     enddo
     lambda=num/denom
     do j=1,ma
        a(j)=a(j)+lambda*beta(j)
     enddo
     deltach=abs(varsq-varsqold)
     varsqold=varsq
     atemp(1:ma)=a(1:ma)
     conv=((deltach.lt.tolstd).or.(it.gt.200))
  enddo
  if(it.gt.200)write(*,*)'WARNING: stepest descent did not converge after',it, 'iterations'
  deallocate(beta)
  deallocate(alpha)
  return
end subroutine stdesc

subroutine mrqcof(x,y,ndata,a,ma,alpha,beta,nca,chisq)
  !  Used by \texttt{mrqmin} to evaluate the linearized
  !  fitting matrix \texttt{alpha}, and vector \texttt{beta} as:
  !
  ! \begin{equation}\label{mrqcof-01}
  ! \begin{aligned}
  !\beta_k &\equiv - \frac{1}{2}\frac{\partial\chi^2}{\partial a_k} &
  !\alpha_{kl}&\equiv \frac{1}{2}\frac{\partial^2\chi^2}{\partial
  !a_k\partial a_l} ,
  !\end{aligned}
  !\end{equation}
  !and calculate $\chi^2$.
  implicit none
  integer(4), intent(in) :: ndata ! Number of datapoints to be fitted
  integer(4), intent(in) :: ma    ! Number of coefficients
  integer(4), intent(in) :: nca   ! Size of working-space arrays
  real(8),    intent(in) :: x(*)  ! abscisas of the datapoints
  complex*16, intent(in) :: y(*)  ! data value of the datapoint
  real(8),    intent(inout) :: chisq
  real(8),    intent(inout) :: a(ma), beta(ma), alpha(nca,nca)
  integer(4) :: i, j, k, l, m
  complex*16 :: wt, dy, ymod, cx
  complex*16 :: dyda(ma), d2yda(ma,ma)
  external ratfun
  !
  ! Original subroutine: mrqcof.for (c) copr. 1986-92 numerical recipes
  ! software &681i..
  ! Last modified: 7th. Jul. 2005 by RGA
  !
  do j=1,ma
     !
     !       Initialize (symmetric) alpha, beta.
     !
     do k=1,j
        alpha(j,k)=0.
     enddo ! k
     beta(j)=0.
  enddo ! j
  chisq=0.0d0
  !
  !     Summation loop over all data.
  !
  do i=1,ndata
     cx=cmplx(0.0d0,x(i),8)
     call ratfun(cx,a,ymod,dyda,d2yda,ma/4-1)
     dy=y(i)-ymod
     do l=1,ma
        wt=dyda(l)
        do m=1,l
           alpha(l,m)=alpha(l,m)+real(wt*conjg(dyda(m)))
        enddo
        beta(l)=beta(l)+real(dy*conjg(wt))
     enddo ! l
     chisq = chisq + dble(dy*conjg(dy)) ! And find \chi^2.
  enddo ! i
  chisq=chisq/ndata
  !     Fill in the symmetric side.
  do j=2,ma
     do k=1,j-1
        alpha(k,j)=alpha(j,k)
     enddo ! k
  enddo ! j
  return
end subroutine mrqcof

subroutine gaussj(a,n,np,b,m,mp)
  ! Linear equation solution by Gauss-Jordan elimination, equation
  !\ref{gaussj-1} below.
  !
  !\begin{equation}\label{gaussj-1}
  !\begin{aligned}
  !  \begin{bmatrix}
  !    a_{11}&a_{12}&a_{13}&a_{14}\\
  !    a_{21}&a_{22}&a_{23}&a_{24}\\
  !    a_{31}&a_{32}&a_{33}&a_{34}\\
  !    a_{41}&a_{42}&a_{43}&a_{44}
  !  \end{bmatrix}\cdot &
  !  \begin{bmatrix}
  !    \begin{pmatrix}
  !      x_{11}\\
  !      x_{21}\\
  !      x_{31}\\
  !      x_{41}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      x_{12}\\
  !      x_{22}\\
  !      x_{32}\\
  !      x_{42}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      x_{13}\\
  !      x_{23}\\
  !      x_{33}\\
  !      x_{43}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      y_{11}&y_{12}&y_{13}&y_{14}\\
  !      y_{21}&y_{22}&y_{23}&y_{24}\\
  !      y_{31}&y_{32}&y_{33}&y_{34}\\
  !      y_{41}&y_{42}&y_{43}&y_{44}
  !    \end{pmatrix}
  !  \end{bmatrix}\\
  != & \begin{bmatrix}
  !    \begin{pmatrix}
  !      b_{11}\\
  !      b_{21}\\
  !      b_{31}\\
  !      b_{41}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      b_{12}\\
  !      b_{22}\\
  !      b_{32}\\
  !      b_{42}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      b_{13}\\
  !      b_{23}\\
  !      b_{33}\\
  !      b_{43}
  !    \end{pmatrix}\sqcup
  !    \begin{pmatrix}
  !      1 & 0 & 0 & 0 \\
  !      0 & 1 & 0 & 0 \\
  !      0 & 0 & 1 & 0 \\
  !      0 & 0 & 0 & 1 \\
  !    \end{pmatrix}
  !  \end{bmatrix}
  !\end{aligned}
  !\end{equation}
  ! \texttt{a(1:n,1:n)}
  ! is an imput matrix stored in an array of physical dimensions \texttt{np}
  ! by \texttt{np}.\texttt{b(1:n,1:m)} is an input matrix containing the
  ! \texttt{m} right-hand side vectors, stored in an array of physical
  ! dimensions \texttt{np} by \texttt{mp}. On output, \texttt{a(1:n,1:n)} is
  ! replaced by its matrix inverse, and \texttt{b(1:n,1:m)} is replaced by
  ! the corresponding set of solution vectors.
  implicit none
  integer, intent(in)    :: m, mp, n, np
  real(8), intent(inout) :: a(np,np), b(np,mp)
  integer(4) :: i, j, k, l, ll, icol, irow
  integer(4) :: indxc(1:np) ! Used for bookkeeping on the pivoting
  integer(4) :: indxr(1:np) ! Used for bookkeeping on the pivoting
  integer(4) :: ipiv(1:np)  ! Used for bookkeeping on the pivoting
  real(8) :: big, dum, pivinv
  ! Original subroutine: gaussj.for (c) copr. 1986-92 numerical recipes
  ! software &30i..
  ! Last modified: 7th. Jul. 2005 by RGA
  do j=1,n
     ipiv(j)=0
  enddo ! j
  !     This is the main loop over the columns to be reduced
  do i=1,n
     big=0.0d0
     !        This is the outer loop of the search for a pivot element
     do j=1,n
        if(ipiv(j).ne.1)then
           do  k=1,n
              if (ipiv(k).eq.0) then
                 if (abs(a(j,k)).ge.big)then
                    big=abs(a(j,k))
                    irow=j
                    icol=k
                 endif
              else if (ipiv(k).gt.1) then
                 stop 'singular matrix in gaussj'
              endif
           enddo ! k
        endif
     enddo ! j
     ipiv(icol)=ipiv(icol)+1
     !
     !       We now have the pivot element, so we interchange rows, if needed,
     !       to put the pivot element on the diagonal. The columns are not
     !       physically interchanged, only relabeled: indxc(i), the column of
     !       the ith pivot element, is the ith column that is reduced, while
     !       indxr(i) is the row in which that pivot   element was originally
     !       located. If indxr(i) \neq indxc(i) there is an implied column
     !       interchange. With this form of bookkeeping, the solution b's will
     !       end up in the correct order, and the inverse matrix will be
     !       scrambled by columns.
     !
     if (irow.ne.icol) then
        do l=1,n
           dum=a(irow,l)
           a(irow,l)=a(icol,l)
           a(icol,l)=dum
        enddo ! l
        do l=1,m
           dum=b(irow,l)
           b(irow,l)=b(icol,l)
           b(icol,l)=dum
        enddo ! l
     endif
     indxr(i)=irow
     indxc(i)=icol
     !       We are now ready to divide the pivot row by the pivot element,
     !       located at irow and icol.
     if (a(icol,icol).eq.0.0d0) stop 'singular matrix in gaussj'
     pivinv=1./a(icol,icol)
     a(icol,icol)=1.
     do l=1,n
        a(icol,l)=a(icol,l)*pivinv
     enddo ! l
     do l=1,m
        b(icol,l)=b(icol,l)*pivinv
     enddo ! l
     !       Next, we reduce the rows...
     do ll=1,n
        if(ll.ne.icol)then   ! ... except for the pivor one, of course.
           dum=a(ll,icol)
           a(ll,icol)=0.0d0
           do l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
           enddo ! l
           do l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
           enddo ! l
        endif
     enddo ! ll
  enddo ! i
  !
  !     This is the end of the main loop over columns of the reduction. It
  !     only remains to unscramble the solution in view of the column
  !     interchanges. We do this by interchanging pairs of columns in the
  !     reverse order that the permutation was bilt up.
  !
  do l=n,1,-1
     if(indxr(l).ne.indxc(l))then
        do k=1,n
           dum=a(k,indxr(l))
           a(k,indxr(l))=a(k,indxc(l))
           a(k,indxc(l))=dum
        enddo ! k
     endif
  enddo ! l
  return
end subroutine gaussj


MODULE m_tides_ocean

! ----------------------------------------------------------------------
! MODULE: m_tides_ocean.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the tides_ocean subroutine
!
! Subroutines contained within the module:
! - tides_ocean
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	16 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE tides_ocean(n_max, m_max , mjd, ut1_utc, dCnm_ocean, dSnm_ocean)

! ----------------------------------------------------------------------
! SUBROUTINE: tides_ocean
! ----------------------------------------------------------------------
! Purpose:
!  Ocean Tides perturbations according to the formula of the IERS Conv. 2010
!  Computation of the variations in the Stokes coefficients are based on
!  an ocean tide model.
!
! ----------------------------------------------------------------------
! Input arguments:
! - n_max :			Degree limit of the ocean tides coefficients
! - m_max :			Order limit of the ocean tides coefficients
! - mjd   :			Modified Julian Day in Terrestrial Time (TT) scale including the fraction
!             		of the day
! - ut1_utc:   		Time difference between UT1 and UTC (seconds)
!
! Allocatable arrays called via module : mdl_tides.f90
! - Delaunay_FES : Delaunay variables multipliers for FES2004 tidal waves
! - dCnm_p		 : Spherical harmonic coefficients of ocean tide model to
!   dSnm_p         be used in Eq. 6.15 of IERS Conventions 2010
!   dCnm_m         Coefficients are stored in four 3D arrays
!   dSnm_m
!
! Output arguments:
! - dCnm_ocean :	Geopotential Cnm corrections matrix due to Ocean Tides
! - dSnm_ocean :	Geopotential Snm corrections matrix due to Ocean Tides
! ----------------------------------------------------------------------
! Remark 1:
!  Computed dCnm and dSnm are formed into lower triangular matrices.
!  Coefficient dCnm corresponds to matrix element dCnm(n+1,m+1).
!
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	12 November 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 27 October 2017:
!   The subroutine has been modified in order to call the subroutine gmst_iers.f03
!   for the computation of the Greenwich mean sidereal time
! - Dr. Thomas Papanikolaou, 16 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 advantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_tides
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: n_max, m_max
      REAL (KIND = prec_q), INTENT(IN) :: mjd, ut1_utc

!	  "Delaunay_FES, dCnm_p,dSnm_p, dCnm_m,dSnm_m" variables are declared in module "mdl_tides.f90"

! OUT
! 	  "dCnm_ocean, dSnm_ocean" variables are declared as allocatable arrays in module "mdl_tides.f90"
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: dCnm_ocean, dSnm_ocean
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: thetag, thetaf
      REAL (KIND = prec_q) :: F1,F2,F3,F4,F5
      REAL (KIND = prec_q) :: beta1, beta2, beta3, beta4, beta5, beta6
      REAL (KIND = prec_d), DIMENSION(5) :: delaunay_arr
      REAL (KIND = prec_d), DIMENSION(6) :: doodson_arr
      INTEGER (KIND = prec_int4) :: Nfrq, i, j, ifrq, AllocateStatus, N_arg
      REAL (KIND = prec_q) :: dCnm_fi,dSnm_fi, dCnm_f,dSnm_f, matrix_mult
      INTEGER (KIND = prec_int8) :: n, m, m_limit
      REAL (KIND = prec_q) :: pi
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int4) :: fundarguments, n1_mult

pi = PI_global

! ----------------------------------------------------------------------
! Fundamental arguments
! 1. Delaunay arguments
! 2. Doodson arguments
fundarguments = 2
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Delaunay variables (in radians)
CALL delaunay (mjd , F1,F2,F3,F4,F5)
delaunay_arr = (/ F1 , F2 , F3 , F4 , F5 /)
! ----------------------------------------------------------------------
!PRINT *,"Delaunay",delaunay_arr

! ----------------------------------------------------------------------
! Greenwich Mean Sidereal Time (GMST) in radians
Call gmst_iers(mjd, ut1_utc , thetag)
! ----------------------------------------------------------------------
!PRINT *,"thetag",thetag

! ----------------------------------------------------------------------
! Doodson arguments in radians
! ----------------------------------------------------------------------
! N' = -Omega : Negative of the Mean Longitude of the Ascending Node of the Moon
beta5 = -1.0D0 * F5

! s = F+Omega : Mean Longitude of the Moon
beta2 = F3 + F5

! taph = thetag+p - s : Mean Lunar Time
beta1 = (thetag + pi) -1.0D0 * beta2

! h = s - D : Mean Longitude of the Sun
beta3 = beta2 - F4

! p = s - l : Longitude of the Moon's mean perigee
beta4 = beta2 - F1

! ps = s - D - l' : Longitude of the Sun's mean perigee
beta6 = beta2 - F4 -F2

doodson_arr = (/ beta1 , beta2 , beta3 , beta4 , beta5, beta6 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
IF (fundarguments == 1) then
Nfrq = SIZE (Delaunay_FES,DIM=1)
!sz2 = SIZE (Delaunay_FES,DIM=2)

Else if (fundarguments == 2) then

Nfrq = SIZE (Doodson_mult_glb,DIM=1)
N_arg = SIZE (Doodson_mult_glb,DIM=2)

End IF
!PRINT *,"tides_ocean.f90 Nfrq", Nfrq
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Allocate Arrays
! ---------------------------------------------------------------------------
      ALLOCATE (dCnm_ocean(n_max+1,n_max+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE tides_ocean.f90"
         PRINT *, "Error: Allocatable Array: dCnm_ocean | Nmax:", n_max
!         STOP "*** Not enough memory ***"
      END IF

      ALLOCATE (dSnm_ocean(n_max+1,n_max+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE tides_ocean.f90"
         PRINT *, "Error: Allocatable Array: dSnm_ocean | Nmax:", n_max
!         STOP "*** Not enough memory ***"
      END IF
! ---------------------------------------------------------------------------
dCnm_ocean = 0.0D0
dSnm_ocean = 0.0D0

! ---------------------------------------------------------------------------
DO n = 2 , n_max
    IF (n > m_max) THEN
        m_limit = m_max
    ELSE
        m_limit = n
    END IF
    DO m = 0 , m_limit
        dCnm_f = 0.0D0
        dSnm_f = 0.0D0
        DO ifrq = 1 , Nfrq
            ! thetaf (in radians)
			IF (fundarguments == 1) THEN

            matrix_mult = 0.0D0
            DO j = 1 , 5
               matrix_mult = matrix_mult + ( Delaunay_FES(ifrq,j+1) * delaunay_arr(j) )
            END DO
			!thetaf = m * (thetag + pi) - 1.0D0 * matrix_mult
			If (ifrq.LE.8) Then
			n1_mult = 0
			Else If (ifrq>8 .and. ifrq.LE.12) Then
			n1_mult = 1
			Else If (ifrq>12 .and. ifrq.LE.17) Then
			n1_mult = 2
			! M4
			Else If (ifrq==18) Then
			n1_mult = 4
			End IF
			thetaf = n1_mult * (thetag + pi) - 1.0D0 * matrix_mult
			!END IF

			ELSE IF (fundarguments == 2) THEN

            matrix_mult = 0.0D0
            DO j = 1 , 6
               matrix_mult = matrix_mult + ( Doodson_mult_glb(ifrq,j+1) * doodson_arr(j) )
            END DO
			thetaf = matrix_mult

			END IF

            dCnm_fi = (dCnm_p(n+1,m+1,ifrq) + dCnm_m(n+1,m+1,ifrq)) * cos(thetaf) &
			        + (dSnm_p(n+1,m+1,ifrq) + dSnm_m(n+1,m+1,ifrq)) * sin(thetaf)
            dSnm_fi = (dSnm_p(n+1,m+1,ifrq) - dSnm_m(n+1,m+1,ifrq)) * cos(thetaf) &
			        - (dCnm_p(n+1,m+1,ifrq) - dCnm_m(n+1,m+1,ifrq)) * sin(thetaf)
            dCnm_f = dCnm_f + dCnm_fi
            dSnm_f = dSnm_f + dSnm_fi
        END DO

        ! IERS Conventions update 10/08/2012 Section 6.3.2
        IF (m == 0) THEN
          dSnm_f = 0.0D0
        END IF

        dCnm_ocean(n+1,m+1) = dCnm_f
        dSnm_ocean(n+1,m+1) = dSnm_f
    END DO
END DO
! ---------------------------------------------------------------------------

END SUBROUTINE

END Module


C++::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C       PROGRAM PERIOD
C
C  This program computes periods for different potentials
C
C JLP
C Version of 03-10-86
C--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
        PROGRAM PERIOD
	PARAMETER (IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM),RAD(IDIM),
     1	PHI(IDIM),DPHI(IDIM),
     1	WK(5000),LOGR(IDIM),LOGPROF(IDIM)
	REAL*8 PERIO(IDIM),APOCEN(IDIM),VMASS(IDIM),RMASS(IDIM)
	REAL*4 X1PLOT(IDIM),Y1PLOT(IDIM)
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,ANS*1,PLOTDEV*32
	CHARACTER NAME*25

	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON/KING3/W0,RTIDAL,RHO0
	COMMON/CONSTANT/PI,PIROOT
	PI=4.0D0*DATAN(1.0D0)
	PIROOT=DSQRT(PI)
10	FORMAT(A)
	OPEN(1,FILE='period.log',STATUS='unknown')

	WRITE(1,89)
88	PRINT 89
89	FORMAT(' MENU :',/,
     1	' 1. INPUT OF A MODEL (FILE)',/,
     1	' 2. COMPUTATION OF KING''S MODEL',/,
     1	' 3. COMPUTATION OF A KEPLERIAN MODEL',/,
C     1	' 4. COMPUTATION OF HUBBLE''S MODEL',/,
     1	' 8. COMPUTATION OF PERIODS',/,
     1	' 9. DISPLAYING THE CURVES',/,
     1	' 10. EXIT',/,
     1	' ENTER THE OPTION YOU WANT : ',$)
	READ(5,*) IOPT
	WRITE(1,90)IOPT
90	FORMAT(' OPTION = ',I3)

C---------------------------------------------------------------------
C OPTION 1 : Input of a model :
C  Reads the model with 2 possible formats.
C
	IF(IOPT.EQ.1)THEN

	PRINT *,' FORMAT :  1. (NPTS,X,Y)      2. (NPTS,X,Y,VNUMB)  ?'
	READ(5,*) IFORMT
1022	PRINT *,' NAME OF THE FILE ?'
	READ(5,10) NAME
	OPEN (9,FILE=NAME,STATUS='OLD',ERR=1022)
	READ(9,*)NPTS
	WRITE(1,1025)IFORMT,NAME,NPTS
1025	FORMAT(' FORMAT = ',I3,' NAME :',A,' NPTS :',I5)

	IF(IFORMT.EQ.1)THEN
	  DO I=1,NPTS
	  READ (9,*,END=111) RAD(I),PHI(I)
	  END DO
	ELSE
	  DO I=1,NPTS
	  READ (9,*,END=111) RAD(I),PHI(I),WORK
	  END DO
	ENDIF

	GO TO 101
111	NPTS=I-1
	PRINT 102
	WRITE(1,102)
102	FORMAT(' WARNING : LESS POINTS THAN EXPECTED !!!!')
101	PRINT 103,NPTS
	WRITE(1,103) NPTS
103	FORMAT(2X,I5,' POINTS RECEIVED')
	PRINT 104,RAD(1),RAD(NPTS)
	WRITE(1,104) RAD(1),RAD(NPTS)
104	FORMAT(' MODEL FROM ',F12.3,' ARCSECONDS TO ',
     1	F12.3,' ARCSECONDS')
	CLOSE(9)

	GO TO 88
	ENDIF

C------------------------------------------------------------------------------
C Option 2 : Computation of  King's model
C
	IF(IOPT.EQ.2)THEN

	WRITE (6,201)
201	FORMAT(' ENTER W0 (CENTRAL POTENTIAL) AND RCORE (KPC) : ',$)
	READ (5,*) W0,RCORE

C Number of points calculated for the model
	WRITE (6,202)
202	FORMAT(' Enter number of points for the model : (max 10000)',$)
	READ (5,*) NPTS
	WRITE (1,206)W0,RCORE,NPTS
206	FORMAT(' CALCULATING KING''S MODEL',/,
     1	' W0=',F10.4,'  RCORE=',F12.3,'  NPTS =',I5)

C Setting up the radius array for the model (From 1.E-1 to 1.E+3)
	RAD(1)=0.D0
	DO I=2,NPTS
	WORK=-1.D0 +4.D0*FLOAT(I)/FLOAT(NPTS)
	RAD(I)=10.D0**WORK
	END DO

	PRINT *,' CALCULATING THE MODEL... '
	CALL KING(NPTS)

C Computing the total mass :
	PRINT *,' PROPOSED RADMAX FOR THE MASS :',RTIDAL
276	PRINT *,' ENTER RADMAX (TO EXIT TYPE 0.)'
	READ(5,*) RADMAX

	IF(RADMAX.NE.0.)THEN
	CALL MASS_KING(RADMAX,XMU1,NPTS)
	XMU=RHO0*XMU1
	XMASS1=XMU*RCORE*RCORE*RCORE
	PRINT *,' MU =',XMU,'MASS1 =',XMASS1
	GO TO 276
	ENDIF
C
	PRINT *,' TOTAL MASS YOU WANT FOR THIS MODEL ?',
     1	' (UNITS: 10.D+10 SOLAR MASS)'
	READ(5,*) XMASS
	XRHO0=RHO0*XMASS/XMASS1
	PRINT *,' NEW RHO0 :',XRHO0
	WRITE(1,207)XMU,XRHO0,XMASS1,XMASS
207	FORMAT(' XMU =',E12.4,' NEW RHO0 =',E12.4,
     1	'  XMASS1 = ',E12.4,/,
     1	' TOTAL MASS = ',E12.4,' IN 1.E+10 SOLAR MASS')

C Computation of a mass profile
	PRINT *,' DO YOU WANT A MASS PROFILE ? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	PRINT *,' NUMBER OF POINTS ?'
	READ(5,*) NVMASS
	XINC=RTIDAL/FLOAT(NVMASS)
	  DO I=1,NVMASS
	  RMASS(I)=XINC*FLOAT(I)
	  CALL MASS_KING(RMASS(I),XMU2,NPTS)
	  VMASS(I)=XMASS*XMU2/XMU1
	  END DO
	ENDIF

C Normalization of the potential to get the correct mass :
C (Potential energy is proportional to mass)
C PHI is multiplied by -1. because the output of KING is positive.
C PHI is shifted of G.M/RT because in King's model, it is assumed PHI=0.
C when RAD=RT
	GRAV=4.497D-02

	DO I=1,NPTS
	PHI(I)=(GRAV*XMASS/RTIDAL)-1.D0*XMASS*PHI(I)/XMASS1
	END DO

C Transformation of the computed radii in physical radii
	DO I=1,NPTS
	RAD(I)=RCORE*RAD(I)
	END DO

C Possibility of a Keplerian extension :
	PRINT *,' DO YOU WANT AN EXTENSION TO THE OUTER PARTS ? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	PRINT *,' MAX. RADIUS AND NUMBER OF POINTS ?'
	READ(5,*) RADMAX,NUMBER
	CALL KEPLER_EXTENSION(RAD,PHI,NPTS,XMASS,
     1	RADMAX,NUMBER)
	WRITE(1,208)RADMAX,NUMBER
208	FORMAT(' KEPLERIAN EXTENSION IN THE OUTER PARTS',/,
     1	' UNTIL ',F12.3,' ARCSECONDS',/,
     1	' WITH ',I5,' MORE POINTS')
	ENDIF

	GO TO 88
	ENDIF
C---------------------------------------------------------------
C Option 4 : Computes a Keplerian model
	IF(IOPT.EQ.3)THEN
	WRITE (6,402)
402	FORMAT(' Enter number of points for the model : (max 10000) ',$)
	READ (5,*) NPTS
	PRINT *,' MASS OF THE GALAXY (UNIT=1.D+10 SOLAR MASS) ?'
	READ(5,*) XMASS
	PRINT *,' CALCULATING THE MODEL... '
	CALL KEPLER(RAD,PHI,NPTS,XMASS)
	WRITE(1,403)NPTS,XMASS
403	FORMAT(' CALCULATING A KEPLERIAN MODEL',/,
     1	' WITH :',I5,' POINTS.      MASS =',E12.4,
     1	' IN 1.D+10 SOLAR MASS')
	GO TO 88
	ENDIF

C------------------------------------------------------------------
C Option 8 : Computes the periods from the potential :
	IF(IOPT.EQ.8)THEN
	WRITE (6,802)
802	FORMAT(' Enter number of points  : (max 10000) ',$)
	READ (5,*) NPOINTS
	PRINT *,' CALCULATING THE PERIODS... '
	CALL PERIOD1(RAD,PHI,NPTS,PERIO,APOCEN,NPOINTS)
	PRINT *,NPOINTS,' POINTS'
	WRITE(1,803)NPOINTS
803	FORMAT(' CALCULATING THE PERIODS WITH ',I5,' POINTS')
	GO TO 88
	ENDIF

C--------------------------------------------------------------------
C Option 9 : Displays the periods or the potential:
	IF(IOPT.EQ.9)THEN

	PRINT 900
900	FORMAT(' MENU :',/,
     1	' 1. DISPLAYING THE POTENTIAL',/,
     1	' 2. DISPLAYING THE PERIODS',/,
     1	' 3. DISPLAYING THE MASS PROFILE',/,
     1	' ENTER THE OPTION YOU WANT : ',$)
	READ(5,*) IOPT9

C----
	IF(IOPT9.EQ.1)THEN
	NMAX=NPTS
	CHAR1='RADIUS'
	CHAR2='POTENTIAL'
	DO I=1,NMAX
	X1PLOT(I)=RAD(I)
	Y1PLOT(I)=PHI(I)
	END DO
	ENDIF
C----
	IF(IOPT9.EQ.2)THEN
	NMAX=NPOINTS
	CHAR1='APOCENTER (KPCS)'
	CHAR2='PERIOD (MILLION YEARS)'
	DO I=1,NMAX
	X1PLOT(I)=APOCEN(I)
	Y1PLOT(I)=PERIO(I)
	END DO
	ENDIF
C----
	IF(IOPT9.EQ.3)THEN
	NMAX=NVMASS
	CHAR1='RADIUS (KPCS)'
	CHAR2='MASS (1.D+10 SOLAR MASS)'
	DO I=1,NMAX
	X1PLOT(I)=RMASS(I)
	Y1PLOT(I)=VMASS(I)
	END DO
	ENDIF

C----
	TITLE=' '
	PRINT *,' TITLE ?'
	READ(5,10) TITLE
	PRINT *,' DEVICE : TEKTRO, CIFER_T5, CANON ?'
	READ(5,10) PLOTDEV
	CALL DISPLAY1(X1PLOT,Y1PLOT,1,NMAX,
     1	CHAR1,CHAR2,TITLE,PLOTDEV)

	PRINT *,' DO YOU WANT TO STORE THE CURVE IN A FILE ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')THEN
	KCURVE=1
	CALL STORE_GRAPH(X1PLOT,Y1PLOT,1,NMAX,X1PLOT,Y1PLOT,
     1	1,NMAX,KCURVE)
	ENDIF

	GO TO 88
	ENDIF

	CLOSE(1)
	PRINT *,' Logfile in period.log"
	STOP
	END
C------------------------------------------------------------------
C Subroutine PERIOD1 to compute the periods from a given potential
C
C Input :
C  RAD : Radii for the potential
C  PHI : Potential
C  NPTS : Number of input points for the potential
C  NPOINTS
C
C Output :
C  PERIO : Periods
C  APOCEN : Apocenters
C  NPOINTS : Number of periods computed by this routine
C------------------------------------------------------------------

	SUBROUTINE PERIOD1(RAD,PHI,NPTS,PERIO,APOCEN,NPOINTS)

	PARAMETER (IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI(IDIM),RAD(IDIM)
	REAL*8 K(IDIM),SPLINE(IDIM),SOL(5),XX(IDIM)
	REAL*8 YY(IDIM),PERIO(IDIM),APOCEN(IDIM)
	CHARACTER*1 ANS
	COMMON/CONSTANT/PI,PIROOT
10	FORMAT(A)
	CSTE=DSQRT(2.D0)
	II=0

	PRINT *,' PHI(1),PHI(NPTS)',PHI(1),PHI(NPTS)

C Preparing the radius arrays :
	NUMBER=NPOINTS
	DELTAJ=(RAD(NPTS)-RAD(1))/FLOAT(NUMBER)
	NUMBI=NPOINTS*10
	DELTAI=(RAD(NPTS)-RAD(1))/FLOAT(NUMBI+1)
	DO I=1,NUMBI
	XX(I)=RAD(1)+FLOAT(I)*DELTAI
	END DO

C-----
C Interpolates with a cubic-spline the input potential
	CALL SPLINE_INTER(RAD,PHI,NPTS,SPLINE,NCAP7,K)

C-----
	DO J=1,NUMBER
C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	XX1=RAD(1)+FLOAT(J)*DELTAJ
	II=II+1
	APOCEN(II)=XX1
	CALL E02BCF(NCAP7,K,SPLINE,XX1,LEFT,SOL,IFAIL)
	IF(IFAIL.NE.0) PRINT 44,IFAIL
	PHI0=SOL(1)

	DO I=1,NUMBI
C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	XX1=XX(I)
	CALL E02BCF(NCAP7,K,SPLINE,XX1,LEFT,SOL,IFAIL)
	IF(IFAIL.NE.0) PRINT 44,IFAIL
44	FORMAT(' ***** WARNING ! ***** IN E02BCF  IFAIL =',I3)
	WORK=PHI0-SOL(1)
	  IF(WORK.GT.0.D0)THEN
	  YY(I)=1.D0/DSQRT(WORK)
	  ELSE
	  NPOINT=I-1
	  GO TO 100
	  ENDIF
	END DO
	GO TO 999

C Integration of the array Y(NPOINT)
100	IF(NPOINT.GT.5)THEN
C Calling NAG routine D01GAF:
	IFAIL=1
	CALL D01GAF(XX,YY,NPOINT,SUM,ERR,IFAIL)
	IF(IFAIL.NE.0) PRINT 45,IFAIL
45	FORMAT(' ***** WARNING ! ***** IN D01GAF  IFAIL =',I3)
	PERIO(II)=SUM*CSTE
	ELSE
	II=II-1
C	PRINT *,' TOO FEW POINTS (LESS THAN 5), FOR PHI0=',PHI0
	ENDIF

	END DO

999	NPOINTS=II

	RETURN
	END

C------------------------------------------------------------------
C Subroutine to calculate a Keplerian potential
C Pot = - GRAV * MASS / radius
C Units :
C    Apocentric distance (= RAD) in Kpcs
C    Mass in 1.D+10 Solar mass
C    Time in million years (1.D+06)
C So
C    GRAV=4.497D-02
C------------------------------------------------------------------
	SUBROUTINE KEPLER(RAD,PHI,NPTS,XMASS)

	PARAMETER(IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI(IDIM),RAD(IDIM)
	COMMON/CONSTANT/PI,PIROOT
	GRAV=4.497D-02
	CST=-1.D0*XMASS*GRAV

	SCALE=1.D0
C In radius we take an exponential scale from 1.D-01 to 300.
C	XSTART=-1.D0
C	XEND=2.5D0
	XSTART=0.1
	XEND=300.
	XINC=(XEND-XSTART)/FLOAT(NPTS)

	DO I=1,NPTS
	WORK=XSTART+FLOAT(I)*XINC
	RAD(I)=SCALE*FLOAT(I)		!LINEAR
C	RAD(I)=SCALE*(10.D0**WORK)	!EXPON.
	PHI(I)=CST/RAD(I)
	END DO

	RETURN
	END
C------------------------------------------------------------------
C Subroutine to compute a Keplerian extension to the potential in its
C outer parts.
C
C Pot = - GRAV * MASS / radius
C Units :
C    Apocentric distance (= RAD) in Kpcs
C    Mass in 1.D+10 Solar mass
C    Time in million years (1.D+06)
C So
C    GRAV=4.497D-02
C------------------------------------------------------------------
	SUBROUTINE KEPLER_EXTENSION(RAD,PHI,NPTS,XMASS,
     1	RADMAX,NUMBER)

	PARAMETER(IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI(IDIM),RAD(IDIM)
	COMMON/CONSTANT/PI,PIROOT
	GRAV=4.497D-02

	CST=-1.D0*XMASS*GRAV

C In radius we take an exponential scale from 1.D-01 to 300.
	SCALE=1.D0
	XSTART=RAD(NPTS)
	XEND=RADMAX
	XINC=(XEND-XSTART)/FLOAT(NUMBER)
	DO I=1,NUMBER
	RAD(I+NPTS)=XSTART+FLOAT(I)*XINC
	PHI(I+NPTS)=CST/RAD(I+NPTS)
	END DO
	NPTS=NPTS+NUMBER

	RETURN
	END
C--------------------------------------------------------------------
	include 'jlpsub:project.for'
	include 'jlpsub:king_model.for'


module wavelets

  implicit none

  integer, save ::  ncof = 0, ioff, joff
  real, dimension(:), allocatable, save :: cc,cr
  real, dimension(:), allocatable, save :: mc
!
!-------------------------------------------------------------------------------
!
  contains
!
!===============================================================================
!
! DWT: subroutine for the discrete wavelet transform
!
!===============================================================================
!
  subroutine dwt(a, nn, order)

    implicit none

    real   , dimension(:,:,:), intent(inout) :: a
    integer, dimension(3)    , intent(in)    :: nn
    integer                  , intent(in)    :: order

! local variables
!
    integer                         :: i, j, k
!
!------------------------------------------------------------------------------
!
    if (order .ne. ncof) then
      call pwtset(order)
    endif

! transform along x-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do j = 1, nn(2)
        call dwtstep(nn(1), a(1:nn(1),j,k))
      enddo
    enddo
!$omp end parallel do

! transform along y-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do i = 1, nn(1)
        call dwtstep(nn(2), a(i,1:nn(2),k))
      enddo
    enddo
!$omp end parallel do

! transform along z-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do j = 1, nn(2)
      do i = 1, nn(1)
        call dwtstep(nn(3), a(i,j,1:nn(3)))
      enddo
    enddo
!$omp end parallel do

  end subroutine dwt
!
!===============================================================================
!
! IDWT: subroutine for the inverse discrete wavelet transform
!
!===============================================================================
!
  subroutine idwt(a, nn, order)

    implicit none

    real   , dimension(:,:,:), intent(inout) :: a
    integer, dimension(3)    , intent(in)    :: nn
    integer                  , intent(in)    :: order

! local variables
!
    integer                         :: i, j, k
!
!------------------------------------------------------------------------------
!
    if (order .ne. ncof) then
      call pwtset(order)
    endif

! transform along x-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do j = 1, nn(2)
        call idwtstep(nn(1), a(1:nn(1),j,k))
      enddo
    enddo
!$omp end parallel do

! transform along y-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do i = 1, nn(1)
        call idwtstep(nn(2), a(i,1:nn(2),k))
      enddo
    enddo
!$omp end parallel do

! transform along z-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do j = 1, nn(2)
      do i = 1, nn(1)
        call idwtstep(nn(3), a(i,j,1:nn(3)))
      enddo
    enddo
!$omp end parallel do

  end subroutine idwt
!
!===============================================================================
!
! DWM: subroutine for discrete wavelet averaging
!
!===============================================================================
!
  subroutine dwm(a, nn, order)

    implicit none

    real   , dimension(:,:,:), intent(inout) :: a
    integer, dimension(3)    , intent(in)    :: nn
    integer                  , intent(in)    :: order

! local variables
!
    integer                         :: i, j, k
!
!------------------------------------------------------------------------------
!
    if (order .ne. ncof) then
      call pwtset(order)
    endif

! transform along x-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do j = 1, nn(2)
        call dwmean(nn(1), a(1:nn(1),j,k))
      enddo
    enddo
!$omp end parallel do

! transform along y-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do k = 1, nn(3)
      do i = 1, nn(1)
        call dwmean(nn(2), a(i,1:nn(2),k))
      enddo
    enddo
!$omp end parallel do

! transform along z-ddirection
!
!$omp parallel do default(private) shared(nn,a)
    do j = 1, nn(2)
      do i = 1, nn(1)
        call dwmean(nn(3), a(i,j,1:nn(3)))
      enddo
    enddo
!$omp end parallel do

  end subroutine dwm
!
!===============================================================================
!
! DWTSTEP: subroutine for the 1D discrete wavelet transform
!
!===============================================================================
!
  subroutine dwtstep(n, a)

    implicit none

    integer              , intent(in)    :: n
    real   , dimension(n), intent(inout) :: a

! local variables
!
    integer            :: nt
!
!------------------------------------------------------------------------------
!
    nt = n
    do while(nt >= 4)
      call pwt(a(1:nt),1)
      nt = nt / 2
    end do
  end subroutine dwtstep
!
!===============================================================================
!
! IDWTSTEP: subroutine for the 1D discrete wavelet transform
!
!===============================================================================
!
  subroutine idwtstep(n, a)

    implicit none

    integer              , intent(in)    :: n
    real   , dimension(n), intent(inout) :: a

! local variables
!
    integer            :: nt
!
!------------------------------------------------------------------------------
!
    nt = 4
    do while(nt <= n)
      call pwt(a(1:nt),-1)
      nt = nt * 2
    end do
  end subroutine idwtstep
!
!===============================================================================
!
! DWMEAN: subroutine for the 1D discrete wavelet averaging
!
!===============================================================================
!
  subroutine dwmean(n, a)

    implicit none

    integer              , intent(in)    :: n
    real   , dimension(n), intent(inout) :: a

! local variables
!
    integer            :: nt
!
!------------------------------------------------------------------------------
!
    nt = n
    do while(nt >= 4)
      call pwm(a(1:nt))
      nt = nt / 2
    end do
  end subroutine dwmean
!
!===============================================================================
!
! PWT: single run of the 1D discrete wavelet transform
!
!===============================================================================
!
  subroutine pwt(a, isign)

    implicit none

    real, dimension(:), intent(inout) :: a
    integer           , intent(in)    :: isign

    real   , dimension(size(a))   :: wksp
    integer, dimension(size(a)/2) :: jf, jr
    integer                       :: k, n, nh, nmod
!
!------------------------------------------------------------------------------
!
    n = size(a)

    if (n < 2) return

    nmod = ncof*n
    nh   = n/2

    wksp(:) = 0.0

    jf = iand(n-1,arth(2+nmod+ioff,2,nh))
    jr = iand(n-1,arth(2+nmod+joff,2,nh))

    if (isign >= 0) then
      do k = 1, ncof
        wksp(1:nh)   = wksp(1:nh)+cc(k)*a(jf+1)
        wksp(nh+1:n) = wksp(nh+1:n)+cr(k)*a(jr+1)
        if (k == ncof) exit
        jf = iand(n-1,jf+1)
        jr = iand(n-1,jr+1)
      end do
    else
      do k = 1, ncof
        wksp(jf+1)   = wksp(jf+1)+cc(k)*a(1:nh)
        wksp(jr+1)   = wksp(jr+1)+cr(k)*a(nh+1:n)
        if (k == ncof) exit
        jf = iand(n-1,jf+1)
        jr = iand(n-1,jr+1)
      end do
    end if

    a(:) = wksp(:)

  end subroutine pwt
!
!===============================================================================
!
! PWM: single run of the 1D discrete wavelet averaging
!
!===============================================================================
!
  subroutine pwm(a)

    implicit none

    real, dimension(:), intent(inout) :: a

    real   , dimension(size(a))   :: wksp
    integer, dimension(size(a)/2) :: jf, jr
    integer                       :: k, n, nh, nmod
    real, dimension(4)            :: c
!
!------------------------------------------------------------------------------
!
    n = size(a)

    if (n < 2) return

    nmod = ncof*n
    nh   = n/2

    wksp(:) = 0.0

    jf = iand(n-1,arth(2+nmod-ioff,2,nh))
    jr = iand(n-1,arth(2+nmod-joff,2,nh))

    do k = 1, ncof
      wksp(1:nh)   = wksp(1:nh)+mc(k)*a(jf+1)
      wksp(nh+1:n) = wksp(nh+1:n)+mc(k)*a(jr+1)
      if (k == ncof) exit
      jf = iand(n-1,jf+1)
      jr = iand(n-1,jr+1)
    end do

    a(:) = wksp(:)

  end subroutine pwm
!
!===============================================================================
!
! PWSET: subroutine to initialize coefficients for transforms
!
!===============================================================================
!
  subroutine pwtset(n)

    implicit none

    integer, intent(in) :: n

    real            :: sig
    real, parameter :: &
      c4(4)=(/&
                0.4829629131445341, 0.8365163037378079, &
                0.2241438680420134,-0.1294095225512604 /), &
      c12(12)=(/&
                0.111540743350, 0.494623890398, 0.751133908021, &
                0.315250351709,-0.226264693965,-0.129766867567, &
                0.097501605587, 0.027522865530,-0.031582039318, &
                0.000553842201, 0.004777257511,-0.001077301085 /), &
      c20(20)=(/&
                0.026670057901, 0.188176800078, 0.527201188932, &
                0.688459039454, 0.281172343661,-0.249846424327, &
               -0.195946274377, 0.127369340336, 0.093057364604, &
               -0.071394147166,-0.029457536822, 0.033212674059, &
                0.003606553567,-0.010733175483, 0.001395351747, &
                0.001992405295,-0.000685856695,-0.000116466855, &
                0.000093588670,-0.000013264203 /)
!
!------------------------------------------------------------------------------
!
    if (allocated(cc)) deallocate(cc)
    if (allocated(cr)) deallocate(cr)
    if (allocated(mc)) deallocate(mc)

    allocate(cc(n),cr(n),mc(n))

    ncof =  n
    ioff = -n/2
    joff = -n/2
    sig  = -1.0

    select case(n)
      case(4)
        cc=c4
      case(12)
        cc=c12
      case(20)
        cc=c20
      case default
        cc=c12
    end select

    cr(n:1:-1) =  cc
    cr(n:1:-2) = -cr(n:1:-2)

    mc(:) = 1. / ncof

  end subroutine pwtset
!
!===============================================================================
!
! ARTH: function to retrieve indexes
!
!===============================================================================
!
  function arth(first,increment,n)
    integer, intent(in) :: first, increment
    integer, intent(in) :: n
    integer, dimension(n) :: arth
    integer :: k, k2, temp

    if (n > 0) arth(1)=first
    if (n <= 16) then
      do k=2,n
        arth(k)=arth(k-1)+increment
      end do
    else
      do k=2,8
        arth(k)=arth(k-1)+increment
      end do
      temp=increment*8
      k=8
      do
        if (k >= n) exit
        k2=k+k
        arth(k+1:min(k2,n))=temp+arth(1:min(k,n-k))
        temp=temp+temp
        k=k2
      end do
    end if
  end function arth

end module wavelets


MODULE Euler_SlopeLimiterModule_NonRelativistic_IDEAL

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    One
  USE ProgramHeaderModule, ONLY: &
    nDOFX, &
    nDimsX, &
    nNodes, &
    nNodesX, &
    bcX
  USE ReferenceElementModuleX, ONLY: &
    WeightsX_q
  USE UtilitiesModule, ONLY: &
    MinModB, &
    NodeNumberX
  USE PolynomialBasisModule_Legendre, ONLY: &
    P_X1, &
    P_X2, &
    P_X3, &
    IndPX_Q
  USE PolynomialBasisMappingModule, ONLY: &
    MapNodalToModal_Fluid, &
    MapModalToNodal_Fluid
  USE MeshModule, ONLY: &
    MeshX
  USE GeometryFieldsModule, ONLY: &
    nGF, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33, &
    iGF_SqrtGm
  USE FluidFieldsModule, ONLY: &
    nCF, &
    iDF_TCI
  USE Euler_BoundaryConditionsModule, ONLY: &
    ApplyInnerBC_Euler, &
    ApplyOuterBC_Euler, &
    iApplyBC_Euler_Both, &
    ApplyBoundaryConditions_Euler
  USE Euler_CharacteristicDecompositionModule_NonRelativistic_IDEAL, ONLY: &
    ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL
  USE Euler_DiscontinuityDetectionModule, ONLY: &
    InitializeTroubledCellIndicator_Euler, &
    FinalizeTroubledCellIndicator_Euler, &
    LimiterThreshold, &
    DetectTroubledCells_Euler
  USE TimersModule_Euler, ONLY: &
    TimersStart_Euler, &
    TimersStop_Euler, &
    Timer_Euler_SlopeLimiter

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL
  PUBLIC :: FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL
  PUBLIC :: ApplySlopeLimiter_Euler_NonRelativistic_IDEAL

  LOGICAL  :: UseSlopeLimiter
  LOGICAL  :: UseCharacteristicLimiting
  LOGICAL  :: UseConservativeCorrection
  LOGICAL  :: Verbose
  REAL(DP) :: BetaTVD, BetaTVB
  REAL(DP) :: SlopeTolerance
  REAL(DP) :: I_6x6(1:6,1:6)

CONTAINS

  SUBROUTINE InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL &
    ( BetaTVD_Option, BetaTVB_Option, SlopeTolerance_Option, &
      UseSlopeLimiter_Option, UseCharacteristicLimiting_Option, &
      UseTroubledCellIndicator_Option, LimiterThresholdParameter_Option, &
      UseConservativeCorrection_Option, Verbose_Option )

    REAL(DP), INTENT(in), OPTIONAL :: &
      BetaTVD_Option, BetaTVB_Option
    REAL(DP), INTENT(in), OPTIONAL :: &
      SlopeTolerance_Option
    LOGICAL,  INTENT(in), OPTIONAL :: &
      UseSlopeLimiter_Option, &
      UseCharacteristicLimiting_Option, &
      UseTroubledCellIndicator_Option,  &
      UseConservativeCorrection_Option, &
      Verbose_Option
    REAL(DP), INTENT(in), OPTIONAL :: &
      LimiterThresholdParameter_Option

    INTEGER  :: i
    LOGICAL  :: UseTroubledCellIndicator
    REAL(DP) :: LimiterThresholdParameter

    BetaTVD = One
    IF( PRESENT( BetaTVD_Option ) ) &
      BetaTVD = BetaTVD_Option

    BetaTVB = Zero
    IF( PRESENT( BetaTVB_Option ) ) &
      BetaTVB = BetaTVB_Option

    SlopeTolerance = 1.0d-3
    IF( PRESENT( SlopeTolerance_Option ) ) &
      SlopeTolerance = SlopeTolerance_Option

    UseSlopeLimiter = .TRUE.
    IF( PRESENT( UseSlopeLimiter_Option ) ) &
      UseSlopeLimiter = UseSlopeLimiter_Option

    UseCharacteristicLimiting = .FALSE.
    IF( PRESENT( UseCharacteristicLimiting_Option ) ) &
      UseCharacteristicLimiting = UseCharacteristicLimiting_Option

    UseTroubledCellIndicator = .TRUE.
    IF( PRESENT( UseTroubledCellIndicator_Option ) ) &
      UseTroubledCellIndicator = UseTroubledCellIndicator_Option

    LimiterThresholdParameter = 0.03_DP
    IF( PRESENT( LimiterThresholdParameter_Option ) ) &
      LimiterThresholdParameter = LimiterThresholdParameter_Option

    UseConservativeCorrection = .TRUE.
    IF( PRESENT( UseConservativeCorrection_Option ) ) &
      UseConservativeCorrection = UseConservativeCorrection_Option

    Verbose = .TRUE.
    IF( PRESENT( Verbose_Option ) ) &
      Verbose = Verbose_Option

    CALL InitializeTroubledCellIndicator_Euler &
           ( UseTroubledCellIndicator_Option = UseTroubledCellIndicator, &
             LimiterThresholdParameter_Option = LimiterThresholdParameter )

    IF( Verbose )THEN
      WRITE(*,*)
      WRITE(*,'(A)') &
        '  INFO: InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL:'
      WRITE(*,'(A)') &
        '  ---------------------------------------------------------'
      WRITE(*,*)
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseSlopeLimiter: ' , &
        UseSlopeLimiter
      WRITE(*,*)
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'BetaTVD: ' , &
        BetaTVD
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'BetaTVB: ' , &
        BetaTVB
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'SlopeTolerance: ' , &
        SlopeTolerance
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseCharacteristicLimiting: ' , &
        UseCharacteristicLimiting
      WRITE(*,*)
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseTroubledCellIndicator: ' , &
        UseTroubledCellIndicator
      WRITE(*,*)
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'LimiterThreshold: ' , &
        LimiterThreshold
      WRITE(*,*)
      WRITE(*,'(A4,A27,L1)'       ) '', 'UseConservativeCorrection: ' , &
        UseConservativeCorrection
    END IF

    I_6x6 = Zero
    DO i = 1, 6
      I_6x6(i,i) = One
    END DO

  END SUBROUTINE InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL

  SUBROUTINE FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL

    CALL FinalizeTroubledCellIndicator_Euler

  END SUBROUTINE FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL

  SUBROUTINE ApplySlopeLimiter_Euler_NonRelativistic_IDEAL &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, U, D, SuppressBC_Option, iApplyBC_Option )

    INTEGER,  INTENT(in)           :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(in)           :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(inout)        :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(inout)        :: &
      D(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    LOGICAL,  INTENT(in), OPTIONAL :: &
      SuppressBC_Option
    INTEGER,  INTENT(in), OPTIONAL :: &
      iApplyBC_Option(3)

    LOGICAL  :: LimitedCell(nCF,iX_B0(1):iX_E0(1), &
                                iX_B0(2):iX_E0(2), &
                                iX_B0(3):iX_E0(3))
    LOGICAL  :: SuppressBC
    LOGICAL  :: ExcludeInnerGhostCell(3), ExcludeOuterGhostCell(3)
    INTEGER  :: iX1, iX2, iX3, iGF, iCF
    INTEGER  :: iApplyBC(3)
    REAL(DP) :: dX1, dX2, dX3
    REAL(DP) :: SlopeDifference(nCF)
    REAL(DP) :: a(nCF), b(nCF), c(nCF) ! --- Arguments for MinMod (fluid)
    REAL(DP) :: G_K(nGF)
    REAL(DP) :: dU (nCF,nDimsX)
    REAL(DP) :: U_M(nCF,0:2*nDimsX,nDOFX)
    REAL(DP) :: R_X1(nCF,nCF), invR_X1(nCF,nCF)
    REAL(DP) :: R_X2(nCF,nCF), invR_X2(nCF,nCF)
    REAL(DP) :: R_X3(nCF,nCF), invR_X3(nCF,nCF)
    REAL(DP) :: V_K(iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP) :: U_K(nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))

    IF( nDOFX == 1 ) RETURN

    IF( .NOT. UseSlopeLimiter ) RETURN

    CALL TimersStart_Euler( Timer_Euler_SlopeLimiter )

    U_M = Zero

    iApplyBC = iApplyBC_Euler_Both
    IF( PRESENT( iApplyBC_Option ) ) &
       iApplyBC = iApplyBC_Option

    SuppressBC = .FALSE.
    IF( PRESENT( SuppressBC_Option ) ) &
      SuppressBC = SuppressBC_Option

    IF( .NOT. SuppressBC ) &
      CALL ApplyBoundaryConditions_Euler &
             ( iX_B0, iX_E0, iX_B1, iX_E1, U )

    CALL DetectTroubledCells_Euler &
           ( iX_B0, iX_E0, iX_B1, iX_E1, U, D )

    LimitedCell = .FALSE.

    ExcludeInnerGhostCell = .FALSE.
    ExcludeOuterGhostCell = .FALSE.
    IF( ApplyInnerBC_Euler( iApplyBC(1) ) .AND. bcX(1) .NE. 1 ) &
      ExcludeInnerGhostCell(1) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(1) ) .AND. bcX(1) .NE. 1 ) &
      ExcludeOuterGhostCell(1) = .TRUE.
    IF( ApplyInnerBC_Euler( iApplyBC(2) ) .AND. bcX(2) .NE. 1 ) &
      ExcludeInnerGhostCell(2) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(2) ) .AND. bcX(2) .NE. 1 ) &
      ExcludeOuterGhostCell(2) = .TRUE.
    IF( ApplyInnerBC_Euler( iApplyBC(3) ) .AND. bcX(3) .NE. 1 ) &
      ExcludeInnerGhostCell(3) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(3) ) .AND. bcX(3) .NE. 1 ) &
      ExcludeOuterGhostCell(3) = .TRUE.

    DO iX3 = iX_B0(3), iX_E0(3)
    DO iX2 = iX_B0(2), iX_E0(2)
    DO iX1 = iX_B0(1), iX_E0(1)

      IF( ALL( D(:,iX1,iX2,iX3,iDF_TCI) < LimiterThreshold ) ) CYCLE

      dX1 = MeshX(1) % Width(iX1)
      dX2 = MeshX(2) % Width(iX2)
      dX3 = MeshX(3) % Width(iX3)

      ! --- Cell Volume ---

      V_K(iX1,iX2,iX3) &
        = DOT_PRODUCT( WeightsX_q(:), G(:,iX1,iX2,iX3,iGF_SqrtGm) )

      ! --- Cell Average of Conserved Fluid ---

      DO iCF = 1, nCF

        U_K(iCF,iX1,iX2,iX3) &
          = SUM( WeightsX_q(:) * G(:,iX1,iX2,iX3,iGF_SqrtGm) &
                   * U(:,iX1,iX2,iX3,iCF) ) / V_K(iX1,iX2,iX3)

      END DO

      ! --- Map to Modal Representation ---

      DO iCF = 1, nCF

        CALL MapNodalToModal_Fluid &
               ( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

        ! --- Cell Average of Neighbors in X1 Direction ---

        U_M(iCF,1,1) &
          = DOT_PRODUCT( WeightsX_q(:), U(:,iX1-1,iX2,iX3,iCF) )

        U_M(iCF,2,1) &
          = DOT_PRODUCT( WeightsX_q(:), U(:,iX1+1,iX2,iX3,iCF) )

        IF( nDimsX > 1 )THEN

          ! --- Cell Average of Neighbors in X2 Direction ---

          U_M(iCF,3,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2-1,iX3,iCF) )

          U_M(iCF,4,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2+1,iX3,iCF) )

        END IF

        IF( nDimsX > 2 )THEN

          ! --- Cell Average of Neighbors in X3 Direction ---

          U_M(iCF,5,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2,iX3-1,iCF) )

          U_M(iCF,6,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2,iX3+1,iCF) )

        END IF

      END DO

      IF( UseCharacteristicLimiting )THEN

        ! --- Cell Average of Geometry (Spatial Metric Only) ---

        DO iGF = iGF_Gm_dd_11, iGF_Gm_dd_33

          G_K(iGF) = DOT_PRODUCT( WeightsX_q(:), G(:,iX1,iX2,iX3,iGF) )

        END DO

        ! --- Compute Eigenvectors ---

        CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL &
               ( 1, G_K(:), U_M(:,0,1), R_X1, invR_X1 )

        IF( nDimsX > 1 )THEN

          CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL &
                 ( 2, G_K(:), U_M(:,0,1), R_X2, invR_X2 )

        END IF

        IF( nDimsX > 2 )THEN

          CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL &
                 ( 3, G_K(:), U_M(:,0,1), R_X3, invR_X3 )

        END IF

      ELSE

        ! --- Componentwise Limiting ---

        R_X1 = I_6x6; invR_X1 = I_6x6
        R_X2 = I_6x6; invR_X2 = I_6x6
        R_X3 = I_6x6; invR_X3 = I_6x6

      END IF

      ! --- Compute Limited Slopes ---

      a = MATMUL( invR_X1, U_M(:,0,2) )

      IF     ( iX1 .EQ. iX_B0(1) .AND. ExcludeInnerGhostCell(1) )THEN

        c = BetaTVD * MATMUL( invR_X1, ( U_M(:,2,1) - U_M(:,0,1) ) )
        b = c

      ELSE IF( iX1 .EQ. iX_E0(1) .AND. ExcludeOuterGhostCell(1) )THEN

        b = BetaTVD * MATMUL( invR_X1, ( U_M(:,0,1) - U_M(:,1,1) ) )
        c = b

      ELSE

        b = BetaTVD * MATMUL( invR_X1, ( U_M(:,0,1) - U_M(:,1,1) ) )
        c = BetaTVD * MATMUL( invR_X1, ( U_M(:,2,1) - U_M(:,0,1) ) )

      END IF

      dU(:,1) = MinModB( a, b, c, dX1, BetaTVB )

      IF( nDimsX > 1 )THEN

        a = MATMUL( invR_X2, U_M(:,0,3) )

        IF     ( iX2 .EQ. iX_B0(2) .AND. ExcludeInnerGhostCell(2) )THEN

          c = BetaTVD * MATMUL( invR_X2, ( U_M(:,4,1) - U_M(:,0,1) ) )
          b = c

        ELSE IF( iX2 .EQ. iX_E0(2) .AND. ExcludeOuterGhostCell(2) )THEN

          b = BetaTVD * MATMUL( invR_X2, ( U_M(:,0,1) - U_M(:,3,1) ) )
          c = b

        ELSE

          b = BetaTVD * MATMUL( invR_X2, ( U_M(:,0,1) - U_M(:,3,1) ) )
          c = BetaTVD * MATMUL( invR_X2, ( U_M(:,4,1) - U_M(:,0,1) ) )

        END IF

        dU(:,2) = MinModB( a, b, c, dX2, BetaTVB )

      END IF

      IF( nDimsX > 2 )THEN

        a = MATMUL( invR_X3, U_M(:,0,4) )

        IF     ( iX3 .EQ. iX_B0(3) .AND. ExcludeInnerGhostCell(3) )THEN

          c = BetaTVD * MATMUL( invR_X3, ( U_M(:,6,1) - U_M(:,0,1) ) )
          b = c

        ELSE IF( iX3 .EQ. iX_E0(3) .AND. ExcludeOuterGhostCell(3) )THEN

          b = BetaTVD * MATMUL( invR_X3, ( U_M(:,0,1) - U_M(:,5,1) ) )
          c = b

        ELSE

          b = BetaTVD * MATMUL( invR_X3, ( U_M(:,0,1) - U_M(:,5,1) ) )
          c = BetaTVD * MATMUL( invR_X3, ( U_M(:,6,1) - U_M(:,0,1) ) )

        END IF

        dU(:,3) = MinModB( a, b, c, dX3, BetaTVB )

      END IF

      IF( UseCharacteristicLimiting )THEN

        ! --- Transform Back from Characteristic Variables ---

        dU(:,1) = MATMUL( R_X1, dU(:,1) )

        IF( nDimsX > 1 )THEN

          dU(:,2) = MATMUL( R_X2, dU(:,2) )

        END IF

        IF( nDimsX > 2 )THEN

          dU(:,3) = MATMUL( R_X3, dU(:,3) )

        END IF

      END IF

      ! --- Compare Limited Slopes to Original Slopes ---

      DO iCF = 1, nCF

        SlopeDifference(iCF) &
          = ABS( U_M(iCF,0,2) - dU(iCF,1) )

        IF( nDimsX > 1 )THEN

          SlopeDifference(iCF) &
            = MAX( SlopeDifference(iCF), &
                   ABS( U_M(iCF,0,3) - dU(iCF,2) ) )

        END IF

        IF( nDimsX > 2 )THEN

          SlopeDifference(iCF) &
            = MAX( SlopeDifference(iCF), &
                   ABS( U_M(iCF,0,4) - dU(iCF,3) ) )

        END IF

      END DO

      ! --- Replace Slopes and Discard High-Order Components ---
      ! --- if Limited Slopes Deviate too Much from Original ---

      DO iCF = 1, nCF

        IF( SlopeDifference(iCF) &
              > SlopeTolerance * ABS( U_M(iCF,0,1) ) )THEN

          U_M(iCF,0,2:nDOFX) = Zero

          U_M(iCF,0,2) = dU(iCF,1)

          IF( nDimsX > 1 ) &
            U_M(iCF,0,3) = dU(iCF,2)

          IF( nDimsX > 2 ) &
            U_M(iCF,0,4) = dU(iCF,3)

          CALL MapModalToNodal_Fluid &
                 ( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

          LimitedCell(iCF,iX1,iX2,iX3) = .TRUE.

        END IF

      END DO

    END DO
    END DO
    END DO

    CALL ApplyConservativeCorrection &
           ( iX_B0, iX_E0, iX_B1, iX_E1, G, V_K, U, U_K, LimitedCell )

    CALL TimersStop_Euler( Timer_Euler_SlopeLimiter )

  END SUBROUTINE ApplySlopeLimiter_Euler_NonRelativistic_IDEAL

  SUBROUTINE ApplyConservativeCorrection &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, V_K, U, U_K, LimitedCell )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(in)    :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      V_K(iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP), INTENT(in)    :: &
      U_K(1:nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP), INTENT(inout) :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    LOGICAL, INTENT(in)     :: &
      LimitedCell(nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))

    INTEGER  :: iX1, iX2, iX3, iCF, iPol, iDimX
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNodeX
    REAL(DP) :: Correction
    REAL(DP) :: LegendreX(nDOFX,nDOFX)
    REAL(DP) :: U_M(nCF,0:2**nDimsX,nDOFX)

    IF( .NOT. UseConservativeCorrection ) RETURN

    DO iPol = 1, nDOFX ! Only need for iPol = 2,3,4 (FIXME)

      DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
      DO iNodeX1 = 1, nNodesX(1)

        iNodeX = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

        LegendreX(iNodeX,iPol) &
          = P_X1  (IndPX_Q(1,iPol)) % P( MeshX(1) % Nodes(iNodeX1) ) &
            * P_X2(IndPX_Q(2,iPol)) % P( MeshX(2) % Nodes(iNodeX2) ) &
            * P_X3(IndPX_Q(3,iPol)) % P( MeshX(3) % Nodes(iNodeX3) )

      END DO
      END DO
      END DO

    END DO

    ! --- Applies a correction to the 0-th order ---
    ! --- mode to maintain the cell average.     ---

    DO iX3 = iX_B0(3), iX_E0(3)
    DO iX2 = iX_B0(2), iX_E0(2)
    DO iX1 = iX_B0(1), iX_E0(1)

      DO iCF = 1, nCF

        IF( LimitedCell(iCF,iX1,iX2,iX3) )THEN

          CALL MapNodalToModal_Fluid( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

          Correction = Zero
          DO iDimX = 1, nDimsX

            Correction &
              = Correction &
                  + ( U_M(iCF,0,iDimX+1) &
                      * SUM( WeightsX_q(:) * LegendreX(:,iDimX+1) &
                             * G(:,iX1,iX2,iX3,iGF_SqrtGm) ) ) &
                    / V_K(iX1,iX2,iX3)

          END DO

          U_M(iCF,0,1) = U_K(iCF,iX1,iX2,iX3) - Correction

          CALL MapModalToNodal_Fluid( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

        END IF

      END DO

    END DO
    END DO
    END DO

  END SUBROUTINE ApplyConservativeCorrection

END MODULE Euler_SlopeLimiterModule_NonRelativistic_IDEAL


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: costf1.f,v 1.2 2006-11-21 01:10:17 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DCOSTF1(N,INC,X,WSAVE,WORK,IER)
      DOUBLE PRECISION WORK
      DOUBLE PRECISION X1H
      DOUBLE PRECISION X1P3
      DOUBLE PRECISION TX2
      DOUBLE PRECISION T1
      DOUBLE PRECISION T2
      DOUBLE PRECISION SNM1
      DOUBLE PRECISION XI
      DOUBLE PRECISION X(INC,*),WSAVE(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DSUM

      IER = 0
      NM1 = N - 1
      NP1 = N + 1
      NS2 = N/2
      IF (N-2) 200,101,102
  101 X1H = X(1,1) + X(1,2)
      X(1,2) = .5D0* (X(1,1)-X(1,2))
      X(1,1) = .5D0*X1H
      GO TO 200
  102 IF (N.GT.3) GO TO 103
      X1P3 = X(1,1) + X(1,3)
      TX2 = X(1,2) + X(1,2)
      X(1,2) = .5D0* (X(1,1)-X(1,3))
      X(1,1) = .25D0* (X1P3+TX2)
      X(1,3) = .25D0* (X1P3-TX2)
      GO TO 200
  103 DSUM = X(1,1) - X(1,N)
      X(1,1) = X(1,1) + X(1,N)
      DO 104 K = 2,NS2
          KC = NP1 - K
          T1 = X(1,K) + X(1,KC)
          T2 = X(1,K) - X(1,KC)
          DSUM = DSUM + WSAVE(KC)*T2
          T2 = WSAVE(K)*T2
          X(1,K) = T1 - T2
          X(1,KC) = T1 + T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN.EQ.0) GO TO 124
      X(1,NS2+1) = X(1,NS2+1) + X(1,NS2+1)
  124 LENX = INC* (NM1-1) + 1
      LNSV = NM1 + INT(LOG(DBLE(NM1))) + 4
      LNWK = NM1
C
      CALL DRFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
      IF (IER1.NE.0) THEN
          IER = 20
          CALL DXERFFT('COSTF1',-5)
          GO TO 200
      END IF
C
      SNM1 = 1.D0/DBLE(NM1)
      DSUM = SNM1*DSUM
      IF (MOD(NM1,2).NE.0) GO TO 30
      X(1,NM1) = X(1,NM1) + X(1,NM1)
   30 DO 105 I = 3,N,2
          XI = .5D0*X(1,I)
          X(1,I) = .5D0*X(1,I-1)
          X(1,I-1) = DSUM
          DSUM = DSUM + XI
  105 CONTINUE
      IF (MODN.NE.0) GO TO 117
      X(1,N) = DSUM
  117 X(1,1) = .5D0*X(1,1)
      X(1,N) = .5D0*X(1,N)
  200 RETURN
      END


      PROGRAM WIND_STAT_NC
      USE netcdf   ! NetCDF fortran 90 interface
      IMPLICIT NONE
C
      CHARACTER*40     CTITLE
      INTEGER          IWI,JWI,NREC
      REAL             XFIN,YFIN,DXIN,DYIN
C
      CHARACTER*240    CFILE
      INTEGER          ncFID,ncDID,ncVID
      INTEGER          KREC
      REAL             JDAY,YEAR
      DOUBLE PRECISION TIME_NEXT
C
      REAL,             ALLOCATABLE :: WDAY(:)
      DOUBLE PRECISION, ALLOCATABLE :: TIME(:),WLON(:),WLAT(:)
C
C**********
C*
C 1)  PRINT MODEL WIND FILE STATISTICS.
C
C 2)  NRL-style NetCDF WIND FILE FROM ENVIRONEMENT VARIABLE CDF055.
C
C 3)  ALAN J. WALLCRAFT,  JULY 2010.
C*
C**********
c
      integer          i
      double precision time_i
C
C     OPEN THE FILE.
C
      CFILE = ' '
      CALL GETENV('CDF055',CFILE)
      IF     (CFILE.EQ.' ') THEN
        WRITE(0,*) 'wind_stat_nc: no CDF055 environment variable'
        CALL EXIT(1)
        STOP
      ENDIF
      call nchek('nf90_open',
     &            nf90_open(trim(CFILE), nf90_nowrite, ncFID))
C
C     READ THE TITLE.
C
      call nchek("nf90_get_att-title",
     &            nf90_get_att(ncFID,nf90_global,
     &                               "title",
     &                               CTITLE))
C
C     READ THE AXES.
C
      call nchek('nf90_inq_dimid-MT',
     &            nf90_inq_dimid(        ncFID, 'MT',ncDID))
      call nchek('nf90_inquire_dimension-MT',
     &            nf90_inquire_dimension(ncFID,      ncDID,
     &                                               len=NREC))
      ALLOCATE( TIME(NREC) )
      call nchek('nf90_inq_varid-MT',
     &            nf90_inq_varid(ncFID,'MT',ncVID))
      call nchek('nf90_get_var-MT',
     &            nf90_get_var(  ncFID,     ncVID,TIME(:)))
      call nchek("nf90_get_att-next_MT",
     &            nf90_get_att(ncFID,       ncVID,
     &                                      "next_MT",
     &                                      TIME_NEXT))
C
      do i= 2,nrec
        time_i = time(1) +
     &             (time_next - time(1))/nrec * (i-1.d0)
        time_i = NINT(time_i*24.d0)/24.d0
        if     (abs(time(i)-time_i).gt.1.d-5) then
          write(6,'(i5,f20.6,f20.16)') i,time(i),time(i)-time_i
        endif
      enddo !i
C
      call nchek('nf90_inq_dimid-Latitude',
     &            nf90_inq_dimid(        ncFID, 'Latitude',ncDID))
      call nchek('nf90_inquire_dimension-Latitude',
     &            nf90_inquire_dimension(ncFID,            ncDID,
     &                                                 len=JWI))
      ALLOCATE( WLAT(JWI) )
      call nchek('nf90_inq_varid-Latitude',
     &            nf90_inq_varid(ncFID,'Latitude',ncVID))
      call nchek('nf90_get_var-Latitude',
     &            nf90_get_var(  ncFID,           ncVID,WLAT(:)))
C
      call nchek('nf90_inq_dimid-Longitude',
     &            nf90_inq_dimid(        ncFID, 'Longitude',ncDID))
      call nchek('nf90_inquire_dimension-Longitude',
     &            nf90_inquire_dimension(ncFID,             ncDID,
     &                                                  len=IWI))
      ALLOCATE( WLON(IWI) )
      call nchek('nf90_inq_varid-Longitude',
     &            nf90_inq_varid(ncFID,'Longitude',ncVID))
      call nchek('nf90_get_var-Longitude',
     &            nf90_get_var(  ncFID,            ncVID,WLON(:)))
      call nchek("nf90_close",
     &            nf90_close(ncFID))
C
      XFIN = WLON(1)
      DXIN = (WLON(IWI) - WLON(1))/(IWI-1.D0)  !assume uniform spaced
      YFIN = WLAT(1)
      IF     (ABS((WLAT(JWI)-WLAT(1))-
     &            (WLAT(  2)-WLAT(1))*(JWI-1.D0)).LT.1.D-2) THEN
*       write(6,*)     (WLAT(JWI)-WLAT(1))
*       write(6,*)     (WLAT(  2)-WLAT(1))*(JWI-1.D0)
*       write(6,*) ABS((WLAT(JWI)-WLAT(1))-
*    &                 (WLAT(  2)-WLAT(1))*(JWI-1.D0))
        DYIN = (WLAT(JWI) - WLAT(1))/(JWI-1.D0)  !assume uniform spaced
      ELSE
        DYIN = 0.0  ! assume a gaussian grid
      ENDIF
      ALLOCATE( WDAY(NREC+1) )
      DO KREC= 1,NREC
        WDAY(KREC) = TIME(KREC)
      ENDDO
      WDAY(NREC+1) = TIME_NEXT
C
C     STATISTICS.
C
      WRITE(6,6000) CTITLE
      WRITE(6,6100) IWI,JWI,XFIN,YFIN,DXIN,DYIN,
     +              NREC,(WDAY(KREC), KREC=1,NREC+1)
*     CALL FLUSH(6)
C
C     SUMMARY.
C
      CALL WNDAY(WDAY(1), YEAR,JDAY)
      IF     (YEAR.LT.1904.5) THEN
        WRITE(6,6200) NREC,JDAY,NINT(YEAR),WDAY(NREC+1)-WDAY(1)
      ELSE
        WRITE(6,6250) NREC,JDAY,NINT(YEAR),WDAY(NREC+1)-WDAY(1)
      ENDIF
      CALL EXIT(0)
      STOP
C
 6000 FORMAT(A40)
 6100 FORMAT(
     +      'IWI,JWI =',I4,',',I4,
     +   3X,'XFIN,YFIN =',F9.3,',',F9.3,
     +   3X,'DXIN,DYIN =',F6.3,',',F6.3 /
     +      'NREC =',I5,5X,'WDAY =' / (8F10.3) )
 6200 FORMAT(I5,' RECORD CLIMATOLOGY STARTING ON',F7.2,'/',I4,
     +   ' COVERING',F9.2,' DAYS')
 6250 FORMAT(I5,' WIND RECORDS STARTING ON',F7.2,'/',I4,
     +   ' COVERING',F9.2,' DAYS')
C     END OF WDSTAT.
      END
      SUBROUTINE WNDAY(WDAY, YEAR,DAY)
      IMPLICIT NONE
      REAL WDAY,YEAR,DAY
C
C**********
C*
C  1) CONVERT 'WIND DAY' INTO JULIAN DAY AND YEAR.
C
C  2) THE 'WIND DAY' IS THE NUMBER OF DAYS SINCE 001/1901 (WHICH IS
C      WIND DAY 1.0).
C     FOR EXAMPLE:
C      A) YEAR=1901.0 AND DAY=1.0, REPRESENTS 0000Z HRS ON 001/1901
C         SO WDAY WOULD BE 1.0.
C      B) YEAR=1901.0 AND DAY=2.5, REPRESENTS 1200Z HRS ON 002/1901
C         SO WDAY WOULD BE 2.5.
C     YEAR MUST BE NO LESS THAN 1901.0, AND NO GREATER THAN 2099.0.
C     NOTE THAT YEAR 2000 IS A LEAP YEAR (BUT 1900 AND 2100 ARE NOT).
C
C  3) ALAN J. WALLCRAFT, PLANNING SYSTEMS INC., FEBRUARY 1993.
C*
C**********
C
      INTEGER IYR,NLEAP
      REAL    WDAY1
C
C     FIND THE RIGHT YEAR.
C
      IYR   = (WDAY-1.0)/365.25
      NLEAP = IYR/4
      WDAY1 = 365.0*IYR + NLEAP + 1.0
      DAY   = WDAY - WDAY1 + 1.0
      IF     (WDAY1.GT.WDAY) THEN
        IYR   = IYR - 1
      ELSEIF (DAY.GE.367.0) THEN
        IYR   = IYR + 1
      ELSEIF (DAY.GE.366.0 .AND. MOD(IYR,4).NE.3) THEN
        IYR   = IYR + 1
      ENDIF
      NLEAP = IYR/4
      WDAY1 = 365.0*IYR + NLEAP + 1.0
C
C     RETURN YEAR AND JULIAN DAY.
C
      YEAR = 1901 + IYR
      DAY  = WDAY - WDAY1 + 1.0
      RETURN
C     END OF WNDAY.
      END
      subroutine nchek(cnf90,status)
      use netcdf   ! NetCDF fortran 90 interface
      implicit none
c
      character*(*), intent(in) :: cnf90
      integer,       intent(in) :: status
c
c     subroutine to handle NetCDF errors
c
*     if     (.TRUE. ) then !debug
      if     (.FALSE.) then !nodebug
        write(6,'(a)') trim(cnf90)
      endif

      if (status /= nf90_noerr) then
        write(6,'(/a)')   'error in profout - from NetCDF library'
        write(6,'(a/)')   trim(cnf90)
        write(6,'(a/)')   trim(nf90_strerror(status))
        stop
      end if
      end subroutine nchek


      subroutine qr(ndime,m, n, a, b, x, resq)
      implicit double precision (a-h, o-z)
c$$$$  calls no other routines
c  solves over-determined least-squares problem  ax = b
c  where  a  is an  m by n  matrix,  b  is an m-vector .
c  resq  is the sum of squared residuals of optimal solution.  also used
c  to signal error conditions - if -2 , system is underdetermined,  if
c  -1,  system is singular.
c  method - successive householder rotations.  see lawson+hanson - solv
c  -ing least squares problems.
c  routine will also work when m=n.
c*****   caution -  a and b  are overwritten by this routine.
      dimension a(ndime,1),b(1),x(1)
      double precision sum,dot
c
      resq=-2.0d0
      if (m.lt.n) return
c   loop ending on 1800 rotates  a  into upper triangular form
      do 1800 j=1,n
c  find constants for rotation and diagonal entry
      sq=0.0d0
      do 1100 i=j,m
 1100 sq=a(i,j)**2 + sq
      qv1=-dsign(dsqrt(sq),a(j,j))
      u1=a(j,j) - qv1
      a(j,j)=qv1
      j1=j + 1
      if (j1.gt.n) go to 1500
c  rotate remaining columns of sub-matrix
      do 1400 jj=j1,n
      dot=u1*a(j,jj)
      do 1200 i=j1,m
 1200 dot=a(i,jj)*a(i,j) + dot
      const=dot/dabs(qv1*u1)
      do 1300 i=j1,m
 1300 a(i,jj)=a(i,jj) - const*a(i,j)
      a(j,jj)=a(j,jj) - const*u1
 1400 continue
c  rotate  b  vector
 1500 dot=u1*b(j)
      if (j1.gt.m) go to 1610
      do 1600 i=j1,m
 1600 dot=b(i)*a(i,j) + dot
 1610 const=dot/dabs(qv1*u1)
      b(j)=b(j) - const*u1
      if (j1.gt.m) go to 1800
      do 1700 i=j1,m
 1700 b(i)=b(i) - const*a(i,j)
 1800 continue
c  solve triangular system by back-substitution.
      resq=-1.0d0
      do 2200 ii=1,n
      i=n-ii+1
      sum=b(i)
      if (ii.eq.1) go to 2110
      i1=i+1
      do 2100 j=i1,n
 2100 sum=sum - a(i,j)*x(j)
 2110 if (a(i,i).eq. 0.0d0) return
 2200 x(i)=sum/a(i,i)
c  find residual in overdetermined case.
      resq=0.0d0
      if (m.eq.n) return
      i1=n+1
      do 2300 i=i1,m
 2300 resq=b(i)**2 + resq
      return
      end

c $Id$


! simple code for random number sequences
! from numerical recipes..
function ranfb(ix)
  real :: y,ranfb
  integer :: ix,ix1,ix2,ia1,ia2,ic,j1,j2,j3

  ia1=273
  ia2=25301
  ic=226908345

  if (ix.lt.0) ix=-ix
  if (ix.gt.2**30) ix=MOD(ix,2**30)

  ix1=ix/(2**15)
  ix2=ix-ix1*(2**15)
  j1=MOD(ix1*ia2,2**15)*2**15
  j2=MOD(ix2*ia1,2**15)*2**15
  j3=ix2*ia2
  ix=MOD(j1+j2,2**30)
  ix=MOD(ix+j3,2**30)
  ix=MOD(ix+ic,2**30)
  y=FLOAT(ix)

  ranfb=y/2**30

end function

function ran2(ix)
 real ran2,ranfb
 integer ix
 ran2=ranfb(ix)
end function

FUNCTION gasdev(iseed)
 REAL :: gasdev,x(2),r2,fac,ran2
 INTEGER :: iseed
 INTEGER, SAVE :: iset=0
 REAL, SAVE :: saved
 IF(iset.EQ.0) THEN
   r2=2.
   DO WHILE(r2.GE.1.OR.r2.EQ.0)
     x(1)=ran2(iseed)
     x(2)=ran2(iseed)
     x=2*x-1
     r2=sum(x**2)
   ENDDO
   fac=sqrt(-2.*log(r2)/r2)
   saved=x(1)*fac
   gasdev=x(2)*fac
   iset=1
 ELSE
   iset=0
   gasdev=saved
 ENDIF
END FUNCTION

!
   SUBROUTINE makefractal(nstar,rstar,vstar,fdim,idum)
!
! makes fractal of nstar particles of dimension fdim, using ndiv
! subunits forcing the number of cells if force=.true.
! Simon Goodwin & Ant Whitworth (2004, A&A, 413, 929)
!
! fdim (real) = fractal dimension
! ndiv (int) = number of divisions of box (>=2)
! nstar (int) = number of stars in *final* distribution
! rstar (3,n) = positions to return
! vstar (3,n) = velocities to return
! force (logical) = make box dimension such that integer no. children
! vtype (logical) = .true. - inherit velocities
! vir (real) = virial ratio (virialised = 0.5)
! idum = random number seed
! outfile = output file name
   IMPLICIT NONE
   INTEGER :: ndiv,nstar,idum,isnext,iforce
   INTEGER :: is,nsmax,islast,flagabort,k
   INTEGER :: k1,k2,k3,i,isfirst,nswap,ndo,nsnow
   REAL :: fdim,dum,delta,dr(3),prob,rad,cov(3)
   REAL :: how,how2,ran2,com(3)
   REAL :: gasdev
   LOGICAL :: force,vtype
   INTEGER :: n,isurv,level
   REAL :: rstar(1:3,nstar),vstar(1:3,nstar)
   INTEGER, DIMENSION(:), ALLOCATABLE :: forced
   REAL, DIMENSION(:,:), ALLOCATABLE :: r,v
!
! set initial parameters
   ndiv=2
   force=.TRUE.
   vtype=.TRUE.
   ALLOCATE(r(1:3,1:nstar*50))
   ALLOCATE(v(1:3,1:nstar*50))
   ALLOCATE(forced(1:ndiv**3))
!
! ===================================================================
! probability of a child surviving
   prob=REAL(ndiv)**(fdim-3.)
!
! list characteristics
   WRITE(6,*) 'fractal dimension', fdim
   WRITE(6,*) 'ndiv', ndiv
   WRITE(6,*) 'number of stars', nstar
   WRITE(6,*) 'survival chance', prob
   WRITE(6,*) 'forcing?', force
!
! warning
   how=REAL(ndiv)**fdim
   WRITE(6,*) '# of children expected', how
   how2=how - INT(how)
   IF (how2>0.2 .AND. how2<0.8) THEN
     WRITE(6,*) 'WARNING:'
     IF (how2<0.5) THEN
       dum=LOG(REAL(INT(how)))/LOG(REAL(ndiv))
       WRITE(6,*) 'could look like fdim=', dum
     ELSE
       dum=LOG(REAL(INT(how)+1))/LOG(REAL(ndiv))
       WRITE(6,*) 'could look like fdim=', dum
     END IF
   END IF
!
   IF (force) THEN
     iforce=INT(how + 0.5)
     WRITE(6,*) 'forcing to survivors=', iforce
     dum=LOG(REAL(iforce))/LOG(REAL(ndiv))
     WRITE(6,*) 'which means fdim=', dum
   END IF
!
! build fractal cube
   r=0.
   v=0.
   nsmax=1
   islast=1
   flagabort=0
   delta=1./REAL(ndiv)
   level=0
   DO
     level=level + 1
     isfirst=nsmax + 1
     isnext=isfirst
! loop over all parents
     DO is=1,nsmax
!
! if forced decide on survivors now
       IF (force) THEN
         forced=0
         DO n=1,iforce
4          isurv=INT(ran2(idum)*REAL(ndiv**3)) + 1
           IF (forced(isurv)==1) GOTO 4
           forced(isurv)=1
         END DO
       END IF
! loop over all ndiv**3 possible children
       n=0
       DO k1=1,ndiv
         dr(1)=REAL(2*k1-1-ndiv)*delta
         DO k2=1,ndiv
           dr(2)=REAL(2*k2-1-ndiv)*delta
           DO k3=1,ndiv
             n=n+1
             dr(3)=REAL(2*k3-1-ndiv)*delta
             r(1:3,isnext)=r(1:3,is) + dr(1:3)
             IF (vtype) THEN
! keep parent's velocity
               v(1:3,isnext)=v(1:3,is)
             END IF
! do children survive?
! forced or not forced here
             IF (force) THEN
               IF (forced(n)==1) THEN
                 islast=isnext
                 isnext=isnext + 1
               END IF
             ELSE
               IF (ran2(idum)<prob) THEN
                 islast=isnext
                 isnext=isnext + 1
               END IF
             END IF
           END DO
         END DO
       END DO
     END DO
! are there children (we hope so)
     IF (islast/=nsmax) THEN
! delete parents
       DO is=isfirst,islast
         r(1:3,is-nsmax)=r(1:3,is)
         v(1:3,is-nsmax)=v(1:3,is)
       END DO
! new total number
       nsmax=islast - nsmax
       DO is=nsmax+1,islast
         r(1:3,is)=0.
         v(1:3,is)=0.
       END DO
! resize delta
       delta=delta/REAL(ndiv)
     ELSE
       flagabort=1
       EXIT
     END IF
     IF (flagabort==1) STOP 'no children'
! add noise to positions and velocity
     DO is=1,nsmax
       DO k=1,3
         r(k,is)=r(k,is) + (2.*ran2(idum) - 1.)*delta
!         v(k,is)=v(k,is) + 2.**(fdim-1.)*gasdev(idum)
         v(k,is)=v(k,is) + delta*gasdev(idum)
       END DO
     END DO
! exit if enough particles
     IF (nsmax>3.5*nstar) EXIT
!     WRITE(6,*) 'done', delta, nsmax
   END DO
   WRITE(6,*) 'Made initial cubic distribution'
!
! cut out sphere
   nsnow=nsmax
   DO is=1,nsmax
     rad=r(1,is)**2 + r(2,is)**2 + r(3,is)**2
     IF (rad>1.) THEN
       r(1,is)=69.
       nsnow=nsnow - 1
     END IF
   END DO
   nswap=nsmax
   ndo=1
   DO
8    IF (r(1,ndo)==69.) THEN
       r(1:3,ndo)=r(1:3,nswap)
       nswap=nswap - 1
       GOTO 8
     END IF
     ndo=ndo + 1
     IF (ndo==nsnow) EXIT
   END DO
   nsmax=ndo - 1
   IF (nsmax<nstar) THEN
     WRITE(6,*) 'nsmax<nstar - change random number seed'
     nstar=nsmax
  ENDIF
!
! we now have a fractal of nsmax stars
! need to randomly remove stars until we get nstar
   DO
! star to remove
     IF (nsmax==nstar) EXIT
     is=INT(ran2(idum)*REAL(nsmax)) + 1
     r(1:3,is)=r(1:3,nsmax)
     v(1:3,is)=v(1:3,nsmax)
     nsmax=nsmax - 1
   END DO
   WRITE(6,*) 'Cut to size', nsmax
!
! now put r in rstar array
   DO is=1,nstar
     rstar(1:3,is)=r(1:3,is)
     vstar(1:3,is)=v(1:3,is)
   END DO
!
   IF (.NOT.vtype) THEN
     DO is=1,nstar
       DO k=1,3
         vstar(k,is)=(2.*ran2(idum) - 1.)
       END DO
     END DO
   END IF
!
! set coms to zero
   com=0.
   cov=0.
   DO i=1,nstar
     com(1:3)=com(1:3) + rstar(1:3,i)
     cov(1:3)=cov(1:3) + vstar(1:3,i)
   END DO
   com=com/REAL(nstar)
   cov=cov/REAL(nstar)
   WRITE(6,*) 'COM', com(1), com(2), com(3)
   DO i=1,nstar
     rstar(1:3,i)=rstar(1:3,i) - com(1:3)
     vstar(1:3,i)=vstar(1:3,i) - cov(1:3)
   END DO
!
   END SUBROUTINE makefractal
!