! ------------------------------------
! Routines used to evaluate the indefinite integrals that arise when exactly
! integrating interpolated spectra weighted by particular SFHs.
!
! Adding new SFHs is as easy as adding new sfh%type cases in both sfhint_*
! functions below (and making sure the sfhlimits.f90 make sense)
! ------------------------------------

function intsfwght(sspind, logt, sfh)
  ! Wrapper on the sfhint_* routines to choose the correct interpolation type
  ! and calculate the definite integral of the weighted SFR between the given
  ! limits.
  !
  ! Inputs
  ! -------
  !
  ! sspind:
  !    The index of the SSP forming the bracket with the SSP you are getting a
  !    weight for.
  !
  ! logt:
  !    the limits of the integral, 2-element array (lo, hi) of
  !    log(lookback time) (in yrs).
  !
  ! sfh:
  !    Structure containing the SFH parameters in units of years, including an
  !    integer `type` specifiying the form of SFR(t).
  !
  ! Outputs
  !--------
  !  intsfwght:
  !    The exact definite integral between the limits specified in `logt`.

  use sps_vars, only: interpolation_type, SFHPARAMS, SP
  implicit none

  integer, intent(in) :: sspind
  real(SP), intent(in), dimension(2) :: logt
  type(SFHPARAMS), intent(in) :: sfh

  real(SP) :: intsfwght, sfwght_log, sfwght_lin

  if (interpolation_type.eq.0) then
     intsfwght =  sfwght_log(sspind, logt(2), sfh) - sfwght_log(sspind, logt(1), sfh)
  else if (interpolation_type.eq.1) then
     intsfwght = (sfwght_lin(sspind, 10**logt(2), sfh) - sfwght_lin(sspind, 10**logt(1), sfh))
  endif

end function intsfwght

function sfwght_log(sspind, logt, sfh)
  ! Evaluates the indefinite integral of the interpolation weight in log time,
  ! weighted by the SFH, and evaluated at `logt`.  In detail, this function
  ! returns:
  !   (\int dt \, \mathrm{SFR}(t) \, (x - \log t) )|_{\texttt{logt}}
  ! where x = time_full(ssp_ind) and `t` is *lookback* time.
  !
  ! Inputs
  ! -------
  !
  ! sspind:
  !    The index of the SSP forming the bracket with the SSP you are getting a
  !    weight for.
  !
  ! logt:
  !    Where the indefinite integral is evaluated, log(t_lookback) (in yrs).
  !
  ! sfh:
  !    Structure containing the SFH parameters in units of years, including an
  !    integer `type` specifiying the form of SFR(t).
  !
  ! Outputs
  !--------
  !  sfwght_log:
  !    The exact indefinite integral, evaluated at `logt`.  Scalar float.

  use sps_vars, only: time_full, tiny_logt, SFHPARAMS, SP
  implicit none

  integer, intent(in) :: sspind
  real(SP), intent(in) :: logt
  type(SFHPARAMS), intent(in) :: sfh

  real(SP) :: sfwght_log

  real(SP) :: loge, ei
  real(SP) :: logage, tprime ! intermediate time variables
  real(SP) :: a, b, c ! dummy variables used to break up long expressions

  REAL(SP), PARAMETER :: e=2.7182818284590452353602874713526624977572_sp
  loge = log10(e)

  ! Zero index means use ~0 age.
  if (sspind.gt.0) then
     logage = time_full(sspind)
  else
     logage = tiny_logt
  endif

  if (sfh%type.eq.0) then
     ! SFR = Constant ~ 1
     sfwght_log = 10**logt * (logage - logt + loge)

  else if (sfh%type.eq.1) then
     ! SFR = exponential ~ exp(-T/tau)
     tprime = 10**logt / sfh%tau
     sfwght_log = (logage - logt) * exp(tprime) + loge * ei(tprime)

  else if (sfh%type.eq.4) then
     ! SFR = delayed exponential ~ T/tau exp(-T/tau)
     tprime = 10**logt / sfh%tau ! t/tau
     a = (10**logt - sfh%tage - sfh%tau) * (logt - logage)
     b = sfh%tau * loge
     c = (sfh%tage + sfh%tau) * loge
     sfwght_log = (a - b) * exp(tprime) + c * ei(tprime)

  else if (sfh%type.eq.5) then
     !SFR = linear ~ (1 - sf_slope * (T - T_trunc)), T > T_trunc
     tprime = max(0.0, sfh%tage - sfh%sf_trunc) !t_q
     a = 1 - sfh%sf_slope * tprime
     b = a * 10**logt * (logage - logt + loge)
     c = sfh%sf_slope * (10**logt)**2 / 2 * (logage - logt + loge / 2)
     sfwght_log = b + c

  endif

end function sfwght_log

function sfwght_lin(sspind, t, sfh)
  ! Evaluates the indefinite integral of the interpolation weight in linear
  ! time, weighted by the SFH, and evaluated at `logt`.  In detail, this
  ! function returns:
  !   (\int dt \, \mathrm{SFR}(t) \, (x - t) )|_{\texttt{t}}
  ! where x = 10**time_full(ssp_ind), and `t` is *lookback* time.
  !
  ! Inputs
  ! -------
  !
  ! sspind:
  !    The index of the SSP forming the bracket with the SSP you are getting a
  !    weight for.
  !
  ! t:
  !    Where the indefinite integral is evaluated, linear years (lookback time).
  !
  ! sfh:
  !    Structure containing the SFH parameters in units of years, including an
  !    integer `type` specifiying the form of SFR(t).
  !
  ! Outputs
  !--------
  !  sfwght_lin:
  !    The indefinite integral, evaluated at `t`

  use sps_vars, only: time_full, tiny_logt, SFHPARAMS, SP
  implicit none

  integer, intent(in) :: sspind
  real(SP), intent(in) :: t
  type(SFHPARAMS), intent(in) :: sfh

  real(SP) :: sfwght_lin

  real(SP) :: age, tprime
  real(SP) :: a

  ! Convert from log(age_ssp) to age_ssp,
  ! accounting for the case sspind=0 (where age~0)
  if (sspind.gt.0) then
     age = 10**time_full(sspind)
  else
     age = 10**tiny_logt
  endif

  if (sfh%type.eq.0) then
     ! SFR = Constant ~ 1
     sfwght_lin = age * t - t**2 / 2

  else if (sfh%type.eq.1) then
     ! SFR = exponential ~ 1/tau * exp(-T/tau)
     tprime = t / sfh%tau
     sfwght_lin = (age - t + sfh%tau) * exp(tprime)

  else if (sfh%type.eq.4) then
     ! SFR = delayed exponential ~ T/tau**2 * exp(-T/tau)
     tprime = t / sfh%tau
     a = sfh%tage * age - (sfh%tage + age) * (t - sfh%tau) + &
          t**2 - 2*t*sfh%tau + 2*sfh%tau**2
     sfwght_lin = a * exp(tprime)

  else if (sfh%type.eq.5) then
     ! SFR = linear ~ (1 - sf_slope * (T - T_trunc)), T > T_trunc
     tprime = max(0.0, sfh%tage - sfh%sf_trunc) !t_q
     a = 1 - sfh%sf_slope * tprime
     sfwght_lin = a * age * t + (sfh%sf_slope*age - a) * t**2 / 2 - sfh%sf_slope * t**3 / 3

  endif

end function sfwght_lin

FUNCTION EI(X)
!
! ============================================
! Purpose: Compute exponential integral Ei(x)
! Input :  x  --- Argument of Ei(x)
! Output:  EI --- Ei(x)
!
! Shanjie Zhang and Jianming Jin
!
!  Copyrighted but permission granted to use code in programs.
!  Buy their book "Computation of Special Functions", 1996, John Wiley & Sons, Inc.
!
!       ============================================
!
  implicit none
  INTEGER, PARAMETER :: SP = KIND(1.d0)
  REAL(SP) :: X, EI

  INTEGER :: K, MAXIT=1000
  REAL(SP), PARAMETER :: GA=0.5772156649015328D0, eps=1.0D-20
  REAL(SP) :: R

  IF (X.EQ.0.0) THEN
     EI=-1.0D+300
  ELSE IF (X .LT. 0) THEN
     WRITE(*,*) "EI: X < 0."
     STOP
  ELSE IF (DABS(X).LE.40.0) THEN
     ! Power series around x=0
     EI=1.0D0
     R=1.0D0
     DO K = 1, MAXIT
        R = R*K*X / (K+1.0D0)**2
        EI = EI+R
        IF (DABS(R/EI).LE.eps) THEN
           CONTINUE
        ELSE IF (K.eq.MAXIT) then
           write(*,*) "EI: Series failed to converge."
           STOP
        ENDIF

     ENDDO
     EI=GA+DLOG(X)+X*EI

  ELSE
     ! Asymptotic expansion (the series is not convergent)
     EI=1.0D0
     R=1.0D0
     DO K=1,20
        R=R*K/X
        EI=EI+R
     ENDDO
     EI=DEXP(X)/X*EI
  ENDIF
  RETURN
END FUNCTION EI


module sort

contains
!---------------------------------------------------
subroutine insert_sort(myarray,fun)
implicit none

double precision, intent(inout) :: myarray(:)
double precision, optional      :: fun
integer                         :: i,j
double precision                :: key

do j = 2, size(myarray)
 key = myarray(j)
 i = j - 1
 do while ( (i > 0) .and. (myarray(i) > key) )
    myarray(i+1) = myarray(i)
    i = i - 1
 end do
 myarray(i+1)=key
end do

end subroutine insert_sort
!---------------------------------------------------
subroutine shake_sort(myarray)
implicit none

double precision, intent(inout) :: myarray(:)
integer                         :: left, right, i,j
double precision                :: tmp

left = 2
right = size(myarray)

do while (left <= right)
  i = right
  j = left
  do while (i>=left)
     if (myarray(i-1) > myarray(i)) then
        tmp = myarray(i)
        myarray(i) = myarray(i-1)
        myarray(i-1) = tmp
     end if
     i = i-1
  end do
  left = left+1

  do while (j<=right)
    if (myarray(j-1) > myarray(j)) then
       tmp = myarray(j)
       myarray(j) = myarray(j-1)
       myarray(j-1) = tmp
    end if
    j =j+1
  end do
  right = right-1
end do

end subroutine shake_sort
!--------------------------------------------------
end module


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.16 (master) -  9 Oct 2020 17:47
!
MODULE MOD_MEAN_D
  USE MOD_MATH_D, ONLY : divide_d, add_d
  IMPLICIT NONE
  PUBLIC :: mean_d
  PRIVATE

CONTAINS
!  Differentiation of mean in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: b
!   with respect to varying inputs: a
!   RW status of diff variables: a:in b:out
  SUBROUTINE MEAN_D(a, ad, b, bd)
    IMPLICIT NONE
    real(8), DIMENSION(:), INTENT(INOUT) :: a
    real(8), DIMENSION(:), INTENT(INOUT) :: ad
    real(8), INTENT(INOUT) :: b
    real(8), INTENT(INOUT) :: bd
    real(8) :: temp
    real(8) :: tempd
    real(8) :: n
    INTEGER*8 :: i
    INTRINSIC SIZE
    INTRINSIC REAL
    INTRINSIC INT
    n = REAL(SIZE(a), 8)
    b = 0.0
    bd = 0.0_8
    DO i=1,INT(n)
      CALL ADD_D(b, bd, a(i), ad(i), temp, tempd)
      bd = tempd
      b = temp
    END DO
    CALL DIVIDE_D(b, bd, n, temp, tempd)
    bd = tempd
    b = temp
  END SUBROUTINE MEAN_D

END MODULE MOD_MEAN_D


      SUBROUTINE CLARSCL2 ( M, N, D, X, LDX )
*
*     -- LAPACK routine (version 3.2.1)                               --
*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
*     -- Jason Riedy of Univ. of California Berkeley.                 --
*     -- April 2009                                                   --
*
*     -- LAPACK is a software package provided by Univ. of Tennessee, --
*     -- Univ. of California Berkeley and NAG Ltd.                    --
*
      IMPLICIT NONE
*     ..
*     .. Scalar Arguments ..
      INTEGER            M, N, LDX
*     ..
*     .. Array Arguments ..
      COMPLEX            X( LDX, * )
      REAL               D( * )
*     ..
*
*  Purpose
*  =======
*
*  CLARSCL2 performs a reciprocal diagonal scaling on an vector:
*    x <-- inv(D) * x
*  where the REAL diagonal matrix D is stored as a vector.
*
*  Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS
*  standard.
*
*  Arguments
*  =========
*
*     M       (input) INTEGER
*     The number of rows of D and X. M >= 0.
*
*     N       (input) INTEGER
*     The number of columns of D and X. N >= 0.
*
*     D       (input) REAL array, length M
*     Diagonal matrix D, stored as a vector of length M.
*
*     X       (input/output) COMPLEX array, dimension (LDX,N)
*     On entry, the vector X to be scaled by D.
*     On exit, the scaled vector.
*
*     LDX     (input) INTEGER
*     The leading dimension of the vector X. LDX >= 0.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. Executable Statements ..
*
      DO J = 1, N
         DO I = 1, M
            X( I, J ) = X( I, J ) / D( I )
         END DO
      END DO

      RETURN
      END


!----------------------------------------------------------------------
!   lor:  Point-to-cycle connection in the Lorenz model via homotopy
!----------------------------------------------------------------------

!----------------------------------------------------------------------
!     Adjoint scaled eigenfunction of the cycle in the Lorenz model
!
!     PAR(10)=square norm of the eigenfunction at T=0
!     PAR(12)=log(FM)
!----------------------------------------------------------------------

  SUBROUTINE RHS(N,U,PAR,F,DFDU,IJAC)
! ---------- ----

    IMPLICIT NONE
    INTEGER N
    DOUBLE PRECISION U(N),PAR(*),F(N),DFDU(N,N)
    LOGICAL IJAC

    DOUBLE PRECISION x,y,z,r,b,sigma

!     System parameters
!     PAR(1)		! r
!     PAR(2)		! b
!     PAR(3)		! sigma

!     Variables
    x=U(1)
    y=U(2)
    z=U(3)
!     Parameters
    r=PAR(1)
    b=PAR(2)
    sigma=PAR(3)
!     RHS
    F(1)=sigma*(y-x)
    F(2)=r*x-y-x*z
    F(3)=x*y-b*z

    IF(.NOT.IJAC)RETURN

!     Jacobian elements
    DFDU(1,1)=-sigma
    DFDU(1,2)=sigma
    DFDU(1,3)=0.0d0
    DFDU(2,1)=r-z
    DFDU(2,2)=-1.d0
    DFDU(2,3)=-x
    DFDU(3,1)=y
    DFDU(3,2)=x
    DFDU(3,3)=-b

  END SUBROUTINE RHS

  SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
! ---------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
    DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
    DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

    DOUBLE PRECISION A(3,3)
!     Variables
!     U(1)-U(3) = limit cycle
!     U(4)-U(6) = adjoint eigenfunction
!     U(7)-U(9) = connecting orbit
!     Cycle equations
    CALL RHS(3,U,PAR,F,A,NDIM/=3)
    IF(NDIM==3)RETURN
    F(1:3) = PAR(11)*F(1:3)

!     Adjoint variational equations
!     PAR(11) = cycle period
!     PAR(12) = log(FM)
    F(4:6) = -PAR(11)*MATMUL(TRANSPOSE(A(:,:)),U(4:6))-PAR(12)*U(4:6)
    IF(NDIM==6)RETURN

!     Connecting orbit equations
    CALL RHS(3,U(7),PAR,F(7),A,.FALSE.)
!     PAR(13) = connection interval
    F(7:9) = PAR(13)*F(7:9)

  END SUBROUTINE FUNC

  SUBROUTINE STPNT(NDIM,U,PAR,T)
! ---------- -----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM
    DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM), PAR(*)
    DOUBLE PRECISION, INTENT(IN) :: T

    DOUBLE PRECISION r,b,sigma,v1,v2,v3,vnorm,eps,i

    IF (NDIM==9) THEN
       !extend system
       eps=PAR(23)
       U(7:9)=PAR(14:16) + eps*PAR(17:19)
       RETURN
    ENDIF

! Parameter values for the starting equilibrium
    r=0.d0
    b=8.0d0/3.0d0
    sigma=10.0d0
    U(1:3)=0.

    PAR(1)=r
    PAR(2)=b
    PAR(3)=sigma
!     Eigenvalue approx
    PAR(12)=-1.0d0
!     Initial connection time
    PAR(13)=0.0d0

!     Equilibrium coordinates
    PAR(14:16)=U(1:3)

!     Normalized exit eigenvector of the equilibrium
    r=21.0d0
    v1=1.0-sigma+SQRT((1.0-sigma)**2+4.0*r*sigma)
    v2=2.0*r
    v3=0.0D0
    vnorm=SQRT(v1**2+v2**2+v3**2)
    PAR(17)=v1/vnorm
    PAR(18)=v2/vnorm
    PAR(19)=v3/vnorm
!     Exit eigenvalue
    PAR(20)=(-1.0d0-sigma+SQRT((1.0d0-sigma)**2+4.0d0*r*sigma))/2.0d0

! epsilon for the starting point y0
    PAR(23)=-1d-4

  END SUBROUTINE STPNT

  SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
! ---------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
    DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
    DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
    DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

    DOUBLE PRECISION X(3),R(3),A(3,3),V(3),H(3),epsilon,rlambda

!     Periodic boundary conditions
!     ----------------------------
    FB(1:3) = U0(1:3) - U1(1:3)
    FB(4:6) = U1(4:6) - U0(4:6)

!     Eigenfunction normalisation
    FB(7) = DOT_PRODUCT(U0(4:6),U0(4:6)) - PAR(10)
    IF(NBC == 7)RETURN

    ! Exit eigenvector
    V(:) = PAR(17:19)

    ! Connecting orbit starting point
    epsilon = PAR(23)
    FB(8:10) = U0(7:9)-PAR(14:16)-epsilon*V(:)

    ! Equilibrium coordinates
    CALL RHS(3,PAR(14:16),PAR,FB(11:13),A,.TRUE.)

    ! Exit eigenvalue
    rlambda = PAR(20)
    FB(14:16) = MATMUL(A(:,:),V(:))-rlambda*V(:)

    ! Exit vector normalization
    FB(17) = DOT_PRODUCT(V(:),V(:)) - 1.0d0

    ! Connection endpoint in the orthogonal plane to velocity
    H(:) = U1(7:9) - U0(1:3)
    CALL RHS(3,U0,PAR,R,A,.FALSE.)
    FB(18) = DOT_PRODUCT(H(:),R(:)) - PAR(21)

    ! Projection boundary condition at the endpoint
    FB(19) = DOT_PRODUCT(H(:),U0(4:6)) - PAR(22)

  END SUBROUTINE BCND

  SUBROUTINE PVLS(NDIM,U,PAR)
! ---------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
    DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
    DOUBLE PRECISION GETP

    DOUBLE PRECISION X(3),W(3),F(3),A(3,3),H(3),length

    IF(NDIM==6)THEN
       ! Initial values for homotopy parameters
       ! Base point on the cycle
       X(1)=GETP('BV0',1,U)
       X(2)=GETP('BV0',2,U)
       X(3)=GETP('BV0',3,U)
       ! End point of the initial connection
       length=PAR(23)*EXP(PAR(20)*PAR(13))
       H(1:3)=PAR(14:16)+length*PAR(17:19)-X(1:3)
       CALL RHS(3,X,PAR,F,A,.FALSE.)

       ! Homotopy parameter
       PAR(21) = DOT_PRODUCT(H,F)

       ! Eigenfunction at t=0
       W(1)=GETP('BV0',4,U)
       W(2)=GETP('BV0',5,U)
       W(3)=GETP('BV0',6,U)
       ! Homotopy parameter
       PAR(22) = DOT_PRODUCT(H,W)
    ENDIF

  END SUBROUTINE PVLS

  SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
! ---------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
    DOUBLE PRECISION, INTENT(IN) :: PAR(*)
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM),UOLD(NDIM),UDOT(NDIM),UPOLD(NDIM)
    DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
    DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

    ! Integral phase condition
    ! ------------------------
    FI(1) = DOT_PRODUCT(U(:3),UPOLD(:3))

  END SUBROUTINE ICND

  SUBROUTINE FOPT
  END SUBROUTINE FOPT


! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! The following is a simple example problem for IDA, due to Robertson,
! is from chemical kinetics, and consists of the following three
! equations:
!
!      dy1/dt = -.04*y1 + 1.e4*y2*y3
!      dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
!         0   = y1 + y2 + y3 - 1
!
! on the interval from t = 0.0 to t = 4.e10, with initial
! conditions: y1 = 1, y2 = y3 = 0.
!
! While integrating the system, we also use the rootfinding
! feature to find the points at which y1 = 1e-4 or at which
! y3 = 0.01.
!
! The problem is solved with IDA using the DENSE linear
! solver, with a user-supplied Jacobian. Output is printed at
! t = .4, 4, 40, ..., 4e10.
! ------------------------------------------------------------------

module dae_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none

  integer(c_long), parameter :: neq = 3
  integer(c_long), parameter :: nout = 12

contains

  ! ----------------------------------------------------------------
  ! resrob: The DAE residual function
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function resrob(tres, sunvec_y, sunvec_yp, sunvec_r, user_data) &
       result(ierr) bind(C,name='resrob')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fnvector_serial_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tres      ! current time
    type(N_Vector)        :: sunvec_y  ! solution N_Vector
    type(N_Vector)        :: sunvec_yp ! derivative N_Vector
    type(N_Vector)        :: sunvec_r  ! residual N_Vector
    type(c_ptr),    value :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: yval(:)
    real(c_double), pointer :: ypval(:)
    real(c_double), pointer :: rval(:)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    yval  => FN_VGetArrayPointer(sunvec_y)
    ypval => FN_VGetArrayPointer(sunvec_yp)
    rval  => FN_VGetArrayPointer(sunvec_r)

    ! fill residual vector
    rval(1)  = -0.04d0*yval(1) + 1.0d4*yval(2)*yval(3)
    rval(2)  = -rval(1) - 3.0d7*yval(2)**2 - ypval(2)
    rval(1)  = rval(1) - ypval(1)
    rval(3)  = yval(1) + yval(2) + yval(3) - 1.d0

    ! return success
    ierr = 0
    return

  end function resrob

  ! ----------------------------------------------------------------
  ! grob: The root function routine
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function grob(t, sunvec_y, sunvec_yp, gout, user_data) &
       result(ierr) bind(C,name='grob')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fnvector_serial_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: t         ! current time
    type(N_Vector)        :: sunvec_y  ! solution N_Vector
    type(N_Vector)        :: sunvec_yp ! derivative N_Vector
    real(c_double)        :: gout(2)   ! root function values
    type(c_ptr),    value :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: yval(:)

    !======= Internals ============

    ! get data array from SUNDIALS vector
    yval => FN_VGetArrayPointer(sunvec_y)

    ! fill root vector
    gout(1) = yval(1) - 0.0001d0
    gout(2) = yval(3) - 0.01d0

    ! return success
    ierr = 0
    return

  end function grob

  ! ----------------------------------------------------------------
  ! jacrob: The DAE Jacobian function
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function jacrob(t, cj, sunvec_y, sunvec_yp, sunvec_r, &
       sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) &
       result(ierr) bind(C,name='jacrob')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsundials_matrix_mod
    use fnvector_serial_mod
    use fsunmatrix_dense_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: t         ! current time
    real(c_double), value :: cj        ! step size scaling factor
    type(N_Vector)        :: sunvec_y  ! solution N_Vector
    type(N_Vector)        :: sunvec_yp ! derivative N_Vector
    type(N_Vector)        :: sunvec_r  ! residual N_Vector
    type(SUNMatrix)       :: sunmat_J  ! Jacobian SUNMatrix
    type(c_ptr),    value :: user_data ! user-defined data
    type(N_Vector)        :: sunvec_t1 ! temporary N_Vectors
    type(N_Vector)        :: sunvec_t2
    type(N_Vector)        :: sunvec_t3

    ! pointers to data in SUNDIALS vector and matrix
    real(c_double), pointer :: yval(:)
    real(c_double), pointer :: J(:,:)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    yval => FN_VGetArrayPointer(sunvec_y)
    j(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J)

    ! fill Jacobian entries
    J(1,1) = -0.04d0 - cj
    J(2,1) = 0.04d0
    J(3,1) = 1.d0
    J(1,2) = 1.d4*yval(3)
    J(2,2) = -1.d4*yval(3) - 6.0d7*yval(2) - cj
    J(3,2) = 1.d0
    J(1,3) = 1.d4*yval(2)
    J(2,3) = -1.d4*yval(2)
    J(3,3) = 1.d0

    ! return success
    ierr = 0
    return

  end function jacrob

  ! ----------------------------------------------------------------
  ! check_ans: checks the solution error
  ! ----------------------------------------------------------------
  integer(c_int) function check_ans(y, t, rtol, atol) result(passfail)

    !======= Inclusions ===========
    use iso_c_binding

    !======= Declarations =========
    implicit none
    real(c_double) :: y(neq), atol(neq), t, rtol
    real(c_double) :: ref(neq), ewt(neq), err

    !======= Internals ============

    ! set the reference solution data
    ref(1) = 5.2083474251394888d-8
    ref(2) = 2.0833390772616859d-13
    ref(3) = 9.9999994791631752d-1

    ! compute the error weight vector, loosen atol by 10x
    ewt = 1.d0/(rtol*dabs(ref) + 10.d0*atol)

    ! compute the solution error
    ref = y-ref
    err = dsqrt( dot_product(ewt*ref,ewt*ref)/3 )

    ! is the solution within the tolerances (pass=0 or fail=1)?
    passfail = 0
    if (err .ge. 1.d0) then
       passfail = 1
       print *, " "
       print *, "SUNDIALS_WARNING: check_ans error=", err
       print *, " "
    end if

    return

  end function check_ans

end module dae_mod
! ------------------------------------------------------------------

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fida_mod                      ! Fortran interface to IDA
  use fnvector_serial_mod           ! Fortran interface to serial N_Vector
  use fsunmatrix_dense_mod          ! Fortran interface to dense SUNMatrix
  use fsunlinsol_dense_mod          ! Fortran interface to dense SUNLinearSolver
  use fsunnonlinsol_newton_mod      ! Fortran interface to Newton SUNNonlinearSolver
  use fsundials_matrix_mod          ! Fortran interface to generic SUNMatrix
  use fsundials_nvector_mod         ! Fortran interface to generic N_Vector
  use fsundials_linearsolver_mod    ! Fortran interface to generic SUNLinearSolver
  use fsundials_nonlinearsolver_mod ! Fortran interface to generic SUNNonlinearSolver
  use dae_mod                       ! ODE functions

  !======= Declarations =========
  implicit none

  ! local variables
  real(c_double) :: rtol, t0, tout1, tout, tret(1)
  integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2)

  type(N_Vector),           pointer :: sunvec_y      ! sundials solution vector
  type(N_Vector),           pointer :: sunvec_yp     ! sundials derivative vector
  type(N_Vector),           pointer :: sunvec_av     ! sundials tolerance vector
  type(SUNMatrix),          pointer :: sunmat_A      ! sundials matrix
  type(SUNLinearSolver),    pointer :: sunlinsol_LS  ! sundials linear solver
  type(SUNNonLinearSolver), pointer :: sunnonlin_NLS ! sundials nonlinear solver
  type(c_ptr)                       :: ida_mem       ! IDA memory

  ! solution and tolerance vectors, neq is set in the dae_mod module
  real(c_double) :: yval(neq), ypval(neq), avtol(neq)

  !======= Internals ============

  ! initialize solution vectors and tolerances
  yval(1) = 1.d0
  yval(2) = 0.d0
  yval(3) = 0.d0

  ypval(1) = -0.040
  ypval(2) = 0.04d0
  ypval(3) = 0.d0

  rtol = 1.d-4

  avtol(1) = 1.d-8
  avtol(2) = 1.d-6
  avtol(3) = 1.d-6

  ! create serial vectors
  sunvec_y => FN_VMake_Serial(neq, yval)
  if (.not. associated(sunvec_y)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_yp => FN_VMake_Serial(neq, ypval)
  if (.not. associated(sunvec_yp)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_av => FN_VMake_Serial(neq, avtol)
  if (.not. associated(sunvec_av)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  ! set integration limits
  t0 = 0.d0
  tout1 = 0.4d0

  call PrintHeader(rtol, avtol, yval)

  ! Call FIDACreate and FIDAInit to initialize IDA memory
  ida_mem = FIDACreate()
  if (.not. c_associated(ida_mem)) then
     print *, 'ERROR: ida_mem = NULL'
     stop 1
  end if

  retval = FIDAInit(ida_mem, c_funloc(resrob), t0, sunvec_y, sunvec_yp)
  if (retval /= 0) then
     print *, 'Error in FIDAInit, retval = ', retval, '; halting'
     stop 1
  end if

  ! Call FIDASVtolerances to set tolerances
  retval = FIDASVtolerances(ida_mem, rtol, sunvec_av)
  if (retval /= 0) then
     print *, 'Error in FIDASVtolerances, retval = ', retval, '; halting'
     stop 1
  end if

  ! Call FIDARootInit to specify the root function grob with 2 components
  nrtfn = 2
  retval = FIDARootInit(ida_mem, nrtfn, c_funloc(grob))
  if (retval /= 0) then
     print *, 'Error in FIDARootInit, retval = ', retval, '; halting'
     stop 1
  end if

  ! Create dense SUNMatrix for use in linear solves
  sunmat_A => FSUNDenseMatrix(neq, neq)
  if (.not. associated(sunmat_A)) then
     print *, 'ERROR: sunmat = NULL'
     stop 1
  end if

  ! Create dense SUNLinearSolver object
  sunlinsol_LS => FSUNDenseLinearSolver(sunvec_y, sunmat_A)
  if (.not. associated(sunlinsol_LS)) then
     print *, 'ERROR: sunlinsol = NULL'
     stop 1
  end if

  ! Attach the matrix and linear solver
  retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A);
  if (retval /= 0) then
     print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting'
     stop 1
  end if

  ! Set the user-supplied Jacobian routine
  retval = FIDASetJacFn(ida_mem, c_funloc(jacrob))
  if (retval /= 0) then
     print *, 'Error in FIDASetJacFn, retval = ', retval, '; halting'
     stop 1
  end if

  ! Create Newton SUNNonlinearSolver object. IDA uses a
  ! Newton SUNNonlinearSolver by default, so it is not necessary
  ! to create it and attach it. It is done in this example code
  ! solely for demonstration purposes.
  sunnonlin_NLS => FSUNNonlinSol_Newton(sunvec_y)
  if (.not. associated(sunnonlin_NLS)) then
     print *, 'ERROR: sunnonlinsol = NULL'
     stop 1
  end if

  ! Attach the nonlinear solver
  retval = FIDASetNonlinearSolver(ida_mem, sunnonlin_NLS)
  if (retval /= 0) then
     print *, 'Error in FIDASetNonlinearSolver, retval = ', retval, '; halting'
     stop 1
  end if

  ! In loop, call IDASolve, print results, and test for error.
  ! Break out of loop when NOUT preset output times have been reached.

  iout = 0
  tout = tout1
  do

     retval = FIDASolve(ida_mem, tout, tret, sunvec_y, sunvec_yp, IDA_NORMAL)
     if (retval < 0) then
        print *, 'Error in FIDASolve, retval = ', retval, '; halting'
        stop 1
     endif

     call PrintOutput(ida_mem, tret(1), yval)

     if (retval .eq. IDA_ROOT_RETURN) then
        retvalr = FIDAGetRootInfo(ida_mem, rootsfound)
        if (retvalr < 0) then
           print *, 'Error in FIDAGetRootInfo, retval = ', retval, '; halting'
           stop 1
        endif
        print '(a,2(i2,2x))', "    rootsfound[] = ", rootsfound(1), rootsfound(2)
     end if

     if (retval .eq. IDA_SUCCESS) then
        iout = iout+1
        tout = tout*10.d0
     end if

     if (iout .eq. NOUT) exit

  end do

  call PrintFinalStats(ida_mem)

  retval = check_ans(yval, tret(1), rtol, avtol)

  ! free memory
  call FIDAFree(ida_mem)
  retval = FSUNNonlinSolFree(sunnonlin_NLS)
  retval = FSUNLinSolFree(sunlinsol_LS)
  call FSUNMatDestroy(sunmat_A)
  call FN_VDestroy(sunvec_y)
  call FN_VDestroy(sunvec_av)
  call FN_VDestroy(sunvec_yp)

end program main

! ----------------------------------------------------------------
! PrintHeader: prints first lines of output (problem description)
! ----------------------------------------------------------------
subroutine PrintHeader(rtol, avtol, y)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use dae_mod

  !======= Declarations =========
  implicit none

  ! calling variable
  real(c_double) :: rtol
  real(c_double) :: avtol(neq)
  real(c_double) :: y(neq)

  !======= Internals ============

  print *, " "
  print *, "idaRoberts_dns_f2003: Robertson kinetics DAE serial example problem for IDA"
  print *, "         Three equation chemical kinetics problem."
  print *, " "
  print *, "Linear solver: DENSE, with user-supplied Jacobian."
  print '(a,f6.4,a,3(es6.0,1x))', "Tolerance parameters:  rtol = ",rtol,"   atol = ", avtol
  print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")"
  print *, "Constraints and id not used."
  print *, " "
  print *, "-----------------------------------------------------------------------"
  print *, "  t             y1           y2           y3     | nst  k      h"
  print *, "-----------------------------------------------------------------------"

  return
end subroutine PrintHeader

! ----------------------------------------------------------------
! PrintOutput
! ----------------------------------------------------------------
subroutine PrintOutput(ida_mem, t, y)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use fida_mod
  use dae_mod

  !======= Declarations =========
  implicit none

  ! calling variable
  type(c_ptr)    :: ida_mem
  real(c_double) :: t, y(neq)

  ! internal variables
  integer(c_int)  :: retval, kused(1)
  integer(c_long) :: nst(1)
  real(c_double)  :: hused(1)

  !======= Internals ============

  retval = FIDAGetLastOrder(ida_mem, kused)
  if (retval /= 0) then
     print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumSteps(ida_mem, nst)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetLastStep(ida_mem, hused)
  if (retval /= 0) then
     print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting'
     stop 1
  end if

  print '(es10.4,1x,3(es12.4,1x),a,i3,2x,i1,1x,es12.4)', &
       t, y(1), y(2), y(3), "| ", nst, kused(1), hused(1)

end subroutine PrintOutput

! ----------------------------------------------------------------
! PrintFinalStats
!
! Print KINSOL statstics to standard out
! ----------------------------------------------------------------
subroutine PrintFinalStats(ida_mem)

  !======= Inclusions ===========
  use iso_c_binding
  use fida_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: ida_mem
  integer(c_int)  :: retval
  integer(c_long) :: nst(1), nni(1), nje(1), nre(1), nreLS(1), nge(1), ncfn(1), netf(1)

  !======= Internals ============

  retval = FIDAGetNumSteps(ida_mem, nst)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumResEvals(ida_mem, nre)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumJacEvals(ida_mem, nje)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumJacEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumNonlinSolvIters(ida_mem, nni)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumErrTestFails(ida_mem, netf)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumLinResEvals(ida_mem, nreLS)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumGEvals(ida_mem, nge)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumGEvals, retval = ', retval, '; halting'
     stop 1
  end if

  print *, " "
  print *, "Final Run Statistics: "
  print *, "Number of steps                    = ", nst
  print *, "Number of residual evaluations     = ", nre+nreLS
  print *, "Number of Jacobian evaluations     = ", nje
  print *, "Number of nonlinear iterations     = ", nni
  print *, "Number of error test failures      = ", netf
  print *, "Number of nonlinear conv. failures = ", ncfn
  print *, "Number of root fn. evaluations     = ", nge

  return

end subroutine PrintFinalStats


subroutine SHMTCouplingMatrix(Mmt, lmax, tapers_power, lwin, K, taper_wt, &
                              exitstatus)
!------------------------------------------------------------------------------
!
!   This routine returns the multitaper coupling matrix, which relates the
!   global input spectrum to the expectation of the localized multitaper
!   spectrum.
!
!   < S_{Phi Phi}^(mt) > = M^(mt) S_{ff}
!
!   This is given by eqs 4.5 and 4.6 of Wieczorek and Simons (2007).
!   The input tapers_power is a matrix containing the power spectra (in
!   columns) of all the localization windows. When using spherical cap
!   localization windows, this is simply
!
!   tapers_power[:,:] = tapers[:,:]**2
!
!   Note that this routine returns the "full" coupling matrix of dimension
!   (lmax+lwin+1, lmax+1). When multiplied by a global input power spectrum
!   with bandwidth lmax, it returns the output power spectrum with a bandwidth
!   of lmax+lwin. In doing so, it is implicitly assumed that input power
!   spectrum is exactly zero for all degrees greater than lmax. If this is not
!   the case, the ouput power spectrum should be considered valid only
!   for the degrees up to and including lmax-lwin.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: wigner3j

    implicit none
    real*8, intent(out) :: Mmt(:,:)
    real*8, intent(in) :: tapers_power(:,:)
    real*8, intent(in), optional :: taper_wt(:)
    integer, intent(in) :: lmax, K, lwin
    integer, intent(out), optional :: exitstatus
    real*8 :: w3j(lwin+2*lmax+1), sum1
    integer :: i, j, l, wmin, wmax

    if (present(exitstatus)) exitstatus = 0

    if  (size(Mmt(:,1)) < lmax+lwin+1 .or. size(Mmt(1,:)) < lmax+1) then
        print*, "Error --- SHMTCouplingMatrix"
        print*, "MMT must be dimensioned as (LMAX+LWIN+1, LMAX+1) where "// &
                "LMAX and LWIN are ", lmax, lwin
        print*, "Input array is dimensioned as ", size(Mmt(:,1)), size(Mmt(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    endif

    if (size(tapers_power(:,1)) < lwin+1 .or. size(tapers_power(1,:)) < K) then
        print*, "Error --- SHMTCouplingMatrix"
        print*, "TAPERS_POWER must be dimensioned as (LWIN+1, K) where LWIN "// &
                "and K are ", lwin, k
        print*, "Input array is dimensioned as ", size(tapers_power(:,1)), &
            size(tapers_power(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    endif

    if (present(taper_wt)) then
        if (size(taper_wt) < K) then
            print*, "Error --- SHMTCouplingMatrix"
            print*, "TAPER_WT must be dimensioned as (K) where K is ", k
            print*, "Input array is dimensioned as ", size(taper_wt)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if
        endif

    endif

    !--------------------------------------------------------------------------
    !
    !   Compute coupling matrix, M^(mt)
    !
    !--------------------------------------------------------------------------

    if (present(taper_wt)) then

        do i=0, lmax+lwin
            do j=0, lmax
                if (present(exitstatus)) then
                    call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0, &
                                  exitstatus = exitstatus)
                    if (exitstatus /= 0) return
                else
                    call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0)
                end if
                sum1 = 0.0d0

                do l = wmin, min(wmax,lwin), 2
                    sum1 = sum1 + dot_product(taper_wt(1:K), &
                           tapers_power(l+1,1:K)) * w3j(l-wmin+1)**2
                enddo

                Mmt(i+1,j+1) = sum1 * dble(2*i+1)

            end do
        end do

    else

        do i = 0, lmax+lwin
            do j = 0, lmax
                if (present(exitstatus)) then
                    call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0, &
                                  exitstatus = exitstatus)
                    if (exitstatus /= 0) return
                else
                    call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0)
                end if
                sum1 = 0.0d0

                do l = wmin, min(wmax,lwin), 2
                    sum1 = sum1 + sum(tapers_power(l+1,1:K)) * w3j(l-wmin+1)**2
                enddo

                Mmt(i+1,j+1) = sum1 * dble(2*i+1) / dble(K)

            end do
        end do

    end if

end subroutine SHMTCouplingMatrix


c     Program DRZPOLZ
c>> 2009-10-27 DRZPOLZ Krogh/Snyder Added ',' in format stmt.
c>> 1996-06-14 DRZPOLZ Krogh Set for deriving C vers.
c>> 1992-03-06 DRZPOLZ CLL
c>> 1987-12-09 DRZPOLZ  Lawson  Initial Code.
c Conversion should only be done from "Z" to "C" for processing to C.
c--Z replaces "?": DR?POLZ, ?POLZ
c     Demonstration driver for ZPOLZ.
c     ------------------------------------------------------------------
      double precision A1(2,4), A2(2,6), A3(2,6), H(50)
      double precision Z(2,5)
      integer  N1, N2, N3, IERR
c%%   long int i;
      integer  I, K
c
      data A1 / 1.D0, 0.D0, -4.D0, 0.D0, 1.D0, 0.D0, -4.D0, 0.D0 /
      data A2 / 1.D0, 0.D0, -15.D0, 0.D0, 85.D0, 0.D0, -225.D0, 0.D0,
     *          274.D0, 0.D0, -120.D0, 0.D0 /
      data A3 / 1.0d0, 0.0d0,   -5.5d0, -1.5d0,
     *         10.00d0,   7.750d0,  -7.500d0,  -13.25d0,
     *         -1.000d0,   11.00d0,  3.000d0,  -1.500d0/
c     ------------------------------------------------------------------
      N1 = 3
      N2 = 5
      N3 = 5
c
      call ZPOLZ(A1,N1,Z,H,IERR)
c++ CODE for ~.C. is active
  100 format(' Degree =',I2//
     *       ' Coefficients ='/
     *       (2(1X:'(',1X,F14.9,',',1X,F14.9,1X,')',2X)))
  200 format(/' Roots ='/(2(1X,'(',1X,F14.9,',',1X,F14.9,1X,')':2X)))
c
      print 100, N1, ((A1(K,I),K=1,2),I=1,N1+1)
      print 200, ((Z(K,I),K=1,2),I=1,N1)
c
      print'(/)'
      print 100, N2, ((A2(K,I),K=1,2),I=1,N2+1)
      call ZPOLZ(A2,N2,Z,H,IERR)
      print 200, ((Z(K,I),K=1,2),I=1,N2)
c
      print'(/)'
      print 100, N3, ((A3(K,I),K=1,2),I=1,N3+1)
      call ZPOLZ(A3,N3,Z,H,IERR)
      print 200, ((Z(K,I),K=1,2),I=1,N3)
c++ CODE for .C. is inactive
c%%   printf( " Degree =%2ld\n\n Coefficients =\n", n1 );
c%%   for (i = 0; i <= n1; i+=2){
c%%     printf( " (%14.9f, %14.9f )", a1[i][0], a1[i][1] );
c%%     if (i < n1) printf( "  (%14.9f, %14.9f )", a1[i+1][0],
c%%        a1[i+1][1] );
c%%     printf( " \n" );}
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i <= (n1-1); i+=2){
c%%     printf( " (%14.9f, %14.9f )", z[i][0], z[i][1] );
c%%     if (i < (n1-1)) printf( " (%14.9f, %14.9f )", z[i+1][0],
c%%        z[i+1][1] );
c%%     printf( " \n" );}
c%%
c%%   printf( "\n\n Degree =%2ld\n\n Coefficients =\n", n2 );
c%%   for (i = 0; i <= n2; i+=2){
c%%     printf( " (%14.9f, %14.9f )", a2[i][0], a2[i][1] );
c%%     if (i < n2) printf( "  (%14.9f, %14.9f )", a2[i+1][0],
c%%        a2[i+1][1] );
c%%     printf( "\n" );}
c%%   zpolz( a2, n2, z, h, &ierr );
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i <= (n2-1); i+=2){
c%%     printf( " (%14.9f, %14.9f )", z[i][0], z[i][1] );
c%%     if (i < (n2-1)) printf( "  (%14.9f, %14.9f )", z[i+1][0],
c%%        z[i+1][1] );
c%%     printf( " \n" );}
c%%
c%%   printf( "\n\n Degree =%2ld\n\n Coefficients =\n", n3 );
c%%   for (i = 0; i <= n3; i+=2){
c%%     printf( " (%14.9f, %14.9f )", a3[i][0], a3[i][1] );
c%%     if (i < n3) printf( "  (%14.9f, %14.9f )", a3[i+1][0],
c%%        a3[i+1][1] );
c%%     printf( "\n" );}
c%%   zpolz( a3, n3, z, h, &ierr );
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i <= (n3-1); i+=2){
c%%     printf( " (%14.9f, %14.9f )", z[i][0], z[i][1] );
c%%     if (i < (n3-1)) printf( "  (%14.9f, %14.9f )", z[i+1][0],
c%%        z[i+1][1] );
c%%     printf( " \n" );}
c++ END
      end


! store AB into (already-allocated) C, where A is m-by-n and B is n-by-p
subroutine matrix_multiply(pA, pB, m, n, p, pC) bind (C, name="matrix_multiply")
use iso_c_binding
implicit none

integer(kind=c_int), intent(in), value :: m, n, p
type(c_ptr), value :: pA, pB, pC
double precision, pointer :: A(:,:), B(:,:), C(:,:)

call c_f_pointer(pA, A, shape=[m, n])
call c_f_pointer(pB, B, shape=[n, p])
call c_f_pointer(pC, C, shape=[m, p])

! delegate to fortran's builtin matrix-multiply routine
! according to `objdump -d matrix_multiply.so`, this gets fully inlined
C = MATMUL(A, B)

end subroutine matrix_multiply


program main
    ! compare the calculate and exact solution of the wavefunction of a particle in in 1-dimension infinite square potential well

    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    ! local vars
    integer :: i
    real(dp) :: x(201), yCalculated(201), yExact(201), err = .0d0

    ! get the data of calculated and exact solution
    open(unit = 1, file = '1-wavefunction.txt', status = 'unknown')
    do i = 1,201
        read(1, '(2f20.8)') x(i), yCalculated(i)
    end do
    close(1)
    open(unit = 2, file = '1-wavefunction-exact.txt', status = 'unknown')
    do i = 1,201
        read(2, '(2f20.8)') x(i), yExact(i)
    end do
    close(2)

    do i = 1,201
        err = err + abs(yCalculated(i) - yExact(i))
    end do
    err = err / 201.d0
    write(*, *) err
end program main


integer function SHFindLWin(theta0, m, alpha, taper_number)
!------------------------------------------------------------------------------
!
!   This function will output the spherical harmonic bandwidth for
!   the space concentrated taper that yields a concetration factor
!   equal to or greater than the input value of alpha. By default, the
!   concentration factor of the first taper is computed, but this can be
!   modified by inputing the optional arguement taper_number.
!
!   Calling Parameters
!
!       IN
!           theta0          Angular radius of the concentration spherical
!                           cap in RADIANS.
!           alpha           Concentration factor of the window.
!           m               Angular order of the space concetrated tapers.
!
!       IN (OPTIONAL)
!           taper_number    Taper number used to calculate concentration
!                           factors.
!
!   Dependencies: LAPACK, BLAS, ComputeDm, EigValSym
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: ComputeDm, EigvalSym

    implicit none

    real*8, intent(in) :: theta0, alpha
    integer, intent(in) ::  m
    integer, intent(in), optional :: taper_number
    real*8, allocatable ::  dllm(:,:), eval(:)
    real*8 ::   pi, alpha1
    integer ::  l, astat(2), tn

    if (alpha < 0.0d0 .or. alpha > 1.0d0) then
        print*, "Error --- SHFindLWin"
        print*, "The concentration factor alpha must be between 0 and 1."
        print*, "Input value is ", alpha
        stop
    end if

    pi = acos(-1.0d0)

    if (present(taper_number)) then
        if (taper_number < 1) then
            print*, "Error --- SHFindLWin"
            print*, "TAPER_NUMBER must be greater than 0."
            print*, "Input value is ", taper_number
            stop
        end if

        tn = taper_number

    else
        tn = 1

    end if

    l = tn

    do
        l = l + 1

        allocate (dllm(l+1,l+1), stat = astat(1)) ; dllm = 0.0d0
        allocate (eval(l+1), stat = astat(2)) ; eval = 0.0d0

        if (astat(1) /=0 .or. astat(2) /=0) then
            print*, "Error --- SHFindLWin"
            print*, "Probelm allocating arrays."
            stop
        end if

        call ComputeDm(dllm, l, abs(m), theta0)
        call EigValSym(dllm, l+1, eval(1:l+1))

        alpha1 = eval(tn)

        deallocate (dllm)
        deallocate (eval)

        if (alpha1 >= alpha) then
            SHFindLWin = l
            return
        end if
    end do

end function SHFindLWin


! Demonstrate an infinite do loop with exit
program exit_loop
implicit none
integer :: i,ssq
ssq = 0 ! Fortran variables are not initialized to zero by default
i = 0
do
   i = i+1
   ssq = ssq + i**2
   if (ssq > 100) exit
end do
print*,"sum of squares from 1 to ",i," is",ssq
! output: sum of squares from 1 to            7  is         140
end program exit_loop


program diskquad

    use zernike
    use bquad

    implicit none

    integer,    parameter                       :: dp = kind(1.0d0)
    integer,    parameter                       :: pi = 4*atan(1.0d0)
    integer										:: seed, numrand
    integer                                     :: maxdeg, numpt, numg, dm
    real(dp),   dimension(:),   allocatable     :: x0, y0
    real(dp),   dimension(:,:), allocatable     :: W
    real(dp)                                    :: sigma_out

    integer                                     :: k
    real(dp)                                    :: r, theta
    logical                                     :: input_flag

    real(dp)									:: time

!   include 'nlopt.f'

! ================================================================================================

    input_flag = .true.
    dm = 2										! Dimension of space
    maxdeg = 8									! Bquad evaluates IP for degrees up to maxdeg - 1
    numrand = 1000								! Number of random initial pts to generate
    numpt = maxdeg * (maxdeg + 1)/2				! Number of eval pts in quadrature
    numg = maxdeg + 1							! Dimension of minimizing space

    allocate(x0(1:numpt *dm), W(1:numpt,1:numpt), y0(1:numpt *dm))

	! Build parameters

    call zern_buildpars(maxdeg)
    call bquad_buildpars(numpt,dm,numg)

    ! Read input points
    if (input_flag) then
        open(unit = 1, file = "input.txt", action = "read", status = "old")

        do k = 1,numpt
            read(1,*) x0(2*k-1), x0(2*k)
        end do

    else
    	call system_clock(count = seed)
        call srand(seed)
        do k = 1,numpt
            r = sqrt(rand())
            theta = 2*pi*rand()
            x0(2*k - 1) = r*cos(theta)
            x0(2*k) = r*sin(theta)
            !print *, 'Error: Input flag set to false.'
            !stop
        end do

    end if

    ! Construct quadrature

	call bquad_construct(dm*numpt,zern_bquad,x0,W,sigma_out,time)

    ! Write output points

    open(unit = 2, file = "output.txt", action = "write", status = "replace")

    do k = 1, numpt
        write(2,*) x0(2*k -1), x0(2*k)
    end do

end program diskquad


module constants

    implicit none
    ! static
    integer, parameter :: iter=selected_int_kind(8)                             ! kind for iterative variables
    integer, parameter :: p=selected_real_kind(16)                              ! float precision parameter
    integer, parameter :: char_max=80                                           ! max character length
    ! Program Interface Parameters %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    character(len=char_max) :: title='Monte Carlo Simulation of Ising Model'    ! title which is displayed in shell
    character(len=char_max), parameter :: dirname='data'                        ! path for data output
    logical, parameter :: default_lattice_array=.true.                          ! use shell prompt to enter lattice sizes
    logical, parameter :: output=.true.                                         ! generate output files
    logical, parameter :: verbose=.false.                                       ! console ouput with additional information
    ! Ising Model Parameters %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    character(len=char_max), parameter :: method='heat_up'                      ! 'metropolis' or 'heat_bath'
    integer, parameter :: T_min=1                                               ! min. temperature [J/k_B]
    integer, parameter :: T_max=4                                               ! max. temperature [J/k_B]
    integer, parameter :: T_steps=40
    integer, parameter :: sweeps=50000                                          ! N° of sweeps
    integer, parameter :: pre_sweeps=int(sweeps*0.15_p ,kind=iter)              ! 15% warm-up sweeps
    integer, parameter :: NN=4                                                  ! N° of neighbors
    integer, dimension(NN), parameter :: Inn=(/ 1, -1, 0, 0/)                   ! Nearest neighbor array I
    integer, dimension(NN), parameter :: Jnn=(/ 0, 0, 1, -1/)                   ! Nearest neighbor array J
    real(kind=p), parameter :: JJ=1._p, HH=0._p                                 ! Coupling constant, magnetic field

    integer, dimension(6), parameter :: lattice_array=(/4, 8, 16, 32, 64, 128/)
    integer, parameter :: lattice_dim_max=128
    integer, dimension(lattice_dim_max, lattice_dim_max) :: lattice

end module constants


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

! Li_3(x) for x in [-1,0]
double precision function dli3_neg(x)
  implicit none
  double precision :: x, x2, x4, p, q
  double precision, parameter :: cp(6) = (/                &
      0.9999999999999999795D+0, -2.0281801754117129576D+0, &
      1.4364029887561718540D+0, -4.2240680435713030268D-1, &
      4.7296746450884096877D-2, -1.3453536579918419568D-3 /)
  double precision, parameter :: cq(7) = (/                &
      1.0000000000000000000D+0, -2.1531801754117049035D+0, &
      1.6685134736461140517D+0, -5.6684857464584544310D-1, &
      8.1999463370623961084D-2, -4.0756048502924149389D-3, &
      3.4316398489103212699D-5                            /)

  x2 = x*x
  x4 = x2*x2
  p = cp(1) + x*cp(2) + x2*(cp(3) + x*cp(4)) +             &
      x4*(cp(5) + x*cp(6))
  q = cq(1) + x*cq(2) + x2*(cq(3) + x*cq(4)) +             &
      x4*(cq(5) + x*cq(6) + x2*cq(7))

  dli3_neg = x*p/q

end function dli3_neg

! Li_3(x) for x in [0,1/2]
double precision function dli3_pos(x)
  implicit none
  double precision :: x, x2, x4, p, q
  double precision, parameter :: cp(6) = (/                &
      0.9999999999999999893D+0, -2.5224717303769789628D+0, &
      2.3204919140887894133D+0, -9.3980973288965037869D-1, &
      1.5728950200990509052D-1, -7.5485193983677071129D-3 /)
  double precision, parameter :: cq(7) = (/                &
      1.0000000000000000000D+0, -2.6474717303769836244D+0, &
      2.6143888433492184741D+0, -1.1841788297857667038D+0, &
      2.4184938524793651120D-1, -1.8220900115898156346D-2, &
      2.4927971540017376759D-4                            /)

  x2 = x*x
  x4 = x2*x2
  p = cp(1) + x*cp(2) + x2*(cp(3) + x*cp(4)) +             &
      x4*(cp(5) + x*cp(6))
  q = cq(1) + x*cq(2) + x2*(cq(3) + x*cq(4)) +             &
      x4*(cq(5) + x*cq(6) + x2*cq(7))

  dli3_pos = x*p/q

end function dli3_pos

!*********************************************************************
!> @brief Real trilogarithm \f$\operatorname{Li}_3(x)\f$
!> @param x real argument
!> @return \f$\operatorname{Li}_3(x)\f$
!> @author Alexander Voigt
!*********************************************************************
double precision function dli3(x)
  implicit none
  double precision :: x, neg, pos, rest, sgn, l
  double precision :: dli3_neg, dli3_pos
  double precision, parameter :: zeta2 = 1.6449340668482264D0
  double precision, parameter :: zeta3 = 1.2020569031595943D0

  ! transformation to [-1,0] and [0,1/2]
  if (x .lt. -1) then
     l = log(-x)
     neg = dli3_neg(1/x)
     pos = 0
     sgn = 1
     rest = -l*(zeta2 + 1.0D0/6*l**2)
  elseif (x .eq. -1) then
     dli3 = -0.75D0*zeta3
     return
  elseif (x .lt. 0) then
     neg = dli3_neg(x)
     pos = 0
     sgn = 1
     rest = 0
  elseif (x .eq. 0) then
     dli3 = 0
     return
  elseif (x .lt. 0.5D0) then
     neg = 0
     pos = dli3_pos(x)
     sgn = 1
     rest = 0
  elseif (x .eq. 0.5D0) then
     dli3 = 0.53721319360804020D0
     return
  elseif (x .lt. 1) then
     l = log(x)
     neg = dli3_neg((x - 1)/x)
     pos = dli3_pos(1 - x)
     sgn = -1
     rest = zeta3 + l*(zeta2 + l*(-0.5D0*log(1 - x) + 1.0D0/6*l))
  elseif (x .eq. 1) then
     dli3 = zeta3
     return
  elseif (x .lt. 2) then
     l = log(x)
     neg = dli3_neg(1 - x)
     pos = dli3_pos((x - 1)/x)
     sgn = -1
     rest = zeta3 + l*(zeta2 + l*(-0.5D0*log(x - 1) + 1.0D0/6*l))
  else ! x >= 2.0D0
     l = log(x)
     neg = 0
     pos = dli3_pos(1/x)
     sgn = 1
     rest = l*(2*zeta2 - 1.0D0/6*l**2)
  endif

  dli3 = rest + sgn*(neg + pos)

end function dli3

!*********************************************************************
!> @brief Complex trilogarithm \f$\operatorname{Li}_3(z)\f$
!> @param z complex argument
!> @return \f$\operatorname{Li}_3(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli3(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c0, c1, lmz, rest, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg, dli3
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: zeta2 = 1.6449340668482264D0
  double precision, parameter :: zeta3 = 1.2020569031595943D0
  double precision, parameter :: bf(18) = (/           &
      1.0D0                 , -3.0D0/8.0D0           , &
      17.0D0/216.0D0        , -5.0D0/576.0D0         , &
      1.2962962962962963D-04,  8.1018518518518519D-05, &
     -3.4193571608537595D-06, -1.3286564625850340D-06, &
      8.6608717561098513D-08,  2.5260875955320400D-08, &
     -2.1446944683640648D-09, -5.1401106220129789D-10, &
      5.2495821146008294D-11,  1.0887754406636318D-11, &
     -1.2779396094493695D-12, -2.3698241773087452D-13, &
      3.1043578879654623D-14,  5.2617586299125061D-15  /)
  double precision, parameter :: cs(7) = (/            &
     -3.4722222222222222D-03,  1.1574074074074074D-05, &
     -9.8418997228521038D-08,  1.1482216343327454D-09, &
     -1.5815724990809166D-11,  2.4195009792525152D-13, &
     -3.9828977769894877D-15                           /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .le. 1) then
         cdli3 = dli3(rz)
         return
      else
         lnz = log(rz)
         cdli3 = dcmplx(dli3(rz), -0.5D0*PI*lnz**2)
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      u4 = u2**2
      u8 = u4**2
      c0 = zeta3 + u*(zeta2 - u2/12)
      c1 = 0.25D0*(3 - 2*fast_pos_cdlog(-u))
      cdli3 =                                            &
         c0 +                                            &
         c1*u2 +                                         &
         u4*(cs(1) + u2*cs(2)) +                         &
         u8*(cs(3) + u2*cs(4) + u4*(cs(5) + u2*cs(6))) + &
         u8*u8*cs(7)
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      rest = 0
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      rest = -lmz*(lmz**2/6 + zeta2)
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli3 =                                                   &
      rest +                                                 &
      u*bf(1) +                                              &
      u2*(bf(2) + u*bf(3)) +                                 &
      u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
      u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
          u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
      u8*u8*(bf(16) + u*bf(17) + u2*bf(18))

end function cdli3


	subroutine fte(tu,latmag_ref,tmag_ref,latmag,tmag,Bmag,VM,WM,
     &   		dpot,dEx,dEy)

	data pi/3.14/

	real x,y
	real gamma,Dx_gamma,Dy_gamma
	real f1,f2,Dx_f1,Dy_f1,Dx_f2,Dy_f2
	real Pthese
	real R,Dx_r2,Dy_r2
	real latmag,tmag,latmag_ref,tmag_ref
 	real tu,m,n,B0,V0,beta0

	logical in

	real tmag2dist,latmag2dist

	real Ex_in,Ex_out,dEx,Ey_in,Ey_out,dEy
	real pot_in,pot_out,dpot

	real W_in,W_out,W,v_in,v_out,v
	real Vx_in,Vx_out,Vy_in,Vy_out,Vx,Vy

c	ellipse's half axis toward magnetic est

	m = 350.

c	ellipse's half axis toward magnetic north

	n = 100.

c tmag2dist converts 1hMLT into dist. in km

	tmag2dist   = 2.*pi*6370.*cos(latmag)/24.

c latmag2dist is the dist.in km corresponding to 1degre of lat.

	latmag2dist = 2.*pi*6370./360.

	x = (tmag-tmag_ref)*tmag2dist
	y = (latmag-latmagref)*latmag2dist

	in = ((x/n)**2+(y/m)**2).le.1

	B0 = Bmag
	V0 = sqrt(VM**2+WM**2)

	Pthese =  (x**2-y**2+m**2-n**2)

	gamma  =  0.5*atan2(2*x*y,Pthese)
	if (x.lt.0) gamma=gamma+pi
       	Dx_gamma = 0.5*(2*y*Pthese-4*(x**2)*y)/Pthese**2/
     &	 	(1+(2*x*y/Pthese)**2)
	Dy_gamma = 0.5*(2*x*Pthese+4*x*y**2)/Pthese**2/
     &		(1+(2*x*y/Pthese)**2)

	R  =  (Pthese**2+4*x**2*y**2)
	Dx_r2 = 0.25*(4*x*Pthese+8*x*y**2)*R**(-0.75)
	Dy_r2 = 0.25*(-4*y*Pthese+8*x**2*y)*R**(-0.75)

	f1 = R**(0.25)*cos(gamma)-x
	f2 = R**(0.25)*sin(gamma)-y
	Dx_f1 = -sin(gamma)*Dx_gamma*R**(0.25)+cos(gamma)*Dx_r2-1
	Dx_f2 = cos(gamma)*Dx_gamma*R**(0.25)+sin(gamma)*Dx_r2
	Dy_f1 = -sin(gamma)*Dy_gamma*R**(0.25)+cos(gamma)*Dy_r2
	Dy_f2 = cos(gamma)*Dy_gamma*R**(0.25)+sin(gamma)*Dy_r2-1

c Plasma velocity

	Vx_out = -V0/(m-n)*(n*sin(beta0)*Dy_f1+m*cos(beta0)*Dy_f2)
	Vy_out = V0/(m-n)*(n*sin(beta0)*Dx_f1+m*cos(beta0)*Dx_f2)

	Vx_in = V0*cos(beta0)
	Vy_in = V0*sin(beta0)

c Velocity potential

	W_in = -V0*(cos(beta0)*x+sin(beta0)*y)
	W_out = -V0/(m-n)*(n*f2*sin(beta0)-m*f1*cos(beta0))

c Electric potential

	dpot = -B0*W

c Streamline function

	v_in = V0*(cos(beta0)*y-sin(beta0)*x)
	v_out = -V0/(m-n)*(n*f1*sin(beta0)+m*f2*cos(beta0))

c Electric field (x- and y-components)

	Ex_in = -V0*B0*sin(beta0)
	Ey_in = V0*B0*cos(beta0)

	Ex_out = -V0*B0/(m-n)*(n*Dx_f1*sin(beta0)+m*Dx_f2*cos(beta0))
	Ex_out = -V0*B0/(m-n)*(n*Dy_f1*sin(beta0)+m*Dy_f2*cos(beta0))

	if (in) then
		Vx = Vx_in
		Vy = Vy_in

		W = W_in
		v = v_in

		dpot = pot_in

		dEx = dEx_in
		dEy = dEy_in

     	else
		Vx = Vx_out
		Vy = Vy_out

		W = W_out
		v = v_out

		dpot = pot_out

		dEx = dEx_out
		dEy = dEy_out

	end if

	return
	end


      SUBROUTINE secsdms( iflag, seconds, ideg, min, sec )
!    convert from geodetic degrees/minutes/seconds to seconds of an arc.
!
! ARGUMENTS:
! iflag   >=0, converts seconds to degrees/minutes/seconds.
!         <0, converts degrees/minutes/seconds to seconds.
! seconds - the REAL number of degrees to convert
! ideg    - The integer number of degrees returned.
! min     - The integer number of minutes returned.
! sec     - The REAL number of seconds returned.
!
      INTEGER ideg, min, iflag
      REAL seconds, sec, temp

      IF( iflag .GE. 0 ) THEN
          i = 1
          temp = seconds / (60.*60.)
          IF( seconds .LT. 0 ) THEN
              i = -1
              temp = -temp
          ENDIF
          ideg = IFIX(temp)
          temp = temp - ideg
          ideg = ideg * i
          min = IFIX(temp*60.)
          temp = temp - FLOAT(min)/60.
          sec = temp * 60. * 60.
      ELSE
          temp = 1.
          itemp = ideg
          IF( ideg .LT. 0 ) THEN
              temp = -1.
              ideg = -ideg
          ENDIF
          seconds = (FLOAT(ideg)*60.*60. + FLOAT(min)*60. + sec) * temp
      ENDIF
      RETURN
      END

      SUBROUTINE dsecsdms( iflag, dseconds, ideg, min, sec )
c    convert from geodetic degrees/minutes/seconds to seconds of an arc.
c
c ARGUMENTS:
c iflag   >=0, converts seconds to degrees/minutes/seconds.
c         <0, converts degrees/minutes/seconds to seconds.
c seconds - the REAL*8 number of degrees to convert
c ideg    - The integer number of degrees returned.
c min     - The integer number of minutes returned.
c sec     - The REAL number of seconds returned.
c
      INTEGER ideg, min, iflag
      REAL*8 dseconds

      IF( iflag .GE. 0 ) THEN
          i = 1
          temp = dseconds / (60.*60.)
          IF( dseconds .LT. 0 ) THEN
              i = -1
              temp = -temp
          ENDIF
          ideg = IFIX(temp)
          temp = temp - ideg
          ideg = ideg * i
          min = IFIX(temp*60.)
          temp = temp - FLOAT(min)/60.
          sec = temp * 60. * 60.
      ELSE
          temp = 1.
          itemp = ideg
          IF( ideg .LT. 0 ) THEN
              temp = -1.
              ideg = -ideg
          ENDIF
          dseconds = (FLOAT(ideg)*60.*60. + FLOAT(min)*60. + sec) * temp
      ENDIF
      RETURN
      END


module renormalization
    contains

    function mat_adj(entries) result(adj_entries)
        implicit none
        complex*16, intent(in) :: entries(:,:)
        complex*16, allocatable :: adj_entries(:,:)
        integer*4 :: ii, jj, NN, MM
        integer*4 :: mat_shape(1:2)

        mat_shape = shape(entries)
        NN = mat_shape(1)
        MM = mat_shape(2)
        allocate(adj_entries(1:MM,1:NN))
        do ii = 1, NN
            do jj = 1, MM
                adj_entries(jj, ii) = conjg(entries(ii,jj))
            end do
        end do
    end function mat_adj

    subroutine zallocate_1(array,MM)
    implicit none
    integer :: allocate_status, MM
    double complex, allocatable :: array(:)

        allocate(array(1:MM), stat = allocate_status)
        if (allocate_status .ne. 0) stop "***Not enough memory to allocate arrays***"

    end subroutine

    subroutine zallocate_2(array,MM,NN)
    implicit none
    integer :: allocate_status, MM,NN
    double complex, allocatable :: array(:,:)

        allocate(array(1:MM,1:NN), stat = allocate_status)
        if (allocate_status .ne. 0) stop "***Not enough memory to allocate arrays***"

    end subroutine

    subroutine rallocate_1(array,MM)
    implicit none
    integer :: allocate_status, MM
    real*8, allocatable :: array(:)

        allocate(array(1:MM), stat = allocate_status)
        if (allocate_status .ne. 0) stop "***Not enough memory to allocate arrays***"

    end subroutine

    subroutine rallocate_2(array,MM,NN)
    implicit none
    integer :: allocate_status, MM,NN
    real*8, allocatable :: array(:,:)

        allocate(array(1:MM,1:NN), stat = allocate_status)
        if (allocate_status .ne. 0) stop "***Not enough memory to allocate arrays***"

    end subroutine

    subroutine diagonalization(org_hermitian, eigenvalues, NN)
    ! Obtains the e-values of an hermitian matrix
    ! Modifies org_hermitian
    implicit none
    integer :: NN, ok, lwork
    complex*16 :: org_hermitian(1:NN,1:NN)
    real*8 :: eigenvalues(1:NN)
    complex*16, allocatable :: work(:)
    real*8, allocatable :: rwork(:)

        ! we don't want to saturate the memory
        call zallocate_1(work,2*NN-1)

        ! Obtain an optimal lwork
        call zheev('V','U',NN,org_hermitian,NN,eigenvalues,work,-1,rwork,ok)

        ! the first element of work is the optimal lwork
        lwork = int(work(1))
        if (lwork.le.0) stop "overflow in lwork"
        ! Resize the work vector and validate memory
        deallocate(work)
        call zallocate_1(work,lwork)

        call rallocate_1(rwork,3*NN-2)

        call zheev('V','U',NN,org_hermitian,NN,eigenvalues,work,lwork,rwork,ok)

        ! Releasing memory
        deallocate(work,rwork)

        if (ok.ne.0) stop "Unsuccessful eigenvalue calculation"

    end subroutine

    subroutine print_mat(mat_a)
    implicit none
    double complex, dimension(:,:) :: mat_a
    integer :: ii, shape_a(1:2)
        shape_a = shape(mat_a)
        do ii = 1, shape_a(1)
            write(*,'(*(F0.8,SP,F0.8,"i",","))') mat_a(ii,:)
        end do
        write(*,*) "---------------------------------------"
    end subroutine

    subroutine compare_mat(mat_a,mat_b)
    implicit none
    double complex, dimension(:,:) :: mat_a,mat_b
    integer :: ii, jj, shape_a(1:2), shape_b(1:2)
        shape_a = shape(mat_a)
        shape_b = shape(mat_b)
        do ii = 1,2
            if (shape_a(ii).ne.shape_b(ii)) stop "Matrices differ in shape"
        end do
        do jj = 1, shape_a(2)
            do ii = 1, shape_a(1)
                if(&
                    (real(real(mat_a(ii,jj))).ne.real(real(mat_b(ii,jj))))&
                    .or.&
                    (real(aimag(mat_a(ii,jj))).ne.real(aimag(mat_b(ii,jj))))&
                    ) then
                    write(*,'(A,I0)') "matrix A, row ", ii
                    call print_mat(mat_a(ii:ii,:))
                    write(*,'(A,I0)') "matrix B, row ", ii
                    call print_mat(mat_b(ii:ii,:))
                    write(*,'(A,I0)') "different in element ",jj
                    stop
                end if
            end do
        end do
    end subroutine

    function tens_prod_2(A,B,MM,NN,OO,PP)
        implicit none
        double complex, dimension(:,:) :: A,B
        double complex, dimension(1:MM*OO,1:NN*PP) :: tens_prod_2
        integer :: ii, jj, MM, NN, OO, PP, base(1:MM), out(1:MM)
        logical :: mask(1:MM)

            base = (/(ii,ii=1,MM)/)
            tens_prod_2 = 0
            do jj = 1, NN
                mask = A(:,jj)/=0
                out = pack(base,mask)
                do ii = 1, count(mask)
                    !if(A(ii,jj).eq.0) continue
                    tens_prod_2((out(ii)-1)*OO+1:out(ii)*OO,&
                    (jj-1)*PP+1:jj*PP) = A(out(ii),jj)*B
                end do
            end do
    end function

    function identity(NN)
    implicit none
    integer :: NN, ii
    double complex, dimension(1:NN,1:NN) :: identity

        identity = 0
        do ii = 1, NN
            identity(ii,ii) = dcmplx(1,0)
        end do

    end function

    function diag_val(OO,val)
    implicit none
    integer :: OO, ii
    double complex :: val, diag_val(1:OO,1:OO)

        diag_val = 0
        !if (val.eq.dcmplx(0,0)) return
        do ii = 1, OO
            diag_val(ii,ii) = val
        end do

    end function

    function tens_id_2(mat_a,MM,NN,id_nn)
    ! Obtains the tensor product of a matrix A and the id_nn identity matrix
    implicit none
    double complex, dimension(:,:) :: mat_a
    double complex, dimension(1:MM*id_nn,1:NN*id_nn) :: tens_id_2
    integer :: ii, jj, MM, NN, id_nn, base(1:MM), out(1:MM)
    logical :: mask(1:MM)

        base = (/(ii,ii=1,MM)/)
        tens_id_2 = 0
        do jj = 1, NN
            mask = mat_a(:,jj) /= 0
            out = pack(base,mask)
            do ii = 1, count(mask)
                !if(mat_a(ii,jj).eq.0) continue
                tens_id_2((out(ii)-1)*id_nn+1:out(ii)*id_nn,&
                (jj-1)*id_nn+1:jj*id_nn) = diag_val(id_nn,mat_a(out(ii),jj))
            end do
        end do

    end function

    function outer(vec_1,vec_2,MM,NN)
    implicit none
    integer :: MM, NN, ii, jj
    double complex :: vec_1(1:MM), vec_2(1:NN), outer(1:MM,1:NN)

        do jj = 1, NN
            do ii = 1, MM
                outer(ii,jj) = vec_1(ii)*conjg(vec_2(jj))
            end do
        end do

    end function

    function ising_model_1D(NN,lambda) result(hamiltonian)
    ! Builds hamiltonian for the 1/2 spin chain with nearest-neighbours interaction
    implicit none
    double complex, dimension(1:2,1:2) :: sigma_x, sigma_y, sigma_z
    double complex, dimension(1:2**2,1:2**2) :: sigma_int
    integer ii, NN
    double complex, dimension(:,:), allocatable :: hamiltonian,holder_int
    real*8 :: lambda

        sigma_x = dcmplx(reshape((/0,1,&
                                   1,0/),&
                            (/2,2/)),0)

        sigma_y = dcmplx(0,reshape((/0,-1,&
                                     1,0/),&
                            (/2,2/)))

        sigma_z = dcmplx(reshape((/1,0,&
                                   0,-1/),&
                            (/2,2/)),0)

        sigma_int = tens_prod_2(sigma_x,sigma_x,2,2,2,2)
        call zallocate_2(hamiltonian,2**NN,2**NN)
        call zallocate_2(holder_int,2**NN,2**NN)

        ! Transverse field interaction
        ! Setting everything for ii = 1
        holder_int = tens_id_2(&
            sigma_z,&
            2,2,2**(NN-1))

        hamiltonian = -holder_int

        ! Setting for states inbetween
        do ii = 2, NN-1
            holder_int(1:2**ii,1:2**ii) = tens_prod_2(&
                    identity(2**(ii-1)),&
                    sigma_z,&
                    2**(ii-1),2**(ii-1),2,2)
            holder_int = tens_id_2(&
            holder_int(1:2**ii,1:2**ii),&
            2**ii,2**ii,2**(NN-ii))
            hamiltonian = hamiltonian - holder_int
        end do

        ! Setting everything for ii = NN
        holder_int = tens_prod_2(&
            identity(2**(NN-1)),&
            sigma_z,&
            2**(NN-1),2**(NN-1),2,2)

        hamiltonian = hamiltonian - holder_int

        hamiltonian = lambda*hamiltonian

        ! Nearest neighbours interaction
        ! Prepare interaction of the first two
        holder_int = tens_id_2(&
                        sigma_int,&
                        2**2,2**2,2**(NN-2))

        hamiltonian = hamiltonian - holder_int

        do ii = 2, NN-2
            holder_int(1:2**(ii+1),1:2**(ii+1)) = tens_prod_2(&
                            identity(2**(ii-1)),&
                            sigma_int,&
                            2**(ii-1),2**(ii-1),2**2,2**2)
            holder_int = tens_id_2(&
                            holder_int(1:2**(ii+1),1:2**(ii+1)),&
                            2**(ii+1),2**(ii+1),2**(NN-ii-1))
            hamiltonian = hamiltonian - holder_int
        end do

        ! Prepare interaction of the last two
        holder_int = tens_prod_2(&
                        identity(2**(NN-2)),&
                        sigma_int,&
                        2**(NN-2),2**(NN-2),2**2,2**2)

        hamiltonian = hamiltonian - holder_int

    end function

    subroutine allocate_group(holder_ham,H_int_A,H_int_B,eigenvalues,projector_0,red_proj,curr_size,M_size)
    implicit none
    integer :: curr_size, M_size
    double complex, allocatable :: holder_ham(:,:), projector_0(:,:), red_proj(:,:), H_int_A(:,:), H_int_B(:,:)
    real*8, allocatable :: eigenvalues(:)

        call zallocate_2(holder_ham,curr_size,curr_size)
        call zallocate_2(H_int_A,curr_size,curr_size)
        call zallocate_2(H_int_B,curr_size,curr_size)
        call rallocate_1(eigenvalues,curr_size)
        call zallocate_2(projector_0,curr_size,curr_size)
        call zallocate_2(red_proj,curr_size,M_size)

    end subroutine

    subroutine real_space_rg(&
        N_size,&! Number of particles described by the initial hamiltonian
        d_states,&! Number of states for the individual systems
        hamiltonian_N,&! The analytical hamiltonian for the N particle system
        boundary_A,&! The leftmost boundary interaction term
        boundary_B,&! The rightmost boundary interaction term
        M_size,&! dimension of the truncated hamiltonian
        iterations,& ! using instead of target size
        !target_size,&! number of particles of the final system. Must be N_size*2**w_it for some non negative integer w_it
        output_hamiltonian,&
        convergence_test&
        )
    implicit none
    integer :: N_size, M_size, d_states, iterations, curr_size, ii, jj
    double complex :: output_hamiltonian(1:M_size,1:M_size), H_int(1:M_size**2,1:M_size**2)
    double complex :: hamiltonian_N(1:d_states**N_size,1:d_states**N_size), hamiltonian_M(1:M_size**2,1:M_size**2)
    double complex :: boundary_A(1:d_states,1:d_states), boundary_B(1:d_states,1:d_states)
    double complex :: H_int_A(1:M_size,1:M_size), H_int_B(1:M_size,1:M_size)
    double complex, allocatable :: holder_ham(:,:), projector_0(:,:), red_proj(:,:)
    double complex, allocatable :: H_A(:,:), H_B(:,:)
    real*8, allocatable :: eigenvalues(:)
    real*8 :: tol_e = 1d-10, Energy_ii
    integer*8 :: sim_size
    logical :: convergence_test

        curr_size = d_states**N_size
        sim_size = int(N_size,8)
        !output_hamiltonian = 0
        ! The renormalization group dimension must be lower or equal to the initial configuration dimension.
        if (curr_size.lt.M_size) stop "Dimension of hilbert space for initial configuration too small."

        call allocate_group(holder_ham,H_A,H_B,eigenvalues,projector_0,red_proj,curr_size,M_size)
        holder_ham = hamiltonian_N

        ! Diagonalize the initial hamiltonian
        call diagonalization(holder_ham, eigenvalues, curr_size)

        ! Project on the basis for the first M eigenstates
        projector_0 = holder_ham
        !projector_0 = 0
        !do jj = 1, M_size
        !    projector_0 = projector_0 + outer(holder_ham(:,jj),holder_ham(:,jj),curr_size,curr_size)
        !end do
        red_proj = projector_0(1:curr_size,1:M_size)
        output_hamiltonian = matmul(mat_adj(red_proj),matmul(hamiltonian_N,red_proj))
        H_A = tens_prod_2(&
                identity(d_states**(N_size-1)),&
                boundary_A,&
                d_states**(N_size-1),d_states**(N_size-1),d_states,d_states)
        H_B = tens_id_2(&
                boundary_B,&
                d_states,d_states,d_states**(N_size-1))
        H_int_A = matmul(mat_adj(red_proj),matmul(H_A,red_proj))
        H_int_B = matmul(mat_adj(red_proj),matmul(H_B,red_proj))

        ! Build interaction hamiltonian
        H_int = tens_prod_2(&
            H_int_A,&
            H_int_B,&
            M_size,M_size,M_size,M_size)

        ! Resize the dummy variables
        curr_size = M_size*M_size
        deallocate(holder_ham,H_A,H_B,eigenvalues,projector_0,red_proj)
        call allocate_group(holder_ham,H_A,H_B,eigenvalues,projector_0,red_proj,curr_size,M_size)

        ! repeat until the desired number of particles is reached
        do ii = 1, iterations

            ! build the 2N-particle hamiltonian as tens(H,id)+tens(id,H)+H_int
            hamiltonian_M = tens_id_2(output_hamiltonian,M_size,M_size,M_size)&
            + tens_prod_2(identity(M_size),output_hamiltonian,M_size,M_size,M_size,M_size)&
            + H_int! Projected interaction term

            ! store the energy from the past iteration
            Energy_ii = eigenvalues(1)/sim_size

            ! diagonalize N-particle system hamiltonian
            holder_ham = hamiltonian_M
            call diagonalization(holder_ham, eigenvalues, curr_size)

            ! project only the first m e-values
            projector_0 = holder_ham
            !projector_0 = 0
            !do jj = 1, M_size
            !    projector_0 = projector_0 + outer(holder_ham(:,jj),holder_ham(:,jj),curr_size,curr_size)
            !end do
            red_proj = projector_0(1:curr_size,1:M_size)
            output_hamiltonian = matmul(mat_adj(red_proj),matmul(hamiltonian_M,red_proj))

            sim_size = sim_size*2
            ! convergence test
            if (convergence_test.and.abs(Energy_ii-eigenvalues(1)/sim_size).lt.tol_e) then
                write(*,*) "Converged at", ii
                iterations = ii
                exit
            end if

            ! Build interaction hamiltonian
            ! Fixed interaction terms
            H_A = tens_prod_2(&
                    identity(M_size),&
                    H_int_A,&
                    M_size,M_size,M_size,M_size)
            H_B = tens_id_2(&
                    H_int_B,&
                    M_size,M_size,M_size)
            H_int_A = matmul(mat_adj(red_proj),matmul(H_A,red_proj))
            H_int_B = matmul(mat_adj(red_proj),matmul(H_B,red_proj))
            H_int = tens_prod_2(&
                H_int_A,&
                H_int_B,&
                M_size,M_size,M_size,M_size)

        end do

        ! Releasing memory
        deallocate(holder_ham,eigenvalues,projector_0,red_proj)

    end subroutine

end module

program real_group_ising
use renormalization
implicit none
integer :: NN, MM, iterations, ii
double complex, allocatable :: hamiltonian_N(:,:), hamiltonian_M(:,:)
double complex :: sigma_x(1:2,1:2)
real*8 :: lambda
real*8, allocatable :: eigenvalues(:)
character*64 :: energy_file
logical :: convergence_test = .false.
integer*8 :: sim_size

sigma_x = dcmplx(reshape((/0,1,&
                           1,0/),&
                    (/2,2/)),0)

write(*,*) "Enter NN, MM, lambda, iterations"
read(*,*) NN, MM, lambda, iterations

call zallocate_2(hamiltonian_N,2**NN,2**NN)
call zallocate_2(hamiltonian_M,MM,MM)
call rallocate_1(eigenvalues,MM)

hamiltonian_N = ising_model_1D(NN,lambda)

if (iterations.eq.0) then
    iterations = 100! Large number of iterations in order to test for convergence
    convergence_test = .true.
end if

call real_space_rg(NN,2,hamiltonian_N,sigma_x,-sigma_x,MM,iterations,hamiltonian_M,convergence_test)

call diagonalization(hamiltonian_M,eigenvalues,MM)

sim_size = int(NN,8)*2**int(iterations,8)

write(*,*) eigenvalues/sim_size

if (lambda.lt.1) then
    write(energy_file,'(A,I0,A,I0,A,f0.2,A)') "data/",MM,"_energies_",sim_size,"_spins_lambda_0",lambda,".dat"
else
    write(energy_file,'(A,I0,A,I0,A,f0.2,A)') "data/",MM,"_energies_",sim_size,"_spins_lambda_",lambda,".dat"
end if
open(12,file = energy_file)
do ii = 1,MM
    write(12,*) eigenvalues(ii)
end do
close(12)
write(*,*) "Successfully wrote to ", energy_file

write(*,*) iterations

end program


!
! ej2.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej2

use precision, pr => dp
use ran2mod
use mzranmod
use mtmod

implicit none
integer                     :: i, j, k
integer                     :: idum1=-130103, m, p, quad(4), Nc=10000
real(dp)                    :: r2, r, x(2)

open(unit=10, file='ej2_.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#   n     rms  quad1   quad2   quad3   quad4"

!
! Programa que realiza caminatas al azar
! Utilizando generadores de numeros random
!

do i = 1, 60                ! loop sobre los distintos longitudes
    m = 10 * i
    r2 = 0
    quad = (/0, 0, 0, 0/)
    do k = 1, Nc
        x = (/ 0, 0 /)
        do j = 1, m         ! loop para dar los pasos
            r = ran2(idum1)
            x = x + step(r)
        end do
        r2 = r2 + x(1) * x(1) + x(2) * x(2)

        ! eleccion del cuadrante
        ! 1 --> III
        ! 2 --> II
        ! 3 --> IV
        ! 4 --> I
        p = 1
        if (x(1) >= 0) then
            p = p + 1
        end if

        if (x(2) >= 0) then
                p = p + 2
        end if
        quad(p) = quad(p) + 1

    end do
    r2 = r2/Nc
    write(10, *) m, r2, quad(4), quad(2), quad(1), quad(3)
end do
close(10)

contains

function step(r)
integer(pr), parameter      :: d = 2
real (pr)                   :: dr, step(d)
real (pr), intent(in)       :: r

dr = int(r * 4._dp)

if (dr.eq.0) then
    step = (/1, 0/)
end if
if (dr.eq.1) then
step = (/-1, 0/)
end if
if (dr.eq.2) then
step = (/0, 1/)
end if
if (dr.eq.3) then
step = (/0, -1/)
end if

end function step

end program ej2