! -------------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! Based on ark_kpr_mri.c in examples/arkode/C_serial.
! -------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2022, 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
! -------------------------------------------------------------------
! Multirate nonlinear Kvaerno-Prothero-Robinson ODE test problem:
!
!    [u]' = [ G  e ] [(-1+u^2-r)/(2u)] + [      r'(t)/(2u)        ]
!    [v]    [ e -1 ] [(-2+v^2-s)/(2v)]   [ s'(t)/(2*sqrt(2+s(t))) ]
!         = [ fs(t,u,v) ]
!           [ ff(t,u,v) ]
!
! where r(t) = 0.5*cos(t),  s(t) = cos(w*t),  0 < t < 5.
!
! This problem has analytical solution given by
!    u(t) = sqrt(1+r(t)),  v(t) = sqrt(2+s(t)).
!
! We use the parameters:
!   e = 0.5 (fast/slow coupling strength) [default]
!   G = -1e2 (stiffness at slow time scale) [default]
!   w = 100  (time-scale separation factor) [default]
!   hs = 0.01 (slow step size) [default]
!
! The stiffness of the slow time scale is essentially determined
! by G, for |G| > 50 it is 'stiff' and ideally suited to a
! multirate method that is implicit at the slow time scale.
!
! We select the MRI method to use based on an additional input,
! solve_type with options (slow type-order/fast type-order):
! 0. exp-3/exp-3 (standard MIS) [default]
! 1. none/exp-3 (no slow, explicit fast)
! 2. none/dirk-3 (no slow, dirk fast)
! 3. exp-3/none (explicit slow, no fast)
! 4. dirk-2/none (dirk slow, no fast) -- solve-decoupled
! 5. exp-4/exp-4 (MRI-GARK-ERK45a / ERK-4-4)
! 6. exp-4/exp-3 (MRI-GARK-ERK45a / ERK-3-3)
! 7. dirk-3/exp-3 (MRI-GARK-ESDIRK34a / ERK-3-3) -- solve decoupled
! 8. ars343/exp-3 (IMEX-MRI3b / ERK-3-3) -- solve decoupled
! 9. imexark4/exp-4 (IMEX-MRI4/ ERK-4-4) -- solve decoupled
!
! We note that once we have methods that are IMEX at the slow time
! scale, the nonstiff slow term,  [ r'(t)/(2u) ], can be treated
! explicitly.
!
! The program should be run with arguments in the following order:
!   $ a.out solve_type h G w e
! Not all arguments are required, but these must be omitted from
! end-to-beginning, i.e. any one of
!   $ a.out solve_type h G w
!   $ a.out solve_type h G
!   $ a.out solve_type h
!   $ a.out solve_type
!   $ a.out
! are acceptable.  We require:
!   * 0 <= solve_type <= 9
!   * 0 < h < 1/|G|
!   * G < 0.0
!   * w >= 1.0
!
! This program solves the problem with the MRI stepper. Outputs are
! printed at equal intervals of 0.1 and run statistics are printed
! at the end.
!--------------------------------------------------------------------

module ode_mod

  use, intrinsic :: iso_c_binding
  use farkode_mod
  use farkode_arkstep_mod
  use farkode_mristep_mod
  use fnvector_serial_mod
  use fsunmatrix_dense_mod
  use fsunlinsol_dense_mod
  use fsundials_context_mod
  use fsundials_matrix_mod
  use fsundials_linearsolver_mod
  use fsundials_nvector_mod

  implicit none

  ! Constants
  real(c_double) :: ZERO = 0.0d0
  real(c_double) :: ONE  = 1.0d0
  real(c_double) :: TWO  = 2.0d0

  ! general problem parameters
  real(c_double), parameter  :: T0          = 0.0d0    ! initial time
  real(c_double), parameter  :: Tf          = 5.0d0    ! final time
  real(c_double), parameter  :: dTout       = 0.1d0    ! time between outputs
  integer(c_long), parameter :: NEQ         = 2        ! number of dependent vars.
  integer(c_int), parameter  :: Nt          = ceiling(Tf/dTout) ! number of output times

  ! parameters that can be modified via CLI args or are derived
  real(c_double) :: hs         = 0.01d0   ! slow step size
  real(c_double) :: e          = 0.5d0    ! fast/slow coupling strength
  real(c_double) :: G          = -100.0d0 ! stiffness at slow time scale
  real(c_double) :: w          = 100.0d0  ! time-scale separation factor
  real(c_double) :: reltol     = 0.01d0   ! integrator tolerances
  real(c_double) :: abstol     = 1e-11

contains

  !
  ! RHS functions
  !

  ! ff routine to compute the fast portion of the ODE RHS.
  integer(c_int) function ff(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    real(c_double) :: u, v
    real(c_double) :: tmp1, tmp2
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: ydotarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(yvec)
    ydotarr => FN_VGetArrayPointer(ydotvec)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the RHS function:
    !  [0  0]*[(-1+u^2-r(t))/(2*u)] + [         0          ]
    !  [e -1] [(-2+v^2-s(t))/(2*v)]   [sdot(t)/(2*vtrue(t))]
    tmp1 = (-ONE+u*u-r(t))/(TWO*u)
    tmp2 = (-TWO+v*v-s(t))/(TWO*v)
    ydotarr(1) = ZERO
    ydotarr(2) = e*tmp1 - tmp2 + sdot(t)/(TWO*vtrue(t))

    ! return success
    ierr = 0
    return

  end function

  ! fs routine to compute the slow portion of the ODE RHS.
  integer(c_int) function fs(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    real(c_double) :: u, v
    real(c_double) :: tmp1, tmp2
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: ydotarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(yvec)
    ydotarr => FN_VGetArrayPointer(ydotvec)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the RHS function:
    !  [G e]*[(-1+u^2-r(t))/(2*u))] + [rdot(t)/(2*u)]
    !  [0 0] [(-2+v^2-s(t))/(2*v)]    [      0      ]
    tmp1 = (-ONE+u*u-r(t))/(TWO*u)
    tmp2 = (-TWO+v*v-s(t))/(TWO*v)
    ydotarr(1) = G*tmp1 + e*tmp2 + rdot(t)/(TWO*u)
    ydotarr(2) = ZERO

    ! return success
    ierr = 0
    return

  end function

  ! fse routine to compute the slow portion of the ODE RHS.
  integer(c_int) function fse(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    real(c_double) :: u, v
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: ydotarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(yvec)
    ydotarr => FN_VGetArrayPointer(ydotvec)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the slow explicit RHS function:
    !  [rdot(t)/(2*u)]
    !  [      0      ]
    ydotarr(1) = rdot(t)/(TWO*u)
    ydotarr(2) = ZERO

    ! return success
    ierr = 0
    return

  end function

  ! fsi routine to compute the slow portion of the ODE RHS.(currently same as fse)
  integer(c_int) function fsi(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    real(c_double) :: u, v
    real(c_double) :: tmp1, tmp2
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: ydotarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(yvec)
    ydotarr => FN_VGetArrayPointer(ydotvec)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the slow implicit RHS function:
    !  [G e]*[(-1+u^2-r(t))/(2*u))]
    !  [0 0] [(-2+v^2-s(t))/(2*v)]
    tmp1 = (-ONE+u*u-r(t))/(TWO*u)
    tmp2 = (-TWO+v*v-s(t))/(TWO*v)
    ydotarr(1) = G*tmp1 + e*tmp2
    ydotarr(2) = ZERO

    ! return success
    ierr = 0
    return

  end function

  integer(c_int) function fn(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    real(c_double) :: u, v
    real(c_double) :: tmp1, tmp2
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: ydotarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(yvec)
    ydotarr => FN_VGetArrayPointer(ydotvec)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the RHS function:
    !  [G e]*[(-1+u^2-r(t))/(2*u))] + [rdot(t)/(2*u)]
    !  [e -1] [(-2+v^2-s(t))/(2*v)]   [sdot(t)/(2*vtrue(t))]
    tmp1 = (-ONE+u*u-r(t))/(TWO*u)
    tmp2 = (-TWO+v*v-s(t))/(TWO*v)
    ydotarr(1) = G*tmp1 + e*tmp2 + rdot(t)/(TWO*u)
    ydotarr(2) = e*tmp1 - tmp2 + sdot(t)/(TWO*vtrue(t))

    ! return success
    ierr = 0
    return

  end function

  integer(c_int) function f0(t, yvec, ydotvec, user_data) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: yvec
    type(N_Vector) :: ydotvec
    type(c_ptr)    :: user_data

    call FN_VConst(ZERO, ydotvec)

    ! return success
    ierr = 0
    return

  end function

  !
  ! Jacobian functions
  !

  integer(c_int) function Js(t, y, fy, J, user_data, tmp1, tmp2, tmp3) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double), value  :: t
    type(N_Vector)  :: y
    type(N_Vector)  :: fy
    type(SUNMatrix) :: J
    type(c_ptr)     :: user_data
    type(N_Vector)  :: tmp1, tmp2, tmp3

    real(c_double) :: u, v
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: Jarr(:)

    ! get N_Vector data arrays
    yarr => FN_VGetArrayPointer(y)

    ! get Jacobian data array
    Jarr => FSUNDenseMatrix_Data(J)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the Jacobian:
    !  [G/2 + (w*(1+r(t))-rdot(t))/(2*u^2)   e/2 + e*(2+s(t))/(2*v^2)]
    !  [                 0                              0            ]
    Jarr(1) = G/TWO + (G*(ONE+r(t))-rdot(t))/(2*u*u)
    Jarr(2) = ZERO
    Jarr(3) = e/TWO + e*(TWO+s(t))/(TWO*v*v)
    Jarr(4) = ZERO

    ! return success
    ierr = 0
    return

  end function

  integer(c_int) function Jsi(t, y, fy, J, user_data, tmp1, tmp2, tmp3) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double), value :: t
    type(N_Vector)  :: y
    type(N_Vector)  :: fy
    type(SUNMatrix) :: J
    type(c_ptr)     :: user_data
    type(N_Vector)  :: tmp1, tmp2, tmp3

    real(c_double) :: u, v
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: Jarr(:)

    ! get N_Vector data array
    yarr => FN_VGetArrayPointer(y)

    ! get Jacobian data array
    Jarr => FSUNDenseMatrix_Data(J)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the Jacobian:
    !  [G/2 + (G*(1+r(t)))/(2*u^2)   e/2+e*(2+s(t))/(2*v^2)]
    !  [                 0                             0   ]
    Jarr(1) = G/TWO + (G*(ONE+r(t)))/(2*u*u)
    Jarr(2) = ZERO
    Jarr(3) = e/TWO + e*(TWO+s(t))/(TWO*v*v)
    Jarr(4) = ZERO

    ! return success
    ierr = 0
    return

  end function

  integer(c_int) function Jn(t, y, fy, J, user_data, tmp1, tmp2, tmp3) &
    result(ierr) bind(C)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double), value  :: t
    type(N_Vector)  :: y
    type(N_Vector)  :: fy
    type(SUNMatrix) :: J
    type(c_ptr)     :: user_data
    type(N_Vector)  :: tmp1, tmp2, tmp3

    real(c_double) :: u, v
    real(c_double), pointer :: yarr(:)
    real(c_double), pointer :: Jarr(:)

    ! get N_Vector data array
    yarr => FN_VGetArrayPointer(y)

    ! get Jacobian data array
    Jarr => FSUNDenseMatrix_Data(J)

    ! extract variables
    u = yarr(1)
    v = yarr(2)

    ! fill in the Jacobian:
    ! [G/2 + (G*(1+r(t))-rdot(t))/(2*u^2)     e/2 + e*(2+s(t))/(2*v^2)]
    ! [e/2 + e*(1+r(t))/(2*u^2)              -1/2 - (2+s(t))/(2*v^2)]
    Jarr(1) = G/TWO + (G*(1+r(t))-rdot(t))/(TWO*u*u)
    Jarr(2) = e/TWO + e*(ONE+r(t))/(TWO*u*u)
    Jarr(3) = e/TWO + e*(TWO+s(t))/(TWO*v*v)
    Jarr(4) = -ONE/TWO - (TWO+s(t))/(TWO*v*v)

    ! return success
    ierr = 0
    return

  end function

  ! Helper functions
  real(c_double) function r(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none
    real(c_double) :: t

    result = 0.5d0*cos(t)
    return

  end function

  real(c_double) function s(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double) :: t

    result = cos(w*t)
    return

  end function

  real(c_double) function rdot(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double) :: t

    result = -0.5d0*sin(t)
    return

  end function

  real(c_double) function sdot(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double) :: t

    result = -w*sin(w*t)
    return

  end function

  real(c_double) function utrue(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double) :: t

    result = sqrt(ONE+r(t))
    return

  end function

  real(c_double) function vtrue(t) &
    result(result)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double) :: t

    result = sqrt(TWO+s(t))
    return

  end function

  integer(c_int) function Ytrue(t, y) &
    result(ierr)

    use, intrinsic :: iso_c_binding
    implicit none

    real(c_double), value :: t
    type(N_Vector) :: y

    real(c_double), pointer :: yarr(:)

    yarr => FN_VGetArrayPointer(y)

    yarr(1) = utrue(t)
    yarr(2) = vtrue(t)

    ierr = 0
    return

  end function

end module

program main

  use ode_mod
  implicit none

  ! general problem variables
  type(c_ptr) sunctx                       ! SUNDIALS simulation context
  integer(c_int) :: retval                 ! reusable error-checking flag
  type(N_Vector), pointer :: y             ! vector for the solution
  real(c_double), pointer :: yarr(:)       ! array of data for y vector
  type(c_ptr) :: arkode_mem                ! ARKODE memory structure
  type(c_ptr) :: inner_arkode_mem          ! ARKODE memory structure
  type(c_ptr) :: inner_stepper             ! inner stepper
  type(c_ptr) :: BTF, BTs                  ! fast/slow method Butcher table
  type(c_ptr) :: SC                        ! slow coupling coefficients
  type(SUNMatrix), pointer :: MATf         ! matrix for fast solver
  type(SUNLinearSolver), pointer :: LSf    ! fast linear solver object
  type(SUNMatrix), pointer :: MATs         ! matrix for slow solver
  type(SUNLinearSolver), pointer :: LSs    ! slow linear solver object
  integer(c_int) :: solve_type = 0         ! problem configuration type
  logical :: implicit_slow
  logical :: imex_slow = .FALSE.
  real(c_double) :: hf, gamma, beta, t, tret(1), tout
  real(c_double) :: uerr, verr, uerrtot, verrtot, errtot
  real(c_double), allocatable :: Af(:,:), bf(:), cf(:), df(:) ! Arrays for fast Butcher table, NOTE: must be in row-major order
  real(c_double), allocatable :: As(:,:), bs(:), cs(:), ds(:) ! Arrays for slow Butcher table, NOTE: must be in row-major order
  integer(c_int) :: iout, argc, argi
  integer(c_long) :: nsts(1), nstf(1), nfse(1), nfsi(1), nff(1)
  integer(c_long) :: nnif(1), nncf(1), njef(1), nnis(1), nncs(1), njes(1), tmp(1)
  character(len=32), dimension(:), allocatable :: argv

  !
  ! Initialization
  !

  arkode_mem = c_null_ptr
  inner_arkode_mem = c_null_ptr
  inner_stepper = c_null_ptr
  BTs = c_null_ptr
  SC = c_null_ptr
  MATf => null()
  MATs => null()
  LSf => null()
  LSs => null()

  argc = command_argument_count()
  allocate(argv(argc))  ! I've omitted checking the return status of the allocation

  do argi = 1, argc
    call get_command_argument(argi, argv(argi))
  end do

  ! Retrieve the command-line options: solve_type h G w e */
  if (argc > 0) read(argv(1), *) solve_type
  if (argc > 1) read(argv(2), *) hs
  if (argc > 2) read(argv(3), *) G
  if (argc > 3) read(argv(4), *) w
  if (argc > 4) read(argv(5), *) e

  ! Check arguments for validity
  !   0 <= solve_type <= 9
  !   G < 0.0
  !   h > 0
  !   h < 1/|G| (explicit slow)
  !   w >= 1.0
  if ((solve_type < 0) .or. (solve_type > 9)) then
    print *, "ERROR: solve_type be an integer in [0,9]"
    stop -1
  end if
  if (G >= ZERO) then
    print *, "ERROR: G must be a negative real number"
    stop -1
  end if
  implicit_slow = .false.
  if ((solve_type == 4) .or. (solve_type == 7)) then
    implicit_slow = .true.
  end if
  if ((solve_type == 8) .or. (solve_type == 9)) then
    implicit_slow = .true.
    imex_slow = .true.
  end if
  if (hs <= ZERO) then
    print *, "ERROR: hs must be in positive"
    stop -1
  end if
  if ((hs > ONE/abs(G)) .and. (.not. implicit_slow)) then
    print *, "ERROR: hs must be in (0, 1/|G|)"
    stop -1
  end if
  if (w < ONE) then
    print *, "ERROR: w must be >= 1.0"
    stop -1
  end if
  hf = hs/w

  ! Initial problem output (and set implicit solver tolerances as needed)
  print *, "Multirate nonlinear Kvaerno-Prothero-Robinson test problem:"
  print '(A,F4.2,A,F4.2,A)', "    time domain: (", T0, ", ", Tf, "]"
  print '(A,E12.4,A)', "    hs = ", hs
  print '(A,E12.4,A)', "    hf = ", hf
  print '(A,E12.4,A)', "     G = ", G
  print '(A,E12.4,A)', "     w = ", w
  print '(A,E12.4,A)', "     e = ", e

  select case (solve_type)
    case (0)
      print *, "   solver: exp-3/exp-3 (standard MIS)"
    case (1)
      print *, "   solver: none/exp-3 (no slow, explicit fast)"
    case (2)
      reltol = max(hs*hs*hs, real(1e-10,8))
      abstol = 1e-11
      print *, "   solver: none/dirk-3 (no slow, dirk fast)"
      print '(A,E12.4,A,E12.4)', "    reltol: ", reltol, " abstol: ", abstol
    case (3)
      print *, "   solver: exp-3/none (explicit slow, no fast)"
    case (4)
      reltol = max(hs*hs, real(1e-10,8))
      abstol = 1e-11
      print *, "   solver: dirk-2/none (dirk slow, no fast)"
      print '(A,E12.4,A,E12.4)', "    reltol: ", reltol, " abstol: ", abstol
    case (5)
      print *, "   solver: exp-4/exp-4 (MRI-GARK-ERK45a / ERK-4-4)"
    case (6)
      print *, "   solver: exp-4/exp-3 (MRI-GARK-ERK45a / ERK-3-3)"
    case (7)
      reltol = max(hs*hs*hs, real(1e-10,8))
      abstol = 1e-11
      print *, "   solver: dirk-3/exp-3 (MRI-GARK-ESDIRK34a / ERK-3-3) -- solve decoupled"
      print '(A,E12.4,A,E12.4)', "    reltol: ", reltol, " abstol: ", abstol
    case (8)
      reltol = max(hs*hs*hs, real(1e-10,8))
      abstol = 1e-11
      print *, "   solver: ars343/exp-3 (IMEX-MRI3b / ERK-3-3) -- solve decoupled"
      print '(A,E12.4,A,E12.4)', "    reltol: ", reltol, " abstol: ", abstol
    case (9)
      reltol = max(hs*hs*hs*hs, real(1e-14,8))
      abstol = 1e-14
      print *, "   solver: imexark4/exp-4 (IMEX-MRI4 / ERK-4-4) -- solve decoupled"
      print '(A,E12.4,A,E12.4)', "    reltol: ", reltol, " abstol: ", abstol
  end select

  ! Create the SUNDIALS context object for this simulation
  retval = FSUNContext_Create(c_null_ptr, sunctx)
  call check_retval(retval, 'FSUNContext_Create')

  ! Create and initialize serial vector for the solution
  y => FN_VNew_Serial(NEQ, sunctx)
  if (.not. associated(y)) then
    print *, 'ERROR: N_VNew_Serial failed'
    stop 1
  end if
  yarr => FN_VGetArrayPointer(y)

  retval = Ytrue(T0, y)
  call check_retval(retval, 'Ytrue')

  !
  ! Create the fast integrator and set options
  !

  ! Initialize the fast integrator. Specify the fast right-hand side
  ! function in y'=fs(t,y)+ff(t,y) = fse(t,y)+fsi(t,y)+ff(t,y), the inital time T0,
  ! and the initial dependent variable vector y.

  if (solve_type == 0 .or. solve_type == 6 .or. solve_type == 7 .or. solve_type == 8) then
    ! erk-3-3 fast solver
    inner_arkode_mem = FARKStepCreate(c_funloc(ff), c_null_funptr, T0, y, sunctx)
    allocate(Af(3,3))
    allocate(bf(3))
    allocate(cf(3))
    allocate(df(3))
    Af = 0.d0
    bf = 0.d0
    cf = 0.d0
    df = 0.d0
    Af(1,2) = 0.5d0
    Af(1,3) = -ONE
    Af(2,3) = TWO
    bf(1) = ONE/6.0d0
    bf(2) = TWO/3.0d0
    bf(3) = ONE/6.0d0
    df(3) = ONE
    cf(2) = 0.5d0
    cf(3) = ONE
    BTf = FARKodeButcherTable_Create(3, 3, 2, cf, Af, bf, df)
    retval = FARKStepSetTables(inner_arkode_mem, 3, 2, c_null_ptr, BTf)
    call check_retval(retval, "FARKStepSetTables")
  else if (solve_type == 1) then
    ! erk-3-3 fast solver (full problem)
    inner_arkode_mem = FARKStepCreate(c_funloc(fn), c_null_funptr, T0, y, sunctx)
    allocate(Af(3,3))
    allocate(bf(3))
    allocate(cf(3))
    allocate(df(3))
    Af = 0.d0
    bf = 0.d0
    cf = 0.d0
    df = 0.d0
    Af(1,2) = 0.5d0
    Af(1,3) = -ONE
    Af(2,3) = TWO
    bf(1) = ONE/6.0d0
    bf(2) = TWO/3.0d0
    bf(3) = ONE/6.0d0
    df(3) = ONE
    cf(2) = 0.5d0
    cf(3) = ONE
    BTf = FARKodeButcherTable_Create(3, 3, 2, cf, Af, bf, df)
    retval = FARKStepSetTables(inner_arkode_mem, 3, 2, c_null_ptr, BTf)
    call check_retval(retval, "FARKStepSetTables")
  else if (solve_type == 5 .or. solve_type == 9) then
    ! erk-4-4 fast solver
    inner_arkode_mem = FARKStepCreate(c_funloc(ff), c_null_funptr, T0, y, sunctx)
    allocate(Af(4,4))
    allocate(bf(4))
    allocate(cf(4))
    allocate(df(4))
    Af = 0.d0
    bf = 0.d0
    cf = 0.d0
    df = 0.d0
    Af(1,2) = 0.5d0
    Af(2,3) = 0.5d0
    Af(3,4) = ONE
    bf(1) = ONE/6.0d0
    bf(2) = ONE/3.0d0
    bf(3) = ONE/3.0d0
    bf(4) = ONE/6.0d0
    cf(2) = 0.5d0
    cf(3) = 0.5d0
    cf(4) = ONE
    BTf = FARKodeButcherTable_Create(4, 4, 0, cf, Af, bf, df)
    retval = FARKStepSetTables(inner_arkode_mem, 4, 0, c_null_ptr, BTf)
    call check_retval(retval, "FARKStepSetTables")
  else if (solve_type == 2) then
    ! esdirk-3-3 fast solver (full problem)
    inner_arkode_mem = FARKStepCreate(c_null_ptr, c_funloc(fn), T0, y, sunctx)
    beta  = sqrt(3.0d0)/6.0d0 + 0.5d00
    gamma = (-ONE/8.0d0)*(sqrt(3.0d0)+ONE)
    allocate(Af(3,3))
    allocate(bf(3))
    allocate(cf(3))
    allocate(df(3))
    Af = 0.d0
    bf = 0.d0
    cf = 0.d0
    df = 0.d0
    Af(1,2) = 4.0d0*gamma+TWO*beta
    Af(2,2) = ONE-4.0d0*gamma-TWO*beta
    Af(1,3) = 0.5d0-beta-gamma
    Af(2,3) = gamma
    Af(3,3) = beta
    bf(1) = ONE/6.0d0
    bf(2) = ONE/6.0d0
    bf(3) = TWO/3.0d0
    cf(2) = ONE
    cf(3) = 0.5d0
    BTf = FARKodeButcherTable_Create(3, 3, 0, cf, Af, bf, df)
    retval = FARKStepSetTables(inner_arkode_mem, 3, 0, BTf, c_null_ptr)
    call check_retval(retval, "FARKStepSetTables")
    MATf => FSUNDenseMatrix(NEQ, NEQ, sunctx)
    LSf => FSUNLinSol_Dense(y, MATf, sunctx)
    retval = FARKStepSetLinearSolver(inner_arkode_mem, LSf, MATf)
    call check_retval(retval, "FARKStepSetLinearSolver")
    retval = FARKStepSetJacFn(inner_arkode_mem, c_funloc(Jn))
    call check_retval(retval, "FARKStepSetJacFn")
    retval = FARKStepSStolerances(inner_arkode_mem, reltol, abstol)
    call check_retval(retval, "FARKStepSStolerances")
  else if (solve_type == 3 .or. solve_type == 4) then
    ! no fast dynamics ('evolve' explicitly w/ erk-3-3)
    inner_arkode_mem = FARKStepCreate(c_funloc(f0), c_null_funptr, T0, y, sunctx)
    allocate(Af(3,3))
    allocate(bf(3))
    allocate(cf(3))
    allocate(df(3))
    Af = 0.d0
    bf = 0.d0
    cf = 0.d0
    df = 0.d0
    Af(1,2) = 0.5d0
    Af(1,3) = -ONE
    Af(2,3) = TWO
    bf(1) = ONE/6.0d0
    bf(2) = TWO/3.0d0
    bf(3) = ONE/6.0d0
    df(1) = ONE
    cf(2) = 0.5d0
    cf(3) = ONE
    BTf = FARKodeButcherTable_Create(3, 3, 2, cf, Af, bf, df)
    retval = FARKStepSetTables(inner_arkode_mem, 3, 2, c_null_ptr, BTf)
    call check_retval(retval, "FARKStepSetTables")
  end if

  if (.not. c_associated(inner_arkode_mem)) then
    print *, 'ERROR: inner_arkode_mem = NULL'
    stop 1
  end if

  ! Set the fast step size */
  retval = FARKStepSetFixedStep(inner_arkode_mem, hf)
  if (retval /= 0) then
    print *, 'ERROR: FARKStepSetFixedStep failed'
    stop 1
  end if

  ! Create inner stepper */
  retval = FARKStepCreateMRIStepInnerStepper(inner_arkode_mem, inner_stepper)
  if (retval /= 0) then
    print *, 'ERROR: FARKStepCreateMRIStepInnerStepper failed'
    stop 1
  end if

  !
  ! Create the slow integrator and set options
  !

  ! Initialize the slow integrator. Specify the slow right-hand side
  ! function in y'=fs(t,y)+ff(t,y) = fse(t,y)+fsi(t,y)+ff(t,y), the inital time
  ! T0, the initial dependent variable vector y, and the fast integrator.
  if (solve_type == 0) then
    ! KW3 slow solver
    arkode_mem = FMRIStepCreate(c_funloc(fs), c_null_funptr, T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_MIS_KW3)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
  else if (solve_type == 3) then
    ! KW3 slow solver (full problem)
    arkode_mem = FMRIStepCreate(c_funloc(fn), c_null_funptr, T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_MIS_KW3)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
  else if (solve_type == 5 .or. solve_type == 6) then
    ! MRI-GARK-ERK45a slow solver
    arkode_mem = FMRIStepCreate(c_funloc(fs), c_null_funptr, T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_MRI_GARK_ERK45a)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
  else if (solve_type == 1 .or. solve_type == 2) then
    ! no slow dynamics (use ERK-2-2)
    arkode_mem = FMRIStepCreate(c_funloc(f0), c_null_funptr, T0, y, inner_stepper, sunctx)
    if (.not. c_associated(arkode_mem)) then
      print *, 'ERROR: arkode_mem = NULL'
      stop 1
    end if
    allocate(As(2,2))
    allocate(bs(2))
    allocate(cs(2))
    allocate(ds(2))
    As = 0.d0
    bs = 0.d0
    cs = 0.d0
    ds = 0.d0
    As(1,2) = TWO/3.0d0
    bs(1) = 0.25d0
    bs(2) = 0.75d0
    cs(2) = TWO/3.0d0
    BTs = FARKodeButcherTable_Create(2, 2, 0, cs, As, bs, ds)
    SC = FMRIStepCoupling_MIStoMRI(BTs, 2, 0)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
  else if (solve_type == 4) then
    ! dirk-2 (trapezoidal), solve-decoupled slow solver
    arkode_mem = FMRIStepCreate(c_null_ptr, c_funloc(fn), T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_MRI_GARK_IRK21a)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
    MATs => FSUNDenseMatrix(NEQ, NEQ, sunctx)
    LSs => FSUNLinSol_Dense(y, MATs, sunctx)
    retval = FMRIStepSetLinearSolver(arkode_mem, LSs, MATs)
    call check_retval(retval, "FMRIStepSetLinearSolver")
    retval = FMRIStepSetJacFn(arkode_mem, c_funloc(Jn))
    call check_retval(retval, "FMRIStepSetJacFn")
    retval = FMRIStepSStolerances(arkode_mem, reltol, abstol)
    call check_retval(retval, "FMRIStepSStolerances")
  else if (solve_type == 7) then
    ! MRI-GARK-ESDIRK34a, solve-decoupled slow solver
    arkode_mem = FMRIStepCreate(c_null_ptr, c_funloc(fs), T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_MRI_GARK_ESDIRK34a)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
    MATs => FSUNDenseMatrix(NEQ, NEQ, sunctx)
    LSs => FSUNLinSol_Dense(y, MATs, sunctx)
    retval = FMRIStepSetLinearSolver(arkode_mem, LSs, MATs)
    call check_retval(retval, "FMRIStepSetLinearSolver")
    retval = FMRIStepSetJacFn(arkode_mem, c_funloc(Js))
    call check_retval(retval, "FMRIStepSetJacFn")
    retval = FMRIStepSStolerances(arkode_mem, reltol, abstol)
    call check_retval(retval, "FMRIStepSStolerances")
  else if (solve_type == 8) then
    ! IMEX-MRI-GARK3b, solve-decoupled slow solver
    arkode_mem = FMRIStepCreate(c_funloc(fse), c_funloc(fsi), T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_IMEX_MRI_GARK3b)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    call check_retval(retval, "FMRIStepSetCoupling")
    MATs => FSUNDenseMatrix(NEQ, NEQ, sunctx)
    LSs => FSUNLinSol_Dense(y, MATs, sunctx)
    retval = FMRIStepSetLinearSolver(arkode_mem, LSs, MATs)
    call check_retval(retval, "FMRIStepSetLinearSolver")
    retval = FMRIStepSetJacFn(arkode_mem, c_funloc(Jsi))
    call check_retval(retval, "FMRIStepSetJacFn")
    retval = FMRIStepSStolerances(arkode_mem, reltol, abstol)
    call check_retval(retval, "FMRIStepSStolerances")
  else if (solve_type == 9) then
    ! IMEX-MRI-GARK4, solve-decoupled slow solver
    arkode_mem = FMRIStepCreate(c_funloc(fse), c_funloc(fsi), T0, y, inner_stepper, sunctx)
    SC = FMRIStepCoupling_LoadTable(ARKODE_IMEX_MRI_GARK4)
    retval = FMRIStepSetCoupling(arkode_mem, SC)
    MATs => FSUNDenseMatrix(NEQ, NEQ, sunctx)
    LSs => FSUNLinSol_Dense(y, MATs, sunctx)
    retval = FMRIStepSetLinearSolver(arkode_mem, LSs, MATs)
    call check_retval(retval, "FMRIStepSetLinearSolver")
    retval = FMRIStepSetJacFn(arkode_mem, c_funloc(Jsi))
    call check_retval(retval, "FMRIStepSetJacFn")
    retval = FMRIStepSStolerances(arkode_mem, reltol, abstol)
    call check_retval(retval, "FMRIStepSStolerances")
  end if

  if (.not. c_associated(arkode_mem)) then
    print *, 'ERROR: arkode_mem = NULL'
    stop 1
  end if

  ! Set the slow step size
  retval = FMRIStepSetFixedStep(arkode_mem, hs)
  call check_retval(retval, "FMRIStepSetFixedStep")

  !
  ! Integrate ODE
  !

  ! Main time-stepping loop: calls MRIStepEvolve to perform the
  ! integration, then prints results. Stops when the final time
  ! has been reached
  t = T0
  tout = T0+dTout
  uerr = ZERO
  verr = ZERO
  uerrtot = ZERO
  verrtot = ZERO
  errtot  = ZERO
  print *, "        t           u           v       uerr      verr"
  print *, "   ------------------------------------------------------"
  print '(A, F10.6, A, F10.6, A, F10.6, A, E8.2, A, E8.2)', &
    "   ", t, "  ", yarr(1), "  ", yarr(2), "  ", uerr, "  ", verr

  do iout = 1, Nt
    ! call integrator
    retval = FMRIStepEvolve(arkode_mem, tout, y, tret, ARK_NORMAL)
    call check_retval(retval, "FMRIStepEvolve")

    ! access/print solution and error
    uerr = abs(yarr(1)-utrue(tret(1)))
    verr = abs(yarr(2)-vtrue(tret(1)))
    print '(A, F10.6, A, F10.6, A, F10.6, A, E8.2, A, E8.2)', &
    "   ", tret(1), "  ", yarr(1), "  ", yarr(2), "  ", uerr, "  ", verr
    uerrtot = uerrtot + uerr*uerr
    verrtot = verrtot + verr*verr
    errtot = errtot + uerr*uerr + verr*verr

    ! successful solve: update time
    tout = tout + dTout
    if (tout > Tf) then
      tout = Tf
    end if
  enddo
  uerrtot = sqrt(uerrtot / Nt)
  verrtot = sqrt(verrtot / Nt)
  errtot = sqrt(errtot / Nt / 2)
  print *, "   ------------------------------------------------------"

  !
  ! Finalize
  !

  ! Get some slow integrator statistics
  retval = FMRIStepGetNumSteps(arkode_mem, nsts)
  retval = FMRIStepGetNumRhsEvals(arkode_mem, nfse, nfsi)

  ! Get some fast integrator statistics
  retval = FARKStepGetNumSteps(inner_arkode_mem, nstf)
  retval = FARKStepGetNumRhsEvals(inner_arkode_mem, nff, tmp)

  ! Print some final statistics
  print *, "Final Solver Statistics:"
  print '(A, I7, A, I7)', "   Steps: nsts = ", nsts, ", nstf = ", nstf
  print '(A, E9.3, A, E9.3, A, E9.3)', "   u error = ", uerrtot, ", v error = ", verrtot, ", total error = ", errtot
  if (imex_slow) then
    print '(A, I7, A, I7, A, I7)', "   Total RHS evals: Fse = ", nfse(1), ", Fsi = ", nfsi(1), ", Ff = ", nff(1)
  else if (implicit_slow) then
    print '(A, I7, A, I7)', "   Total RHS evals: Fs = ", nfsi(1), ", Ff = ", nff(1)
  else
    print '(A, I7, A, I7)', "   Total RHS evals: Fs = ", nfse(1), ", Ff = ", nff(1)
  end if

  ! Get/print slow integrator decoupled implicit solver statistics
  if ((solve_type == 4) .or. (solve_type == 7) .or. &
      (solve_type == 8) .or. (solve_type == 9)) then
    retval = FMRIStepGetNonlinSolvStats(arkode_mem, nnis, nncs)
    call check_retval(retval, "MRIStepGetNonlinSolvStats")
    retval = FMRIStepGetNumJacEvals(arkode_mem, njes)
    call check_retval(retval, "MRIStepGetNumJacEvals")
    print '(A, I7)', "   Slow Newton iters = ", nnis
    print '(A, I7)', "   Slow Newton conv fails = ", nncs
    print '(A, I7)', "   Slow Jacobian evals = ", njes
  end if

  ! Get/print fast integrator implicit solver statistics
  if (solve_type == 2) then
    retval = FARKStepGetNonlinSolvStats(inner_arkode_mem, nnif, nncf)
    call check_retval(retval, "ARKStepGetNonlinSolvStats")
    retval = FARKStepGetNumJacEvals(inner_arkode_mem, njef)
    call check_retval(retval, "ARKStepGetNumJacEvals")
    print '(A, I7)', "   Fast Newton iters = ", nnif
    print '(A, I7)', "   Fast Newton conv fails = ", nncf
    print '(A, I7)', "   Fast Jacobian evals = ", njef
  end if

  ! Clean up and return
  if (allocated(Af)) deallocate(Af)
  if (allocated(bf)) deallocate(bf)
  if (allocated(cf)) deallocate(cf)
  if (allocated(df)) deallocate(df)
  if (allocated(As)) deallocate(As)
  if (allocated(bs)) deallocate(bs)
  if (allocated(cs)) deallocate(cs)
  if (allocated(ds)) deallocate(ds)
  call FN_VDestroy(y)                                ! Free y vector
  call FARKodeButcherTable_Free(BTs)                 ! Butcher table
  call FMRIStepCoupling_Free(SC)                     ! Free coupling coefficients
  if (associated(MATf)) call FSUNMatDestroy(MATf)    ! Free fast matrix
  if (associated(LSf)) retval = FSUNLinSolFree(LSf)  ! Free fast linear solver
  if (associated(MATs)) call FSUNMatDestroy(MATs)    ! Free slow matrix
  if (associated(LSs)) retval = FSUNLinSolFree(LSs)  ! Free slow linear solver
  call FARKStepFree(inner_arkode_mem)                ! Free fast integrator memory
  retval = FMRIStepInnerStepper_Free(inner_stepper)  ! Free inner stepper
  call FMRIStepFree(arkode_mem)                      ! Free slow integrator memory
  retval = FSUNContext_Free(sunctx)                  ! Free context

end program

subroutine check_retval(retval, name)
  use, intrinsic :: iso_c_binding

  character(len=*) :: name
  integer(c_int)   :: retval

  if (retval /= 0) then
    write(*,'(A,A,A)') 'ERROR: ', name,' returned nonzero'
    stop 1
  end if
end subroutine


      program fabien
      implicit integer(a-z)

c     Problem with expression normalization

      integer n, m, i
cfirst      parameter(n=101, m=24, l1=min(n,m), l2=max(n,m), l3=m**2,
cfirst     &     l4=mod(n,m), l5=n/m)

c     Alternative to PARAMETER (partial evaluation)
csecond      n = 101
csecond      m = 24
csecond      l1 = min(n,m)
csecond      l2=max(n,m)
csecond      l3=m**2
csecond      l4=mod(n,m)
csecond      l5=n/m

c     Check that parameters are properly evaluated (eval.c)

      j1 = l1
      j2 = l2
      j3 = l3
      j4 = l4
      j5 = l5
      print *, j1, j2, j3, j4, j5

c     Check expression normalization or partial evaluation

      i1 = min(n, m)
      i1 = min0(n, m)
      i2 = max(n, m)
      i2 = max0(n, m)
      i3 = m**2
      i4 = mod(n, m)
      i5 = n/m
      print *, i1, i2, i3, i4, i5

      end


! { dg-do compile }
! Complex constants with integer components should take ther kind from
! the real typed component, or default complex type if both components have
! integer type.
program prog
  call test1 ((1_8, 1.0_4))
  call test2 ((1_8, 2_8))
contains
subroutine test1(x)
  complex(4) :: x
end subroutine
subroutine test2(x)
  complex :: x
end subroutine
end program


program test_random_number

    use OMP_LIB
    integer, parameter :: l = 3
    real :: rr(l)
    integer, allocatable :: seed(:)
    integer :: n

    call random_seed(size = n)
    allocate(seed(n*3))
    seed = 878768768
    call random_seed(put=seed)

    !$OMP PARALLEL private(rr)

        call random_number(rr)

        print *, 'Process', OMP_GET_THREAD_NUM(), rr

    !$OMP END PARALLEL

    ! this parallel code will produce this code in two runs:
    !
    !    PS C:\Users\AMartinez\Desktop\fortran_test> ./random.exe
    !     Process           2  0.162345409      0.840058029       9.94555354E-02
    !     Process           0  0.334234238      0.642744005      0.283221900
    !     Process           4   7.85911679E-02  0.241505861      0.400358200
    !     Process           3  0.766133487      0.591100812      0.382381201
    !     Process           6   1.73936486E-02  0.396930397      0.280517757
    !     Process           5  0.186948657      0.335481524      0.356720865
    !     Process           7  0.252353966      0.576505065       2.22165585E-02
    !     Process           1  0.844142258      0.983546615      0.513327420
    !    PS C:\Users\AMartinez\Desktop\fortran_test> ./random.exe
    !     Process           6  0.162345409      0.840058029       9.94555354E-02
    !     Process           0  0.334234238      0.642744005      0.283221900
    !     Process           3   7.85911679E-02  0.241505861      0.400358200
    !     Process           2   1.73936486E-02  0.396930397      0.280517757
    !     Process           1  0.766133487      0.591100812      0.382381201
    !     Process           5  0.186948657      0.335481524      0.356720865
    !     Process           7  0.252353966      0.576505065       2.22165585E-02
    !     Process           4  0.844142258      0.983546615      0.513327420
    !
    ! the sequences of random numbers are the same but obtained in a different order
    !
    ! for conditional simulations, you can generate the entire array in one call

end program


      SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To pack/unpack the upper or lower triangle of a symmetric matrix.
C     The packed matrix is stored column-wise in the one-dimensional
C     array AP.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether the matrix should be packed or unpacked,
C             as follows:
C             = 'P':  The matrix should be packed;
C             = 'U':  The matrix should be unpacked.
C
C     UPLO    CHARACTER*1
C             Specifies the part of the matrix to be packed/unpacked,
C             as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input or output) DOUBLE PRECISION array, dimension
C             (LDA,N)
C             This array is an input parameter if JOB = 'P', and an
C             output parameter if JOB = 'U'.
C             On entry, if JOB = 'P', the leading N-by-N upper
C             triangular part (if UPLO = 'U'), or lower triangular part
C             (if UPLO = 'L'), of this array must contain the
C             corresponding upper or lower triangle of the symmetric
C             matrix A, and the other strictly triangular part is not
C             referenced.
C             On exit, if JOB = 'U', the leading N-by-N upper triangular
C             part (if UPLO = 'U'), or lower triangular part (if
C             UPLO = 'L'), of this array contains the corresponding
C             upper or lower triangle of the symmetric matrix A; the
C             other strictly triangular part is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     AP      (output or input) DOUBLE PRECISION array, dimension
C             (N*(N+1)/2)
C             This array is an output parameter if JOB = 'P', and an
C             input parameter if JOB = 'U'.
C             On entry, if JOB = 'U', the leading N*(N+1)/2 elements of
C             this array must contain the upper (if UPLO = 'U') or lower
C             (if UPLO = 'L') triangle of the symmetric matrix A, packed
C             column-wise. That is, the elements are stored in the order
C             11, 12, 22, ..., 1n, 2n, 3n, ..., nn,      if UPLO = 'U';
C             11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'.
C             On exit, if JOB = 'P', the leading N*(N+1)/2 elements of
C             this array contain the upper (if UPLO = 'U') or lower
C             (if UPLO = 'L') triangle of the symmetric matrix A, packed
C             column-wise, as described above.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER          JOB, UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), AP(*)
C     .. Local Scalars ..
      LOGICAL            LUPLO
      INTEGER            IJ, J
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
      LUPLO = LSAME( UPLO, 'L' )
      IJ = 1
      IF( LSAME( JOB, 'P' ) ) THEN
         IF( LUPLO ) THEN
C
C           Pack the lower triangle of A.
C
            DO 20 J = 1, N
               CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 )
               IJ = IJ + N - J + 1
   20       CONTINUE
C
         ELSE
C
C           Pack the upper triangle of A.
C
            DO 40 J = 1, N
               CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 )
               IJ = IJ + J
   40       CONTINUE
C
         END IF
      ELSE
         IF( LUPLO ) THEN
C
C           Unpack the lower triangle of A.
C
            DO 60 J = 1, N
               CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 )
               IJ = IJ + N - J + 1
   60       CONTINUE
C
         ELSE
C
C           Unpack the upper triangle of A.
C
            DO 80 J = 1, N
               CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 )
               IJ = IJ + J
   80       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of MA02DD ***
      END


program test_ewald2

! This test compares lattice energy 'eew' calculated from the Ewald summation
! against the energy calculated using the Madelung constant for various lattice
! constants L. The agreement is essentially to machine precision.

! Similar to test_ewald, but here we the diagonal Na atom is moved by 3/8
! towards the Cl atom.

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: ewald, ewald2, fred2fcart
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat
! Various NaCl lattice constants in A
real(dp), parameter :: Llist(5) = [5.6402_dp, 5.5_dp, 4.5_dp, 6.5_dp, 10._dp]
! The components of the correct force and stress tensor (multiplied by L)
real(dp), parameter :: fcorrect0 = 10.180280846982683_dp
real(dp), parameter :: stress1 = -6.6903565769534099_dp
real(dp), parameter :: stress2 = -5.7797035916557675_dp

real(dp) :: ucvol
integer, allocatable :: typat(:)
real(dp) :: gmet(3, 3), rmet(3, 3), rprim(3, 3), gprim(3, 3), stress(6)
real(dp) :: eew
real(dp), allocatable :: xred(:, :), zion(:), grewtn(:, :), fcart(:, :)
real(dp) :: L, alpha, E_ewald, E_madelung
integer :: i, j

! Madelung constant for NaCl, where the diagonal Na atom is moved by 3/8
! towards the Cl atom
alpha = 2.5088837163575413_dp

! Conventional cell:
natom = 8
ntypat = 2
allocate(xred(3, natom), zion(ntypat), grewtn(3, natom), typat(natom), &
    fcart(3, natom))
! Cl^-
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 0] / 2._dp
xred(:, 3) = [1, 0, 1] / 2._dp
xred(:, 4) = [0, 1, 1] / 2._dp
! Na^+
xred(:, 5) = [1, 1, 1] / 2._dp
xred(:, 6) = [1, 0, 0] / 2._dp
xred(:, 7) = [0, 1, 0] / 2._dp
xred(:, 8) = [0, 0, 1] / 2._dp
xred(:, 5:8) = xred(:, 5:8) - spread([3, 3, 3] / 8._dp, 2, 4)
xred(:, 6:8) = xred(:, 6:8) - floor(xred(:, 6:8))
typat = [1, 1, 1, 1, 2, 2, 2, 2]
zion = [-1, +1]

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr
    print *, L

    rmet = 0
    rmet(1, 1) = L**2
    rmet(2, 2) = L**2
    rmet(3, 3) = L**2

    ! gmet = inv(rmet)
    gmet = 0
    gmet(1, 1) = 1/L**2
    gmet(2, 2) = 1/L**2
    gmet(3, 3) = 1/L**2

    ! ucvol = sqrt(det(rmet))
    ucvol = L**3

    ! Reciprocal primitive vectors (without 2*pi) in cartesian coordinates.
    ! gmet = matmul(transpose(gprim), gprim)
    gprim = 0
    gprim(1, 1) = 1 / L
    gprim(2, 2) = 1 / L
    gprim(3, 3) = 1 / L

    ! Real space primitive vectors
    rprim = 0
    rprim(1, 1) = L
    rprim(2, 2) = L
    rprim(3, 3) = L

    call ewald(eew,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)

    E_ewald = eew / (natom/ntypat)
    E_madelung = -2*alpha/L

    call ewald2(gmet,natom,ntypat,rmet,rprim,gprim,stress,typat,ucvol, &
                xred,zion)

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung:", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:   ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "error:   ", abs(E_ewald - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-14_dp)
    stress = -stress * ucvol
    call assert(all(abs(stress - [stress1, stress1, stress1, &
        stress2, stress2, stress2]/L) < 1e-10_dp))

    call fred2fcart(fcart, grewtn, gprim)
    do j = 1, 4
        call assert(all(abs(fcart(:, j) - (-fcorrect0/L**2)) < 1e-10_dp))
    end do
    do j = 5, 8
        call assert(all(abs(fcart(:, j) - (+fcorrect0/L**2)) < 1e-10_dp))
    end do
end do
deallocate(xred, zion, grewtn, typat, fcart)

print *, "--------"

! Primitive cell (FCC lattice)
natom = 2
ntypat = 2
allocate(xred(3, natom), zion(ntypat), grewtn(3, natom), typat(natom), &
    fcart(3, natom))
! Cl^-
xred(:, 1) = [0, 0, 0]
! Na^+
xred(:, 2) = [1, 1, 1] / 2._dp
xred(:, 2) = xred(:, 2) - [3, 3, 3] / 8._dp
typat = [1, 2]
zion = [-1._dp, 1._dp]

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr

    rmet(1, :) = [2, 1, 1]
    rmet(2, :) = [1, 2, 1]
    rmet(3, :) = [1, 1, 2]
    rmet = rmet * L**2 / 4

    ! gmet = inv(rmet)
    gmet(1, :) = [ 3, -1, -1]
    gmet(2, :) = [-1,  3, -1]
    gmet(3, :) = [-1, -1,  3]
    gmet = gmet / L**2

    ! ucvol = sqrt(det(rmet))
    ucvol = L**3 / 4

    ! Reciprocal primitive vectors (without 2*pi) in cartesian coordinates.
    ! gmet = matmul(transpose(gprim), gprim)
    gprim(:, 1) = [ 1,  1, -1] / L
    gprim(:, 2) = [-1,  1,  1] / L
    gprim(:, 3) = [ 1, -1,  1] / L

    rprim(:, 1) = [1, 0, 1] * L / 2
    rprim(:, 2) = [1, 1, 0] * L / 2
    rprim(:, 3) = [0, 1, 1] * L / 2

    call ewald(eew,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)

    E_ewald = eew / (natom/ntypat)
    E_madelung = -2*alpha/L

    call ewald2(gmet,natom,ntypat,rmet,rprim,gprim,stress,typat,ucvol, &
                xred,zion)

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung:", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:   ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "error:   ", abs(E_ewald - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-14_dp)
    call fred2fcart(fcart, grewtn, gprim)
    call assert(all(abs(fcart(:, 1) - (-fcorrect0/L**2)) < 1e-10_dp))
    call assert(all(abs(fcart(:, 2) - (+fcorrect0/L**2)) < 1e-10_dp))
    stress = -stress * L**3
    call assert(all(abs(stress - [stress1, stress1, stress1, &
        stress2, stress2, stress2]/L) < 1e-10_dp))
end do
deallocate(xred, zion, grewtn, typat, fcart)
end program


      subroutine clawpack46_set_capacity(mx,my,mbc,dx,dy,
     &      area,mcapa,maux,aux)
      implicit none

      integer mbc, mx, my, maux, mcapa
      double precision dx, dy
      double precision  aux(1-mbc:mx+mbc,1-mbc:my+mbc, maux)
      double precision area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      integer i,j
      double precision dxdy

      dxdy = dx*dy

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            aux(i,j,mcapa) = area(i,j)/dxdy
         enddo
      enddo

      end


program phaml_master
use phaml
implicit none
type(phaml_solution_type) :: soln
call phaml_create(soln,nproc=4,triangle_files="superior.1")
call phaml_solve_pde(soln,print_grid_when=PHASES,print_grid_who=MASTER, &
                     print_error_when=FINAL,print_error_what=LINF_ERR, &
                     solver=CG_SOLVER,print_error_who=MASTER,max_elem=2000)
call phaml_destroy(soln)
end program phaml_master


      subroutine setsupr(nx,xmn,xsiz,ny,ymn,ysiz,nz,zmn,zsiz,nd,x,y,z, &
                         vr,tmp,nsec,sec1,sec2,sec3,MAXSBX,MAXSBY, &
                         MAXSBZ,nisb,nxsup,xmnsup,xsizsup,nysup,ymnsup, &
                         ysizsup,nzsup,zmnsup,zsizsup)
!-----------------------------------------------------------------------
!
!           Establish Super Block Search Limits and Sort Data
!           *************************************************
!
! This subroutine sets up a 3-D "super block" model and orders the data
! by super block number.  The limits of the super block is set to the
! minimum and maximum limits of the grid; data outside are assigned to
! the nearest edge block.
!
! The idea is to establish a 3-D block network that contains all the
! relevant data.  The data are then sorted by their index location in
! the search network, i.e., the index location is given after knowing
! the block index in each coordinate direction (ix,iy,iz):
!          ii = (iz-1)*nxsup*nysup + (iy-1)*nxsup + ix
! An array, the same size as the number of super blocks, is constructed
! that contains the cumulative number of data in the model.  With this
! array it is easy to quickly check what data are located near any given
! location.
!
!
!
! INPUT VARIABLES:
!
!   nx,xmn,xsiz      Definition of the X grid being considered
!   ny,ymn,ysiz      Definition of the Y grid being considered
!   nz,zmn,zsiz      Definition of the Z grid being considered
!   nd               Number of data
!   x(nd)            X coordinates of the data
!   y(nd)            Y coordinates of the data
!   z(nd)            Z coordinates of the data
!   vr(nd)           Variable at each location.
!   tmp(nd)          Temporary storage to keep track of the super block
!                      index associated to each data (uses the same
!                      storage already allocated for the simulation)
!   nsec             Number of secondary variables to carry with vr
!   sec1(nd)         First secondary variable (if nsec >= 1)
!   sec2(nd)         Second secondary variable (if nsec >= 2)
!   sec3(nd)         Third secondary variable (if nsec = 3)
!   MAXSB[X,Y,Z]     Maximum size of super block network
!
!
!
! OUTPUT VARIABLES:
!
!   nisb()                Array with cumulative number of data in each
!                           super block.
!   nxsup,xmnsup,xsizsup  Definition of the X super block grid
!   nysup,ymnsup,ysizsup  Definition of the Y super block grid
!   nzsup,zmnsup,zsizsup  Definition of the Z super block grid
!
!
!
! EXTERNAL REFERENCES:
!
!   sortem           Sorting routine to sort the data
!
!
!
!-----------------------------------------------------------------------
      real    x(*),y(*),z(*),vr(*),tmp(*),sec1(*),sec2(*),sec3(*)
      integer nisb(*)
      logical inflag
!
! Establish the number and size of the super blocks:
!
      nxsup   = min(nx,MAXSBX)
      nysup   = min(ny,MAXSBY)
      nzsup   = min(nz,MAXSBZ)
      xsizsup = real(nx)*xsiz/real(nxsup)
      ysizsup = real(ny)*ysiz/real(nysup)
      zsizsup = real(nz)*zsiz/real(nzsup)
      xmnsup  = (xmn-0.5*xsiz)+0.5*xsizsup
      ymnsup  = (ymn-0.5*ysiz)+0.5*ysizsup
      zmnsup  = (zmn-0.5*zsiz)+0.5*zsizsup
!
! Initialize the extra super block array to zeros:
!
      do i=1,nxsup*nysup*nzsup
            nisb(i) = 0
      end do
!
! Loop over all the data assigning the data to a super block and
! accumulating how many data are in each super block:
!
      do i=1,nd
            call getindx(nxsup,xmnsup,xsizsup,x(i),ix,inflag)
            call getindx(nysup,ymnsup,ysizsup,y(i),iy,inflag)
            call getindx(nzsup,zmnsup,zsizsup,z(i),iz,inflag)
            ii = ix + (iy-1)*nxsup + (iz-1)*nxsup*nysup
            tmp(i)   = ii
            nisb(ii) = nisb(ii) + 1
      end do
!
! Sort the data by ascending super block number:
!
      nsort = 4 + nsec
      call sortem(1,nd,tmp,nsort,x,y,z,vr,sec1,sec2,sec3)
!
! Set up array nisb with the starting address of the block data:
!
      do i=1,(nxsup*nysup*nzsup-1)
            nisb(i+1) = nisb(i) + nisb(i+1)
      end do
!
! Finished:
!
      return
      end


!##############################################################################
!# Tutorial 008e: Create a 2x2 block system with Mass/Laplace, nonlinear coeff.
!##############################################################################

module tutorial008e

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock

  use scalarpde
  use derivatives
  use bilinearformevaluation
  use domainintegration
  use feevaluation
  use collection

  use matrixio

  implicit none
  private

  public :: start_tutorial008e

contains

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

!<subroutine>

  subroutine fcoeff_Matrix (rdiscretisationTrial,&
                rdiscretisationTest, rform, nelements, npointsPerElement,&
                Dpoints, IdofsTrial, IdofsTest, rdomainIntSubset,&
                Dcoefficients, rcollection)

!<description>
  ! This subroutine is called during the matrix assembly. It has to compute
  ! the coefficients in front of the terms of the bilinear form.
  !
  ! The routine accepts a set of elements and a set of points on these
  ! elements (cubature points) in real coordinates.
  ! According to the terms in the bilinear form, the routine has to compute
  ! simultaneously for all these points and all the terms in the bilinear form
  ! the corresponding coefficients in front of the terms.
!</description>

!<input>
  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.; trial space.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisationTrial

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.; test space.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisationTest

  ! The bilinear form which is currently being evaluated:
  type(t_bilinearForm), intent(in) :: rform

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  ! DIMENSION(dimension,npointsPerElement,nelements)
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTrial

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in test space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset
!</input>

!<inputoutput>
  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection
!</inputoutput>

!<output>
  ! A list of all coefficients in front of all terms in the bilinear form -
  ! for all given points on all given elements.
  !   DIMENSION(itermCount,npointsPerElement,nelements)
  ! with itermCount the number of terms in the bilinear form.
  real(DP), dimension(:,:,:), intent(out) :: Dcoefficients
!</output>

!</subroutine>

    ! local variables
    integer :: imatrixType
    integer :: ivt,iel
    type(t_vectorBlock), pointer :: p_rcoeffVector
    real(DP), dimension(:,:,:), pointer :: p_Dcoeff

    ! The collection tells us what to assemble.
    imatrixType = rcollection%IquickAccess(1)

    ! Get the coefficient vector from the collection
    p_rcoeffVector => rcollection%p_rvectorQuickAccess1

    ! Get the temp memory provided by bilf_buildMatrixScalar
    ! for the coefficients. This is reserved due to ntemp=2.
    p_Dcoeff => rdomainIntSubset%p_DtempArrays

    ! --------------------------------------------------
    ! Calculate the coefficients in the cubature points.
    ! Use the two temporary arrays provided by bilf_buildMatrixScalar.
    !
    ! 1st component
    call fevl_evaluate_sim (p_rcoeffVector%RvectorBlock(1),rdomainIntSubset, &
        DER_FUNC2D, p_Dcoeff(:,:,1))

    ! 2nd component
    call fevl_evaluate_sim (p_rcoeffVector%RvectorBlock(2),rdomainIntSubset, &
        DER_FUNC2D, p_Dcoeff(:,:,2))

    ! Assemble
    select case (imatrixType)

    ! Mass matrix
    case (1)

      ! Loop over all points and elements. Return the function in each point
      do iel=1,nelements
        do ivt=1,npointsPerElement

          ! Initialise the coefficients by the 1st coordinate:
          Dcoefficients(1,ivt,iel) = p_Dcoeff(ivt,iel,1)

        end do
      end do

    ! Laplace matrix
    case (2)

      ! Loop over all points and elements. Return the function in each point
      do iel=1,nelements
        do ivt=1,npointsPerElement

          ! Initialise the coefficients by the 2nd coordinate.
          ! Both the same.
          Dcoefficients(1,ivt,iel) = p_Dcoeff(ivt,iel,2)   ! for (g phi_x,psi_x)
          Dcoefficients(2,ivt,iel) = p_Dcoeff(ivt,iel,2)   ! for (g phi_y,psi_y)

        end do
      end do

    end select

  end subroutine

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

  subroutine start_tutorial008e

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr

    type(t_matrixScalar) :: rtemplateMatrix
    type(t_matrixBlock) :: rmatrix
    type(t_vectorBlock), target :: rcoeffVector

    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_bilinearForm) :: rform
    type(t_collection) :: rcollection
    character(LEN=SYS_STRLEN) :: spostdir

    integer :: i,ntemp
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata1, p_Ddata2

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 008e")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Create a block discretisation that encapsules
    ! two equations, both discretised with Q1.
    ! =================================

    ! Set up a Q1 discretisation
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Set up a block discretisation for two equations. Both equations are Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a 2x2 block matrix with
    ! entries in (1,1) and (2,2)
    ! =================================

    ! Create a template matrix for the FEM space. CSR structure.
    call bilf_createMatrixStructure (rspatialDiscr,LSYSSC_MATRIX9,rtemplateMatrix)

    ! Use the block discretisation to create a basic system matrix.
    call lsysbl_createMatrix (rblockDiscr,rmatrix)

    ! Create (1,1) and (2,2) using the template matrix.
    ! Structure is "shared" (no new memory is allocated), content is allocated.
    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,1,1,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,2,2,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    ! =================================
    ! Clear the matrix
    ! =================================

    call lsysbl_clearMatrix (rmatrix)

    ! =================================
    ! Create a coefficient block vector rcoeffVector = ( 1+x^2, 1+y^2 )
    ! =================================

    ! Create a vector
    call lsysbl_createVector (rblockDiscr,rcoeffVector)

    ! Get vertex positions
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Get pointers to the 1st and 2nd subvector
    call lsyssc_getbase_double (rcoeffVector%RvectorBlock(1), p_Ddata1)
    call lsyssc_getbase_double (rcoeffVector%RvectorBlock(2), p_Ddata2)

    ! Initialise the vector
    do i=1,rtriangulation%NVT
      p_Ddata1(i) = 1.0_DP + p_DvertexCoords(1,i)**2
      p_Ddata2(i) = 1.0_DP + p_DvertexCoords(2,i)**2
    end do

    ! =================================
    ! Use a 3-point Gauss Formula for the assembly
    ! =================================

    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Block (1,1): f Mass
    ! =================================

    ! Set up a bilinear for for Mass. There is 1 term...
    rform%itermCount = 1

    ! We have nonconstant coefficients
    rform%ballCoeffConstant = .false.

    ! Term 1/2: Mass  =>  (f phi, psi)
    rform%Dcoefficients(1)  = 1.0_DP
    rform%Idescriptors(1,1) = DER_FUNC2D
    rform%Idescriptors(2,1) = DER_FUNC2D

    ! Via the collection tell the callback routine to assemble Mass.
    ! Pass rcoeffVector via the collection as nonconstant coefficient.
    rcollection%IquickAccess(1) = 1
    rcollection%p_rvectorQuickAccess1 => rcoeffVector

    ! Build the matrix block (1,1). Reserve two temporary arrays for the coefficients.
    ntemp = 2
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(1,1),rcubatureInfo,&
        fcoeff_Matrix, rcollection, ntemp)

    ! =================================
    ! Block (2,2): g (-Laplace)
    ! =================================

    ! Set up a bilinear for for Laplace...
    rform%itermCount = 2

    ! We have nonconstant coefficients:
    rform%ballCoeffConstant = .false.

    ! Term 1/2: -Laplace  =>  (g phi_x, psi_x)  +  (g phi_y, psi_y)
    rform%Idescriptors(1,1) = DER_DERIV2D_X
    rform%Idescriptors(2,1) = DER_DERIV2D_X

    rform%Idescriptors(1,2) = DER_DERIV2D_Y
    rform%Idescriptors(2,2) = DER_DERIV2D_Y

    ! Via the collection tell the callback routine to assemble Laplace.
    ! Pass rvector via the collection as nonconstant coefficient.
    rcollection%IquickAccess(1) = 2
    rcollection%p_rvectorQuickAccess1 => rcoeffVector

    ! Build the matrix block (2,2). Reserve two temporary arrays for the coefficients.
    ntemp = 2
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(2,2),rcubatureInfo,&
        fcoeff_Matrix, rcollection, ntemp)

    ! =================================
    ! Output of the matrix
    ! =================================
    call output_line ("Writing matrix to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial008e_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          trim(spostdir)//"/tutorial008e_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          trim(spostdir)//"/tutorial008e_matrix.maple", "(E11.2)")
    else
       ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial008e_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          "./post/tutorial008e_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          "./post/tutorial008e_matrix.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the cubature formula
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the coefficient vector
    call lsysbl_releaseVector (rcoeffVector)

    ! Release the matrix
    call lsysbl_releaseMatrix (rmatrix)

    ! ... and the FEM template matrix
    call lsyssc_releaseMatrix (rtemplateMatrix)

    ! Release the block discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


SUBROUTINE neo_spline_test
! Test of Spline Routine
! **********************************************************************
! Modules
! **********************************************************************
  USE neo_precision
  USE neo_input
  USE neo_work
  USE neo_units
  USE neo_parameters
  USE neo_control
! **********************************************************************
! Local Definitions
! **********************************************************************
  IMPLICIT NONE
! **********************************************************************
  INTEGER            :: i, j, n
  REAL(kind=dp)      :: theta, phi, bval, gval, kval, pval, qval
  INTEGER, PARAMETER :: div = 5, ip = 43, it = 88
  REAL(kind=dp)      :: td, pd
  n = MIN(theta_n,phi_n)

  IF (spline_test .EQ. 1) THEN ! along given phi
     OPEN(unit=w_u1,file='sptest1.dat',status='replace',form='formatted')
     OPEN(unit=w_u2,file='sptest2.dat',status='replace',form='formatted')
     td = theta_end - theta_start
     phi = phi_arr(ip)
     theta = theta_start-td
     DO WHILE (theta < theta_end+td)
        CALL neo_eval(theta,phi,bval,gval,kval,pval,qval)
        WRITE(w_u1,*) theta,phi,bval,gval,kval
        theta = theta + theta_int/div
     END DO
     DO j = -1,1
        DO i = 1, theta_n-1
           theta = theta_arr(i) + j*td
           bval = b(i,ip)
           gval = sqrg11(i,ip)
           kval = kg(i,ip)
           WRITE(w_u2,*) theta,phi,bval,gval,kval
        END DO
     END DO
     CLOSE(unit=w_u2)
     CLOSE(unit=w_u1)
  ELSEIF (spline_test .EQ. 2) THEN ! along given theta
     OPEN(unit=w_u1,file='sptest1.dat',status='replace',form='formatted')
     OPEN(unit=w_u2,file='sptest2.dat',status='replace',form='formatted')
     pd = phi_end - phi_start
     theta = theta_arr(it)
     phi = phi_start-pd
     DO WHILE (phi < phi_end+pd)
        CALL neo_eval(theta,phi,bval,gval,kval,pval,qval)
        WRITE(w_u1,*) theta,phi,bval,gval,kval
        phi = phi + phi_int/div
     END DO
     DO j = -1,1
        DO i = 1, phi_n-1
           phi = phi_arr(i) + j*pd
           bval = b(it,i)
           gval = sqrg11(it,i)
           kval = kg(it,i)
           WRITE(w_u2,*) theta,phi,bval,gval,kval
        END DO
     END DO
     CLOSE(unit=w_u2)
     CLOSE(unit=w_u1)
  ELSEIF (spline_test .EQ. 3) THEN ! diagonal
     OPEN(unit=w_u1,file='sptest1.dat',status='replace',form='formatted')
     DO i = 1, n*div
        theta = theta_start + i*theta_int/div
        phi   = phi_start + i*phi_int/div
        CALL neo_eval(theta,phi,bval,gval,kval,pval,qval)
        WRITE(w_u1,*) theta,phi,bval,gval,kval
     END DO
     CLOSE(unit=w_u1)
     OPEN(unit=w_u1,file='sptest2.dat',status='replace',form='formatted')
     DO i = 1, n
        theta = theta_arr(i)
        phi   = phi_arr(i)
        bval = b(i,i)
        gval = sqrg11(i,i)
        kval = kg(i,i)
        WRITE(w_u1,*) theta,phi,bval,gval,kval
     END DO
     CLOSE(unit=w_u1)
  ENDIF
! **********************************************************************
  RETURN
END SUBROUTINE neo_spline_test


      SUBROUTINE ZHER2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B,LDB, BETA,
     $                   C, LDC )
*     .. Scalar Arguments ..
      CHARACTER          TRANS, UPLO
      INTEGER            K, LDA, LDB, LDC, N
      DOUBLE PRECISION   BETA
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  ZHER2K  performs one of the hermitian rank 2k operations
*
*     C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C,
*
*  or
*
*     C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C,
*
*  where  alpha and beta  are scalars with  beta  real,  C is an  n by n
*  hermitian matrix and  A and B  are  n by k matrices in the first case
*  and  k by n  matrices in the second case.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On  entry,   UPLO  specifies  whether  the  upper  or  lower
*           triangular  part  of the  array  C  is to be  referenced  as
*           follows:
*
*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
*                                  is to be referenced.
*
*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
*                                  is to be referenced.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry,  TRANS  specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'    C := alpha*A*conjg( B' )          +
*                                         conjg( alpha )*B*conjg( A' ) +
*                                         beta*C.
*
*              TRANS = 'C' or 'c'    C := alpha*conjg( A' )*B          +
*                                         conjg( alpha )*conjg( B' )*A +
*                                         beta*C.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N specifies the order of the matrix C.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
*           of  columns  of the  matrices  A and B,  and on  entry  with
*           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
*           matrices  A and B.  K must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - COMPLEX*16         .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by n  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
*           then  LDA must be at least  max( 1, n ), otherwise  LDA must
*           be at least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - COMPLEX*16       array of DIMENSION ( LDB, kb ), where kb is
*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  k by n  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
*           then  LDB must be at least  max( 1, n ), otherwise  LDB must
*           be at least  max( 1, k ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION            .
*           On entry, BETA specifies the scalar beta.
*           Unchanged on exit.
*
*  C      - COMPLEX*16          array of DIMENSION ( LDC, n ).
*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
*           upper triangular part of the array C must contain the upper
*           triangular part  of the  hermitian matrix  and the strictly
*           lower triangular part of C is not referenced.  On exit, the
*           upper triangular part of the array  C is overwritten by the
*           upper triangular part of the updated matrix.
*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
*           lower triangular part of the array C must contain the lower
*           triangular part  of the  hermitian matrix  and the strictly
*           upper triangular part of C is not referenced.  On exit, the
*           lower triangular part of the array  C is overwritten by the
*           lower triangular part of the updated matrix.
*           Note that the imaginary parts of the diagonal elements need
*           not be set,  they are assumed to be zero,  and on exit they
*           are set to zero.
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, n ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*  -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
*     Ed Anderson, Cray Research Inc.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCONJG, MAX
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, L, NROWA
      COMPLEX*16         TEMP1, TEMP2
*     ..
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      IF( LSAME( TRANS, 'N' ) ) THEN
         NROWA = N
      ELSE
         NROWA = K
      END IF
      UPPER = LSAME( UPLO, 'U' )
*
      INFO = 0
      IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = 1
      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND.
     $         ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN
         INFO = 2
      ELSE IF( N.LT.0 ) THEN
         INFO = 3
      ELSE IF( K.LT.0 ) THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
         INFO = 7
      ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN
         INFO = 9
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZHER2K', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND.
     $    ( BETA.EQ.ONE ) ) )RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO ) THEN
         IF( UPPER ) THEN
            IF( BETA.EQ.DBLE( ZERO ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = 1, J
                     C( I, J ) = ZERO
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = 1, J - 1
                     C( I, J ) = BETA*C( I, J )
   30             CONTINUE
                  C( J, J ) = BETA*DBLE( C( J, J ) )
   40          CONTINUE
            END IF
         ELSE
            IF( BETA.EQ.DBLE( ZERO ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = J, N
                     C( I, J ) = ZERO
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  C( J, J ) = BETA*DBLE( C( J, J ) )
                  DO 70 I = J + 1, N
                     C( I, J ) = BETA*C( I, J )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSAME( TRANS, 'N' ) ) THEN
*
*        Form  C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) +
*                   C.
*
         IF( UPPER ) THEN
            DO 130 J = 1, N
               IF( BETA.EQ.DBLE( ZERO ) ) THEN
                  DO 90 I = 1, J
                     C( I, J ) = ZERO
   90             CONTINUE
               ELSE IF( BETA.NE.ONE ) THEN
                  DO 100 I = 1, J - 1
                     C( I, J ) = BETA*C( I, J )
  100             CONTINUE
                  C( J, J ) = BETA*DBLE( C( J, J ) )
               ELSE
                  C( J, J ) = DBLE( C( J, J ) )
               END IF
               DO 120 L = 1, K
                  IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) )
     $                 THEN
                     TEMP1 = ALPHA*DCONJG( B( J, L ) )
                     TEMP2 = DCONJG( ALPHA*A( J, L ) )
                     DO 110 I = 1, J - 1
                        C( I, J ) = C( I, J ) + A( I, L )*TEMP1 +
     $                              B( I, L )*TEMP2
  110                CONTINUE
                     C( J, J ) = DBLE( C( J, J ) ) +
     $                           DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 )
                  END IF
  120          CONTINUE
  130       CONTINUE
         ELSE
            DO 180 J = 1, N
               IF( BETA.EQ.DBLE( ZERO ) ) THEN
                  DO 140 I = J, N
                     C( I, J ) = ZERO
  140             CONTINUE
               ELSE IF( BETA.NE.ONE ) THEN
                  DO 150 I = J + 1, N
                     C( I, J ) = BETA*C( I, J )
  150             CONTINUE
                  C( J, J ) = BETA*DBLE( C( J, J ) )
               ELSE
                  C( J, J ) = DBLE( C( J, J ) )
               END IF
               DO 170 L = 1, K
                  IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) )
     $                 THEN
                     TEMP1 = ALPHA*DCONJG( B( J, L ) )
                     TEMP2 = DCONJG( ALPHA*A( J, L ) )
                     DO 160 I = J + 1, N
                        C( I, J ) = C( I, J ) + A( I, L )*TEMP1 +
     $                              B( I, L )*TEMP2
  160                CONTINUE
                     C( J, J ) = DBLE( C( J, J ) ) +
     $                           DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 )
                  END IF
  170          CONTINUE
  180       CONTINUE
         END IF
      ELSE
*
*        Form  C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A +
*                   C.
*
         IF( UPPER ) THEN
            DO 210 J = 1, N
               DO 200 I = 1, J
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 190 L = 1, K
                     TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J )
                     TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J )
  190             CONTINUE
                  IF( I.EQ.J ) THEN
                     IF( BETA.EQ.DBLE( ZERO ) ) THEN
                        C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )*
     $                              TEMP2 )
                     ELSE
                        C( J, J ) = BETA*DBLE( C( J, J ) ) +
     $                              DBLE( ALPHA*TEMP1+DCONJG( ALPHA )*
     $                              TEMP2 )
                     END IF
                  ELSE
                     IF( BETA.EQ.DBLE( ZERO ) ) THEN
                        C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2
                     ELSE
                        C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 +
     $                              DCONJG( ALPHA )*TEMP2
                     END IF
                  END IF
  200          CONTINUE
  210       CONTINUE
         ELSE
            DO 240 J = 1, N
               DO 230 I = J, N
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 220 L = 1, K
                     TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J )
                     TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J )
  220             CONTINUE
                  IF( I.EQ.J ) THEN
                     IF( BETA.EQ.DBLE( ZERO ) ) THEN
                        C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )*
     $                              TEMP2 )
                     ELSE
                        C( J, J ) = BETA*DBLE( C( J, J ) ) +
     $                              DBLE( ALPHA*TEMP1+DCONJG( ALPHA )*
     $                              TEMP2 )
                     END IF
                  ELSE
                     IF( BETA.EQ.DBLE( ZERO ) ) THEN
                        C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2
                     ELSE
                        C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 +
     $                              DCONJG( ALPHA )*TEMP2
                     END IF
                  END IF
  230          CONTINUE
  240       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of ZHER2K.
*
      END